├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── doc └── ghc-typelits-natnormalise-hcar.tex ├── ghc-typelits-natnormalise.cabal ├── src-ghc-9.12 └── GHC │ └── TypeLits │ └── Normalise.hs ├── src-ghc-9.4 └── GHC │ └── TypeLits │ └── Normalise.hs ├── src-pre-ghc-9.4 └── GHC │ └── TypeLits │ └── Normalise.hs ├── src └── GHC │ └── TypeLits │ └── Normalise │ ├── SOP.hs │ └── Unify.hs └── tests ├── ErrorTests.hs └── Tests.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'ghc-typelits-natnormalise.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250216 12 | # 13 | # REGENDATA ("0.19.20250216",["github","ghc-typelits-natnormalise.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | - compiler: ghc-8.4.4 82 | compilerKind: ghc 83 | compilerVersion: 8.4.4 84 | setup-method: ghcup 85 | allow-failure: false 86 | - compiler: ghc-8.2.2 87 | compilerKind: ghc 88 | compilerVersion: 8.2.2 89 | setup-method: ghcup 90 | allow-failure: false 91 | - compiler: ghc-8.0.2 92 | compilerKind: ghc 93 | compilerVersion: 8.0.2 94 | setup-method: ghcup 95 | allow-failure: false 96 | fail-fast: false 97 | steps: 98 | - name: apt-get install 99 | run: | 100 | apt-get update 101 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 102 | - name: Install GHCup 103 | run: | 104 | mkdir -p "$HOME/.ghcup/bin" 105 | curl -sL https://downloads.haskell.org/ghcup/0.1.40.0/x86_64-linux-ghcup-0.1.40.0 > "$HOME/.ghcup/bin/ghcup" 106 | chmod a+x "$HOME/.ghcup/bin/ghcup" 107 | - name: Install cabal-install 108 | run: | 109 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1 || (cat "$HOME"/.ghcup/logs/*.* && false) 110 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1 -vnormal+nowrap" >> "$GITHUB_ENV" 111 | - name: Install GHC (GHCup) 112 | if: matrix.setup-method == 'ghcup' 113 | run: | 114 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 115 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 116 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 117 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 118 | echo "HC=$HC" >> "$GITHUB_ENV" 119 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 120 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 121 | env: 122 | HCKIND: ${{ matrix.compilerKind }} 123 | HCNAME: ${{ matrix.compiler }} 124 | HCVER: ${{ matrix.compilerVersion }} 125 | - name: Set PATH and environment variables 126 | run: | 127 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 128 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 129 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 130 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 131 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 132 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 133 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 134 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 135 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 136 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 137 | env: 138 | HCKIND: ${{ matrix.compilerKind }} 139 | HCNAME: ${{ matrix.compiler }} 140 | HCVER: ${{ matrix.compilerVersion }} 141 | - name: env 142 | run: | 143 | env 144 | - name: write cabal config 145 | run: | 146 | mkdir -p $CABAL_DIR 147 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 180 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 181 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 182 | rm -f cabal-plan.xz 183 | chmod a+x $HOME/.cabal/bin/cabal-plan 184 | cabal-plan --version 185 | - name: checkout 186 | uses: actions/checkout@v4 187 | with: 188 | path: source 189 | - name: initial cabal.project for sdist 190 | run: | 191 | touch cabal.project 192 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 193 | cat cabal.project 194 | - name: sdist 195 | run: | 196 | mkdir -p sdist 197 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 198 | - name: unpack 199 | run: | 200 | mkdir -p unpacked 201 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 202 | - name: generate cabal.project 203 | run: | 204 | PKGDIR_ghc_typelits_natnormalise="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/ghc-typelits-natnormalise-[0-9.]*')" 205 | echo "PKGDIR_ghc_typelits_natnormalise=${PKGDIR_ghc_typelits_natnormalise}" >> "$GITHUB_ENV" 206 | rm -f cabal.project cabal.project.local 207 | touch cabal.project 208 | touch cabal.project.local 209 | echo "packages: ${PKGDIR_ghc_typelits_natnormalise}" >> cabal.project 210 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package ghc-typelits-natnormalise" >> cabal.project ; fi 211 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 212 | cat >> cabal.project <> cabal.project.local 215 | cat cabal.project 216 | cat cabal.project.local 217 | - name: dump install plan 218 | run: | 219 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 220 | cabal-plan 221 | - name: restore cache 222 | uses: actions/cache/restore@v4 223 | with: 224 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 225 | path: ~/.cabal/store 226 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 227 | - name: install dependencies 228 | run: | 229 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 230 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 231 | - name: build w/o tests 232 | run: | 233 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 234 | - name: build 235 | run: | 236 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 237 | - name: tests 238 | run: | 239 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 240 | - name: cabal check 241 | run: | 242 | cd ${PKGDIR_ghc_typelits_natnormalise} || false 243 | ${CABAL} -vnormal check 244 | - name: haddock 245 | run: | 246 | if [ $((HCNUMVER == 80605)) -ne 0 ] ; then $CABAL v2-haddock --disable-documentation $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all; else $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all; fi 247 | - name: unconstrained build 248 | run: | 249 | rm -f cabal.project.local 250 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 251 | - name: save cache 252 | if: always() 253 | uses: actions/cache/save@v4 254 | with: 255 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 256 | path: ~/.cabal/store 257 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | dist/ 3 | dist-newstyle/ 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for the [`ghc-typelits-natnormalise`](http://hackage.haskell.org/package/ghc-typelits-natnormalise) package 2 | 3 | ## 0.7.11 *March 4th 2025* 4 | * Support for GHC 9.12.1 5 | 6 | ## 0.7.10 *May 22nd 2024* 7 | * Support for GHC 9.10.1 8 | 9 | ## 0.7.9 *October 10th 2023* 10 | * Support for GHC 9.8.1 11 | 12 | ## 0.7.8 *February 20th 2023* 13 | * Try and outright solve substituted constraints, the same as is done with the unsubstituted constraint. Partially Fixes [#65](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/65). 14 | * Support for GHC-9.6.0.20230210 15 | 16 | ## 0.7.7 *October 10th 2022* 17 | * Solve unflattened wanteds instead of the wanteds passed to the plugin. Fixes [#1901]https://github.com/clash-lang/clash-compiler/issues/1901. 18 | * Add support for GHC 9.4 19 | 20 | ## 0.7.6 *June 20th 2021* 21 | * Do not vacuously solve `forall a b . 1 <=? a^b ~ True` 22 | * Do not solve constraints within `KnownNat`, leave that to https://hackage.haskell.org/package/ghc-typelits-knonwnnat 23 | 24 | ## 0.7.5 *June 17th 2021* 25 | * Fixes [#52](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/50) Plugin doesn't solve inside arbitrary class constraints 26 | * Build on GHC 9.2.0.20210422 27 | 28 | ## 0.7.4 *February 12th 2021* 29 | * Fixes [#50](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/50) `x ^ C ~ y` erroneously deemed hard insoluable, a contradiction, when `C` is some type family other than +,-,*,^ 30 | 31 | ## 0.7.3 *January 1st 2021* 32 | * Build on GHC 9.0.1-rc1 33 | 34 | ## 0.7.2 *March 9 2020* 35 | * Fixes [#44](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/44) infinite loop due to boxed equality 36 | 37 | ## 0.7.1 *February 6th 2020* 38 | * Add support for GHC 8.10.1-alpha2 39 | * Fixes [#23](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/23): Can't figure out `+` commutes in some contexts on GHC 8.6.3 40 | * Fixes [#28](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/28): Using the solver seems to break GHC 41 | * Fixes [#34](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/34): inequality solver mishandles subtraction 42 | 43 | ## 0.7 *August 26th 2019* 44 | * Require KnownNat constraints when solving with constants 45 | 46 | ## 0.6.2 *July 10th 2018* 47 | * Add support for GHC 8.6.1-alpha1 48 | * Solve larger inequalities from smaller inequalities, e.g. 49 | * `a <= n` implies `a <= n + 1` 50 | 51 | ## 0.6.1 *May 9th 2018* 52 | * Stop solving `x + y ~ a + b` by asking GHC to solve `x ~ a` and `y ~ b` as 53 | this leads to a situation where we find a solution that is not the most 54 | general. 55 | * Stop using the smallest solution to an inequality to solve an equality, as 56 | this leads to finding solutions that are not the most general. 57 | * Solve smaller inequalities from larger inequalities, e.g. 58 | * `1 <= 2*x` implies `1 <= x` 59 | * `x + 2 <= y` implies `x <= y` and `2 <= y` 60 | 61 | ## 0.6 *April 23rd 2018* 62 | * Solving constraints with `a-b` will emit `b <= a` constraints. e.g. solving 63 | `n-1+1 ~ n` will emit a `1 <= n` constraint. 64 | * If you need subtraction to be treated as addition with a negated operarand 65 | run with `-fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers`, and 66 | the `b <= a` constraint won't be emitted. Note that doing so can lead to 67 | unsound behaviour. 68 | * Try to solve equalities using smallest solution of inequalities: 69 | * Solve `x + 1 ~ y` using `1 <= y` => `x + 1 ~ 1` => `x ~ 0` 70 | * Solve inequalities using simple transitivity rules: 71 | * `2 <= x` implies `1 <= x` 72 | * `x <= 9` implies `x <= 10` 73 | * Solve inequalities using _simple_ monotonicity of addition rules: 74 | * `2 <= x` implies `2 + 2*x <= 3*x` 75 | * Solve inequalities using _simple_ monotonicity of multiplication rules: 76 | * `1 <= x` implies `1 <= 3*x` 77 | * Solve inequalities using _simple_ monotonicity of exponentiation rules: 78 | * `1 <= x` implies `2 <= 2^x` 79 | * Solve inequalities using powers of 2 and monotonicity of exponentiation: 80 | * `2 <= x` implies `2^(2 + 2*x) <= 2^(3*x)` 81 | 82 | ## 0.5.10 *April 15th 2018* 83 | * Add support for GHC 8.5.20180306 84 | 85 | ## 0.5.9 *March 17th 2018* 86 | * Add support for GHC 8.4.1 87 | 88 | ## 0.5.8 *January 4th 2018* 89 | * Add support for GHC 8.4.1-alpha1 90 | 91 | ## 0.5.7 *November 7th 2017* 92 | * Solve inequalities such as: `1 <= a + 3` 93 | 94 | ## 0.5.6 *October 31st 2017* 95 | * Fixes bugs: 96 | * `(x + 1) ~ (2 * y)` no longer implies `((2 * (y - 1)) + 1) ~ x` 97 | 98 | ## 0.5.5 *October 22nd 2017* 99 | * Solve inequalities when their normal forms are the same, i.e. 100 | * `(2 <= (2 ^ (n + d)))` implies `(2 <= (2 ^ (d + n)))` 101 | * Find more unifications: 102 | * `8^x - 2*4^x ~ 8^y - 2*4^y ==> [x := y]` 103 | 104 | ## 0.5.4 *October 14th 2017* 105 | * Perform normalisations such as: `2^x * 4^x ==> 8^x` 106 | 107 | ## 0.5.3 *May 15th 2017* 108 | * Add support for GHC 8.2 109 | 110 | ## 0.5.2 *January 15th 2017* 111 | * Fixes bugs: 112 | * Reification from SOP to Type sometimes loses product terms 113 | 114 | ## 0.5.1 *September 29th 2016* 115 | * Fixes bugs: 116 | * Cannot solve an equality for the second time in a definition group 117 | 118 | ## 0.5 *August 17th 2016* 119 | * Solve simple inequalities, i.e.: 120 | * `a <= a + 1` 121 | * `2a <= 3a` 122 | * `1 <= a^b` 123 | 124 | ## 0.4.6 *July 21th 2016* 125 | * Reduce "x^(-y) * x^y" to 1 126 | * Fixes bugs: 127 | * Subtraction in exponent induces infinite loop 128 | 129 | ## 0.4.5 *July 20th 2016* 130 | * Fixes bugs: 131 | * Reifying negative exponent causes GHC panic 132 | 133 | ## 0.4.4 *July 19th 2016* 134 | * Fixes bugs: 135 | * Rounding error in `logBase` calculation 136 | 137 | ## 0.4.3 *July 18th 2016* 138 | * Fixes bugs: 139 | * False positive: "f :: (CLog 2 (2 ^ n) ~ n, (1 <=? n) ~ True) => Proxy n -> Proxy (n+d)" 140 | 141 | ## 0.4.2 *July 8th 2016* 142 | * Find more unifications: 143 | * `(2*e ^ d) ~ (2*e*a*c) ==> [a*c := 2*e ^ (d-1)]` 144 | * `a^d * a^e ~ a^c ==> [c := d + e]` 145 | * `x+5 ~ y ==> [x := y - 5]`, but only when `x+5 ~ y` is a given constraint 146 | 147 | ## 0.4.1 *February 4th 2016* 148 | * Find more unifications: 149 | * `F x y k z ~ F x y (k-1+1) z` ==> [k := k], where `F` can be any type function 150 | 151 | ## 0.4 *January 19th 2016* 152 | * Stop using 'provenance' hack to create conditional evidence (GHC 8.0+ only) 153 | * Find more unifications: 154 | * `F x + 2 - 1 - 1 ~ F x` ==> [F x := F x], where `F` can be any type function with result `Nat`. 155 | 156 | ## 0.3.2 157 | * Find more unifications: 158 | * `(z ^ a) ~ (z ^ b) ==> [a := b]` 159 | * `(i ^ a) ~ j ==> [a := round (logBase i j)]`, when `i` and `j` are integers, and `ceiling (logBase i j) == floor (logBase i j)`. 160 | 161 | ## 0.3.1 *October 19th 2015* 162 | * Find more unifications: 163 | * `(i * a) ~ j ==> [a := div j i]`, when `i` and `j` are integers, and `mod j i == 0`. 164 | * `(i * a) + j ~ k ==> [a := div (k-j) i]`, when `i`, `j`, and `k` are integers, and `k-j >= 0` and `mod (k-j) i == 0`. 165 | 166 | ## 0.3 *June 3rd 2015* 167 | * Find more unifications: 168 | * ` + x ~ 2 + x ==> [ ~ 2]` 169 | * Fixes bugs: 170 | * Unifying `a*b ~ b` now returns `[a ~ 1]`; before it erroneously returned `[a ~ ]`, which is interpred as `[a ~ 0]`... 171 | * Unifying `a+b ~ b` now returns `[a ~ 0]`; before it returned the undesirable, though equal, `[a ~ ]` 172 | 173 | ## 0.2.1 *May 6th 2015* 174 | * Update `Eq` instance of `SOP`: Empty SOP is equal to 0 175 | 176 | ## 0.2 *April 22nd 2015* 177 | * Finds more unifications: 178 | * `(2 + a) ~ 5 ==> [a := 3]` 179 | * `(3 * a) ~ 0 ==> [a := 0]` 180 | 181 | ## 0.1.2 *April 21st 2015* 182 | * Don't simplify expressions with negative exponents 183 | 184 | ## 0.1.1 *April 17th 2015* 185 | * Add workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 186 | 187 | ## 0.1 *March 30th 2015* 188 | * Initial release 189 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2016, University of Twente, 2 | 2017-2018, QBayLogic B.V. 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the 15 | distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 18 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 19 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 20 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 21 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 22 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 23 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 24 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 25 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 26 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ghc-typelits-natnormalise 2 | 3 | [![Build Status](https://github.com/clash-lang/ghc-typelits-natnormalise/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/clash-lang/ghc-typelits-natnormalise/actions) 4 | [![Hackage](https://img.shields.io/hackage/v/ghc-typelits-natnormalise.svg)](https://hackage.haskell.org/package/ghc-typelits-natnormalise) 5 | [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/ghc-typelits-natnormalise.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=exact%3Aghc-typelits-natnormalise) 6 | 7 | A type checker plugin for GHC that can solve _equalities_ and _inequalities_ 8 | of types of kind `Nat`, where these types are either: 9 | 10 | * Type-level naturals 11 | * Type variables 12 | * Applications of the arithmetic expressions `(+,-,*,^)`. 13 | 14 | It solves these equalities by normalising them to _sort-of_ 15 | `SOP` (Sum-of-Products) form, and then perform a 16 | simple syntactic equality. 17 | 18 | For example, this solver can prove the equality between: 19 | 20 | ``` 21 | (x + 2)^(y + 2) 22 | ``` 23 | 24 | and 25 | 26 | ``` 27 | 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 28 | ``` 29 | 30 | Because the latter is actually the `SOP` normal form 31 | of the former. 32 | 33 | To use the plugin, add 34 | 35 | ``` 36 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} 37 | ``` 38 | 39 | To the header of your file. 40 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ghc-typelits-natnormalise.cabal 2 | 3 | package ghc-typelits-natnormalise 4 | flags: +deverror 5 | -------------------------------------------------------------------------------- /doc/ghc-typelits-natnormalise-hcar.tex: -------------------------------------------------------------------------------- 1 | \documentclass[DIV16,twocolumn,10pt]{scrreprt} 2 | \usepackage{paralist} 3 | \usepackage{graphicx} 4 | \usepackage[final]{hcar} 5 | 6 | %include polycode.fmt 7 | 8 | \begin{document} 9 | 10 | \begin{hcarentry}{GHC type-checker plugin for kind Nat} 11 | \report{Christiaan Baaij} 12 | \status{actively developed} 13 | % \participants{(PARTICIPANTS OTHER THAN MYSELF)}% optional 14 | \makeheader 15 | 16 | % (WHAT IS IT?) 17 | As of GHC version 7.10, GHC's type checking and inference mechanisms can be enriched by plugins. 18 | This particular plugin enriches GHC's knowledge of arithmetic on the type-level. 19 | Specifically it allows the compiler to reason about \emph{equalities} of types of kind \verb!GHC.TypeLits.Nat!. 20 | 21 | GHC's type-checker's knowledge of arithmetic is virtually non-existent: it doesn't know addition is associative and commutative, that multiplication distributes over addition, etc. 22 | In a dependently-typed language, or in Haskell using singleton types, one can provide proofs for these properties and use them to type-check programs that depend on these properties in order to be (type-)correct. 23 | However, most of these properties of arithmetic over natural number are elementary school level knowledge, and it is cumbersome and tiresome to keep on providing and proving them manually. 24 | This type-checker plugin adds the knowledge of these properties to GHC's type-checker. 25 | 26 | For example, using this plugin, GHC now knows that: 27 | \begin{verbatim} 28 | (x + 2)^(y + 2) 29 | \end{verbatim} 30 | is equal to: 31 | \begin{verbatim} 32 | 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 33 | \end{verbatim} 34 | 35 | The way that the plugin works, is that it normalises arithmetic expressions to a normal form that very much resembles \emph{Cantor normal form for ordinals}(\url{http://en.wikipedia.org/wiki/Ordinal_arithmetic#Cantor_normal_form}). 36 | Subsequently, it perform a simple syntactic equality of the two expressions. 37 | Indeed, in the example above, the latter expression is the normal form of the former expression. 38 | 39 | % (WHAT IS ITS STATUS? / WHAT HAS HAPPENED SINCE LAST TIME?) 40 | The main test suite for the plugin can be found at: \url{https://github.com/christiaanb/ghc-typelits-natnormalise/blob/master/tests/Tests.hs}. 41 | It demonstrates what kind of \emph{correct} code can be written without type equality annotations, or the use of \verb!unsafeCoerce!. 42 | 43 | One important aspect of this plugin is that it only enriches the type checkers knowledge of equalities, but \underline{not} \emph{in}equalities. 44 | That is, it does not allow GHC to solve constraints such as: 45 | \begin{verbatim} 46 | CmpNat (x + 2) (x + 3) ~ 'LT 47 | \end{verbatim} 48 | 49 | % (CAN OTHERS GET IT?) 50 | The plugin is available on hackage, for GHC version 7.10 and higher: 51 | \begin{verbatim} 52 | $ cabal update 53 | $ cabal install ghc-typelits-natnormalise 54 | \end{verbatim} 55 | 56 | % (WHAT ARE THE IMMEDIATE PLANS?) 57 | Development focus for the plugin is on further testing and improving its testsuite. 58 | 59 | \FurtherReading 60 | \url{http://hackage.haskell.org/package/ghc-typelits-natnormalise} \\ 61 | \url{http://hackage.haskell.org/package/base/docs/GHC-TypeLits.html} 62 | \end{hcarentry} 63 | 64 | \end{document} 65 | -------------------------------------------------------------------------------- /ghc-typelits-natnormalise.cabal: -------------------------------------------------------------------------------- 1 | name: ghc-typelits-natnormalise 2 | version: 0.7.11 3 | synopsis: GHC typechecker plugin for types of kind GHC.TypeLits.Nat 4 | description: 5 | A type checker plugin for GHC that can solve /equalities/ and /inequalities/ 6 | of types of kind @Nat@, where these types are either: 7 | . 8 | * Type-level naturals 9 | . 10 | * Type variables 11 | . 12 | * Applications of the arithmetic expressions @(+,-,*,^)@. 13 | . 14 | It solves these equalities by normalising them to /sort-of/ @SOP@ 15 | (Sum-of-Products) form, and then perform a simple syntactic equality. 16 | . 17 | For example, this solver can prove the equality between: 18 | . 19 | @ 20 | (x + 2)^(y + 2) 21 | @ 22 | . 23 | and 24 | . 25 | @ 26 | 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 27 | @ 28 | . 29 | Because the latter is actually the @SOP@ normal form of the former. 30 | . 31 | To use the plugin, add the 32 | . 33 | @ 34 | OPTIONS_GHC -fplugin GHC.TypeLits.Normalise 35 | @ 36 | . 37 | Pragma to the header of your file. 38 | homepage: http://www.clash-lang.org/ 39 | bug-reports: http://github.com/clash-lang/ghc-typelits-natnormalise/issues 40 | license: BSD2 41 | license-file: LICENSE 42 | author: Christiaan Baaij 43 | maintainer: christiaan.baaij@gmail.com 44 | copyright: Copyright © 2015-2016, University of Twente, 45 | 2017-2018, QBayLogic B.V. 46 | category: Type System 47 | build-type: Simple 48 | extra-source-files: README.md 49 | CHANGELOG.md 50 | cabal-version: >=1.10 51 | tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, 52 | GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, 53 | GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1, 54 | GHC == 9.12.1 55 | 56 | source-repository head 57 | type: git 58 | location: https://github.com/clash-lang/ghc-typelits-natnormalise.git 59 | 60 | flag deverror 61 | description: 62 | Enables `-Werror` for development mode and TravisCI 63 | default: False 64 | manual: True 65 | 66 | library 67 | exposed-modules: GHC.TypeLits.Normalise, 68 | GHC.TypeLits.Normalise.SOP, 69 | GHC.TypeLits.Normalise.Unify 70 | build-depends: base >=4.9 && <5, 71 | containers >=0.5.7.1 && <0.8, 72 | ghc >=8.0.1 && <9.13, 73 | ghc-tcplugins-extra >=0.5, 74 | transformers >=0.5.2.0 && < 0.7 75 | if impl(ghc >= 9.0.0) 76 | build-depends: ghc-bignum >=1.0 && <1.4 77 | else 78 | build-depends: integer-gmp >=1.0 && <1.1 79 | hs-source-dirs: src 80 | if impl(ghc >= 8.0) && impl(ghc < 9.4) 81 | hs-source-dirs: src-pre-ghc-9.4 82 | if impl(ghc >= 9.4) && impl(ghc < 9.11) 83 | hs-source-dirs: src-ghc-9.4 84 | build-depends: template-haskell >=2.17 && <2.23 85 | if impl(ghc >= 9.11) && impl(ghc < 9.13) 86 | hs-source-dirs: src-ghc-9.12 87 | build-depends: template-haskell >=2.17 && <2.24 88 | default-language: Haskell2010 89 | other-extensions: CPP 90 | LambdaCase 91 | RecordWildCards 92 | TupleSections 93 | if flag(deverror) 94 | ghc-options: -Wall -Werror 95 | else 96 | ghc-options: -Wall 97 | 98 | test-suite unit-tests 99 | type: exitcode-stdio-1.0 100 | main-is: Tests.hs 101 | Other-Modules: ErrorTests 102 | build-depends: base >=4.8 && <5, 103 | ghc-typelits-natnormalise, 104 | tasty >= 0.10, 105 | tasty-hunit >= 0.9, 106 | template-haskell >= 2.11.0.0 107 | if impl(ghc >= 9.4) 108 | build-depends: ghc-prim >= 0.9 109 | hs-source-dirs: tests 110 | default-language: Haskell2010 111 | other-extensions: DataKinds 112 | GADTs 113 | KindSignatures 114 | NoImplicitPrelude 115 | TemplateHaskell 116 | TypeFamilies 117 | TypeOperators 118 | ScopedTypeVariables 119 | if flag(deverror) 120 | ghc-options: -dcore-lint 121 | -------------------------------------------------------------------------------- /src-ghc-9.12/GHC/TypeLits/Normalise.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (C) 2015-2016, University of Twente, 3 | 2017 , QBayLogic B.V. 4 | License : BSD2 (see the file LICENSE) 5 | Maintainer : Christiaan Baaij 6 | 7 | A type checker plugin for GHC that can solve /equalities/ of types of kind 8 | 'GHC.TypeLits.Nat', where these types are either: 9 | 10 | * Type-level naturals 11 | * Type variables 12 | * Applications of the arithmetic expressions @(+,-,*,^)@. 13 | 14 | It solves these equalities by normalising them to /sort-of/ 15 | 'GHC.TypeLits.Normalise.SOP.SOP' (Sum-of-Products) form, and then perform a 16 | simple syntactic equality. 17 | 18 | For example, this solver can prove the equality between: 19 | 20 | @ 21 | (x + 2)^(y + 2) 22 | @ 23 | 24 | and 25 | 26 | @ 27 | 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 28 | @ 29 | 30 | Because the latter is actually the 'GHC.TypeLits.Normalise.SOP.SOP' normal form 31 | of the former. 32 | 33 | To use the plugin, add 34 | 35 | @ 36 | {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} 37 | @ 38 | 39 | To the header of your file. 40 | 41 | == Treating subtraction as addition with a negated number 42 | 43 | If you are absolutely sure that your subtractions can /never/ lead to (a locally) 44 | negative number, you can ask the plugin to treat subtraction as addition with 45 | a negated operand by additionally adding: 46 | 47 | @ 48 | {\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} 49 | @ 50 | 51 | to the header of your file, thereby allowing to use associativity and 52 | commutativity rules when proving constraints involving subtractions. Note that 53 | this option can lead to unsound behaviour and should be handled with extreme 54 | care. 55 | 56 | === When it leads to unsound behaviour 57 | 58 | For example, enabling the /allow-negated-numbers/ feature would allow 59 | you to prove: 60 | 61 | @ 62 | (n - 1) + 1 ~ n 63 | @ 64 | 65 | /without/ a @(1 <= n)@ constraint, even though when /n/ is set to /0/ the 66 | subtraction @n-1@ would be locally negative and hence not be a natural number. 67 | 68 | This would allow the following erroneous definition: 69 | 70 | @ 71 | data Fin (n :: Nat) where 72 | FZ :: Fin (n + 1) 73 | FS :: Fin n -> Fin (n + 1) 74 | 75 | f :: forall n . Natural -> Fin n 76 | f n = case of 77 | 0 -> FZ 78 | x -> FS (f \@(n-1) (x - 1)) 79 | 80 | fs :: [Fin 0] 81 | fs = f \<$\> [0..] 82 | @ 83 | 84 | === When it might be Okay 85 | 86 | This example is taken from the 87 | library. 88 | 89 | When you have: 90 | 91 | @ 92 | -- | Singleton type for the number of repetitions of an element. 93 | data Times (n :: Nat) where 94 | T :: Times n 95 | 96 | -- | An element of a "run-length encoded" vector, containing the value and 97 | -- the number of repetitions 98 | data Elem :: Type -> Nat -> Type where 99 | (:*) :: t -> Times n -> Elem t n 100 | 101 | -- | A length-indexed vector, optimised for repetitions. 102 | data OptVector :: Type -> Nat -> Type where 103 | End :: OptVector t 0 104 | (:-) :: Elem t l -> OptVector t (n - l) -> OptVector t n 105 | @ 106 | 107 | And you want to define: 108 | 109 | @ 110 | -- | Append two optimised vectors. 111 | type family (x :: OptVector t n) ++ (y :: OptVector t m) :: OptVector t (n + m) where 112 | ys ++ End = ys 113 | End ++ ys = ys 114 | (x :- xs) ++ ys = x :- (xs ++ ys) 115 | @ 116 | 117 | then the last line will give rise to the constraint: 118 | 119 | @ 120 | (n-l)+m ~ (n+m)-l 121 | @ 122 | 123 | because: 124 | 125 | @ 126 | x :: Elem t l 127 | xs :: OptVector t (n-l) 128 | ys :: OptVector t m 129 | @ 130 | 131 | In this case it's okay to add 132 | 133 | @ 134 | {\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} 135 | @ 136 | 137 | if you can convince yourself you will never be able to construct a: 138 | 139 | @ 140 | xs :: OptVector t (n-l) 141 | @ 142 | 143 | where /n-l/ is a negative number. 144 | -} 145 | 146 | {-# LANGUAGE LambdaCase #-} 147 | {-# LANGUAGE NamedFieldPuns #-} 148 | {-# LANGUAGE RecordWildCards #-} 149 | {-# LANGUAGE TupleSections #-} 150 | {-# LANGUAGE ViewPatterns #-} 151 | {-# LANGUAGE TemplateHaskellQuotes #-} 152 | 153 | {-# OPTIONS_HADDOCK show-extensions #-} 154 | 155 | module GHC.TypeLits.Normalise 156 | ( plugin ) 157 | where 158 | 159 | -- external 160 | import Control.Arrow (second) 161 | import Control.Monad ((<=<), forM) 162 | import Control.Monad.Trans.Writer.Strict 163 | import Data.Either (partitionEithers, rights) 164 | import Data.IORef 165 | import Data.List (intersect, partition, stripPrefix, find) 166 | import Data.Maybe (mapMaybe, catMaybes) 167 | import Data.Set (Set, empty, toList, notMember, fromList, union) 168 | import Text.Read (readMaybe) 169 | import qualified Data.Type.Ord 170 | import qualified GHC.TypeError 171 | 172 | import GHC.TcPluginM.Extra (tracePlugin, newGiven, newWanted) 173 | 174 | -- GHC API 175 | import GHC.Builtin.Names (knownNatClassName, eqTyConKey, heqTyConKey, hasKey) 176 | import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon) 177 | import GHC.Builtin.Types.Literals 178 | (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon) 179 | import GHC.Builtin.Types (naturalTy, cTupleDataCon, cTupleTyCon) 180 | import GHC.Builtin.Types.Literals (typeNatCmpTyCon) 181 | import GHC.Core (Expr (..)) 182 | import GHC.Core.Class (className) 183 | import GHC.Core.Coercion (Coercion, Role (..), mkUnivCo) 184 | import GHC.Core.DataCon (dataConWrapId) 185 | import GHC.Core.Predicate 186 | (EqRel (NomEq), Pred (EqPred, IrredPred), classifyPredType, mkClassPred, 187 | mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe) 188 | import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..)) 189 | import GHC.Core.TyCon (TyCon) 190 | import GHC.Core.Type 191 | (Kind, PredType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp) 192 | import GHC.Core.TyCo.Compare 193 | (eqType) 194 | import GHC.Data.IOEnv (getEnv) 195 | import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin) 196 | import GHC.Plugins (thNameToGhcNameIO, HscEnv (hsc_NC)) 197 | import GHC.Tc.Plugin 198 | (TcPluginM, tcLookupClass, tcPluginTrace, tcPluginIO, newEvVar) 199 | import GHC.Tc.Plugin (tcLookupTyCon, unsafeTcPluginTcM) 200 | import GHC.Tc.Types (TcPlugin (..), TcPluginSolveResult(..), Env (env_top)) 201 | import GHC.Tc.Types.Constraint 202 | (Ct, CtEvidence (..), TcEvDest (..), ctEvidence, ctEvCoercion, ctLoc, isGiven, 203 | isWanted, mkNonCanonical, isWantedCt, ctEvLoc, ctEvPred, ctEvExpr, 204 | emptyRewriterSet, setCtEvLoc) 205 | import GHC.Tc.Types.CtLoc (CtLoc, ctLocSpan, setCtLocSpan) 206 | import GHC.Tc.Types.Evidence (EvBindsVar, EvTerm (..), evCast, evId, mkEvCast) 207 | import GHC.Types.Unique.FM (emptyUFM) 208 | import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text) 209 | import GHC (Name) 210 | 211 | -- template-haskell 212 | import qualified Language.Haskell.TH as TH 213 | 214 | -- internal 215 | import GHC.TypeLits.Normalise.SOP 216 | import GHC.TypeLits.Normalise.Unify hiding (subtractionToPred) 217 | 218 | isEqPredClass :: PredType -> Bool 219 | isEqPredClass ty = case tyConAppTyCon_maybe ty of 220 | Just tc -> tc `hasKey` eqTyConKey || tc `hasKey` heqTyConKey 221 | _ -> False 222 | 223 | -- | To use the plugin, add 224 | -- 225 | -- @ 226 | -- {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} 227 | -- @ 228 | -- 229 | -- To the header of your file. 230 | plugin :: Plugin 231 | plugin 232 | = defaultPlugin 233 | { tcPlugin = fmap (normalisePlugin . foldr id defaultOpts) . traverse parseArgument 234 | , pluginRecompile = purePlugin 235 | } 236 | where 237 | parseArgument "allow-negated-numbers" = Just (\ opts -> opts { negNumbers = True }) 238 | parseArgument (readMaybe <=< stripPrefix "depth=" -> Just depth) = Just (\ opts -> opts { depth }) 239 | parseArgument _ = Nothing 240 | defaultOpts = Opts { negNumbers = False, depth = 5 } 241 | 242 | data Opts = Opts { negNumbers :: Bool, depth :: Word } 243 | 244 | normalisePlugin :: Opts -> TcPlugin 245 | normalisePlugin opts = tracePlugin "ghc-typelits-natnormalise" 246 | TcPlugin { tcPluginInit = lookupExtraDefs 247 | , tcPluginSolve = decideEqualSOP opts 248 | , tcPluginRewrite = const emptyUFM 249 | , tcPluginStop = const (return ()) 250 | } 251 | 252 | type ExtraDefs = (IORef (Set CType), (TyCon,TyCon,TyCon)) 253 | 254 | lookupExtraDefs :: TcPluginM ExtraDefs 255 | lookupExtraDefs = do 256 | ref <- tcPluginIO (newIORef empty) 257 | ordCond <- lookupTHName ''Data.Type.Ord.OrdCond >>= tcLookupTyCon 258 | leqT <- lookupTHName ''(Data.Type.Ord.<=) >>= tcLookupTyCon 259 | assertT <- lookupTHName ''GHC.TypeError.Assert >>= tcLookupTyCon 260 | return (ref, (leqT,assertT,ordCond)) 261 | 262 | lookupTHName :: TH.Name -> TcPluginM Name 263 | lookupTHName th = do 264 | nc <- unsafeTcPluginTcM (hsc_NC . env_top <$> getEnv) 265 | res <- tcPluginIO $ thNameToGhcNameIO nc th 266 | maybe (fail $ "Failed to lookup " ++ show th) return res 267 | 268 | decideEqualSOP 269 | :: Opts 270 | -> ExtraDefs 271 | -- ^ 1. Givens that is already generated. 272 | -- We have to generate new givens at most once; 273 | -- otherwise GHC will loop indefinitely. 274 | -- 275 | -- 276 | -- 2. For GHc 9.2: TyCon of Data.Type.Ord.OrdCond 277 | -- For older: TyCon of GHC.TypeLits.<=? 278 | -> EvBindsVar 279 | -> [Ct] 280 | -> [Ct] 281 | -> TcPluginM TcPluginSolveResult 282 | 283 | -- Simplification phase: Derives /simplified/ givens; 284 | -- we can reduce given constraints like @Show (Foo (n + 2))@ 285 | -- to its normal form @Show (Foo (2 + n))@, which is eventually 286 | -- useful in solving phase. 287 | -- 288 | -- This helps us to solve /indirect/ constraints; 289 | -- without this phase, we cannot derive, e.g., 290 | -- @IsVector UVector (Fin (n + 1))@ from 291 | -- @Unbox (1 + n)@! 292 | decideEqualSOP opts (gen'd,(leqT,_,_)) ev givens [] = do 293 | done <- tcPluginIO $ readIORef gen'd 294 | let reds = 295 | filter (\(_,(_,_,v)) -> null v || negNumbers opts) $ 296 | reduceGivens opts leqT done givens 297 | newlyDone = map (\(_,(prd, _,_)) -> CType prd) reds 298 | tcPluginIO $ 299 | modifyIORef' gen'd $ union (fromList newlyDone) 300 | newGivens <- forM reds $ \(origCt, (pred', evTerm, _)) -> 301 | mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm 302 | return (TcPluginOk [] newGivens) 303 | 304 | -- Solving phase. 305 | -- Solves in/equalities on Nats and simplifiable constraints 306 | -- containing naturals. 307 | decideEqualSOP opts (gen'd,tcs@(leqT,_,_)) ev givens wanteds = do 308 | let unit_wanteds = mapMaybe (toNatEquality tcs) wanteds 309 | nonEqs = filter ( not 310 | . (\p -> isEqPred p || isEqPrimPred p) 311 | . ctEvPred 312 | . ctEvidence ) 313 | wanteds 314 | done <- tcPluginIO $ readIORef gen'd 315 | let redGs = reduceGivens opts leqT done givens 316 | newlyDone = map (\(_,(prd, _,_)) -> CType prd) redGs 317 | redGivens <- forM redGs $ \(origCt, (pred', evTerm, _)) -> 318 | mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm 319 | reducible_wanteds 320 | <- catMaybes <$> mapM (\ct -> fmap (ct,) <$> 321 | reduceNatConstr (givens ++ redGivens) ct) 322 | nonEqs 323 | if null unit_wanteds && null reducible_wanteds 324 | then return $ TcPluginOk [] [] 325 | else do 326 | -- Since reducible wanteds also can have some negation/subtraction 327 | -- subterms, we have to make sure appropriate inequalities to hold. 328 | -- Here, we generate such additional inequalities for reduction 329 | -- that is to be added to new [W]anteds. 330 | ineqForRedWants <- fmap concat $ forM redGs $ \(ct, (_,_, ws)) -> forM ws $ 331 | fmap (mkNonCanonical' (ctLoc ct)) . newWanted (ctLoc ct) 332 | tcPluginIO $ 333 | modifyIORef' gen'd $ union (fromList newlyDone) 334 | let unit_givens = mapMaybe 335 | (toNatEquality tcs) 336 | givens 337 | sr <- simplifyNats opts leqT unit_givens unit_wanteds 338 | tcPluginTrace "normalised" (ppr sr) 339 | reds <- forM reducible_wanteds $ \(origCt,(term, ws, wDicts)) -> do 340 | wants <- evSubtPreds (ctLoc origCt) $ subToPred opts leqT ws 341 | return ((term, origCt), wDicts ++ wants) 342 | case sr of 343 | Simplified evs -> do 344 | let simpld = filter (not . isGiven . ctEvidence . (\((_,x),_) -> x)) evs 345 | -- Only solve derived when we solved a wanted 346 | simpld1 = case filter (isWanted . ctEvidence . (\((_,x),_) -> x)) evs ++ reds of 347 | [] -> [] 348 | _ -> simpld 349 | (solved',newWanteds) = second concat (unzip $ simpld1 ++ reds) 350 | return (TcPluginOk solved' $ newWanteds ++ ineqForRedWants) 351 | Impossible eq -> return (TcPluginContradiction [fromNatEquality eq]) 352 | 353 | type NatEquality = (Ct,CoreSOP,CoreSOP) 354 | type NatInEquality = (Ct,(CoreSOP,CoreSOP,Bool)) 355 | 356 | reduceGivens :: Opts -> TyCon -> Set CType -> [Ct] -> [(Ct, (Type, EvTerm, [PredType]))] 357 | reduceGivens opts leqT done givens = 358 | let nonEqs = 359 | [ ct 360 | | ct <- givens 361 | , let ev = ctEvidence ct 362 | prd = ctEvPred ev 363 | , isGiven ev 364 | , not $ (\p -> isEqPred p || isEqPrimPred p || isEqPredClass p) prd 365 | ] 366 | in filter 367 | (\(_, (prd, _, _)) -> 368 | notMember (CType prd) done 369 | ) 370 | $ mapMaybe 371 | (\ct -> (ct,) <$> tryReduceGiven opts leqT givens ct) 372 | nonEqs 373 | 374 | tryReduceGiven 375 | :: Opts -> TyCon -> [Ct] -> Ct 376 | -> Maybe (PredType, EvTerm, [PredType]) 377 | tryReduceGiven opts leqT simplGivens ct = do 378 | let (mans, ws) = 379 | runWriter $ normaliseNatEverywhere $ 380 | ctEvPred $ ctEvidence ct 381 | ws' = [ p 382 | | p <- subToPred opts leqT ws 383 | , all (not . (`eqType` p). ctEvPred . ctEvidence) simplGivens 384 | ] 385 | -- deps = unitDVarSet (ctEvId ct) 386 | pred' <- mans 387 | return (pred', toReducedDict (ctEvidence ct) pred', ws') 388 | 389 | fromNatEquality :: Either NatEquality NatInEquality -> Ct 390 | fromNatEquality (Left (ct, _, _)) = ct 391 | fromNatEquality (Right (ct, _)) = ct 392 | 393 | reduceNatConstr :: [Ct] -> Ct -> TcPluginM (Maybe (EvTerm, [(Type, Type)], [Ct])) 394 | reduceNatConstr givens ct = do 395 | let pred0 = ctEvPred $ ctEvidence ct 396 | (mans, tests) = runWriter $ normaliseNatEverywhere pred0 397 | case mans of 398 | Nothing -> return Nothing 399 | Just pred' -> do 400 | case find ((`eqType` pred') .ctEvPred . ctEvidence) givens of 401 | -- No existing evidence found 402 | Nothing -> case getClassPredTys_maybe pred' of 403 | -- Are we trying to solve a class instance? 404 | Just (cls,_) | className cls /= knownNatClassName -> do 405 | -- Create new evidence binding for normalized class constraint 406 | evVar <- newEvVar pred' 407 | -- Bind the evidence to a new wanted normalized class constraint 408 | let wDict = mkNonCanonical 409 | (CtWanted pred' (EvVarDest evVar) (ctLoc ct) emptyRewriterSet) 410 | -- Evidence for current wanted is simply the coerced binding for 411 | -- the new binding 412 | evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") [] 413 | Representational 414 | pred' pred0 415 | ev = mkEvCast (evId evVar) evCo 416 | -- Use newly created coerced wanted as evidence, and emit the 417 | -- normalized wanted as a new constraint to solve. 418 | return (Just (ev, tests, [wDict])) 419 | _ -> return Nothing 420 | -- Use existing evidence 421 | Just c -> return (Just (toReducedDict (ctEvidence c) pred0, tests, [])) 422 | 423 | toReducedDict :: CtEvidence -> PredType -> EvTerm 424 | toReducedDict ct pred' = 425 | let pred0 = ctEvPred ct 426 | evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") [] 427 | Representational 428 | pred0 pred' 429 | ev = mkEvCast (ctEvExpr ct) evCo 430 | in ev 431 | 432 | data SimplifyResult 433 | = Simplified [((EvTerm,Ct),[Ct])] 434 | | Impossible (Either NatEquality NatInEquality) 435 | 436 | instance Outputable SimplifyResult where 437 | ppr (Simplified evs) = text "Simplified" $$ ppr evs 438 | ppr (Impossible eq) = text "Impossible" <+> ppr eq 439 | 440 | simplifyNats 441 | :: Opts 442 | -- ^ Allow negated numbers (potentially unsound!) 443 | -> TyCon 444 | -- * TyCon of Data.Type.Ord.<= 445 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 446 | -- ^ Given constraints 447 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 448 | -- ^ Wanted constraints 449 | -> TcPluginM SimplifyResult 450 | simplifyNats opts@Opts {..} leqT eqsG eqsW = do 451 | let eqsG1 = map (second (const ([] :: [(Type,Type)]))) eqsG 452 | (varEqs,otherEqs) = partition isVarEqs eqsG1 453 | fancyGivens = concatMap (makeGivensSet otherEqs) varEqs 454 | case varEqs of 455 | [] -> do 456 | let eqs = otherEqs ++ eqsW 457 | tcPluginTrace "simplifyNats" (ppr eqs) 458 | simples [] [] [] [] [] eqs 459 | _ -> do 460 | tcPluginTrace ("simplifyNats(backtrack: " ++ show (length fancyGivens) ++ ")") 461 | (ppr varEqs) 462 | 463 | allSimplified <- forM fancyGivens $ \v -> do 464 | let eqs = v ++ eqsW 465 | tcPluginTrace "simplifyNats" (ppr eqs) 466 | simples [] [] [] [] [] eqs 467 | 468 | pure (foldr findFirstSimpliedWanted (Simplified []) allSimplified) 469 | where 470 | simples :: [Coercion] 471 | -> [CoreUnify] 472 | -> [((EvTerm, Ct), [Ct])] 473 | -> [(CoreSOP,CoreSOP,Bool)] 474 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 475 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 476 | -> TcPluginM SimplifyResult 477 | simples _ _subst evs _leqsG _xs [] = return (Simplified evs) 478 | simples deps subst evs leqsG xs (eq@(Left (ct,u,v),k):eqs') = do 479 | let u' = substsSOP subst u 480 | v' = substsSOP subst v 481 | ur <- unifyNats ct u' v' 482 | tcPluginTrace "unifyNats result" (ppr ur) 483 | case ur of 484 | Win -> do 485 | evs' <- maybe evs (:evs) <$> evMagic ct deps empty (subToPred opts leqT k) 486 | simples deps subst evs' leqsG [] (xs ++ eqs') 487 | Lose -> if null evs && null eqs' 488 | then return (Impossible (fst eq)) 489 | else simples deps subst evs leqsG xs eqs' 490 | Draw [] -> simples deps subst evs [] (eq:xs) eqs' 491 | Draw subst' -> do 492 | evM <- evMagic ct deps empty (map unifyItemToPredType subst' ++ 493 | subToPred opts leqT k) 494 | let (leqsG1, deps1) 495 | | isGiven (ctEvidence ct) = ( eqToLeq u' v' ++ leqsG 496 | , ctEvCoercion (ctEvidence ct):deps) 497 | | otherwise = (leqsG, deps) 498 | case evM of 499 | Nothing -> simples deps1 subst evs leqsG1 xs eqs' 500 | Just ev -> 501 | simples (ctEvCoercion (ctEvidence ct):deps) 502 | (substsSubst subst' subst ++ subst') 503 | (ev:evs) leqsG1 [] (xs ++ eqs') 504 | simples deps subst evs leqsG xs (eq@(Right (ct,u@(x,y,b)),k):eqs') = do 505 | let u' = substsSOP subst (subtractIneq u) 506 | x' = substsSOP subst x 507 | y' = substsSOP subst y 508 | uS = (x',y',b) 509 | leqsG' | isGiven (ctEvidence ct) = (x',y',b):leqsG 510 | | otherwise = leqsG 511 | ineqs = concat [ leqsG 512 | , map (substLeq subst) leqsG 513 | , map snd (rights (map fst eqsG)) 514 | ] 515 | tcPluginTrace "unifyNats(ineq) results" (ppr (ct,u,u',ineqs)) 516 | case runWriterT (isNatural u') of 517 | Just (True,knW) -> do 518 | evs' <- maybe evs (:evs) <$> evMagic ct deps knW (subToPred opts leqT k) 519 | simples deps subst evs' leqsG' xs eqs' 520 | 521 | Just (False,_) | null k -> return (Impossible (fst eq)) 522 | _ -> do 523 | let solvedIneq = mapMaybe runWriterT 524 | -- it is an inequality that can be instantly solved, such as 525 | -- `1 <= x^y` 526 | -- OR 527 | (instantSolveIneq depth u: 528 | instantSolveIneq depth uS: 529 | -- This inequality is either a given constraint, or it is a wanted 530 | -- constraint, which in normal form is equal to another given 531 | -- constraint, hence it can be solved. 532 | -- OR 533 | map (solveIneq depth u) ineqs ++ 534 | -- The above, but with valid substitutions applied to the wanted. 535 | map (solveIneq depth uS) ineqs) 536 | smallest = solvedInEqSmallestConstraint solvedIneq 537 | case smallest of 538 | (True,kW) -> do 539 | evs' <- maybe evs (:evs) <$> evMagic ct deps kW (subToPred opts leqT k) 540 | simples deps subst evs' leqsG' xs eqs' 541 | _ -> simples deps subst evs leqsG (eq:xs) eqs' 542 | 543 | eqToLeq x y = [(x,y,True),(y,x,True)] 544 | substLeq s (x,y,b) = (substsSOP s x, substsSOP s y, b) 545 | 546 | isVarEqs (Left (_,S [P [V _]], S [P [V _]]), _) = True 547 | isVarEqs _ = False 548 | 549 | makeGivensSet otherEqs varEq 550 | = let (noMentionsV,mentionsV) = partitionEithers 551 | (map (matchesVarEq varEq) otherEqs) 552 | (mentionsLHS,mentionsRHS) = partitionEithers mentionsV 553 | vS = swapVar varEq 554 | givensLHS = case mentionsLHS of 555 | [] -> [] 556 | _ -> [mentionsLHS ++ ((varEq:mentionsRHS) ++ noMentionsV)] 557 | givensRHS = case mentionsRHS of 558 | [] -> [] 559 | _ -> [mentionsRHS ++ (vS:mentionsLHS ++ noMentionsV)] 560 | in case mentionsV of 561 | [] -> [noMentionsV] 562 | _ -> givensLHS ++ givensRHS 563 | 564 | matchesVarEq (Left (_, S [P [V v1]], S [P [V v2]]),_) r = case r of 565 | (Left (_,S [P [V v3]],_),_) 566 | | v1 == v3 -> Right (Left r) 567 | | v2 == v3 -> Right (Right r) 568 | (Left (_,_,S [P [V v3]]),_) 569 | | v1 == v3 -> Right (Left r) 570 | | v2 == v3 -> Right (Right r) 571 | (Right (_,(S [P [V v3]],_,_)),_) 572 | | v1 == v3 -> Right (Left r) 573 | | v2 == v3 -> Right (Right r) 574 | (Right (_,(_,S [P [V v3]],_)),_) 575 | | v1 == v3 -> Right (Left r) 576 | | v2 == v3 -> Right (Right r) 577 | _ -> Left r 578 | matchesVarEq _ _ = error "internal error" 579 | 580 | swapVar (Left (ct,S [P [V v1]], S [P [V v2]]),ps) = 581 | (Left (ct,S [P [V v2]], S [P [V v1]]),ps) 582 | swapVar _ = error "internal error" 583 | 584 | findFirstSimpliedWanted (Impossible e) _ = Impossible e 585 | findFirstSimpliedWanted (Simplified evs) s2 586 | | any (isWantedCt . snd . fst) evs 587 | = Simplified evs 588 | | otherwise 589 | = s2 590 | 591 | -- If we allow negated numbers we simply do not emit the inequalities 592 | -- derived from the subtractions that are converted to additions with a 593 | -- negated operand 594 | subToPred :: Opts -> TyCon -> [(Type, Type)] -> [PredType] 595 | subToPred Opts{..} leqT 596 | | negNumbers = const [] 597 | | otherwise = map leq 598 | where 599 | leq (a,b) = 600 | let lhs = TyConApp leqT [naturalTy,b,a] 601 | rhs = TyConApp (cTupleTyCon 0) [] 602 | in mkPrimEqPred lhs rhs 603 | 604 | -- Extract the Nat equality constraints 605 | toNatEquality :: (TyCon,TyCon,TyCon) -> Ct -> Maybe (Either NatEquality NatInEquality,[(Type,Type)]) 606 | toNatEquality (_,assertT,ordCond) ct = case classifyPredType $ ctEvPred $ ctEvidence ct of 607 | EqPred NomEq t1 t2 608 | -> go t1 t2 609 | IrredPred p 610 | -> go2 p 611 | _ -> Nothing 612 | where 613 | go (TyConApp tc xs) (TyConApp tc' ys) 614 | | tc == tc' 615 | , null ([tc,tc'] `intersect` [typeNatAddTyCon,typeNatSubTyCon 616 | ,typeNatMulTyCon,typeNatExpTyCon]) 617 | = case filter (not . uncurry eqType) (zip xs ys) of 618 | [(x,y)] 619 | | isNatKind (typeKind x) 620 | , isNatKind (typeKind y) 621 | , let (x',k1) = runWriter (normaliseNat x) 622 | , let (y',k2) = runWriter (normaliseNat y) 623 | -> Just (Left (ct, x', y'),k1 ++ k2) 624 | _ -> Nothing 625 | | tc == ordCond 626 | , [_,cmp,lt,eq,gt] <- xs 627 | , TyConApp tcCmpNat [x,y] <- cmp 628 | , tcCmpNat == typeNatCmpTyCon 629 | , TyConApp ltTc [] <- lt 630 | , ltTc == promotedTrueDataCon 631 | , TyConApp eqTc [] <- eq 632 | , eqTc == promotedTrueDataCon 633 | , TyConApp gtTc [] <- gt 634 | , gtTc == promotedFalseDataCon 635 | , let (x',k1) = runWriter (normaliseNat x) 636 | , let (y',k2) = runWriter (normaliseNat y) 637 | , let ks = k1 ++ k2 638 | = case tc' of 639 | _ | tc' == promotedTrueDataCon 640 | -> Just (Right (ct, (x', y', True)), ks) 641 | _ | tc' == promotedFalseDataCon 642 | -> Just (Right (ct, (x', y', False)), ks) 643 | _ -> Nothing 644 | | tc == assertT 645 | , tc' == (cTupleTyCon 0) 646 | , [] <- ys 647 | , [TyConApp ordCondTc zs, _] <- xs 648 | , ordCondTc == ordCond 649 | , [_,cmp,lt,eq,gt] <- zs 650 | , TyConApp tcCmpNat [x,y] <- cmp 651 | , tcCmpNat == typeNatCmpTyCon 652 | , TyConApp ltTc [] <- lt 653 | , ltTc == promotedTrueDataCon 654 | , TyConApp eqTc [] <- eq 655 | , eqTc == promotedTrueDataCon 656 | , TyConApp gtTc [] <- gt 657 | , gtTc == promotedFalseDataCon 658 | , let (x',k1) = runWriter (normaliseNat x) 659 | , let (y',k2) = runWriter (normaliseNat y) 660 | , let ks = k1 ++ k2 661 | = Just (Right (ct, (x', y', True)), ks) 662 | 663 | go x y 664 | | isNatKind (typeKind x) 665 | , isNatKind (typeKind y) 666 | , let (x',k1) = runWriter (normaliseNat x) 667 | , let (y',k2) = runWriter (normaliseNat y) 668 | = Just (Left (ct,x',y'),k1 ++ k2) 669 | | otherwise 670 | = Nothing 671 | 672 | go2 (TyConApp tc ys) 673 | | tc == assertT 674 | , [TyConApp ordCondTc xs, _] <- ys 675 | , ordCondTc == ordCond 676 | , [_,cmp,lt,eq,gt] <- xs 677 | , TyConApp tcCmpNat [x,y] <- cmp 678 | , tcCmpNat == typeNatCmpTyCon 679 | , TyConApp ltTc [] <- lt 680 | , ltTc == promotedTrueDataCon 681 | , TyConApp eqTc [] <- eq 682 | , eqTc == promotedTrueDataCon 683 | , TyConApp gtTc [] <- gt 684 | , gtTc == promotedFalseDataCon 685 | , let (x',k1) = runWriter (normaliseNat x) 686 | , let (y',k2) = runWriter (normaliseNat y) 687 | , let ks = k1 ++ k2 688 | = Just (Right (ct, (x', y', True)), ks) 689 | 690 | go2 _ = Nothing 691 | 692 | isNatKind :: Kind -> Bool 693 | isNatKind = (`eqType` naturalTy) 694 | 695 | unifyItemToPredType :: CoreUnify -> PredType 696 | unifyItemToPredType ui = mkPrimEqPred ty1 ty2 697 | where 698 | ty1 = case ui of 699 | SubstItem {..} -> mkTyVarTy siVar 700 | UnifyItem {..} -> reifySOP siLHS 701 | ty2 = case ui of 702 | SubstItem {..} -> reifySOP siSOP 703 | UnifyItem {..} -> reifySOP siRHS 704 | 705 | evSubtPreds :: CtLoc -> [PredType] -> TcPluginM [Ct] 706 | evSubtPreds loc = mapM (fmap mkNonCanonical . newWanted loc) 707 | 708 | evMagic :: Ct -> [Coercion] -> Set CType -> [PredType] -> TcPluginM (Maybe ((EvTerm, Ct), [Ct])) 709 | evMagic ct deps knW preds = do 710 | holeWanteds <- evSubtPreds (ctLoc ct) preds 711 | knWanted <- mapM (mkKnWanted (ctLoc ct)) (toList knW) 712 | let newWant = knWanted ++ holeWanteds 713 | case classifyPredType $ ctEvPred $ ctEvidence ct of 714 | EqPred NomEq t1 t2 -> 715 | let ctEv = mkUnivCo (PluginProv "ghc-typelits-natnormalise") deps Nominal t1 t2 716 | in return (Just ((EvExpr (Coercion ctEv), ct),newWant)) 717 | IrredPred p -> 718 | let t1 = mkTyConApp (cTupleTyCon 0) [] 719 | co = mkUnivCo (PluginProv "ghc-typelits-natnormalise") deps Representational t1 p 720 | dcApp = evId (dataConWrapId (cTupleDataCon 0)) 721 | in return (Just ((evCast dcApp co, ct),newWant)) 722 | _ -> return Nothing 723 | 724 | mkNonCanonical' :: CtLoc -> CtEvidence -> Ct 725 | mkNonCanonical' origCtl ev = 726 | let ct_ls = ctLocSpan origCtl 727 | ctl = ctEvLoc ev 728 | in mkNonCanonical (setCtEvLoc ev (setCtLocSpan ctl ct_ls)) 729 | 730 | mkKnWanted 731 | :: CtLoc 732 | -> CType 733 | -> TcPluginM Ct 734 | mkKnWanted loc (CType ty) = do 735 | kc_clas <- tcLookupClass knownNatClassName 736 | let kn_pred = mkClassPred kc_clas [ty] 737 | wantedCtEv <- newWanted loc kn_pred 738 | let wanted' = mkNonCanonical' loc wantedCtEv 739 | return wanted' 740 | -------------------------------------------------------------------------------- /src-ghc-9.4/GHC/TypeLits/Normalise.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (C) 2015-2016, University of Twente, 3 | 2017 , QBayLogic B.V. 4 | License : BSD2 (see the file LICENSE) 5 | Maintainer : Christiaan Baaij 6 | 7 | A type checker plugin for GHC that can solve /equalities/ of types of kind 8 | 'GHC.TypeLits.Nat', where these types are either: 9 | 10 | * Type-level naturals 11 | * Type variables 12 | * Applications of the arithmetic expressions @(+,-,*,^)@. 13 | 14 | It solves these equalities by normalising them to /sort-of/ 15 | 'GHC.TypeLits.Normalise.SOP.SOP' (Sum-of-Products) form, and then perform a 16 | simple syntactic equality. 17 | 18 | For example, this solver can prove the equality between: 19 | 20 | @ 21 | (x + 2)^(y + 2) 22 | @ 23 | 24 | and 25 | 26 | @ 27 | 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 28 | @ 29 | 30 | Because the latter is actually the 'GHC.TypeLits.Normalise.SOP.SOP' normal form 31 | of the former. 32 | 33 | To use the plugin, add 34 | 35 | @ 36 | {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} 37 | @ 38 | 39 | To the header of your file. 40 | 41 | == Treating subtraction as addition with a negated number 42 | 43 | If you are absolutely sure that your subtractions can /never/ lead to (a locally) 44 | negative number, you can ask the plugin to treat subtraction as addition with 45 | a negated operand by additionally adding: 46 | 47 | @ 48 | {\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} 49 | @ 50 | 51 | to the header of your file, thereby allowing to use associativity and 52 | commutativity rules when proving constraints involving subtractions. Note that 53 | this option can lead to unsound behaviour and should be handled with extreme 54 | care. 55 | 56 | === When it leads to unsound behaviour 57 | 58 | For example, enabling the /allow-negated-numbers/ feature would allow 59 | you to prove: 60 | 61 | @ 62 | (n - 1) + 1 ~ n 63 | @ 64 | 65 | /without/ a @(1 <= n)@ constraint, even though when /n/ is set to /0/ the 66 | subtraction @n-1@ would be locally negative and hence not be a natural number. 67 | 68 | This would allow the following erroneous definition: 69 | 70 | @ 71 | data Fin (n :: Nat) where 72 | FZ :: Fin (n + 1) 73 | FS :: Fin n -> Fin (n + 1) 74 | 75 | f :: forall n . Natural -> Fin n 76 | f n = case of 77 | 0 -> FZ 78 | x -> FS (f \@(n-1) (x - 1)) 79 | 80 | fs :: [Fin 0] 81 | fs = f \<$\> [0..] 82 | @ 83 | 84 | === When it might be Okay 85 | 86 | This example is taken from the 87 | library. 88 | 89 | When you have: 90 | 91 | @ 92 | -- | Singleton type for the number of repetitions of an element. 93 | data Times (n :: Nat) where 94 | T :: Times n 95 | 96 | -- | An element of a "run-length encoded" vector, containing the value and 97 | -- the number of repetitions 98 | data Elem :: Type -> Nat -> Type where 99 | (:*) :: t -> Times n -> Elem t n 100 | 101 | -- | A length-indexed vector, optimised for repetitions. 102 | data OptVector :: Type -> Nat -> Type where 103 | End :: OptVector t 0 104 | (:-) :: Elem t l -> OptVector t (n - l) -> OptVector t n 105 | @ 106 | 107 | And you want to define: 108 | 109 | @ 110 | -- | Append two optimised vectors. 111 | type family (x :: OptVector t n) ++ (y :: OptVector t m) :: OptVector t (n + m) where 112 | ys ++ End = ys 113 | End ++ ys = ys 114 | (x :- xs) ++ ys = x :- (xs ++ ys) 115 | @ 116 | 117 | then the last line will give rise to the constraint: 118 | 119 | @ 120 | (n-l)+m ~ (n+m)-l 121 | @ 122 | 123 | because: 124 | 125 | @ 126 | x :: Elem t l 127 | xs :: OptVector t (n-l) 128 | ys :: OptVector t m 129 | @ 130 | 131 | In this case it's okay to add 132 | 133 | @ 134 | {\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} 135 | @ 136 | 137 | if you can convince yourself you will never be able to construct a: 138 | 139 | @ 140 | xs :: OptVector t (n-l) 141 | @ 142 | 143 | where /n-l/ is a negative number. 144 | -} 145 | 146 | {-# LANGUAGE CPP #-} 147 | {-# LANGUAGE LambdaCase #-} 148 | {-# LANGUAGE NamedFieldPuns #-} 149 | {-# LANGUAGE RecordWildCards #-} 150 | {-# LANGUAGE TupleSections #-} 151 | {-# LANGUAGE ViewPatterns #-} 152 | {-# LANGUAGE TemplateHaskellQuotes #-} 153 | 154 | {-# OPTIONS_HADDOCK show-extensions #-} 155 | 156 | module GHC.TypeLits.Normalise 157 | ( plugin ) 158 | where 159 | 160 | -- external 161 | import Control.Arrow (second) 162 | import Control.Monad ((<=<), forM) 163 | import Control.Monad.Trans.Writer.Strict 164 | import Data.Either (partitionEithers, rights) 165 | import Data.IORef 166 | import Data.List (intersect, partition, stripPrefix, find) 167 | import Data.Maybe (mapMaybe, catMaybes) 168 | import Data.Set (Set, empty, toList, notMember, fromList, union) 169 | import Text.Read (readMaybe) 170 | import qualified Data.Type.Ord 171 | import qualified GHC.TypeError 172 | 173 | import GHC.TcPluginM.Extra (tracePlugin, newGiven, newWanted) 174 | 175 | -- GHC API 176 | import GHC.Builtin.Names (knownNatClassName, eqTyConKey, heqTyConKey, hasKey) 177 | import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon) 178 | import GHC.Builtin.Types.Literals 179 | (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon) 180 | import GHC.Builtin.Types (naturalTy, cTupleDataCon, cTupleTyCon) 181 | import GHC.Builtin.Types.Literals (typeNatCmpTyCon) 182 | import GHC.Core (Expr (..)) 183 | import GHC.Core.Class (className) 184 | import GHC.Core.Coercion (Role (..), mkUnivCo) 185 | import GHC.Core.DataCon (dataConWrapId) 186 | import GHC.Core.Predicate 187 | (EqRel (NomEq), Pred (EqPred, IrredPred), classifyPredType, mkClassPred, 188 | mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe) 189 | import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..)) 190 | import GHC.Core.TyCon (TyCon) 191 | #if MIN_VERSION_ghc(9,6,0) 192 | import GHC.Core.Type 193 | (Kind, PredType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp) 194 | import GHC.Core.TyCo.Compare 195 | (eqType) 196 | #else 197 | import GHC.Core.Type 198 | (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp) 199 | #endif 200 | import GHC.Data.IOEnv (getEnv) 201 | import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin) 202 | import GHC.Plugins (thNameToGhcNameIO, HscEnv (hsc_NC)) 203 | import GHC.Tc.Plugin 204 | (TcPluginM, tcLookupClass, tcPluginTrace, tcPluginIO, newEvVar) 205 | import GHC.Tc.Plugin (tcLookupTyCon, unsafeTcPluginTcM) 206 | import GHC.Tc.Types (TcPlugin (..), TcPluginSolveResult(..), Env (env_top)) 207 | import GHC.Tc.Types.Constraint 208 | (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence, 209 | ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLocSpan, 210 | isWantedCt, ctEvLoc, ctEvPred, ctEvExpr, emptyRewriterSet, setCtEvLoc) 211 | import GHC.Tc.Types.Evidence (EvBindsVar, EvTerm (..), evCast, evId) 212 | import GHC.Types.Unique.FM (emptyUFM) 213 | import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text) 214 | import GHC (Name) 215 | 216 | -- template-haskell 217 | import qualified Language.Haskell.TH as TH 218 | 219 | -- internal 220 | import GHC.TypeLits.Normalise.SOP 221 | import GHC.TypeLits.Normalise.Unify hiding (subtractionToPred) 222 | 223 | isEqPredClass :: PredType -> Bool 224 | isEqPredClass ty = case tyConAppTyCon_maybe ty of 225 | Just tc -> tc `hasKey` eqTyConKey || tc `hasKey` heqTyConKey 226 | _ -> False 227 | 228 | -- | To use the plugin, add 229 | -- 230 | -- @ 231 | -- {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} 232 | -- @ 233 | -- 234 | -- To the header of your file. 235 | plugin :: Plugin 236 | plugin 237 | = defaultPlugin 238 | { tcPlugin = fmap (normalisePlugin . foldr id defaultOpts) . traverse parseArgument 239 | , pluginRecompile = purePlugin 240 | } 241 | where 242 | parseArgument "allow-negated-numbers" = Just (\ opts -> opts { negNumbers = True }) 243 | parseArgument (readMaybe <=< stripPrefix "depth=" -> Just depth) = Just (\ opts -> opts { depth }) 244 | parseArgument _ = Nothing 245 | defaultOpts = Opts { negNumbers = False, depth = 5 } 246 | 247 | data Opts = Opts { negNumbers :: Bool, depth :: Word } 248 | 249 | normalisePlugin :: Opts -> TcPlugin 250 | normalisePlugin opts = tracePlugin "ghc-typelits-natnormalise" 251 | TcPlugin { tcPluginInit = lookupExtraDefs 252 | , tcPluginSolve = decideEqualSOP opts 253 | , tcPluginRewrite = const emptyUFM 254 | , tcPluginStop = const (return ()) 255 | } 256 | 257 | type ExtraDefs = (IORef (Set CType), (TyCon,TyCon,TyCon)) 258 | 259 | lookupExtraDefs :: TcPluginM ExtraDefs 260 | lookupExtraDefs = do 261 | ref <- tcPluginIO (newIORef empty) 262 | ordCond <- lookupTHName ''Data.Type.Ord.OrdCond >>= tcLookupTyCon 263 | leqT <- lookupTHName ''(Data.Type.Ord.<=) >>= tcLookupTyCon 264 | assertT <- lookupTHName ''GHC.TypeError.Assert >>= tcLookupTyCon 265 | return (ref, (leqT,assertT,ordCond)) 266 | 267 | lookupTHName :: TH.Name -> TcPluginM Name 268 | lookupTHName th = do 269 | nc <- unsafeTcPluginTcM (hsc_NC . env_top <$> getEnv) 270 | res <- tcPluginIO $ thNameToGhcNameIO nc th 271 | maybe (fail $ "Failed to lookup " ++ show th) return res 272 | 273 | decideEqualSOP 274 | :: Opts 275 | -> ExtraDefs 276 | -- ^ 1. Givens that is already generated. 277 | -- We have to generate new givens at most once; 278 | -- otherwise GHC will loop indefinitely. 279 | -- 280 | -- 281 | -- 2. For GHc 9.2: TyCon of Data.Type.Ord.OrdCond 282 | -- For older: TyCon of GHC.TypeLits.<=? 283 | -> EvBindsVar 284 | -> [Ct] 285 | -> [Ct] 286 | -> TcPluginM TcPluginSolveResult 287 | 288 | -- Simplification phase: Derives /simplified/ givens; 289 | -- we can reduce given constraints like @Show (Foo (n + 2))@ 290 | -- to its normal form @Show (Foo (2 + n))@, which is eventually 291 | -- useful in solving phase. 292 | -- 293 | -- This helps us to solve /indirect/ constraints; 294 | -- without this phase, we cannot derive, e.g., 295 | -- @IsVector UVector (Fin (n + 1))@ from 296 | -- @Unbox (1 + n)@! 297 | decideEqualSOP opts (gen'd,(leqT,_,_)) ev givens [] = do 298 | done <- tcPluginIO $ readIORef gen'd 299 | let reds = 300 | filter (\(_,(_,_,v)) -> null v || negNumbers opts) $ 301 | reduceGivens opts leqT done givens 302 | newlyDone = map (\(_,(prd, _,_)) -> CType prd) reds 303 | tcPluginIO $ 304 | modifyIORef' gen'd $ union (fromList newlyDone) 305 | newGivens <- forM reds $ \(origCt, (pred', evTerm, _)) -> 306 | mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm 307 | return (TcPluginOk [] newGivens) 308 | 309 | -- Solving phase. 310 | -- Solves in/equalities on Nats and simplifiable constraints 311 | -- containing naturals. 312 | decideEqualSOP opts (gen'd,tcs@(leqT,_,_)) ev givens wanteds = do 313 | let unit_wanteds = mapMaybe (toNatEquality tcs) wanteds 314 | nonEqs = filter ( not 315 | . (\p -> isEqPred p || isEqPrimPred p) 316 | . ctEvPred 317 | . ctEvidence ) 318 | wanteds 319 | done <- tcPluginIO $ readIORef gen'd 320 | let redGs = reduceGivens opts leqT done givens 321 | newlyDone = map (\(_,(prd, _,_)) -> CType prd) redGs 322 | redGivens <- forM redGs $ \(origCt, (pred', evTerm, _)) -> 323 | mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm 324 | reducible_wanteds 325 | <- catMaybes <$> mapM (\ct -> fmap (ct,) <$> 326 | reduceNatConstr (givens ++ redGivens) ct) 327 | nonEqs 328 | if null unit_wanteds && null reducible_wanteds 329 | then return $ TcPluginOk [] [] 330 | else do 331 | -- Since reducible wanteds also can have some negation/subtraction 332 | -- subterms, we have to make sure appropriate inequalities to hold. 333 | -- Here, we generate such additional inequalities for reduction 334 | -- that is to be added to new [W]anteds. 335 | ineqForRedWants <- fmap concat $ forM redGs $ \(ct, (_,_, ws)) -> forM ws $ 336 | fmap (mkNonCanonical' (ctLoc ct)) . newWanted (ctLoc ct) 337 | tcPluginIO $ 338 | modifyIORef' gen'd $ union (fromList newlyDone) 339 | let unit_givens = mapMaybe 340 | (toNatEquality tcs) 341 | givens 342 | sr <- simplifyNats opts leqT unit_givens unit_wanteds 343 | tcPluginTrace "normalised" (ppr sr) 344 | reds <- forM reducible_wanteds $ \(origCt,(term, ws, wDicts)) -> do 345 | wants <- evSubtPreds (ctLoc origCt) $ subToPred opts leqT ws 346 | return ((term, origCt), wDicts ++ wants) 347 | case sr of 348 | Simplified evs -> do 349 | let simpld = filter (not . isGiven . ctEvidence . (\((_,x),_) -> x)) evs 350 | -- Only solve derived when we solved a wanted 351 | simpld1 = case filter (isWanted . ctEvidence . (\((_,x),_) -> x)) evs ++ reds of 352 | [] -> [] 353 | _ -> simpld 354 | (solved',newWanteds) = second concat (unzip $ simpld1 ++ reds) 355 | return (TcPluginOk solved' $ newWanteds ++ ineqForRedWants) 356 | Impossible eq -> return (TcPluginContradiction [fromNatEquality eq]) 357 | 358 | type NatEquality = (Ct,CoreSOP,CoreSOP) 359 | type NatInEquality = (Ct,(CoreSOP,CoreSOP,Bool)) 360 | 361 | reduceGivens :: Opts -> TyCon -> Set CType -> [Ct] -> [(Ct, (Type, EvTerm, [PredType]))] 362 | reduceGivens opts leqT done givens = 363 | let nonEqs = 364 | [ ct 365 | | ct <- givens 366 | , let ev = ctEvidence ct 367 | prd = ctEvPred ev 368 | , isGiven ev 369 | , not $ (\p -> isEqPred p || isEqPrimPred p || isEqPredClass p) prd 370 | ] 371 | in filter 372 | (\(_, (prd, _, _)) -> 373 | notMember (CType prd) done 374 | ) 375 | $ mapMaybe 376 | (\ct -> (ct,) <$> tryReduceGiven opts leqT givens ct) 377 | nonEqs 378 | 379 | tryReduceGiven 380 | :: Opts -> TyCon -> [Ct] -> Ct 381 | -> Maybe (PredType, EvTerm, [PredType]) 382 | tryReduceGiven opts leqT simplGivens ct = do 383 | let (mans, ws) = 384 | runWriter $ normaliseNatEverywhere $ 385 | ctEvPred $ ctEvidence ct 386 | ws' = [ p 387 | | p <- subToPred opts leqT ws 388 | , all (not . (`eqType` p). ctEvPred . ctEvidence) simplGivens 389 | ] 390 | pred' <- mans 391 | return (pred', toReducedDict (ctEvidence ct) pred', ws') 392 | 393 | fromNatEquality :: Either NatEquality NatInEquality -> Ct 394 | fromNatEquality (Left (ct, _, _)) = ct 395 | fromNatEquality (Right (ct, _)) = ct 396 | 397 | reduceNatConstr :: [Ct] -> Ct -> TcPluginM (Maybe (EvTerm, [(Type, Type)], [Ct])) 398 | reduceNatConstr givens ct = do 399 | let pred0 = ctEvPred $ ctEvidence ct 400 | (mans, tests) = runWriter $ normaliseNatEverywhere pred0 401 | case mans of 402 | Nothing -> return Nothing 403 | Just pred' -> do 404 | case find ((`eqType` pred') .ctEvPred . ctEvidence) givens of 405 | -- No existing evidence found 406 | Nothing -> case getClassPredTys_maybe pred' of 407 | -- Are we trying to solve a class instance? 408 | Just (cls,_) | className cls /= knownNatClassName -> do 409 | -- Create new evidence binding for normalized class constraint 410 | evVar <- newEvVar pred' 411 | -- Bind the evidence to a new wanted normalized class constraint 412 | let wDict = mkNonCanonical 413 | (CtWanted pred' (EvVarDest evVar) (ctLoc ct) emptyRewriterSet) 414 | -- Evidence for current wanted is simply the coerced binding for 415 | -- the new binding 416 | evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") 417 | Representational 418 | pred' pred0 419 | ev = evId evVar `evCast` evCo 420 | -- Use newly created coerced wanted as evidence, and emit the 421 | -- normalized wanted as a new constraint to solve. 422 | return (Just (ev, tests, [wDict])) 423 | _ -> return Nothing 424 | -- Use existing evidence 425 | Just c -> return (Just (toReducedDict (ctEvidence c) pred0, tests, [])) 426 | 427 | toReducedDict :: CtEvidence -> PredType -> EvTerm 428 | toReducedDict ct pred' = 429 | let pred0 = ctEvPred ct 430 | evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") 431 | Representational 432 | pred0 pred' 433 | ev = ctEvExpr ct 434 | `evCast` evCo 435 | in ev 436 | 437 | data SimplifyResult 438 | = Simplified [((EvTerm,Ct),[Ct])] 439 | | Impossible (Either NatEquality NatInEquality) 440 | 441 | instance Outputable SimplifyResult where 442 | ppr (Simplified evs) = text "Simplified" $$ ppr evs 443 | ppr (Impossible eq) = text "Impossible" <+> ppr eq 444 | 445 | simplifyNats 446 | :: Opts 447 | -- ^ Allow negated numbers (potentially unsound!) 448 | -> TyCon 449 | -- * TyCon of Data.Type.Ord.<= 450 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 451 | -- ^ Given constraints 452 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 453 | -- ^ Wanted constraints 454 | -> TcPluginM SimplifyResult 455 | simplifyNats opts@Opts {..} leqT eqsG eqsW = do 456 | let eqsG1 = map (second (const ([] :: [(Type,Type)]))) eqsG 457 | (varEqs,otherEqs) = partition isVarEqs eqsG1 458 | fancyGivens = concatMap (makeGivensSet otherEqs) varEqs 459 | case varEqs of 460 | [] -> do 461 | let eqs = otherEqs ++ eqsW 462 | tcPluginTrace "simplifyNats" (ppr eqs) 463 | simples [] [] [] [] eqs 464 | _ -> do 465 | tcPluginTrace ("simplifyNats(backtrack: " ++ show (length fancyGivens) ++ ")") 466 | (ppr varEqs) 467 | 468 | allSimplified <- forM fancyGivens $ \v -> do 469 | let eqs = v ++ eqsW 470 | tcPluginTrace "simplifyNats" (ppr eqs) 471 | simples [] [] [] [] eqs 472 | 473 | pure (foldr findFirstSimpliedWanted (Simplified []) allSimplified) 474 | where 475 | simples :: [CoreUnify] 476 | -> [((EvTerm, Ct), [Ct])] 477 | -> [(CoreSOP,CoreSOP,Bool)] 478 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 479 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 480 | -> TcPluginM SimplifyResult 481 | simples _subst evs _leqsG _xs [] = return (Simplified evs) 482 | simples subst evs leqsG xs (eq@(Left (ct,u,v),k):eqs') = do 483 | let u' = substsSOP subst u 484 | v' = substsSOP subst v 485 | ur <- unifyNats ct u' v' 486 | tcPluginTrace "unifyNats result" (ppr ur) 487 | case ur of 488 | Win -> do 489 | evs' <- maybe evs (:evs) <$> evMagic ct empty (subToPred opts leqT k) 490 | simples subst evs' leqsG [] (xs ++ eqs') 491 | Lose -> if null evs && null eqs' 492 | then return (Impossible (fst eq)) 493 | else simples subst evs leqsG xs eqs' 494 | Draw [] -> simples subst evs [] (eq:xs) eqs' 495 | Draw subst' -> do 496 | evM <- evMagic ct empty (map unifyItemToPredType subst' ++ 497 | subToPred opts leqT k) 498 | let leqsG' | isGiven (ctEvidence ct) = eqToLeq u' v' ++ leqsG 499 | | otherwise = leqsG 500 | case evM of 501 | Nothing -> simples subst evs leqsG' xs eqs' 502 | Just ev -> 503 | simples (substsSubst subst' subst ++ subst') 504 | (ev:evs) leqsG' [] (xs ++ eqs') 505 | simples subst evs leqsG xs (eq@(Right (ct,u@(x,y,b)),k):eqs') = do 506 | let u' = substsSOP subst (subtractIneq u) 507 | x' = substsSOP subst x 508 | y' = substsSOP subst y 509 | uS = (x',y',b) 510 | leqsG' | isGiven (ctEvidence ct) = (x',y',b):leqsG 511 | | otherwise = leqsG 512 | ineqs = concat [ leqsG 513 | , map (substLeq subst) leqsG 514 | , map snd (rights (map fst eqsG)) 515 | ] 516 | tcPluginTrace "unifyNats(ineq) results" (ppr (ct,u,u',ineqs)) 517 | case runWriterT (isNatural u') of 518 | Just (True,knW) -> do 519 | evs' <- maybe evs (:evs) <$> evMagic ct knW (subToPred opts leqT k) 520 | simples subst evs' leqsG' xs eqs' 521 | 522 | Just (False,_) | null k -> return (Impossible (fst eq)) 523 | _ -> do 524 | let solvedIneq = mapMaybe runWriterT 525 | -- it is an inequality that can be instantly solved, such as 526 | -- `1 <= x^y` 527 | -- OR 528 | (instantSolveIneq depth u: 529 | instantSolveIneq depth uS: 530 | -- This inequality is either a given constraint, or it is a wanted 531 | -- constraint, which in normal form is equal to another given 532 | -- constraint, hence it can be solved. 533 | -- OR 534 | map (solveIneq depth u) ineqs ++ 535 | -- The above, but with valid substitutions applied to the wanted. 536 | map (solveIneq depth uS) ineqs) 537 | smallest = solvedInEqSmallestConstraint solvedIneq 538 | case smallest of 539 | (True,kW) -> do 540 | evs' <- maybe evs (:evs) <$> evMagic ct kW (subToPred opts leqT k) 541 | simples subst evs' leqsG' xs eqs' 542 | _ -> simples subst evs leqsG (eq:xs) eqs' 543 | 544 | eqToLeq x y = [(x,y,True),(y,x,True)] 545 | substLeq s (x,y,b) = (substsSOP s x, substsSOP s y, b) 546 | 547 | isVarEqs (Left (_,S [P [V _]], S [P [V _]]), _) = True 548 | isVarEqs _ = False 549 | 550 | makeGivensSet otherEqs varEq 551 | = let (noMentionsV,mentionsV) = partitionEithers 552 | (map (matchesVarEq varEq) otherEqs) 553 | (mentionsLHS,mentionsRHS) = partitionEithers mentionsV 554 | vS = swapVar varEq 555 | givensLHS = case mentionsLHS of 556 | [] -> [] 557 | _ -> [mentionsLHS ++ ((varEq:mentionsRHS) ++ noMentionsV)] 558 | givensRHS = case mentionsRHS of 559 | [] -> [] 560 | _ -> [mentionsRHS ++ (vS:mentionsLHS ++ noMentionsV)] 561 | in case mentionsV of 562 | [] -> [noMentionsV] 563 | _ -> givensLHS ++ givensRHS 564 | 565 | matchesVarEq (Left (_, S [P [V v1]], S [P [V v2]]),_) r = case r of 566 | (Left (_,S [P [V v3]],_),_) 567 | | v1 == v3 -> Right (Left r) 568 | | v2 == v3 -> Right (Right r) 569 | (Left (_,_,S [P [V v3]]),_) 570 | | v1 == v3 -> Right (Left r) 571 | | v2 == v3 -> Right (Right r) 572 | (Right (_,(S [P [V v3]],_,_)),_) 573 | | v1 == v3 -> Right (Left r) 574 | | v2 == v3 -> Right (Right r) 575 | (Right (_,(_,S [P [V v3]],_)),_) 576 | | v1 == v3 -> Right (Left r) 577 | | v2 == v3 -> Right (Right r) 578 | _ -> Left r 579 | matchesVarEq _ _ = error "internal error" 580 | 581 | swapVar (Left (ct,S [P [V v1]], S [P [V v2]]),ps) = 582 | (Left (ct,S [P [V v2]], S [P [V v1]]),ps) 583 | swapVar _ = error "internal error" 584 | 585 | findFirstSimpliedWanted (Impossible e) _ = Impossible e 586 | findFirstSimpliedWanted (Simplified evs) s2 587 | | any (isWantedCt . snd . fst) evs 588 | = Simplified evs 589 | | otherwise 590 | = s2 591 | 592 | -- If we allow negated numbers we simply do not emit the inequalities 593 | -- derived from the subtractions that are converted to additions with a 594 | -- negated operand 595 | subToPred :: Opts -> TyCon -> [(Type, Type)] -> [PredType] 596 | subToPred Opts{..} leqT 597 | | negNumbers = const [] 598 | | otherwise = map leq 599 | where 600 | leq (a,b) = 601 | let lhs = TyConApp leqT [naturalTy,b,a] 602 | rhs = TyConApp (cTupleTyCon 0) [] 603 | in mkPrimEqPred lhs rhs 604 | 605 | -- Extract the Nat equality constraints 606 | toNatEquality :: (TyCon,TyCon,TyCon) -> Ct -> Maybe (Either NatEquality NatInEquality,[(Type,Type)]) 607 | toNatEquality (_,assertT,ordCond) ct = case classifyPredType $ ctEvPred $ ctEvidence ct of 608 | EqPred NomEq t1 t2 609 | -> go t1 t2 610 | IrredPred p 611 | -> go2 p 612 | _ -> Nothing 613 | where 614 | go (TyConApp tc xs) (TyConApp tc' ys) 615 | | tc == tc' 616 | , null ([tc,tc'] `intersect` [typeNatAddTyCon,typeNatSubTyCon 617 | ,typeNatMulTyCon,typeNatExpTyCon]) 618 | = case filter (not . uncurry eqType) (zip xs ys) of 619 | [(x,y)] 620 | | isNatKind (typeKind x) 621 | , isNatKind (typeKind y) 622 | , let (x',k1) = runWriter (normaliseNat x) 623 | , let (y',k2) = runWriter (normaliseNat y) 624 | -> Just (Left (ct, x', y'),k1 ++ k2) 625 | _ -> Nothing 626 | | tc == ordCond 627 | , [_,cmp,lt,eq,gt] <- xs 628 | , TyConApp tcCmpNat [x,y] <- cmp 629 | , tcCmpNat == typeNatCmpTyCon 630 | , TyConApp ltTc [] <- lt 631 | , ltTc == promotedTrueDataCon 632 | , TyConApp eqTc [] <- eq 633 | , eqTc == promotedTrueDataCon 634 | , TyConApp gtTc [] <- gt 635 | , gtTc == promotedFalseDataCon 636 | , let (x',k1) = runWriter (normaliseNat x) 637 | , let (y',k2) = runWriter (normaliseNat y) 638 | , let ks = k1 ++ k2 639 | = case tc' of 640 | _ | tc' == promotedTrueDataCon 641 | -> Just (Right (ct, (x', y', True)), ks) 642 | _ | tc' == promotedFalseDataCon 643 | -> Just (Right (ct, (x', y', False)), ks) 644 | _ -> Nothing 645 | | tc == assertT 646 | , tc' == (cTupleTyCon 0) 647 | , [] <- ys 648 | , [TyConApp ordCondTc zs, _] <- xs 649 | , ordCondTc == ordCond 650 | , [_,cmp,lt,eq,gt] <- zs 651 | , TyConApp tcCmpNat [x,y] <- cmp 652 | , tcCmpNat == typeNatCmpTyCon 653 | , TyConApp ltTc [] <- lt 654 | , ltTc == promotedTrueDataCon 655 | , TyConApp eqTc [] <- eq 656 | , eqTc == promotedTrueDataCon 657 | , TyConApp gtTc [] <- gt 658 | , gtTc == promotedFalseDataCon 659 | , let (x',k1) = runWriter (normaliseNat x) 660 | , let (y',k2) = runWriter (normaliseNat y) 661 | , let ks = k1 ++ k2 662 | = Just (Right (ct, (x', y', True)), ks) 663 | 664 | go x y 665 | | isNatKind (typeKind x) 666 | , isNatKind (typeKind y) 667 | , let (x',k1) = runWriter (normaliseNat x) 668 | , let (y',k2) = runWriter (normaliseNat y) 669 | = Just (Left (ct,x',y'),k1 ++ k2) 670 | | otherwise 671 | = Nothing 672 | 673 | go2 (TyConApp tc ys) 674 | | tc == assertT 675 | , [TyConApp ordCondTc xs, _] <- ys 676 | , ordCondTc == ordCond 677 | , [_,cmp,lt,eq,gt] <- xs 678 | , TyConApp tcCmpNat [x,y] <- cmp 679 | , tcCmpNat == typeNatCmpTyCon 680 | , TyConApp ltTc [] <- lt 681 | , ltTc == promotedTrueDataCon 682 | , TyConApp eqTc [] <- eq 683 | , eqTc == promotedTrueDataCon 684 | , TyConApp gtTc [] <- gt 685 | , gtTc == promotedFalseDataCon 686 | , let (x',k1) = runWriter (normaliseNat x) 687 | , let (y',k2) = runWriter (normaliseNat y) 688 | , let ks = k1 ++ k2 689 | = Just (Right (ct, (x', y', True)), ks) 690 | 691 | go2 _ = Nothing 692 | 693 | isNatKind :: Kind -> Bool 694 | isNatKind = (`eqType` naturalTy) 695 | 696 | unifyItemToPredType :: CoreUnify -> PredType 697 | unifyItemToPredType ui = mkPrimEqPred ty1 ty2 698 | where 699 | ty1 = case ui of 700 | SubstItem {..} -> mkTyVarTy siVar 701 | UnifyItem {..} -> reifySOP siLHS 702 | ty2 = case ui of 703 | SubstItem {..} -> reifySOP siSOP 704 | UnifyItem {..} -> reifySOP siRHS 705 | 706 | evSubtPreds :: CtLoc -> [PredType] -> TcPluginM [Ct] 707 | evSubtPreds loc = mapM (fmap mkNonCanonical . newWanted loc) 708 | 709 | evMagic :: Ct -> Set CType -> [PredType] -> TcPluginM (Maybe ((EvTerm, Ct), [Ct])) 710 | evMagic ct knW preds = do 711 | holeWanteds <- evSubtPreds (ctLoc ct) preds 712 | knWanted <- mapM (mkKnWanted (ctLoc ct)) (toList knW) 713 | let newWant = knWanted ++ holeWanteds 714 | case classifyPredType $ ctEvPred $ ctEvidence ct of 715 | EqPred NomEq t1 t2 -> 716 | let ctEv = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Nominal t1 t2 717 | in return (Just ((EvExpr (Coercion ctEv), ct),newWant)) 718 | IrredPred p -> 719 | let t1 = mkTyConApp (cTupleTyCon 0) [] 720 | co = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Representational t1 p 721 | dcApp = evId (dataConWrapId (cTupleDataCon 0)) 722 | in return (Just ((evCast dcApp co, ct),newWant)) 723 | _ -> return Nothing 724 | 725 | mkNonCanonical' :: CtLoc -> CtEvidence -> Ct 726 | mkNonCanonical' origCtl ev = 727 | let ct_ls = ctLocSpan origCtl 728 | ctl = ctEvLoc ev 729 | in mkNonCanonical (setCtEvLoc ev (setCtLocSpan ctl ct_ls)) 730 | 731 | mkKnWanted 732 | :: CtLoc 733 | -> CType 734 | -> TcPluginM Ct 735 | mkKnWanted loc (CType ty) = do 736 | kc_clas <- tcLookupClass knownNatClassName 737 | let kn_pred = mkClassPred kc_clas [ty] 738 | wantedCtEv <- newWanted loc kn_pred 739 | let wanted' = mkNonCanonical' loc wantedCtEv 740 | return wanted' 741 | -------------------------------------------------------------------------------- /src-pre-ghc-9.4/GHC/TypeLits/Normalise.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (C) 2015-2016, University of Twente, 3 | 2017 , QBayLogic B.V. 4 | License : BSD2 (see the file LICENSE) 5 | Maintainer : Christiaan Baaij 6 | 7 | A type checker plugin for GHC that can solve /equalities/ of types of kind 8 | 'GHC.TypeLits.Nat', where these types are either: 9 | 10 | * Type-level naturals 11 | * Type variables 12 | * Applications of the arithmetic expressions @(+,-,*,^)@. 13 | 14 | It solves these equalities by normalising them to /sort-of/ 15 | 'GHC.TypeLits.Normalise.SOP.SOP' (Sum-of-Products) form, and then perform a 16 | simple syntactic equality. 17 | 18 | For example, this solver can prove the equality between: 19 | 20 | @ 21 | (x + 2)^(y + 2) 22 | @ 23 | 24 | and 25 | 26 | @ 27 | 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 28 | @ 29 | 30 | Because the latter is actually the 'GHC.TypeLits.Normalise.SOP.SOP' normal form 31 | of the former. 32 | 33 | To use the plugin, add 34 | 35 | @ 36 | {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} 37 | @ 38 | 39 | To the header of your file. 40 | 41 | == Treating subtraction as addition with a negated number 42 | 43 | If you are absolutely sure that your subtractions can /never/ lead to (a locally) 44 | negative number, you can ask the plugin to treat subtraction as addition with 45 | a negated operand by additionally adding: 46 | 47 | @ 48 | {\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} 49 | @ 50 | 51 | to the header of your file, thereby allowing to use associativity and 52 | commutativity rules when proving constraints involving subtractions. Note that 53 | this option can lead to unsound behaviour and should be handled with extreme 54 | care. 55 | 56 | === When it leads to unsound behaviour 57 | 58 | For example, enabling the /allow-negated-numbers/ feature would allow 59 | you to prove: 60 | 61 | @ 62 | (n - 1) + 1 ~ n 63 | @ 64 | 65 | /without/ a @(1 <= n)@ constraint, even though when /n/ is set to /0/ the 66 | subtraction @n-1@ would be locally negative and hence not be a natural number. 67 | 68 | This would allow the following erroneous definition: 69 | 70 | @ 71 | data Fin (n :: Nat) where 72 | FZ :: Fin (n + 1) 73 | FS :: Fin n -> Fin (n + 1) 74 | 75 | f :: forall n . Natural -> Fin n 76 | f n = case of 77 | 0 -> FZ 78 | x -> FS (f \@(n-1) (x - 1)) 79 | 80 | fs :: [Fin 0] 81 | fs = f \<$\> [0..] 82 | @ 83 | 84 | === When it might be Okay 85 | 86 | This example is taken from the 87 | library. 88 | 89 | When you have: 90 | 91 | @ 92 | -- | Singleton type for the number of repetitions of an element. 93 | data Times (n :: Nat) where 94 | T :: Times n 95 | 96 | -- | An element of a "run-length encoded" vector, containing the value and 97 | -- the number of repetitions 98 | data Elem :: Type -> Nat -> Type where 99 | (:*) :: t -> Times n -> Elem t n 100 | 101 | -- | A length-indexed vector, optimised for repetitions. 102 | data OptVector :: Type -> Nat -> Type where 103 | End :: OptVector t 0 104 | (:-) :: Elem t l -> OptVector t (n - l) -> OptVector t n 105 | @ 106 | 107 | And you want to define: 108 | 109 | @ 110 | -- | Append two optimised vectors. 111 | type family (x :: OptVector t n) ++ (y :: OptVector t m) :: OptVector t (n + m) where 112 | ys ++ End = ys 113 | End ++ ys = ys 114 | (x :- xs) ++ ys = x :- (xs ++ ys) 115 | @ 116 | 117 | then the last line will give rise to the constraint: 118 | 119 | @ 120 | (n-l)+m ~ (n+m)-l 121 | @ 122 | 123 | because: 124 | 125 | @ 126 | x :: Elem t l 127 | xs :: OptVector t (n-l) 128 | ys :: OptVector t m 129 | @ 130 | 131 | In this case it's okay to add 132 | 133 | @ 134 | {\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} 135 | @ 136 | 137 | if you can convince yourself you will never be able to construct a: 138 | 139 | @ 140 | xs :: OptVector t (n-l) 141 | @ 142 | 143 | where /n-l/ is a negative number. 144 | -} 145 | 146 | {-# LANGUAGE CPP #-} 147 | {-# LANGUAGE LambdaCase #-} 148 | {-# LANGUAGE NamedFieldPuns #-} 149 | {-# LANGUAGE RecordWildCards #-} 150 | {-# LANGUAGE TupleSections #-} 151 | {-# LANGUAGE ViewPatterns #-} 152 | 153 | {-# OPTIONS_HADDOCK show-extensions #-} 154 | 155 | module GHC.TypeLits.Normalise 156 | ( plugin ) 157 | where 158 | 159 | -- external 160 | import Control.Arrow (second) 161 | import Control.Monad ((<=<), forM) 162 | #if !MIN_VERSION_ghc(8,4,1) 163 | import Control.Monad (replicateM) 164 | #endif 165 | import Control.Monad.Trans.Writer.Strict 166 | import Data.Either (partitionEithers, rights) 167 | import Data.IORef 168 | import Data.List (intersect, partition, stripPrefix, find) 169 | import Data.Maybe (mapMaybe, catMaybes) 170 | import Data.Set (Set, empty, toList, notMember, fromList, union) 171 | import GHC.TcPluginM.Extra (tracePlugin, newGiven, newWanted) 172 | #if MIN_VERSION_ghc(9,2,0) 173 | import GHC.TcPluginM.Extra (lookupModule, lookupName) 174 | #endif 175 | import qualified GHC.TcPluginM.Extra as TcPluginM 176 | #if MIN_VERSION_ghc(8,4,0) 177 | import GHC.TcPluginM.Extra (flattenGivens) 178 | #endif 179 | import Text.Read (readMaybe) 180 | 181 | -- GHC API 182 | #if MIN_VERSION_ghc(9,0,0) 183 | import GHC.Builtin.Names (knownNatClassName, eqTyConKey, heqTyConKey, hasKey) 184 | import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon) 185 | import GHC.Builtin.Types.Literals 186 | (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon) 187 | #if MIN_VERSION_ghc(9,2,0) 188 | import GHC.Builtin.Types (naturalTy) 189 | import GHC.Builtin.Types.Literals (typeNatCmpTyCon) 190 | #else 191 | import GHC.Builtin.Types (typeNatKind) 192 | import GHC.Builtin.Types.Literals (typeNatLeqTyCon) 193 | #endif 194 | import GHC.Core (Expr (..)) 195 | import GHC.Core.Class (className) 196 | import GHC.Core.Coercion (CoercionHole, Role (..), mkUnivCo) 197 | import GHC.Core.Predicate 198 | (EqRel (NomEq), Pred (EqPred), classifyPredType, getEqPredTys, mkClassPred, 199 | mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe) 200 | import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..)) 201 | import GHC.Core.TyCon (TyCon) 202 | import GHC.Core.Type 203 | (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe, typeKind) 204 | import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin) 205 | import GHC.Tc.Plugin 206 | (TcPluginM, newCoercionHole, tcLookupClass, tcPluginTrace, tcPluginIO, 207 | newEvVar) 208 | #if MIN_VERSION_ghc(9,2,0) 209 | import GHC.Tc.Plugin (tcLookupTyCon) 210 | #endif 211 | import GHC.Tc.Types (TcPlugin (..), TcPluginResult (..)) 212 | import GHC.Tc.Types.Constraint 213 | (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ShadowInfo (WDeriv), ctEvidence, 214 | ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan, 215 | isWantedCt, ctEvLoc, ctEvPred, ctEvExpr) 216 | import GHC.Tc.Types.Evidence (EvTerm (..), evCast, evId) 217 | #if MIN_VERSION_ghc(9,2,0) 218 | import GHC.Data.FastString (fsLit) 219 | import GHC.Types.Name.Occurrence (mkTcOcc) 220 | import GHC.Unit.Module (mkModuleName) 221 | #endif 222 | import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text) 223 | #else 224 | #if MIN_VERSION_ghc(8,5,0) 225 | import CoreSyn (Expr (..)) 226 | #endif 227 | import Outputable (Outputable (..), (<+>), ($$), text) 228 | import Plugins (Plugin (..), defaultPlugin) 229 | #if MIN_VERSION_ghc(8,6,0) 230 | import Plugins (purePlugin) 231 | #endif 232 | import PrelNames (hasKey, knownNatClassName) 233 | import PrelNames (eqTyConKey, heqTyConKey) 234 | import TcEvidence (EvTerm (..)) 235 | #if MIN_VERSION_ghc(8,6,0) 236 | import TcEvidence (evCast, evId) 237 | #endif 238 | #if !MIN_VERSION_ghc(8,4,0) 239 | import TcPluginM (zonkCt) 240 | #endif 241 | import TcPluginM (TcPluginM, tcPluginTrace, tcPluginIO) 242 | import Type 243 | (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe) 244 | import TysWiredIn (typeNatKind) 245 | 246 | import Coercion (CoercionHole, Role (..), mkUnivCo) 247 | import Class (className) 248 | import TcPluginM (newCoercionHole, tcLookupClass, newEvVar) 249 | import TcRnTypes (TcPlugin (..), TcPluginResult(..)) 250 | import TyCoRep (UnivCoProvenance (..)) 251 | import TcType (isEqPred) 252 | import TyCon (TyCon) 253 | import TyCoRep (Type (..)) 254 | import TcTypeNats (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, 255 | typeNatSubTyCon) 256 | 257 | import TcTypeNats (typeNatLeqTyCon) 258 | import TysWiredIn (promotedFalseDataCon, promotedTrueDataCon) 259 | 260 | #if MIN_VERSION_ghc(8,10,0) 261 | import Constraint 262 | (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence, ctEvLoc, ctEvPred, 263 | ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan, 264 | isWantedCt) 265 | import Predicate 266 | (EqRel (NomEq), Pred (EqPred), classifyPredType, getEqPredTys, mkClassPred, 267 | mkPrimEqPred, getClassPredTys_maybe) 268 | import Type (typeKind) 269 | #else 270 | import TcRnTypes 271 | (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence, ctEvLoc, ctEvPred, 272 | ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan, 273 | isWantedCt) 274 | import TcType (typeKind) 275 | import Type 276 | (EqRel (NomEq), PredTree (EqPred), classifyPredType, mkClassPred, mkPrimEqPred, 277 | getClassPredTys_maybe) 278 | #if MIN_VERSION_ghc(8,4,0) 279 | import Type (getEqPredTys) 280 | #endif 281 | #endif 282 | 283 | #if MIN_VERSION_ghc(8,10,0) 284 | import Constraint (ctEvExpr) 285 | #elif MIN_VERSION_ghc(8,6,0) 286 | import TcRnTypes (ctEvExpr) 287 | #else 288 | import TcRnTypes (ctEvTerm) 289 | #endif 290 | 291 | #if MIN_VERSION_ghc(8,2,0) 292 | #if MIN_VERSION_ghc(8,10,0) 293 | import Constraint (ShadowInfo (WDeriv)) 294 | #else 295 | import TcRnTypes (ShadowInfo (WDeriv)) 296 | #endif 297 | #endif 298 | 299 | #if MIN_VERSION_ghc(8,10,0) 300 | import TcType (isEqPrimPred) 301 | #endif 302 | #endif 303 | 304 | -- internal 305 | import GHC.TypeLits.Normalise.SOP 306 | import GHC.TypeLits.Normalise.Unify 307 | 308 | #if MIN_VERSION_ghc(9,2,0) 309 | typeNatKind :: Type 310 | typeNatKind = naturalTy 311 | #endif 312 | 313 | #if !MIN_VERSION_ghc(8,10,0) 314 | isEqPrimPred :: PredType -> Bool 315 | isEqPrimPred = isEqPred 316 | #endif 317 | 318 | isEqPredClass :: PredType -> Bool 319 | isEqPredClass ty = case tyConAppTyCon_maybe ty of 320 | Just tc -> tc `hasKey` eqTyConKey || tc `hasKey` heqTyConKey 321 | _ -> False 322 | 323 | -- | To use the plugin, add 324 | -- 325 | -- @ 326 | -- {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} 327 | -- @ 328 | -- 329 | -- To the header of your file. 330 | plugin :: Plugin 331 | plugin 332 | = defaultPlugin 333 | { tcPlugin = fmap (normalisePlugin . foldr id defaultOpts) . traverse parseArgument 334 | #if MIN_VERSION_ghc(8,6,0) 335 | , pluginRecompile = purePlugin 336 | #endif 337 | } 338 | where 339 | parseArgument "allow-negated-numbers" = Just (\ opts -> opts { negNumbers = True }) 340 | parseArgument (readMaybe <=< stripPrefix "depth=" -> Just depth) = Just (\ opts -> opts { depth }) 341 | parseArgument _ = Nothing 342 | defaultOpts = Opts { negNumbers = False, depth = 5 } 343 | 344 | data Opts = Opts { negNumbers :: Bool, depth :: Word } 345 | 346 | normalisePlugin :: Opts -> TcPlugin 347 | normalisePlugin opts = tracePlugin "ghc-typelits-natnormalise" 348 | TcPlugin { tcPluginInit = lookupExtraDefs 349 | , tcPluginSolve = decideEqualSOP opts 350 | , tcPluginStop = const (return ()) 351 | } 352 | newtype OrigCt = OrigCt { runOrigCt :: Ct } 353 | 354 | type ExtraDefs = (IORef (Set CType), TyCon) 355 | 356 | lookupExtraDefs :: TcPluginM ExtraDefs 357 | lookupExtraDefs = do 358 | ref <- tcPluginIO (newIORef empty) 359 | #if !MIN_VERSION_ghc(9,2,0) 360 | return (ref, typeNatLeqTyCon) 361 | #else 362 | md <- lookupModule myModule myPackage 363 | ordCond <- look md "OrdCond" 364 | return (ref, ordCond) 365 | where 366 | look md s = tcLookupTyCon =<< lookupName md (mkTcOcc s) 367 | myModule = mkModuleName "Data.Type.Ord" 368 | myPackage = fsLit "base" 369 | #endif 370 | 371 | decideEqualSOP 372 | :: Opts 373 | -> ExtraDefs 374 | -- ^ 1. Givens that is already generated. 375 | -- We have to generate new givens at most once; 376 | -- otherwise GHC will loop indefinitely. 377 | -- 378 | -- 379 | -- 2. For GHc 9.2: TyCon of Data.Type.Ord.OrdCond 380 | -- For older: TyCon of GHC.TypeLits.<=? 381 | -> [Ct] 382 | -> [Ct] 383 | -> [Ct] 384 | -> TcPluginM TcPluginResult 385 | 386 | -- Simplification phase: Derives /simplified/ givens; 387 | -- we can reduce given constraints like @Show (Foo (n + 2))@ 388 | -- to its normal form @Show (Foo (2 + n))@, which is eventually 389 | -- useful in solving phase. 390 | -- 391 | -- This helps us to solve /indirect/ constraints; 392 | -- without this phase, we cannot derive, e.g., 393 | -- @IsVector UVector (Fin (n + 1))@ from 394 | -- @Unbox (1 + n)@! 395 | decideEqualSOP opts (gen'd,ordCond) givens _deriveds [] = do 396 | done <- tcPluginIO $ readIORef gen'd 397 | #if MIN_VERSION_ghc(8,4,0) 398 | let simplGivens = flattenGivens givens 399 | #else 400 | simplGivens <- mapM zonkCt givens 401 | #endif 402 | let reds = 403 | filter (\(_,(_,_,v)) -> null v || negNumbers opts) $ 404 | reduceGivens opts ordCond done simplGivens 405 | newlyDone = map (\(_,(prd, _,_)) -> CType prd) reds 406 | tcPluginIO $ 407 | modifyIORef' gen'd $ union (fromList newlyDone) 408 | newGivens <- forM reds $ \(origCt, (pred', evTerm, _)) -> 409 | mkNonCanonical' (ctLoc origCt) <$> newGiven (ctLoc origCt) pred' evTerm 410 | return (TcPluginOk [] newGivens) 411 | 412 | -- Solving phase. 413 | -- Solves in/equalities on Nats and simplifiable constraints 414 | -- containing naturals. 415 | decideEqualSOP opts (gen'd,ordCond) givens deriveds wanteds = do 416 | -- GHC 7.10.1 puts deriveds with the wanteds, so filter them out 417 | let flat_wanteds0 = map (\ct -> (OrigCt ct, ct)) wanteds 418 | #if MIN_VERSION_ghc(8,4,0) 419 | -- flattenGivens should actually be called unflattenGivens 420 | let simplGivens = givens ++ flattenGivens givens 421 | subst = fst $ unzip $ TcPluginM.mkSubst' givens 422 | unflattenWanted (oCt, ct) = (oCt, TcPluginM.substCt subst ct) 423 | unflat_wanteds0 = map unflattenWanted flat_wanteds0 424 | #else 425 | let unflat_wanteds0 = flat_wanteds0 426 | simplGivens <- mapM zonkCt givens 427 | #endif 428 | let unflat_wanteds1 = filter (isWanted . ctEvidence . snd) unflat_wanteds0 429 | -- only return solve deriveds when there are wanteds to solve 430 | unflat_wanteds2 = case unflat_wanteds1 of 431 | [] -> [] 432 | w -> w ++ (map (\a -> (OrigCt a,a)) deriveds) 433 | unit_wanteds = mapMaybe (toNatEquality ordCond) unflat_wanteds2 434 | nonEqs = filter (not . (\p -> isEqPred p || isEqPrimPred p) . ctEvPred . ctEvidence.snd) 435 | $ filter (isWanted. ctEvidence.snd) unflat_wanteds0 436 | done <- tcPluginIO $ readIORef gen'd 437 | let redGs = reduceGivens opts ordCond done simplGivens 438 | newlyDone = map (\(_,(prd, _,_)) -> CType prd) redGs 439 | redGivens <- forM redGs $ \(origCt, (pred', evTerm, _)) -> 440 | mkNonCanonical' (ctLoc origCt) <$> newGiven (ctLoc origCt) pred' evTerm 441 | reducible_wanteds 442 | <- catMaybes <$> 443 | mapM 444 | (\(origCt, ct) -> fmap (runOrigCt origCt,) <$> 445 | reduceNatConstr (simplGivens ++ redGivens) ct 446 | ) 447 | nonEqs 448 | if null unit_wanteds && null reducible_wanteds 449 | then return $ TcPluginOk [] [] 450 | else do 451 | -- Since reducible wanteds also can have some negation/subtraction 452 | -- subterms, we have to make sure appropriate inequalities to hold. 453 | -- Here, we generate such additional inequalities for reduction 454 | -- that is to be added to new [W]anteds. 455 | ineqForRedWants <- fmap concat $ forM redGs $ \(ct, (_,_, ws)) -> forM ws $ 456 | fmap (mkNonCanonical' (ctLoc ct)) . newWanted (ctLoc ct) 457 | tcPluginIO $ 458 | modifyIORef' gen'd $ union (fromList newlyDone) 459 | let unit_givens = mapMaybe 460 | (toNatEquality ordCond) 461 | (map (\a -> (OrigCt a, a)) simplGivens) 462 | sr <- simplifyNats opts ordCond unit_givens unit_wanteds 463 | tcPluginTrace "normalised" (ppr sr) 464 | reds <- forM reducible_wanteds $ \(origCt,(term, ws, wDicts)) -> do 465 | wants <- evSubtPreds origCt $ subToPred opts ordCond ws 466 | return ((term, origCt), wDicts ++ wants) 467 | case sr of 468 | Simplified evs -> do 469 | let simpld = filter (not . isGiven . ctEvidence . (\((_,x),_) -> x)) evs 470 | -- Only solve derived when we solved a wanted 471 | simpld1 = case filter (isWanted . ctEvidence . (\((_,x),_) -> x)) evs ++ reds of 472 | [] -> [] 473 | _ -> simpld 474 | (solved',newWanteds) = second concat (unzip $ simpld1 ++ reds) 475 | return (TcPluginOk solved' $ newWanteds ++ ineqForRedWants) 476 | Impossible eq -> return (TcPluginContradiction [fromNatEquality eq]) 477 | 478 | type NatEquality = (Ct,CoreSOP,CoreSOP) 479 | type NatInEquality = (Ct,(CoreSOP,CoreSOP,Bool)) 480 | 481 | reduceGivens :: Opts -> TyCon -> Set CType -> [Ct] -> [(Ct, (Type, EvTerm, [PredType]))] 482 | reduceGivens opts ordCond done givens = 483 | let nonEqs = 484 | [ ct 485 | | ct <- givens 486 | , let ev = ctEvidence ct 487 | prd = ctEvPred ev 488 | , isGiven ev 489 | , not $ (\p -> isEqPred p || isEqPrimPred p || isEqPredClass p) prd 490 | ] 491 | in filter 492 | (\(_, (prd, _, _)) -> 493 | notMember (CType prd) done 494 | ) 495 | $ mapMaybe 496 | (\ct -> (ct,) <$> tryReduceGiven opts ordCond givens ct) 497 | nonEqs 498 | 499 | tryReduceGiven 500 | :: Opts -> TyCon -> [Ct] -> Ct 501 | -> Maybe (PredType, EvTerm, [PredType]) 502 | tryReduceGiven opts ordCond simplGivens ct = do 503 | let (mans, ws) = 504 | runWriter $ normaliseNatEverywhere $ 505 | ctEvPred $ ctEvidence ct 506 | ws' = [ p 507 | | (p, _) <- subToPred opts ordCond ws 508 | , all (not . (`eqType` p). ctEvPred . ctEvidence) simplGivens 509 | ] 510 | pred' <- mans 511 | return (pred', toReducedDict (ctEvidence ct) pred', ws') 512 | 513 | fromNatEquality :: Either NatEquality NatInEquality -> Ct 514 | fromNatEquality (Left (ct, _, _)) = ct 515 | fromNatEquality (Right (ct, _)) = ct 516 | 517 | reduceNatConstr :: [Ct] -> Ct -> TcPluginM (Maybe (EvTerm, [(Type, Type)], [Ct])) 518 | reduceNatConstr givens ct = do 519 | let pred0 = ctEvPred $ ctEvidence ct 520 | (mans, tests) = runWriter $ normaliseNatEverywhere pred0 521 | case mans of 522 | Nothing -> return Nothing 523 | Just pred' -> do 524 | case find ((`eqType` pred') .ctEvPred . ctEvidence) givens of 525 | -- No existing evidence found 526 | Nothing -> case getClassPredTys_maybe pred' of 527 | -- Are we trying to solve a class instance? 528 | Just (cls,_) | className cls /= knownNatClassName -> do 529 | -- Create new evidence binding for normalized class constraint 530 | evVar <- newEvVar pred' 531 | -- Bind the evidence to a new wanted normalized class constraint 532 | let wDict = mkNonCanonical 533 | (CtWanted pred' (EvVarDest evVar) 534 | #if MIN_VERSION_ghc(8,2,0) 535 | WDeriv 536 | #endif 537 | (ctLoc ct)) 538 | -- Evidence for current wanted is simply the coerced binding for 539 | -- the new binding 540 | evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") 541 | Representational 542 | pred' pred0 543 | #if MIN_VERSION_ghc(8,6,0) 544 | ev = evId evVar `evCast` evCo 545 | #else 546 | ev = EvId evVar `EvCast` evCo 547 | #endif 548 | -- Use newly created coerced wanted as evidence, and emit the 549 | -- normalized wanted as a new constraint to solve. 550 | return (Just (ev, tests, [wDict])) 551 | _ -> return Nothing 552 | -- Use existing evidence 553 | Just c -> return (Just (toReducedDict (ctEvidence c) pred0, tests, [])) 554 | 555 | toReducedDict :: CtEvidence -> PredType -> EvTerm 556 | toReducedDict ct pred' = 557 | let pred0 = ctEvPred ct 558 | evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") 559 | Representational 560 | pred0 pred' 561 | #if MIN_VERSION_ghc(8,6,0) 562 | ev = ctEvExpr ct 563 | `evCast` evCo 564 | #else 565 | ev = ctEvTerm ct `EvCast` evCo 566 | #endif 567 | in ev 568 | 569 | data SimplifyResult 570 | = Simplified [((EvTerm,Ct),[Ct])] 571 | | Impossible (Either NatEquality NatInEquality) 572 | 573 | instance Outputable SimplifyResult where 574 | ppr (Simplified evs) = text "Simplified" $$ ppr evs 575 | ppr (Impossible eq) = text "Impossible" <+> ppr eq 576 | 577 | simplifyNats 578 | :: Opts 579 | -- ^ Allow negated numbers (potentially unsound!) 580 | -> TyCon 581 | -- ^ For GHc 9.2: TyCon of Data.Type.Ord.OrdCond 582 | -- For older: TyCon of GHC.TypeLits.<=? 583 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 584 | -- ^ Given constraints 585 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 586 | -- ^ Wanted constraints 587 | -> TcPluginM SimplifyResult 588 | simplifyNats opts@Opts {..} ordCond eqsG eqsW = do 589 | let eqsG1 = map (second (const ([] :: [(Type,Type)]))) eqsG 590 | (varEqs,otherEqs) = partition isVarEqs eqsG1 591 | fancyGivens = concatMap (makeGivensSet otherEqs) varEqs 592 | case varEqs of 593 | [] -> do 594 | let eqs = otherEqs ++ eqsW 595 | tcPluginTrace "simplifyNats" (ppr eqs) 596 | simples [] [] [] [] eqs 597 | _ -> do 598 | tcPluginTrace ("simplifyNats(backtrack: " ++ show (length fancyGivens) ++ ")") 599 | (ppr varEqs) 600 | 601 | allSimplified <- forM fancyGivens $ \v -> do 602 | let eqs = v ++ eqsW 603 | tcPluginTrace "simplifyNats" (ppr eqs) 604 | simples [] [] [] [] eqs 605 | 606 | pure (foldr findFirstSimpliedWanted (Simplified []) allSimplified) 607 | where 608 | simples :: [CoreUnify] 609 | -> [((EvTerm, Ct), [Ct])] 610 | -> [(CoreSOP,CoreSOP,Bool)] 611 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 612 | -> [(Either NatEquality NatInEquality,[(Type,Type)])] 613 | -> TcPluginM SimplifyResult 614 | simples _subst evs _leqsG _xs [] = return (Simplified evs) 615 | simples subst evs leqsG xs (eq@(Left (ct,u,v),k):eqs') = do 616 | let u' = substsSOP subst u 617 | v' = substsSOP subst v 618 | ur <- unifyNats ct u' v' 619 | tcPluginTrace "unifyNats result" (ppr ur) 620 | case ur of 621 | Win -> do 622 | evs' <- maybe evs (:evs) <$> evMagic ct empty (subToPred opts ordCond k) 623 | simples subst evs' leqsG [] (xs ++ eqs') 624 | Lose -> if null evs && null eqs' 625 | then return (Impossible (fst eq)) 626 | else simples subst evs leqsG xs eqs' 627 | Draw [] -> simples subst evs [] (eq:xs) eqs' 628 | Draw subst' -> do 629 | evM <- evMagic ct empty (map unifyItemToPredType subst' ++ 630 | subToPred opts ordCond k) 631 | let leqsG' | isGiven (ctEvidence ct) = eqToLeq u' v' ++ leqsG 632 | | otherwise = leqsG 633 | case evM of 634 | Nothing -> simples subst evs leqsG' xs eqs' 635 | Just ev -> 636 | simples (substsSubst subst' subst ++ subst') 637 | (ev:evs) leqsG' [] (xs ++ eqs') 638 | simples subst evs leqsG xs (eq@(Right (ct,u@(x,y,b)),k):eqs') = do 639 | let u' = substsSOP subst (subtractIneq u) 640 | x' = substsSOP subst x 641 | y' = substsSOP subst y 642 | uS = (x',y',b) 643 | leqsG' | isGiven (ctEvidence ct) = (x',y',b):leqsG 644 | | otherwise = leqsG 645 | ineqs = concat [ leqsG 646 | , map (substLeq subst) leqsG 647 | , map snd (rights (map fst eqsG)) 648 | ] 649 | tcPluginTrace "unifyNats(ineq) results" (ppr (ct,u,u',ineqs)) 650 | case runWriterT (isNatural u') of 651 | Just (True,knW) -> do 652 | evs' <- maybe evs (:evs) <$> evMagic ct knW (subToPred opts ordCond k) 653 | simples subst evs' leqsG' xs eqs' 654 | 655 | Just (False,_) | null k -> return (Impossible (fst eq)) 656 | _ -> do 657 | let solvedIneq = mapMaybe runWriterT 658 | -- it is an inequality that can be instantly solved, such as 659 | -- `1 <= x^y` 660 | -- OR 661 | (instantSolveIneq depth u: 662 | instantSolveIneq depth uS: 663 | -- This inequality is either a given constraint, or it is a wanted 664 | -- constraint, which in normal form is equal to another given 665 | -- constraint, hence it can be solved. 666 | -- OR 667 | map (solveIneq depth u) ineqs ++ 668 | -- The above, but with valid substitutions applied to the wanted. 669 | map (solveIneq depth uS) ineqs) 670 | smallest = solvedInEqSmallestConstraint solvedIneq 671 | case smallest of 672 | (True,kW) -> do 673 | evs' <- maybe evs (:evs) <$> evMagic ct kW (subToPred opts ordCond k) 674 | simples subst evs' leqsG' xs eqs' 675 | _ -> simples subst evs leqsG (eq:xs) eqs' 676 | 677 | eqToLeq x y = [(x,y,True),(y,x,True)] 678 | substLeq s (x,y,b) = (substsSOP s x, substsSOP s y, b) 679 | 680 | isVarEqs (Left (_,S [P [V _]], S [P [V _]]), _) = True 681 | isVarEqs _ = False 682 | 683 | makeGivensSet otherEqs varEq 684 | = let (noMentionsV,mentionsV) = partitionEithers 685 | (map (matchesVarEq varEq) otherEqs) 686 | (mentionsLHS,mentionsRHS) = partitionEithers mentionsV 687 | vS = swapVar varEq 688 | givensLHS = case mentionsLHS of 689 | [] -> [] 690 | _ -> [mentionsLHS ++ ((varEq:mentionsRHS) ++ noMentionsV)] 691 | givensRHS = case mentionsRHS of 692 | [] -> [] 693 | _ -> [mentionsRHS ++ (vS:mentionsLHS ++ noMentionsV)] 694 | in case mentionsV of 695 | [] -> [noMentionsV] 696 | _ -> givensLHS ++ givensRHS 697 | 698 | matchesVarEq (Left (_, S [P [V v1]], S [P [V v2]]),_) r = case r of 699 | (Left (_,S [P [V v3]],_),_) 700 | | v1 == v3 -> Right (Left r) 701 | | v2 == v3 -> Right (Right r) 702 | (Left (_,_,S [P [V v3]]),_) 703 | | v1 == v3 -> Right (Left r) 704 | | v2 == v3 -> Right (Right r) 705 | (Right (_,(S [P [V v3]],_,_)),_) 706 | | v1 == v3 -> Right (Left r) 707 | | v2 == v3 -> Right (Right r) 708 | (Right (_,(_,S [P [V v3]],_)),_) 709 | | v1 == v3 -> Right (Left r) 710 | | v2 == v3 -> Right (Right r) 711 | _ -> Left r 712 | matchesVarEq _ _ = error "internal error" 713 | 714 | swapVar (Left (ct,S [P [V v1]], S [P [V v2]]),ps) = 715 | (Left (ct,S [P [V v2]], S [P [V v1]]),ps) 716 | swapVar _ = error "internal error" 717 | 718 | findFirstSimpliedWanted (Impossible e) _ = Impossible e 719 | findFirstSimpliedWanted (Simplified evs) s2 720 | | any (isWantedCt . snd . fst) evs 721 | = Simplified evs 722 | | otherwise 723 | = s2 724 | 725 | -- If we allow negated numbers we simply do not emit the inequalities 726 | -- derived from the subtractions that are converted to additions with a 727 | -- negated operand 728 | subToPred :: Opts -> TyCon -> [(Type, Type)] -> [(PredType, Kind)] 729 | subToPred Opts{..} ordCond 730 | | negNumbers = const [] 731 | | otherwise = map (subtractionToPred ordCond) 732 | 733 | -- Extract the Nat equality constraints 734 | toNatEquality :: TyCon -> (OrigCt, Ct) -> Maybe (Either NatEquality NatInEquality,[(Type,Type)]) 735 | toNatEquality ordCond (OrigCt oCt, ct) = case classifyPredType $ ctEvPred $ ctEvidence ct of 736 | EqPred NomEq t1 t2 737 | -> go t1 t2 738 | _ -> Nothing 739 | where 740 | go (TyConApp tc xs) (TyConApp tc' ys) 741 | | tc == tc' 742 | , null ([tc,tc'] `intersect` [typeNatAddTyCon,typeNatSubTyCon 743 | ,typeNatMulTyCon,typeNatExpTyCon]) 744 | = case filter (not . uncurry eqType) (zip xs ys) of 745 | [(x,y)] 746 | | isNatKind (typeKind x) 747 | , isNatKind (typeKind y) 748 | , let (x',k1) = runWriter (normaliseNat x) 749 | , let (y',k2) = runWriter (normaliseNat y) 750 | -> Just (Left (oCt, x', y'),k1 ++ k2) 751 | _ -> Nothing 752 | #if MIN_VERSION_ghc(9,2,0) 753 | | tc == ordCond 754 | , [_,cmp,lt,eq,gt] <- xs 755 | , TyConApp tcCmpNat [x,y] <- cmp 756 | , tcCmpNat == typeNatCmpTyCon 757 | , TyConApp ltTc [] <- lt 758 | , ltTc == promotedTrueDataCon 759 | , TyConApp eqTc [] <- eq 760 | , eqTc == promotedTrueDataCon 761 | , TyConApp gtTc [] <- gt 762 | , gtTc == promotedFalseDataCon 763 | , let (x',k1) = runWriter (normaliseNat x) 764 | , let (y',k2) = runWriter (normaliseNat y) 765 | , let ks = k1 ++ k2 766 | = case tc' of 767 | _ | tc' == promotedTrueDataCon 768 | -> Just (Right (oCt, (x', y', True)), ks) 769 | _ | tc' == promotedFalseDataCon 770 | -> Just (Right (oCt, (x', y', False)), ks) 771 | _ -> Nothing 772 | #else 773 | | tc == ordCond 774 | , [x,y] <- xs 775 | , let (x',k1) = runWriter (normaliseNat x) 776 | , let (y',k2) = runWriter (normaliseNat y) 777 | , let ks = k1 ++ k2 778 | = case tc' of 779 | _ | tc' == promotedTrueDataCon 780 | -> Just (Right (oCt, (x', y', True)), ks) 781 | _ | tc' == promotedFalseDataCon 782 | -> Just (Right (oCt, (x', y', False)), ks) 783 | _ -> Nothing 784 | #endif 785 | 786 | go x y 787 | | isNatKind (typeKind x) 788 | , isNatKind (typeKind y) 789 | , let (x',k1) = runWriter (normaliseNat x) 790 | , let (y',k2) = runWriter (normaliseNat y) 791 | = Just (Left (oCt,x',y'),k1 ++ k2) 792 | | otherwise 793 | = Nothing 794 | 795 | isNatKind :: Kind -> Bool 796 | isNatKind = (`eqType` typeNatKind) 797 | 798 | unifyItemToPredType :: CoreUnify -> (PredType,Kind) 799 | unifyItemToPredType ui = 800 | (mkPrimEqPred ty1 ty2,typeNatKind) 801 | where 802 | ty1 = case ui of 803 | SubstItem {..} -> mkTyVarTy siVar 804 | UnifyItem {..} -> reifySOP siLHS 805 | ty2 = case ui of 806 | SubstItem {..} -> reifySOP siSOP 807 | UnifyItem {..} -> reifySOP siRHS 808 | 809 | evSubtPreds :: Ct -> [(PredType,Kind)] -> TcPluginM [Ct] 810 | evSubtPreds ct preds = do 811 | let predTypes = map fst preds 812 | #if MIN_VERSION_ghc(8,4,1) 813 | holes <- mapM (newCoercionHole . uncurry mkPrimEqPred . getEqPredTys) predTypes 814 | #else 815 | holes <- replicateM (length preds) newCoercionHole 816 | #endif 817 | return (zipWith (unifyItemToCt (ctLoc ct)) predTypes holes) 818 | 819 | evMagic :: Ct -> Set CType -> [(PredType,Kind)] -> TcPluginM (Maybe ((EvTerm, Ct), [Ct])) 820 | evMagic ct knW preds = case classifyPredType $ ctEvPred $ ctEvidence ct of 821 | EqPred NomEq t1 t2 -> do 822 | holeWanteds <- evSubtPreds ct preds 823 | knWanted <- mapM (mkKnWanted ct) (toList knW) 824 | let newWant = knWanted ++ holeWanteds 825 | ctEv = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Nominal t1 t2 826 | #if MIN_VERSION_ghc(8,5,0) 827 | return (Just ((EvExpr (Coercion ctEv), ct),newWant)) 828 | #else 829 | return (Just ((EvCoercion ctEv, ct),newWant)) 830 | #endif 831 | _ -> return Nothing 832 | 833 | mkNonCanonical' :: CtLoc -> CtEvidence -> Ct 834 | mkNonCanonical' origCtl ev = 835 | let ct_ls = ctLocSpan origCtl 836 | ctl = ctEvLoc ev 837 | in setCtLoc (mkNonCanonical ev) (setCtLocSpan ctl ct_ls) 838 | 839 | mkKnWanted 840 | :: Ct 841 | -> CType 842 | -> TcPluginM Ct 843 | mkKnWanted ct (CType ty) = do 844 | kc_clas <- tcLookupClass knownNatClassName 845 | let kn_pred = mkClassPred kc_clas [ty] 846 | wantedCtEv <- TcPluginM.newWanted (ctLoc ct) kn_pred 847 | let wanted' = mkNonCanonical' (ctLoc ct) wantedCtEv 848 | return wanted' 849 | 850 | unifyItemToCt :: CtLoc 851 | -> PredType 852 | -> CoercionHole 853 | -> Ct 854 | unifyItemToCt loc pred_type hole = 855 | mkNonCanonical 856 | (CtWanted 857 | pred_type 858 | (HoleDest hole) 859 | #if MIN_VERSION_ghc(8,2,0) 860 | WDeriv 861 | #endif 862 | loc) 863 | -------------------------------------------------------------------------------- /src/GHC/TypeLits/Normalise/SOP.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (C) 2015-2016, University of Twente, 3 | 2017 , QBayLogic B.V. 4 | License : BSD2 (see the file LICENSE) 5 | Maintainer : Christiaan Baaij 6 | 7 | = SOP: Sum-of-Products, sorta 8 | 9 | The arithmetic operation for 'GHC.TypeLits.Nat' are, addition 10 | (@'GHC.TypeLits.+'@), subtraction (@'GHC.TypeLits.-'@), multiplication 11 | (@'GHC.TypeLits.*'@), and exponentiation (@'GHC.TypeLits.^'@). This means we 12 | cannot write expressions in a canonical SOP normal form. We can get rid of 13 | subtraction by working with integers, and translating @a - b@ to @a + (-1)*b@. 14 | Exponentation cannot be getten rid of that way. So we define the following 15 | grammar for our canonical SOP-like normal form of arithmetic expressions: 16 | 17 | @ 18 | SOP ::= Product \'+\' SOP | Product 19 | Product ::= Symbol \'*\' Product | Symbol 20 | Symbol ::= Integer 21 | | Var 22 | | Var \'^\' Product 23 | | SOP \'^\' ProductE 24 | 25 | ProductE ::= SymbolE \'*\' ProductE | SymbolE 26 | SymbolE ::= Var 27 | | Var \'^\' Product 28 | | SOP \'^\' ProductE 29 | @ 30 | 31 | So a valid SOP terms are: 32 | 33 | @ 34 | x*y + y^2 35 | (x+y)^(k*z) 36 | @ 37 | 38 | , but, 39 | 40 | @ 41 | (x*y)^2 42 | @ 43 | 44 | is not, and should be: 45 | 46 | @ 47 | x^2 * y^2 48 | @ 49 | 50 | Exponents are thus not allowed to have products, so for example, the expression: 51 | 52 | @ 53 | (x + 2)^(y + 2) 54 | @ 55 | 56 | in valid SOP form is: 57 | 58 | @ 59 | 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 60 | @ 61 | 62 | Also, exponents can only be integer values when the base is a variable. Although 63 | not enforced by the grammar, the exponentials are flatted as far as possible in 64 | SOP form. So: 65 | 66 | @ 67 | (x^y)^z 68 | @ 69 | 70 | is flattened to: 71 | 72 | @ 73 | x^(y*z) 74 | @ 75 | -} 76 | 77 | {-# LANGUAGE CPP #-} 78 | 79 | module GHC.TypeLits.Normalise.SOP 80 | ( -- * SOP types 81 | Symbol (..) 82 | , Product (..) 83 | , SOP (..) 84 | -- * Simplification 85 | , reduceExp 86 | , mergeS 87 | , mergeP 88 | , mergeSOPAdd 89 | , mergeSOPMul 90 | , normaliseExp 91 | , simplifySOP 92 | ) 93 | where 94 | 95 | -- External 96 | import Data.Either (partitionEithers) 97 | import Data.List (sort) 98 | 99 | -- GHC API 100 | #if MIN_VERSION_ghc(9,0,0) 101 | import GHC.Utils.Outputable (Outputable (..), (<+>), text, hcat, integer, punctuate) 102 | #else 103 | import Outputable (Outputable (..), (<+>), text, hcat, integer, punctuate) 104 | #endif 105 | 106 | data Symbol v c 107 | = I Integer -- ^ Integer constant 108 | | C c -- ^ Non-integer constant 109 | | E (SOP v c) (Product v c) -- ^ Exponentiation 110 | | V v -- ^ Variable 111 | deriving (Eq,Ord) 112 | 113 | newtype Product v c = P { unP :: [Symbol v c] } 114 | deriving (Eq) 115 | 116 | instance (Ord v, Ord c) => Ord (Product v c) where 117 | compare (P [x]) (P [y]) = compare x y 118 | compare (P [_]) (P (_:_)) = LT 119 | compare (P (_:_)) (P [_]) = GT 120 | compare (P xs) (P ys) = compare xs ys 121 | 122 | newtype SOP v c = S { unS :: [Product v c] } 123 | deriving (Ord) 124 | 125 | instance (Eq v, Eq c) => Eq (SOP v c) where 126 | (S []) == (S [P [I 0]]) = True 127 | (S [P [I 0]]) == (S []) = True 128 | (S ps1) == (S ps2) = ps1 == ps2 129 | 130 | instance (Outputable v, Outputable c) => Outputable (SOP v c) where 131 | ppr = hcat . punctuate (text " + ") . map ppr . unS 132 | 133 | instance (Outputable v, Outputable c) => Outputable (Product v c) where 134 | ppr = hcat . punctuate (text " * ") . map ppr . unP 135 | 136 | instance (Outputable v, Outputable c) => Outputable (Symbol v c) where 137 | ppr (I i) = integer i 138 | ppr (C c) = ppr c 139 | ppr (V s) = ppr s 140 | ppr (E b e) = case (pprSimple b, pprSimple (S [e])) of 141 | (bS,eS) -> bS <+> text "^" <+> eS 142 | where 143 | pprSimple (S [P [I i]]) = integer i 144 | pprSimple (S [P [V v]]) = ppr v 145 | pprSimple sop = text "(" <+> ppr sop <+> text ")" 146 | 147 | mergeWith :: (a -> a -> Either a a) -> [a] -> [a] 148 | mergeWith _ [] = [] 149 | mergeWith op (f:fs) = case partitionEithers $ map (`op` f) fs of 150 | ([],_) -> f : mergeWith op fs 151 | (updated,untouched) -> mergeWith op (updated ++ untouched) 152 | 153 | -- | reduce exponentials 154 | -- 155 | -- Performs the following rewrites: 156 | -- 157 | -- @ 158 | -- x^0 ==> 1 159 | -- 0^x ==> 0 160 | -- 2^3 ==> 8 161 | -- (k ^ i) ^ j ==> k ^ (i * j) 162 | -- @ 163 | reduceExp :: (Ord v, Ord c) => Symbol v c -> Symbol v c 164 | reduceExp (E _ (P [(I 0)])) = I 1 -- x^0 ==> 1 165 | reduceExp (E (S [P [I 0]]) _ ) = I 0 -- 0^x ==> 0 166 | reduceExp (E (S [P [(I i)]]) (P [(I j)])) 167 | | j >= 0 = I (i ^ j) -- 2^3 ==> 8 168 | 169 | -- (k ^ i) ^ j ==> k ^ (i * j) 170 | reduceExp (E (S [P [(E k i)]]) j) = case normaliseExp k (S [e]) of 171 | (S [P [s]]) -> s 172 | _ -> E k e 173 | where 174 | e = P . sort . map reduceExp $ mergeWith mergeS (unP i ++ unP j) 175 | 176 | reduceExp s = s 177 | 178 | -- | Merge two symbols of a Product term 179 | -- 180 | -- Performs the following rewrites: 181 | -- 182 | -- @ 183 | -- 8 * 7 ==> 56 184 | -- 1 * x ==> x 185 | -- x * 1 ==> x 186 | -- 0 * x ==> 0 187 | -- x * 0 ==> 0 188 | -- x * x^4 ==> x^5 189 | -- x^4 * x ==> x^5 190 | -- y*y ==> y^2 191 | -- @ 192 | mergeS :: (Ord v, Ord c) => Symbol v c -> Symbol v c 193 | -> Either (Symbol v c) (Symbol v c) 194 | mergeS (I i) (I j) = Left (I (i * j)) -- 8 * 7 ==> 56 195 | mergeS (I 1) r = Left r -- 1 * x ==> x 196 | mergeS l (I 1) = Left l -- x * 1 ==> x 197 | mergeS (I 0) _ = Left (I 0) -- 0 * x ==> 0 198 | mergeS _ (I 0) = Left (I 0) -- x * 0 ==> 0 199 | 200 | -- x * x^4 ==> x^5 201 | mergeS s (E (S [P [s']]) (P [I i])) 202 | | s == s' 203 | = Left (E (S [P [s']]) (P [I (i + 1)])) 204 | 205 | -- x^4 * x ==> x^5 206 | mergeS (E (S [P [s']]) (P [I i])) s 207 | | s == s' 208 | = Left (E (S [P [s']]) (P [I (i + 1)])) 209 | 210 | -- 4^x * 2^x ==> 8^x 211 | mergeS (E (S [P [I i]]) p) (E (S [P [I j]]) p') 212 | | p == p' 213 | = Left (E (S [P [I (i*j)]]) p) 214 | 215 | -- y*y ==> y^2 216 | mergeS l r 217 | | l == r 218 | = case normaliseExp (S [P [l]]) (S [P [I 2]]) of 219 | (S [P [e]]) -> Left e 220 | _ -> Right l 221 | 222 | -- x^y * x^(-y) ==> 1 223 | mergeS (E s1 (P p1)) (E s2 (P (I i:p2))) 224 | | i == (-1) 225 | , s1 == s2 226 | , p1 == p2 227 | = Left (I 1) 228 | 229 | -- x^(-y) * x^y ==> 1 230 | mergeS (E s1 (P (I i:p1))) (E s2 (P p2)) 231 | | i == (-1) 232 | , s1 == s2 233 | , p1 == p2 234 | = Left (I 1) 235 | 236 | mergeS l _ = Right l 237 | 238 | -- | Merge two products of a SOP term 239 | -- 240 | -- Performs the following rewrites: 241 | -- 242 | -- @ 243 | -- 2xy + 3xy ==> 5xy 244 | -- 2xy + xy ==> 3xy 245 | -- xy + 2xy ==> 3xy 246 | -- xy + xy ==> 2xy 247 | -- @ 248 | mergeP :: (Eq v, Eq c) => Product v c -> Product v c 249 | -> Either (Product v c) (Product v c) 250 | -- 2xy + 3xy ==> 5xy 251 | mergeP (P ((I i):is)) (P ((I j):js)) 252 | | is == js = Left . P $ (I (i + j)) : is 253 | -- 2xy + xy ==> 3xy 254 | mergeP (P ((I i):is)) (P js) 255 | | is == js = Left . P $ (I (i + 1)) : is 256 | -- xy + 2xy ==> 3xy 257 | mergeP (P is) (P ((I j):js)) 258 | | is == js = Left . P $ (I (j + 1)) : is 259 | -- xy + xy ==> 2xy 260 | mergeP (P is) (P js) 261 | | is == js = Left . P $ (I 2) : is 262 | | otherwise = Right $ P is 263 | 264 | -- | Expand or Simplify 'complex' exponentials 265 | -- 266 | -- Performs the following rewrites: 267 | -- 268 | -- @ 269 | -- b^1 ==> b 270 | -- 2^(y^2) ==> 4^y 271 | -- (x + 2)^2 ==> x^2 + 4xy + 4 272 | -- (x + 2)^(2x) ==> (x^2 + 4xy + 4)^x 273 | -- (x + 2)^(y + 2) ==> 4x(2 + x)^y + 4(2 + x)^y + (2 + x)^yx^2 274 | -- @ 275 | normaliseExp :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c 276 | -- b^1 ==> b 277 | normaliseExp b (S [P [I 1]]) = b 278 | 279 | -- x^(2xy) ==> x^(2xy) 280 | normaliseExp b@(S [P [V _]]) (S [e]) = S [P [E b e]] 281 | 282 | -- 2^(y^2) ==> 4^y 283 | normaliseExp b@(S [P [_]]) (S [e@(P [_])]) = S [P [reduceExp (E b e)]] 284 | 285 | -- (x + 2)^2 ==> x^2 + 4xy + 4 286 | normaliseExp b (S [P [(I i)]]) | i > 0 = 287 | foldr1 mergeSOPMul (replicate (fromInteger i) b) 288 | 289 | -- (x + 2)^(2x) ==> (x^2 + 4xy + 4)^x 290 | normaliseExp b (S [P (e@(I i):es)]) | i >= 0 = 291 | -- Without the "| i >= 0" guard, normaliseExp can loop with itself 292 | -- for exponentials such as: 2^(n-k) 293 | normaliseExp (normaliseExp b (S [P [e]])) (S [P es]) 294 | 295 | -- (x + 2)^(xy) ==> (x+2)^(xy) 296 | normaliseExp b (S [e]) = S [P [reduceExp (E b e)]] 297 | 298 | -- (x + 2)^(y + 2) ==> 4x(2 + x)^y + 4(2 + x)^y + (2 + x)^yx^2 299 | normaliseExp b (S e) = foldr1 mergeSOPMul (map (normaliseExp b . S . (:[])) e) 300 | 301 | zeroP :: Product v c -> Bool 302 | zeroP (P ((I 0):_)) = True 303 | zeroP _ = False 304 | 305 | mkNonEmpty :: SOP v c -> SOP v c 306 | mkNonEmpty (S []) = S [P [(I 0)]] 307 | mkNonEmpty s = s 308 | 309 | -- | Simplifies SOP terms using 310 | -- 311 | -- * 'mergeS' 312 | -- * 'mergeP' 313 | -- * 'reduceExp' 314 | simplifySOP :: (Ord v, Ord c) => SOP v c -> SOP v c 315 | simplifySOP = repeatF go 316 | where 317 | go = mkNonEmpty 318 | . S 319 | . sort . filter (not . zeroP) 320 | . mergeWith mergeP 321 | . map (P . sort . map reduceExp . mergeWith mergeS . unP) 322 | . unS 323 | 324 | repeatF f x = 325 | let x' = f x 326 | in if x' == x 327 | then x 328 | else repeatF f x' 329 | {-# INLINEABLE simplifySOP #-} 330 | 331 | -- | Merge two SOP terms by additions 332 | mergeSOPAdd :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c 333 | mergeSOPAdd (S sop1) (S sop2) = simplifySOP $ S (sop1 ++ sop2) 334 | {-# INLINEABLE mergeSOPAdd #-} 335 | 336 | -- | Merge two SOP terms by multiplication 337 | mergeSOPMul :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c 338 | mergeSOPMul (S sop1) (S sop2) 339 | = simplifySOP 340 | . S 341 | $ concatMap (zipWith (\p1 p2 -> P (unP p1 ++ unP p2)) sop1 . repeat) sop2 342 | {-# INLINEABLE mergeSOPMul #-} 343 | -------------------------------------------------------------------------------- /src/GHC/TypeLits/Normalise/Unify.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (C) 2015-2016, University of Twente, 3 | 2017 , QBayLogic B.V. 4 | License : BSD2 (see the file LICENSE) 5 | Maintainer : Christiaan Baaij 6 | -} 7 | 8 | {-# LANGUAGE CPP #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE MagicHash #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | 13 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 14 | #if __GLASGOW_HASKELL__ < 801 15 | #define nonDetCmpType cmpType 16 | #endif 17 | 18 | module GHC.TypeLits.Normalise.Unify 19 | ( -- * 'Nat' expressions \<-\> 'SOP' terms 20 | CType (..) 21 | , CoreSOP 22 | , normaliseNat 23 | , normaliseNatEverywhere 24 | , normaliseSimplifyNat 25 | , reifySOP 26 | -- * Substitution on 'SOP' terms 27 | , UnifyItem (..) 28 | , CoreUnify 29 | , substsSOP 30 | , substsSubst 31 | -- * Find unifiers 32 | , UnifyResult (..) 33 | , unifyNats 34 | , unifiers 35 | -- * Free variables in 'SOP' terms 36 | , fvSOP 37 | -- * Inequalities 38 | , subtractIneq 39 | , solveIneq 40 | , ineqToSubst 41 | , subtractionToPred 42 | , instantSolveIneq 43 | , solvedInEqSmallestConstraint 44 | -- * Properties 45 | , isNatural 46 | ) 47 | where 48 | 49 | -- External 50 | import Control.Arrow (first, second) 51 | import Control.Monad.Trans.Writer.Strict 52 | import Data.Function (on) 53 | import Data.List ((\\), intersect, nub) 54 | import Data.Maybe (fromMaybe, mapMaybe, isJust) 55 | import Data.Set (Set) 56 | import qualified Data.Set as Set 57 | 58 | import GHC.Base (isTrue#,(==#)) 59 | import GHC.Integer (smallInteger) 60 | import GHC.Integer.Logarithms (integerLogBase#) 61 | 62 | -- GHC API 63 | #if MIN_VERSION_ghc(9,0,0) 64 | import GHC.Builtin.Types (boolTy, promotedTrueDataCon) 65 | import GHC.Builtin.Types.Literals 66 | (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon) 67 | #if MIN_VERSION_ghc(9,2,0) 68 | import GHC.Builtin.Types (naturalTy, promotedFalseDataCon) 69 | import GHC.Builtin.Types.Literals (typeNatCmpTyCon) 70 | #else 71 | import GHC.Builtin.Types (typeNatKind) 72 | import GHC.Builtin.Types.Literals (typeNatLeqTyCon) 73 | #endif 74 | import GHC.Core.Predicate (EqRel (NomEq), Pred (EqPred), classifyPredType, mkPrimEqPred) 75 | import GHC.Core.TyCon (TyCon) 76 | #if MIN_VERSION_ghc(9,6,0) 77 | import GHC.Core.Type 78 | (PredType, TyVar, coreView, mkNumLitTy, mkTyConApp, mkTyVarTy, typeKind) 79 | import GHC.Core.TyCo.Compare 80 | (eqType, nonDetCmpType) 81 | #else 82 | import GHC.Core.Type 83 | (PredType, TyVar, coreView, eqType, mkNumLitTy, mkTyConApp, mkTyVarTy, nonDetCmpType, typeKind) 84 | #endif 85 | import GHC.Core.TyCo.Rep (Kind, Type (..), TyLit (..)) 86 | import GHC.Tc.Plugin (TcPluginM, tcPluginTrace) 87 | import GHC.Tc.Types.Constraint (Ct, ctEvidence, ctEvId, ctEvPred, isGiven) 88 | import GHC.Types.Unique.Set 89 | (UniqSet, unionManyUniqSets, emptyUniqSet, unionUniqSets, unitUniqSet) 90 | import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text) 91 | #else 92 | import Outputable (Outputable (..), (<+>), ($$), text) 93 | import TcPluginM (TcPluginM, tcPluginTrace) 94 | import TcTypeNats (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, 95 | typeNatSubTyCon, typeNatLeqTyCon) 96 | import TyCon (TyCon) 97 | import Type (TyVar, 98 | coreView, eqType, mkNumLitTy, mkTyConApp, mkTyVarTy, 99 | nonDetCmpType, PredType, typeKind) 100 | import TyCoRep (Kind, Type (..), TyLit (..)) 101 | import TysWiredIn (boolTy, promotedTrueDataCon, typeNatKind) 102 | import UniqSet (UniqSet, unionManyUniqSets, emptyUniqSet, unionUniqSets, 103 | unitUniqSet) 104 | 105 | #if MIN_VERSION_ghc(8,10,0) 106 | import Constraint (Ct, ctEvidence, ctEvId, ctEvPred, isGiven) 107 | import Predicate (EqRel (NomEq), Pred (EqPred), classifyPredType, mkPrimEqPred) 108 | #else 109 | import TcRnMonad (Ct, ctEvidence, isGiven) 110 | import TcRnTypes (ctEvPred) 111 | import Type (EqRel (NomEq), PredTree (EqPred), classifyPredType, mkPrimEqPred) 112 | #endif 113 | #endif 114 | 115 | -- Internal 116 | import GHC.TypeLits.Normalise.SOP 117 | 118 | -- Used for haddock 119 | import GHC.TypeLits (Nat) 120 | 121 | #if MIN_VERSION_ghc(9,2,0) 122 | typeNatKind :: Type 123 | typeNatKind = naturalTy 124 | #endif 125 | 126 | newtype CType = CType { unCType :: Type } 127 | deriving Outputable 128 | 129 | instance Eq CType where 130 | (CType ty1) == (CType ty2) = eqType ty1 ty2 131 | 132 | instance Ord CType where 133 | compare (CType ty1) (CType ty2) = nonDetCmpType ty1 ty2 134 | 135 | -- | 'SOP' with 'TyVar' variables 136 | type CoreSOP = SOP TyVar CType 137 | type CoreProduct = Product TyVar CType 138 | type CoreSymbol = Symbol TyVar CType 139 | 140 | -- | Convert a type of /kind/ 'GHC.TypeLits.Nat' to an 'SOP' term, but 141 | -- only when the type is constructed out of: 142 | -- 143 | -- * literals 144 | -- * type variables 145 | -- * Applications of the arithmetic operators @(+,-,*,^)@ 146 | normaliseNat :: Type -> Writer [(Type,Type)] CoreSOP 147 | normaliseNat ty | Just ty1 <- coreView ty = normaliseNat ty1 148 | normaliseNat (TyVarTy v) = return (S [P [V v]]) 149 | normaliseNat (LitTy (NumTyLit i)) = return (S [P [I i]]) 150 | normaliseNat (TyConApp tc [x,y]) 151 | | tc == typeNatAddTyCon = mergeSOPAdd <$> normaliseNat x <*> normaliseNat y 152 | | tc == typeNatSubTyCon = do 153 | tell [(x,y)] 154 | mergeSOPAdd <$> normaliseNat x 155 | <*> (mergeSOPMul (S [P [I (-1)]]) <$> normaliseNat y) 156 | | tc == typeNatMulTyCon = mergeSOPMul <$> normaliseNat x <*> normaliseNat y 157 | | tc == typeNatExpTyCon = normaliseExp <$> normaliseNat x <*> normaliseNat y 158 | normaliseNat t = return (S [P [C (CType t)]]) 159 | 160 | -- | Runs writer action. If the result /Nothing/ writer actions will be 161 | -- discarded. 162 | maybeRunWriter 163 | :: Monoid a 164 | => Writer a (Maybe b) 165 | -> Writer a (Maybe b) 166 | maybeRunWriter w = 167 | case runWriter w of 168 | (Nothing, _) -> pure Nothing 169 | (b, a) -> tell a >> pure b 170 | 171 | -- | Applies 'normaliseNat' and 'simplifySOP' to type or predicates to reduce 172 | -- any occurrences of sub-terms of /kind/ 'GHC.TypeLits.Nat'. If the result is 173 | -- the same as input, returns @'Nothing'@. 174 | normaliseNatEverywhere :: Type -> Writer [(Type, Type)] (Maybe Type) 175 | normaliseNatEverywhere ty0 176 | | TyConApp tc _fields <- ty0 177 | , tc `elem` knownTyCons = do 178 | -- Normalize under current type constructor application. 'go' skips all 179 | -- known type constructors. 180 | ty1M <- maybeRunWriter (go ty0) 181 | let ty1 = fromMaybe ty0 ty1M 182 | 183 | -- Normalize (subterm-normalized) type given to 'normaliseNatEverywhere' 184 | ty2 <- normaliseSimplifyNat ty1 185 | -- TODO: 'normaliseNat' could keep track whether it changed anything. That's 186 | -- TODO: probably cheaper than checking for equality here. 187 | pure (if ty2 `eqType` ty1 then ty1M else Just ty2) 188 | | otherwise = go ty0 189 | where 190 | knownTyCons :: [TyCon] 191 | knownTyCons = [typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon, typeNatAddTyCon] 192 | 193 | -- Normalize given type, but ignore all top-level 194 | go :: Type -> Writer [(Type, Type)] (Maybe Type) 195 | go (TyConApp tc_ fields0_) = do 196 | fields1_ <- mapM (maybeRunWriter . cont) fields0_ 197 | if any isJust fields1_ then 198 | pure (Just (TyConApp tc_ (zipWith fromMaybe fields0_ fields1_))) 199 | else 200 | pure Nothing 201 | where 202 | cont = if tc_ `elem` knownTyCons then go else normaliseNatEverywhere 203 | go _ = pure Nothing 204 | 205 | normaliseSimplifyNat :: Type -> Writer [(Type, Type)] Type 206 | normaliseSimplifyNat ty 207 | | typeKind ty `eqType` typeNatKind = do 208 | ty' <- normaliseNat ty 209 | return $ reifySOP $ simplifySOP ty' 210 | | otherwise = return ty 211 | 212 | -- | Convert a 'SOP' term back to a type of /kind/ 'GHC.TypeLits.Nat' 213 | reifySOP :: CoreSOP -> Type 214 | reifySOP = combineP . map negateP . unS 215 | where 216 | negateP :: CoreProduct -> Either CoreProduct CoreProduct 217 | negateP (P ((I i):ps@(_:_))) | i == (-1) = Left (P ps) 218 | negateP (P ((I i):ps)) | i < 0 = Left (P ((I (abs i)):ps)) 219 | negateP ps = Right ps 220 | 221 | combineP :: [Either CoreProduct CoreProduct] -> Type 222 | combineP [] = mkNumLitTy 0 223 | combineP [p] = either (\p' -> mkTyConApp typeNatSubTyCon 224 | [mkNumLitTy 0, reifyProduct p']) 225 | reifyProduct p 226 | combineP [p1,p2] = either 227 | (\x -> either 228 | -- x neg, y neg 229 | (\y -> let r = mkTyConApp typeNatSubTyCon [reifyProduct x 230 | ,reifyProduct y] 231 | in mkTyConApp typeNatSubTyCon [mkNumLitTy 0, r]) 232 | -- x neg, y pos 233 | (\y -> mkTyConApp typeNatSubTyCon [reifyProduct y, reifyProduct x]) 234 | p2) 235 | (\x -> either 236 | -- x pos, y neg 237 | (\y -> mkTyConApp typeNatSubTyCon [reifyProduct x, reifyProduct y]) 238 | -- x pos, y pos 239 | (\y -> mkTyConApp typeNatAddTyCon [reifyProduct x, reifyProduct y]) 240 | p2) 241 | p1 242 | 243 | 244 | combineP (p:ps) = let es = combineP ps 245 | in either (\x -> mkTyConApp typeNatSubTyCon 246 | [es, reifyProduct x]) 247 | (\x -> mkTyConApp typeNatAddTyCon 248 | [reifyProduct x, es]) 249 | p 250 | 251 | reifyProduct :: CoreProduct -> Type 252 | reifyProduct (P ps) = 253 | let ps' = map reifySymbol (foldr mergeExp [] ps) 254 | in foldr1 (\t1 t2 -> mkTyConApp typeNatMulTyCon [t1,t2]) ps' 255 | where 256 | -- "2 ^ -1 * 2 ^ a" must be merged into "2 ^ (a-1)", otherwise GHC barfs 257 | -- at the "2 ^ -1" because of the negative exponent. 258 | mergeExp :: CoreSymbol -> [Either CoreSymbol (CoreSOP,[CoreProduct])] 259 | -> [Either CoreSymbol (CoreSOP,[CoreProduct])] 260 | mergeExp (E s p) [] = [Right (s,[p])] 261 | mergeExp (E s1 p1) (y:ys) 262 | | Right (s2,p2) <- y 263 | , s1 == s2 264 | = Right (s1,(p1:p2)) : ys 265 | | otherwise 266 | = Right (s1,[p1]) : y : ys 267 | mergeExp x ys = Left x : ys 268 | 269 | reifySymbol :: Either CoreSymbol (CoreSOP,[CoreProduct]) -> Type 270 | reifySymbol (Left (I i) ) = mkNumLitTy i 271 | reifySymbol (Left (C c) ) = unCType c 272 | reifySymbol (Left (V v) ) = mkTyVarTy v 273 | reifySymbol (Left (E s p)) = mkTyConApp typeNatExpTyCon [reifySOP s,reifyProduct p] 274 | reifySymbol (Right (s1,s2)) = mkTyConApp typeNatExpTyCon 275 | [reifySOP s1 276 | ,reifySOP (S s2) 277 | ] 278 | 279 | -- | Subtract an inequality, in order to either: 280 | -- 281 | -- * See if the smallest solution is a natural number 282 | -- * Cancel sums, i.e. monotonicity of addition 283 | -- 284 | -- @ 285 | -- subtractIneq (2*y <=? 3*x ~ True) = (-2*y + 3*x) 286 | -- subtractIneq (2*y <=? 3*x ~ False) = (-3*x + (-1) + 2*y) 287 | -- @ 288 | subtractIneq 289 | :: (CoreSOP, CoreSOP, Bool) 290 | -> CoreSOP 291 | subtractIneq (x,y,isLE) 292 | | isLE 293 | = mergeSOPAdd y (mergeSOPMul (S [P [I (-1)]]) x) 294 | | otherwise 295 | = mergeSOPAdd x (mergeSOPMul (S [P [I (-1)]]) (mergeSOPAdd y (S [P [I 1]]))) 296 | 297 | -- | Try to reverse the process of 'subtractIneq' 298 | -- 299 | -- E.g. 300 | -- 301 | -- @ 302 | -- subtractIneq (2*y <=? 3*x ~ True) = (-2*y + 3*x) 303 | -- sopToIneq (-2*y+3*x) = Just (2*x <=? 3*x ~ True) 304 | -- @ 305 | sopToIneq 306 | :: CoreSOP 307 | -> Maybe Ineq 308 | sopToIneq (S [P ((I i):l),r]) 309 | | i < 0 310 | = Just (mergeSOPMul (S [P [I (negate i)]]) (S [P l]),S [r],True) 311 | sopToIneq (S [r,P ((I i:l))]) 312 | | i < 0 313 | = Just (mergeSOPMul (S [P [I (negate i)]]) (S [P l]),S [r],True) 314 | sopToIneq _ = Nothing 315 | 316 | -- | Give the smallest solution for an inequality 317 | ineqToSubst 318 | :: Ineq 319 | -> Maybe CoreUnify 320 | ineqToSubst (x,S [P [V v]],True) 321 | = Just (SubstItem v x) 322 | ineqToSubst _ 323 | = Nothing 324 | 325 | subtractionToPred 326 | :: TyCon 327 | -> (Type,Type) 328 | -> (PredType, Kind) 329 | subtractionToPred ordCond (x,y) = 330 | #if MIN_VERSION_ghc(9,2,0) 331 | let cmpNat = mkTyConApp typeNatCmpTyCon [y,x] 332 | trueTc = mkTyConApp promotedTrueDataCon [] 333 | falseTc = mkTyConApp promotedFalseDataCon [] 334 | ordCmp = mkTyConApp ordCond 335 | [boolTy,cmpNat,trueTc,trueTc,falseTc] 336 | predTy = mkPrimEqPred ordCmp trueTc 337 | in (predTy,boolTy) 338 | #else 339 | (mkPrimEqPred (mkTyConApp ordCond [y,x]) 340 | (mkTyConApp promotedTrueDataCon []) 341 | ,boolTy) 342 | #endif 343 | 344 | -- | A substitution is essentially a list of (variable, 'SOP') pairs, 345 | -- but we keep the original 'Ct' that lead to the substitution being 346 | -- made, for use when turning the substitution back into constraints. 347 | type CoreUnify = UnifyItem TyVar CType 348 | 349 | data UnifyItem v c = SubstItem { siVar :: v 350 | , siSOP :: SOP v c 351 | } 352 | | UnifyItem { siLHS :: SOP v c 353 | , siRHS :: SOP v c 354 | } 355 | deriving Eq 356 | 357 | instance (Outputable v, Outputable c) => Outputable (UnifyItem v c) where 358 | ppr (SubstItem {..}) = ppr siVar <+> text " := " <+> ppr siSOP 359 | ppr (UnifyItem {..}) = ppr siLHS <+> text " :~ " <+> ppr siRHS 360 | 361 | -- | Apply a substitution to a single normalised 'SOP' term 362 | substsSOP :: (Ord v, Ord c) => [UnifyItem v c] -> SOP v c -> SOP v c 363 | substsSOP [] u = u 364 | substsSOP ((SubstItem {..}):s) u = substsSOP s (substSOP siVar siSOP u) 365 | substsSOP ((UnifyItem {}):s) u = substsSOP s u 366 | 367 | substSOP :: (Ord v, Ord c) => v -> SOP v c -> SOP v c -> SOP v c 368 | substSOP tv e = foldr1 mergeSOPAdd . map (substProduct tv e) . unS 369 | 370 | substProduct :: (Ord v, Ord c) => v -> SOP v c -> Product v c -> SOP v c 371 | substProduct tv e = foldr1 mergeSOPMul . map (substSymbol tv e) . unP 372 | 373 | substSymbol :: (Ord v, Ord c) => v -> SOP v c -> Symbol v c -> SOP v c 374 | substSymbol _ _ s@(I _) = S [P [s]] 375 | substSymbol _ _ s@(C _) = S [P [s]] 376 | substSymbol tv e (V tv') 377 | | tv == tv' = e 378 | | otherwise = S [P [V tv']] 379 | substSymbol tv e (E s p) = normaliseExp (substSOP tv e s) (substProduct tv e p) 380 | 381 | -- | Apply a substitution to a substitution 382 | substsSubst :: (Ord v, Ord c) => [UnifyItem v c] -> [UnifyItem v c] -> [UnifyItem v c] 383 | substsSubst s = map subt 384 | where 385 | subt si@(SubstItem {..}) = si {siSOP = substsSOP s siSOP} 386 | subt si@(UnifyItem {..}) = si {siLHS = substsSOP s siLHS, siRHS = substsSOP s siRHS} 387 | {-# INLINEABLE substsSubst #-} 388 | 389 | -- | Result of comparing two 'SOP' terms, returning a potential substitution 390 | -- list under which the two terms are equal. 391 | data UnifyResult 392 | = Win -- ^ Two terms are equal 393 | | Lose -- ^ Two terms are /not/ equal 394 | | Draw [CoreUnify] -- ^ Two terms are only equal if the given substitution holds 395 | 396 | instance Outputable UnifyResult where 397 | ppr Win = text "Win" 398 | ppr (Draw subst) = text "Draw" <+> ppr subst 399 | ppr Lose = text "Lose" 400 | 401 | -- | Given two 'SOP's @u@ and @v@, when their free variables ('fvSOP') are the 402 | -- same, then we 'Win' if @u@ and @v@ are equal, and 'Lose' otherwise. 403 | -- 404 | -- If @u@ and @v@ do not have the same free variables, we result in a 'Draw', 405 | -- ware @u@ and @v@ are only equal when the returned 'CoreSubst' holds. 406 | unifyNats :: Ct -> CoreSOP -> CoreSOP -> TcPluginM UnifyResult 407 | unifyNats ct u v = do 408 | tcPluginTrace "unifyNats" (ppr ct $$ ppr u $$ ppr v) 409 | return (unifyNats' ct u v) 410 | 411 | unifyNats' :: Ct -> CoreSOP -> CoreSOP -> UnifyResult 412 | unifyNats' ct u v 413 | = if eqFV u v 414 | then if containsConstants u || containsConstants v 415 | then if u == v 416 | then Win 417 | else Draw (filter diffFromConstraint (unifiers ct u v)) 418 | else if u == v 419 | then Win 420 | else Lose 421 | else Draw (filter diffFromConstraint (unifiers ct u v)) 422 | where 423 | -- A unifier is only a unifier if differs from the original constraint 424 | diffFromConstraint (UnifyItem x y) = not (x == u && y == v) 425 | diffFromConstraint _ = True 426 | 427 | -- | Find unifiers for two SOP terms 428 | -- 429 | -- Can find the following unifiers: 430 | -- 431 | -- @ 432 | -- t ~ a + b ==> [t := a + b] 433 | -- a + b ~ t ==> [t := a + b] 434 | -- (a + c) ~ (b + c) ==> \[a := b\] 435 | -- (2*a) ~ (2*b) ==> [a := b] 436 | -- (2 + a) ~ 5 ==> [a := 3] 437 | -- (i * a) ~ j ==> [a := div j i], when (mod j i == 0) 438 | -- @ 439 | -- 440 | -- However, given a wanted: 441 | -- 442 | -- @ 443 | -- [W] t ~ a + b 444 | -- @ 445 | -- 446 | -- this function returns @[]@, or otherwise we \"solve\" the constraint by 447 | -- finding a unifier equal to the constraint. 448 | -- 449 | -- However, given a wanted: 450 | -- 451 | -- @ 452 | -- [W] (a + c) ~ (b + c) 453 | -- @ 454 | -- 455 | -- we do return the unifier: 456 | -- 457 | -- @ 458 | -- [a := b] 459 | -- @ 460 | unifiers :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify] 461 | unifiers ct u@(S [P [V x]]) v 462 | = case classifyPredType $ ctEvPred $ ctEvidence ct of 463 | EqPred NomEq t1 _ 464 | | CType (reifySOP u) /= CType t1 || isGiven (ctEvidence ct) -> [SubstItem x v] 465 | _ -> [] 466 | unifiers ct u v@(S [P [V x]]) 467 | = case classifyPredType $ ctEvPred $ ctEvidence ct of 468 | EqPred NomEq _ t2 469 | | CType (reifySOP v) /= CType t2 || isGiven (ctEvidence ct) -> [SubstItem x u] 470 | _ -> [] 471 | unifiers ct u@(S [P [C _]]) v 472 | = case classifyPredType $ ctEvPred $ ctEvidence ct of 473 | EqPred NomEq t1 t2 474 | | CType (reifySOP u) /= CType t1 || CType (reifySOP v) /= CType t2 -> [UnifyItem u v] 475 | _ -> [] 476 | unifiers ct u v@(S [P [C _]]) 477 | = case classifyPredType $ ctEvPred $ ctEvidence ct of 478 | EqPred NomEq t1 t2 479 | | CType (reifySOP u) /= CType t1 || CType (reifySOP v) /= CType t2 -> [UnifyItem u v] 480 | _ -> [] 481 | unifiers ct u v = unifiers' ct u v 482 | 483 | unifiers' :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify] 484 | unifiers' _ct (S [P [V x]]) (S []) = [SubstItem x (S [P [I 0]])] 485 | unifiers' _ct (S []) (S [P [V x]]) = [SubstItem x (S [P [I 0]])] 486 | 487 | unifiers' _ct (S [P [V x]]) s = [SubstItem x s] 488 | unifiers' _ct s (S [P [V x]]) = [SubstItem x s] 489 | 490 | unifiers' _ct s1@(S [P [C _]]) s2 = [UnifyItem s1 s2] 491 | unifiers' _ct s1 s2@(S [P [C _]]) = [UnifyItem s1 s2] 492 | 493 | 494 | -- (z ^ a) ~ (z ^ b) ==> [a := b] 495 | unifiers' ct (S [P [E s1 p1]]) (S [P [E s2 p2]]) 496 | | s1 == s2 = unifiers' ct (S [p1]) (S [p2]) 497 | 498 | -- (2*e ^ d) ~ (2*e*a*c) ==> [a*c := 2*e ^ (d-1)] 499 | unifiers' ct (S [P [E (S [P s1]) p1]]) (S [P p2]) 500 | | all (`elem` p2) s1 501 | = let base = intersect s1 p2 502 | diff = p2 \\ s1 503 | in unifiers ct (S [P diff]) (S [P [E (S [P base]) (P [I (-1)]),E (S [P base]) p1]]) 504 | 505 | unifiers' ct (S [P p2]) (S [P [E (S [P s1]) p1]]) 506 | | all (`elem` p2) s1 507 | = let base = intersect s1 p2 508 | diff = p2 \\ s1 509 | in unifiers ct (S [P [E (S [P base]) (P [I (-1)]),E (S [P base]) p1]]) (S [P diff]) 510 | 511 | -- (i ^ a) ~ j ==> [a := round (logBase i j)], when `i` and `j` are integers, 512 | -- and `ceiling (logBase i j) == floor (logBase i j)` 513 | unifiers' ct (S [P [E (S [P [I i]]) p]]) (S [P [I j]]) 514 | = case integerLogBase i j of 515 | Just k -> unifiers' ct (S [p]) (S [P [I k]]) 516 | Nothing -> [] 517 | 518 | unifiers' ct (S [P [I j]]) (S [P [E (S [P [I i]]) p]]) 519 | = case integerLogBase i j of 520 | Just k -> unifiers' ct (S [p]) (S [P [I k]]) 521 | Nothing -> [] 522 | 523 | -- a^d * a^e ~ a^c ==> [c := d + e] 524 | unifiers' ct (S [P [E s1 p1]]) (S [p2]) = case collectBases p2 of 525 | Just (b:bs,ps) | all (== s1) (b:bs) -> 526 | unifiers' ct (S [p1]) (S ps) 527 | _ -> [] 528 | 529 | unifiers' ct (S [p2]) (S [P [E s1 p1]]) = case collectBases p2 of 530 | Just (b:bs,ps) | all (== s1) (b:bs) -> 531 | unifiers' ct (S ps) (S [p1]) 532 | _ -> [] 533 | 534 | -- (i * a) ~ j ==> [a := div j i] 535 | -- Where 'a' is a variable, 'i' and 'j' are integer literals, and j `mod` i == 0 536 | unifiers' ct (S [P ((I i):ps)]) (S [P [I j]]) = 537 | case safeDiv j i of 538 | Just k -> unifiers' ct (S [P ps]) (S [P [I k]]) 539 | _ -> [] 540 | 541 | unifiers' ct (S [P [I j]]) (S [P ((I i):ps)]) = 542 | case safeDiv j i of 543 | Just k -> unifiers' ct (S [P ps]) (S [P [I k]]) 544 | _ -> [] 545 | 546 | -- (2*a) ~ (2*b) ==> [a := b] 547 | -- unifiers' ct (S [P (p:ps1)]) (S [P (p':ps2)]) 548 | -- | p == p' = unifiers' ct (S [P ps1]) (S [P ps2]) 549 | -- | otherwise = [] 550 | unifiers' ct (S [P ps1]) (S [P ps2]) 551 | | null psx = [] 552 | | otherwise = unifiers' ct (S [P ps1'']) (S [P ps2'']) 553 | where 554 | ps1' = ps1 \\ psx 555 | ps2' = ps2 \\ psx 556 | ps1'' | null ps1' = [I 1] 557 | | otherwise = ps1' 558 | ps2'' | null ps2' = [I 1] 559 | | otherwise = ps2' 560 | psx = intersect ps1 ps2 561 | 562 | -- (2 + a) ~ 5 ==> [a := 3] 563 | unifiers' ct (S ((P [I i]):ps1)) (S ((P [I j]):ps2)) 564 | | i < j = unifiers' ct (S ps1) (S ((P [I (j-i)]):ps2)) 565 | | i > j = unifiers' ct (S ((P [I (i-j)]):ps1)) (S ps2) 566 | 567 | -- (a + c) ~ (b + c) ==> [a := b] 568 | unifiers' ct s1@(S ps1) s2@(S ps2) = case sopToIneq k1 of 569 | Just (s1',s2',_) 570 | | s1' /= s1 || s2' /= s1 571 | , maybe True (uncurry (&&) . second Set.null) (runWriterT (isNatural s1')) 572 | , maybe True (uncurry (&&) . second Set.null) (runWriterT (isNatural s2')) 573 | -> unifiers' ct s1' s2' 574 | _ | null psx 575 | , length ps1 == length ps2 576 | -> case nub (concat (zipWith (\x y -> unifiers' ct (S [x]) (S [y])) ps1 ps2)) of 577 | [] -> unifiers'' ct (S ps1) (S ps2) 578 | [k] | length ps1 == length ps2 -> [k] 579 | _ -> [] 580 | | null psx 581 | , isGiven (ctEvidence ct) 582 | -> unifiers'' ct (S ps1) (S ps2) 583 | | null psx 584 | -> [] 585 | _ -> unifiers' ct (S ps1'') (S ps2'') 586 | where 587 | k1 = subtractIneq (s1,s2,True) 588 | ps1' = ps1 \\ psx 589 | ps2' = ps2 \\ psx 590 | ps1'' | null ps1' = [P [I 0]] 591 | | otherwise = ps1' 592 | ps2'' | null ps2' = [P [I 0]] 593 | | otherwise = ps2' 594 | psx = intersect ps1 ps2 595 | 596 | unifiers'' :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify] 597 | unifiers'' ct (S [P [I i],P [V v]]) s2 598 | | isGiven (ctEvidence ct) = [SubstItem v (mergeSOPAdd s2 (S [P [I (negate i)]]))] 599 | unifiers'' ct s1 (S [P [I i],P [V v]]) 600 | | isGiven (ctEvidence ct) = [SubstItem v (mergeSOPAdd s1 (S [P [I (negate i)]]))] 601 | unifiers'' _ _ _ = [] 602 | 603 | collectBases :: CoreProduct -> Maybe ([CoreSOP],[CoreProduct]) 604 | collectBases = fmap unzip . traverse go . unP 605 | where 606 | go (E s1 p1) = Just (s1,p1) 607 | go _ = Nothing 608 | 609 | -- | Find the 'TyVar' in a 'CoreSOP' 610 | fvSOP :: CoreSOP -> UniqSet TyVar 611 | fvSOP = unionManyUniqSets . map fvProduct . unS 612 | 613 | fvProduct :: CoreProduct -> UniqSet TyVar 614 | fvProduct = unionManyUniqSets . map fvSymbol . unP 615 | 616 | fvSymbol :: CoreSymbol -> UniqSet TyVar 617 | fvSymbol (I _) = emptyUniqSet 618 | fvSymbol (C _) = emptyUniqSet 619 | fvSymbol (V v) = unitUniqSet v 620 | fvSymbol (E s p) = fvSOP s `unionUniqSets` fvProduct p 621 | 622 | eqFV :: CoreSOP -> CoreSOP -> Bool 623 | eqFV = (==) `on` fvSOP 624 | 625 | containsConstants :: CoreSOP -> Bool 626 | containsConstants = 627 | any (any symbolContainsConstant . unP) . unS 628 | where 629 | symbolContainsConstant c = case c of 630 | C {} -> True 631 | E s p -> containsConstants s || containsConstants (S [p]) 632 | _ -> False 633 | 634 | safeDiv :: Integer -> Integer -> Maybe Integer 635 | safeDiv i j 636 | | j == 0 = Just 0 637 | | otherwise = case divMod i j of 638 | (k,0) -> Just k 639 | _ -> Nothing 640 | 641 | -- | Given `x` and `y`, return `Just n` when 642 | -- 643 | -- `ceiling (logBase x y) == floor (logBase x y)` 644 | integerLogBase :: Integer -> Integer -> Maybe Integer 645 | integerLogBase x y | x > 1 && y > 0 = 646 | let z1 = integerLogBase# x y 647 | z2 = integerLogBase# x (y-1) 648 | in if isTrue# (z1 ==# z2) 649 | then Nothing 650 | else Just (smallInteger z1) 651 | integerLogBase _ _ = Nothing 652 | 653 | isNatural :: CoreSOP -> WriterT (Set CType) Maybe Bool 654 | isNatural (S []) = return True 655 | isNatural (S [P []]) = return True 656 | isNatural (S [P (I i:ps)]) 657 | | i >= 0 = isNatural (S [P ps]) 658 | | otherwise = return False 659 | isNatural (S [P (V _:ps)]) = isNatural (S [P ps]) 660 | isNatural (S [P (E s p:ps)]) = do 661 | sN <- isNatural s 662 | pN <- isNatural (S [p]) 663 | if sN && pN 664 | then isNatural (S [P ps]) 665 | else WriterT Nothing 666 | -- We give up for all other products for now 667 | isNatural (S [P (C c:ps)]) = do 668 | tell (Set.singleton c) 669 | isNatural (S [P ps]) 670 | -- Adding two natural numbers is also a natural number 671 | isNatural (S (p:ps)) = do 672 | pN <- isNatural (S [p]) 673 | pK <- isNatural (S ps) 674 | case (pN,pK) of 675 | (True,True) -> return True -- both are natural 676 | (False,False) -> return False -- both are non-natural 677 | _ -> WriterT Nothing 678 | -- if one is natural and the other isn't, then their sum *might* be natural, 679 | -- but we simply cant be sure. 680 | 681 | -- | Try to solve inequalities 682 | solveIneq 683 | :: Word 684 | -- ^ Solving depth 685 | -> Ineq 686 | -- ^ Inequality we want to solve 687 | -> Ineq 688 | -- ^ Given/proven inequality 689 | -> WriterT (Set CType) Maybe Bool 690 | -- ^ Solver result 691 | -- 692 | -- * /Nothing/: exhausted solver steps 693 | -- 694 | -- * /Just True/: inequality is solved 695 | -- 696 | -- * /Just False/: solver is unable to solve inequality, note that this does 697 | -- __not__ mean the wanted inequality does not hold. 698 | solveIneq 0 _ _ = noRewrite 699 | solveIneq k want@(_,_,True) have@(_,_,True) 700 | | want == have 701 | = pure True 702 | | otherwise 703 | = do 704 | let -- Apply all the rules, and get all the successful ones 705 | new = mapMaybe (\f -> runWriterT (f want have)) ineqRules 706 | -- Recurse down with all the transformed equations 707 | solved = map (first (mapMaybe (runWriterT . uncurry (solveIneq (k-1))))) new 708 | -- For the results of every recursive call, find the one that yields 709 | -- 'True' and has the smallest set of constraints. 710 | solved1 = map (first solvedInEqSmallestConstraint) solved 711 | -- Union the constraints from the corresponding rewrites with the 712 | -- constraints from the recursive results 713 | solved2 = map (\((b,s1),s2) -> (b,Set.union s1 s2)) solved1 714 | -- From these results, again find the single result that yields 'True' 715 | -- and has the smallest set of constraints. 716 | solved3 = solvedInEqSmallestConstraint solved2 717 | if null solved then 718 | noRewrite 719 | else do 720 | WriterT (Just solved3) 721 | 722 | solveIneq _ _ _ = pure False 723 | 724 | -- Find the solved inequality with the fewest number of constraints 725 | solvedInEqSmallestConstraint :: [(Bool,Set a)] -> (Bool, Set a) 726 | solvedInEqSmallestConstraint = go (False, Set.empty) 727 | where 728 | go bs [] = bs 729 | go (b,s) ((b1,s1):solved) 730 | | not b && b1 731 | = go (b1,s1) solved 732 | | b && b1 733 | , Set.size s > Set.size s1 734 | = go (b1,s1) solved 735 | | otherwise 736 | = go (b,s) solved 737 | 738 | -- | Try to instantly solve an inequality by using the inequality solver using 739 | -- @1 <=? 1 ~ True@ as the given constraint. 740 | instantSolveIneq 741 | :: Word 742 | -- ^ Solving depth 743 | -> Ineq 744 | -- ^ Inequality we want to solve 745 | -> WriterT (Set CType) Maybe Bool 746 | instantSolveIneq k u = solveIneq k u (one,one,True) 747 | where 748 | one = S [P [I 1]] 749 | 750 | type Ineq = (CoreSOP, CoreSOP, Bool) 751 | type IneqRule = Ineq -> Ineq -> WriterT (Set CType) Maybe [(Ineq,Ineq)] 752 | 753 | noRewrite :: WriterT (Set CType) Maybe a 754 | noRewrite = WriterT Nothing 755 | 756 | ineqRules 757 | :: [IneqRule] 758 | ineqRules = 759 | [ leTrans 760 | , plusMonotone 761 | , timesMonotone 762 | , powMonotone 763 | , pow2MonotoneSpecial 764 | , haveSmaller 765 | , haveBigger 766 | ] 767 | 768 | -- | Transitivity of inequality 769 | leTrans :: IneqRule 770 | leTrans want@(a,b,le) (x,y,_) 771 | -- want: 1 <=? y ~ True 772 | -- have: 2 <=? y ~ True 773 | -- 774 | -- new want: want 775 | -- new have: 1 <=? y ~ True 776 | | S [P [I a']] <- a 777 | , S [P [I x']] <- x 778 | , x' >= a' 779 | = pure [(want,(a,y,le))] 780 | -- want: y <=? 10 ~ True 781 | -- have: y <=? 9 ~ True 782 | -- 783 | -- new want: want 784 | -- new have: y <=? 10 ~ True 785 | | S [P [I b']] <- b 786 | , S [P [I y']] <- y 787 | , y' < b' 788 | = pure [(want,(x,b,le))] 789 | leTrans _ _ = noRewrite 790 | 791 | -- | Monotonicity of addition 792 | -- 793 | -- We use SOP normalization to apply this rule by e.g.: 794 | -- 795 | -- * Given: (2*x+1) <= (3*x-1) 796 | -- * Turn to: (3*x-1) - (2*x+1) 797 | -- * SOP version: -2 + x 798 | -- * Convert back to inequality: 2 <= x 799 | plusMonotone :: IneqRule 800 | plusMonotone want have 801 | | Just want' <- sopToIneq (subtractIneq want) 802 | , want' /= want 803 | = pure [(want',have)] 804 | | Just have' <- sopToIneq (subtractIneq have) 805 | , have' /= have 806 | = pure [(want,have')] 807 | plusMonotone _ _ = noRewrite 808 | 809 | -- | Make the `a` of a given `a <= b` smaller 810 | haveSmaller :: IneqRule 811 | haveSmaller want have 812 | | (S (x:y:ys),us,True) <- have 813 | = pure [(want,(S (x:ys),us,True)) 814 | ,(want,(S (y:ys),us,True)) 815 | ] 816 | | (S [P [I 1]], S [P (I _:p@(_:_))],True) <- have 817 | = pure [(want,(S [P [I 1]],S [P p],True))] 818 | haveSmaller _ _ = noRewrite 819 | 820 | -- | Make the `b` of a given `a <= b` bigger 821 | haveBigger :: IneqRule 822 | haveBigger want have 823 | | (_ ,S vs,True) <- want 824 | , (as,S bs,True) <- have 825 | , let vs' = vs \\ bs 826 | , not (null vs') 827 | -- want : a <= x + 1 828 | -- have : y <= x 829 | -- 830 | -- new want: want 831 | -- new have: y <= x + 1 832 | = do 833 | -- Ensure that we're actually making the RHS larger 834 | b <- isNatural (S vs') 835 | if b then 836 | pure [(want,(as,mergeSOPAdd (S bs) (S vs'),True))] 837 | else 838 | noRewrite 839 | haveBigger _ _ = noRewrite 840 | 841 | -- | Monotonicity of multiplication 842 | timesMonotone :: IneqRule 843 | timesMonotone want@(a,b,le) have@(x,y,_) 844 | -- want: C*a <=? b ~ True 845 | -- have: x <=? y ~ True 846 | -- 847 | -- new want: want 848 | -- new have: C*a <=? C*y ~ True 849 | | S [P a'@(_:_:_)] <- a 850 | , S [P x'] <- x 851 | , S [P y'] <- y 852 | , let ax = a' \\ x' 853 | , let ay = a' \\ y' 854 | -- Ensure we don't repeat this rule over and over 855 | , not (null ax) 856 | , not (null ay) 857 | -- Pick the smallest product 858 | , let az = if length ax <= length ay then S [P ax] else S [P ay] 859 | = pure [(want,(mergeSOPMul az x, mergeSOPMul az y,le))] 860 | 861 | -- want: a <=? C*b ~ True 862 | -- have: x <=? y ~ True 863 | -- 864 | -- new want: want 865 | -- new have: C*a <=? C*y ~ True 866 | | S [P b'@(_:_:_)] <- b 867 | , S [P x'] <- x 868 | , S [P y'] <- y 869 | , let bx = b' \\ x' 870 | , let by = b' \\ y' 871 | -- Ensure we don't repeat this rule over and over 872 | , not (null bx) 873 | , not (null by) 874 | -- Pick the smallest product 875 | , let bz = if length bx <= length by then S [P bx] else S [P by] 876 | = pure [(want,(mergeSOPMul bz x, mergeSOPMul bz y,le))] 877 | 878 | -- want: a <=? b ~ True 879 | -- have: C*x <=? y ~ True 880 | -- 881 | -- new want: C*a <=? C*b ~ True 882 | -- new have: have 883 | | S [P x'@(_:_:_)] <- x 884 | , S [P a'] <- a 885 | , S [P b'] <- b 886 | , let xa = x' \\ a' 887 | , let xb = x' \\ b' 888 | -- Ensure we don't repeat this rule over and over 889 | , not (null xa) 890 | , not (null xb) 891 | -- Pick the smallest product 892 | , let xz = if length xa <= length xb then S [P xa] else S [P xb] 893 | = pure [((mergeSOPMul xz a, mergeSOPMul xz b,le),have)] 894 | 895 | -- want: a <=? b ~ True 896 | -- have: x <=? C*y ~ True 897 | -- 898 | -- new want: C*a <=? C*b ~ True 899 | -- new have: have 900 | | S [P y'@(_:_:_)] <- y 901 | , S [P a'] <- a 902 | , S [P b'] <- b 903 | , let ya = y' \\ a' 904 | , let yb = y' \\ b' 905 | -- Ensure we don't repeat this rule over and over 906 | , not (null ya) 907 | , not (null yb) 908 | -- Pick the smallest product 909 | , let yz = if length ya <= length yb then S [P ya] else S [P yb] 910 | = pure [((mergeSOPMul yz a, mergeSOPMul yz b,le),have)] 911 | 912 | timesMonotone _ _ = noRewrite 913 | 914 | -- | Monotonicity of exponentiation 915 | powMonotone :: IneqRule 916 | powMonotone want (x, S [P [E yS yP]],le) 917 | = case x of 918 | S [P [E xS xP]] 919 | -- want: XXX 920 | -- have: 2^x <=? 2^y ~ True 921 | -- 922 | -- new want: want 923 | -- new have: x <=? y ~ True 924 | | xS == yS 925 | -> pure [(want,(S [xP],S [yP],le))] 926 | -- want: XXX 927 | -- have: x^2 <=? y^2 ~ True 928 | -- 929 | -- new want: want 930 | -- new have: x <=? y ~ True 931 | | xP == yP 932 | -> pure [(want,(xS,yS,le))] 933 | -- want: XXX 934 | -- have: 2 <=? 2 ^ x ~ True 935 | -- 936 | -- new want: want 937 | -- new have: 1 <=? x ~ True 938 | _ | x == yS 939 | -> pure [(want,(S [P [I 1]],S [yP],le))] 940 | _ -> noRewrite 941 | 942 | powMonotone (a,S [P [E bS bP]],le) have 943 | = case a of 944 | S [P [E aS aP]] 945 | -- want: 2^x <=? 2^y ~ True 946 | -- have: XXX 947 | -- 948 | -- new want: x <=? y ~ True 949 | -- new have: have 950 | | aS == bS 951 | -> pure [((S [aP],S [bP],le),have)] 952 | -- want: x^2 <=? y^2 ~ True 953 | -- have: XXX 954 | -- 955 | -- new want: x <=? y ~ True 956 | -- new have: have 957 | | aP == bP 958 | -> pure [((aS,bS,le),have)] 959 | -- want: 2 <=? 2 ^ x ~ True 960 | -- have: XXX 961 | -- 962 | -- new want: 1 <=? x ~ True 963 | -- new have: XXX 964 | _ | a == bS 965 | -> pure [((S [P [I 1]],S [bP],le),have)] 966 | _ -> noRewrite 967 | 968 | powMonotone _ _ = noRewrite 969 | 970 | -- | Try to get the power-of-2 factors, and apply the monotonicity of 971 | -- exponentiation rule. 972 | -- 973 | -- TODO: I wish we could generalize to find arbitrary factors, but currently 974 | -- I don't know how. 975 | pow2MonotoneSpecial :: IneqRule 976 | pow2MonotoneSpecial (a,b,le) have 977 | -- want: 4 * 4^x <=? 8^x ~ True 978 | -- have: XXX 979 | -- 980 | -- want as pow 2 factors: 2^(2+2*x) <=? 2^(3*x) ~ True 981 | -- 982 | -- new want: 2+2*x <=? 3*x ~ True 983 | -- new have: have 984 | | Just a' <- facSOP 2 a 985 | , Just b' <- facSOP 2 b 986 | = pure [((a',b',le),have)] 987 | pow2MonotoneSpecial want (x,y,le) 988 | -- want: XXX 989 | -- have:4 * 4^x <=? 8^x ~ True 990 | -- 991 | -- have as pow 2 factors: 2^(2+2*x) <=? 2^(3*x) ~ True 992 | -- 993 | -- new want: want 994 | -- new have: 2+2*x <=? 3*x ~ True 995 | | Just x' <- facSOP 2 x 996 | , Just y' <- facSOP 2 y 997 | = pure [(want,(x',y',le))] 998 | pow2MonotoneSpecial _ _ = noRewrite 999 | 1000 | -- | Get the power of /N/ factors of a SOP term 1001 | facSOP 1002 | :: Integer 1003 | -- ^ The power /N/ 1004 | -> CoreSOP 1005 | -> Maybe CoreSOP 1006 | facSOP n (S [P ps]) = fmap (S . concat . map unS) (traverse (facSymbol n) ps) 1007 | facSOP _ _ = Nothing 1008 | 1009 | -- | Get the power of /N/ factors of a Symbol 1010 | facSymbol 1011 | :: Integer 1012 | -- ^ The power 1013 | -> CoreSymbol 1014 | -> Maybe CoreSOP 1015 | facSymbol n (I i) 1016 | | Just j <- integerLogBase n i 1017 | = Just (S [P [I j]]) 1018 | facSymbol n (E s p) 1019 | | Just s' <- facSOP n s 1020 | = Just (mergeSOPMul s' (S [p])) 1021 | facSymbol _ _ = Nothing 1022 | -------------------------------------------------------------------------------- /tests/ErrorTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | 13 | #if __GLASGOW_HASKELL__ >= 805 14 | {-# LANGUAGE NoStarIsType #-} 15 | #endif 16 | 17 | {-# OPTIONS_GHC -fdefer-type-errors #-} 18 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} 19 | module ErrorTests where 20 | 21 | import Data.Proxy 22 | import GHC.TypeLits 23 | #if __GLASGOW_HASKELL__ >= 904 24 | import GHC.Types 25 | #endif 26 | 27 | import GHC.IO.Encoding (getLocaleEncoding, textEncodingName, utf8) 28 | import Language.Haskell.TH (litE, stringL) 29 | import Language.Haskell.TH.Syntax (runIO) 30 | 31 | testProxy1 :: Proxy (x + 1) -> Proxy (2 + x) 32 | testProxy1 = id 33 | 34 | testProxy1Errors = 35 | #if __GLASGOW_HASKELL__ >= 900 36 | ["Expected: Proxy (x + 1) -> Proxy (2 + x)" 37 | ," Actual: Proxy (x + 1) -> Proxy (x + 1)" 38 | ] 39 | #else 40 | ["Expected type: Proxy (x + 1) -> Proxy (2 + x)" 41 | ,"Actual type: Proxy (2 + x) -> Proxy (2 + x)" 42 | ] 43 | #endif 44 | 45 | type family GCD (x :: Nat) (y :: Nat) :: Nat 46 | type instance GCD 6 8 = 2 47 | type instance GCD 9 6 = 3 48 | 49 | testProxy2 :: Proxy (GCD 6 8 + x) -> Proxy (x + GCD 9 6) 50 | testProxy2 = id 51 | 52 | testProxy2Errors = 53 | #if __GLASGOW_HASKELL__ >= 900 54 | ["Expected: Proxy (GCD 6 8 + x) -> Proxy (x + GCD 9 6)" 55 | ," Actual: Proxy (2 + x) -> Proxy (2 + x)" 56 | ] 57 | #else 58 | ["Expected type: Proxy (GCD 6 8 + x) -> Proxy (x + GCD 9 6)" 59 | ,"Actual type: Proxy (x + 3) -> Proxy (x + 3)" 60 | ] 61 | #endif 62 | 63 | proxyFun3 :: Proxy (x + x + x) -> () 64 | proxyFun3 = const () 65 | 66 | testProxy3 :: Proxy 8 -> () 67 | testProxy3 = proxyFun3 68 | 69 | testProxy3Errors = 70 | #if __GLASGOW_HASKELL__ >= 900 71 | ["Expected: Proxy 8 -> ()" 72 | ," Actual: Proxy ((x0 + x0) + x0) -> ()" 73 | ] 74 | #else 75 | ["Expected type: Proxy 8 -> ()" 76 | ,"Actual type: Proxy ((x0 + x0) + x0) -> ()" 77 | ] 78 | #endif 79 | 80 | proxyFun4 :: Proxy ((2*y)+4) -> () 81 | proxyFun4 = const () 82 | 83 | testProxy4 :: Proxy 2 -> () 84 | testProxy4 = proxyFun4 85 | 86 | testProxy4Errors = 87 | #if __GLASGOW_HASKELL__ >= 900 88 | ["Expected: Proxy 2 -> ()" 89 | ," Actual: Proxy ((2 * y0) + 4) -> ()" 90 | ] 91 | #else 92 | ["Expected type: Proxy 2 -> ()" 93 | ,"Actual type: Proxy ((2 * y0) + 4) -> ()" 94 | ] 95 | #endif 96 | 97 | testProxy5 :: Proxy 7 -> () 98 | testProxy5 = proxyFun4 99 | 100 | testProxy5Errors = 101 | #if __GLASGOW_HASKELL__ >= 900 102 | ["Expected: Proxy 7 -> ()" 103 | ," Actual: Proxy ((2 * y1) + 4) -> ()" 104 | ] 105 | #else 106 | ["Expected type: Proxy 7 -> ()" 107 | ,"Actual type: Proxy ((2 * y1) + 4) -> ()" 108 | ] 109 | #endif 110 | 111 | proxyFun6 :: Proxy (2^k) -> Proxy (2^k) 112 | proxyFun6 = const Proxy 113 | 114 | testProxy6 :: Proxy 7 115 | testProxy6 = proxyFun6 (Proxy :: Proxy 7) 116 | 117 | testProxy6Errors = 118 | #if __GLASGOW_HASKELL__ >= 902 119 | ["Expected: Proxy 7" 120 | ," Actual: Proxy (2 ^ k0)" 121 | ] 122 | #elif __GLASGOW_HASKELL__ >= 900 123 | ["Expected: Proxy (2 ^ k0)" 124 | ," Actual: Proxy 7" 125 | ] 126 | #else 127 | ["Expected type: Proxy (2 ^ k0)" 128 | ,"Actual type: Proxy 7" 129 | ] 130 | #endif 131 | 132 | proxyFun7 :: Proxy (2^k) -> Proxy k 133 | proxyFun7 = const Proxy 134 | 135 | testProxy8 :: Proxy x -> Proxy (y + x) 136 | testProxy8 = id 137 | 138 | testProxy8Errors = 139 | #if __GLASGOW_HASKELL__ >= 900 140 | ["Expected: Proxy x -> Proxy (y + x)" 141 | ," Actual: Proxy x -> Proxy x" 142 | ] 143 | #else 144 | ["Expected type: Proxy x -> Proxy (y + x)" 145 | ,"Actual type: Proxy x -> Proxy x" 146 | ] 147 | #endif 148 | 149 | #if __GLASGOW_HASKELL__ >= 904 150 | proxyInEq :: ((a <= b) ~ (() :: Constraint)) => Proxy (a :: Nat) -> Proxy b -> () 151 | #else 152 | proxyInEq :: (a <= b) => Proxy (a :: Nat) -> Proxy b -> () 153 | #endif 154 | proxyInEq _ _ = () 155 | 156 | proxyInEq' :: ((a <=? b) ~ 'False) => Proxy (a :: Nat) -> Proxy b -> () 157 | proxyInEq' _ _ = () 158 | 159 | testProxy9 :: Proxy (a + 1) -> Proxy a -> () 160 | testProxy9 = proxyInEq 161 | 162 | testProxy9Errors = 163 | #if __GLASGOW_HASKELL__ >= 904 164 | ["Cannot satisfy: a + 1 <= a"] 165 | #elif __GLASGOW_HASKELL__ >= 902 166 | [$(do localeEncoding <- runIO (getLocaleEncoding) 167 | if textEncodingName localeEncoding == textEncodingName utf8 168 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 169 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 170 | ) 171 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 172 | if textEncodingName localeEncoding == textEncodingName utf8 173 | then litE $ stringL "(CmpNat (a + 1) a) 'True 'True 'False’" 174 | else litE $ stringL "(CmpNat (a + 1) a) 'True 'True 'False'" 175 | ) 176 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 177 | if textEncodingName localeEncoding == textEncodingName utf8 178 | then litE $ stringL "with ‘'True’" 179 | else litE $ stringL "with 'True" 180 | ) 181 | ] 182 | #else 183 | [$(do localeEncoding <- runIO (getLocaleEncoding) 184 | if textEncodingName localeEncoding == textEncodingName utf8 185 | then litE $ stringL "Couldn't match type ‘(a + 1) <=? a’ with ‘'True’" 186 | else litE $ stringL "Couldn't match type `(a + 1) <=? a' with 'True" 187 | )] 188 | #endif 189 | 190 | testProxy10 :: Proxy (a :: Nat) -> Proxy (a + 2) -> () 191 | testProxy10 = proxyInEq' 192 | 193 | testProxy10Errors = 194 | #if __GLASGOW_HASKELL__ >= 912 195 | [$(do localeEncoding <- runIO (getLocaleEncoding) 196 | if textEncodingName localeEncoding == textEncodingName utf8 197 | then litE $ stringL "Couldn't match type ‘ghc-internal-9.1201.0:GHC.Internal.Data.Type.Ord.OrdCond" 198 | else litE $ stringL "Couldn't match type `ghc-internal-9.1201.0:GHC.Internal.Data.Type.Ord.OrdCond" 199 | ) 200 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 201 | if textEncodingName localeEncoding == textEncodingName utf8 202 | then litE $ stringL "(CmpNat a (a + 2)) True True False’" 203 | else litE $ stringL "(CmpNat a (a + 2)) True True False'" 204 | ) 205 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 206 | if textEncodingName localeEncoding == textEncodingName utf8 207 | then litE $ stringL "with ‘False" 208 | else litE $ stringL "with `False" 209 | ) 210 | ] 211 | #elif __GLASGOW_HASKELL__ >= 910 212 | [$(do localeEncoding <- runIO (getLocaleEncoding) 213 | if textEncodingName localeEncoding == textEncodingName utf8 214 | then litE $ stringL "Couldn't match type ‘ghc-internal-9.1001.0:GHC.Internal.Data.Type.Ord.OrdCond" 215 | else litE $ stringL "Couldn't match type `ghc-internal-9.1001.0:GHC.Internal.Data.Type.Ord.OrdCond" 216 | ) 217 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 218 | if textEncodingName localeEncoding == textEncodingName utf8 219 | then litE $ stringL "(CmpNat a (a + 2)) True True False’" 220 | else litE $ stringL "(CmpNat a (a + 2)) True True False'" 221 | ) 222 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 223 | if textEncodingName localeEncoding == textEncodingName utf8 224 | then litE $ stringL "with ‘False" 225 | else litE $ stringL "with `False" 226 | ) 227 | ] 228 | #elif __GLASGOW_HASKELL__ >= 906 229 | [$(do localeEncoding <- runIO (getLocaleEncoding) 230 | if textEncodingName localeEncoding == textEncodingName utf8 231 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 232 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 233 | ) 234 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 235 | if textEncodingName localeEncoding == textEncodingName utf8 236 | then litE $ stringL "(CmpNat a (a + 2)) True True False’" 237 | else litE $ stringL "(CmpNat a (a + 2)) True True False'" 238 | ) 239 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 240 | if textEncodingName localeEncoding == textEncodingName utf8 241 | then litE $ stringL "with ‘False" 242 | else litE $ stringL "with False" 243 | ) 244 | ] 245 | #elif __GLASGOW_HASKELL__ >= 902 246 | [$(do localeEncoding <- runIO (getLocaleEncoding) 247 | if textEncodingName localeEncoding == textEncodingName utf8 248 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 249 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 250 | ) 251 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 252 | if textEncodingName localeEncoding == textEncodingName utf8 253 | then litE $ stringL "(CmpNat a (a + 2)) 'True 'True 'False’" 254 | else litE $ stringL "(CmpNat a (a + 2)) 'True 'True 'False'" 255 | ) 256 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 257 | if textEncodingName localeEncoding == textEncodingName utf8 258 | then litE $ stringL "with ‘'False" 259 | else litE $ stringL "with 'False" 260 | ) 261 | ] 262 | #else 263 | [$(do localeEncoding <- runIO (getLocaleEncoding) 264 | if textEncodingName localeEncoding == textEncodingName utf8 265 | then litE $ stringL "Couldn't match type ‘a <=? (a + 2)’ with ‘'False’" 266 | else litE $ stringL "Couldn't match type `a <=? (a + 2)' with 'False" 267 | )] 268 | #endif 269 | 270 | testProxy11 :: Proxy (a :: Nat) -> Proxy a -> () 271 | testProxy11 = proxyInEq' 272 | 273 | testProxy11Errors = 274 | [$(do localeEncoding <- runIO (getLocaleEncoding) 275 | if textEncodingName localeEncoding == textEncodingName utf8 276 | #if __GLASGOW_HASKELL__ >= 910 277 | then litE $ stringL "Couldn't match type ‘True’ with ‘False’" 278 | else litE $ stringL "Couldn't match type `True' with `False'" 279 | #elif __GLASGOW_HASKELL__ >= 906 280 | then litE $ stringL "Couldn't match type ‘True’ with ‘False’" 281 | else litE $ stringL "Couldn't match type True with False" 282 | #else 283 | then litE $ stringL "Couldn't match type ‘'True’ with ‘'False’" 284 | else litE $ stringL "Couldn't match type 'True with 'False" 285 | #endif 286 | )] 287 | 288 | testProxy12 :: Proxy (a + b) -> Proxy (a + c) -> () 289 | testProxy12 = proxyInEq 290 | 291 | testProxy12Errors = 292 | #if __GLASGOW_HASKELL__ >= 904 293 | ["Cannot satisfy: a + b <= a + c"] 294 | #elif __GLASGOW_HASKELL__ >= 902 295 | [$(do localeEncoding <- runIO (getLocaleEncoding) 296 | if textEncodingName localeEncoding == textEncodingName utf8 297 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 298 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 299 | ) 300 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 301 | if textEncodingName localeEncoding == textEncodingName utf8 302 | then litE $ stringL "(CmpNat (a + b) (a + c)) 'True 'True 'False’" 303 | else litE $ stringL "(CmpNat (a + b) (a + c)) 'True 'True 'False'" 304 | ) 305 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 306 | if textEncodingName localeEncoding == textEncodingName utf8 307 | then litE $ stringL "with ‘'True’" 308 | else litE $ stringL "with 'True" 309 | ) 310 | ] 311 | #else 312 | [$(do localeEncoding <- runIO (getLocaleEncoding) 313 | if textEncodingName localeEncoding == textEncodingName utf8 314 | then litE $ stringL "Couldn't match type ‘(a + b) <=? (a + c)’ with ‘'True’" 315 | else litE $ stringL "Couldn't match type `(a + b) <=? (a + c)' with 'True" 316 | )] 317 | #endif 318 | 319 | testProxy13 :: Proxy (4*a) -> Proxy (2*a) ->() 320 | testProxy13 = proxyInEq 321 | 322 | testProxy13Errors = 323 | #if __GLASGOW_HASKELL__ >= 904 324 | ["Cannot satisfy: 4 * a <= 2 * a"] 325 | #elif __GLASGOW_HASKELL__ >= 902 326 | [$(do localeEncoding <- runIO (getLocaleEncoding) 327 | if textEncodingName localeEncoding == textEncodingName utf8 328 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 329 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 330 | ) 331 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 332 | if textEncodingName localeEncoding == textEncodingName utf8 333 | then litE $ stringL "(CmpNat (4 * a) (2 * a)) 'True 'True 'False’" 334 | else litE $ stringL "(CmpNat (4 * a) (2 * a)) 'True 'True 'False'" 335 | ) 336 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 337 | if textEncodingName localeEncoding == textEncodingName utf8 338 | then litE $ stringL "with ‘'True’" 339 | else litE $ stringL "with 'True" 340 | ) 341 | ] 342 | #else 343 | [$(do localeEncoding <- runIO (getLocaleEncoding) 344 | if textEncodingName localeEncoding == textEncodingName utf8 345 | then litE $ stringL "Couldn't match type ‘(4 * a) <=? (2 * a)’ with ‘'True’" 346 | else litE $ stringL "Couldn't match type `(4 * a) <=? (2 * a)' with 'True" 347 | )] 348 | #endif 349 | 350 | testProxy14 :: Proxy (2*a) -> Proxy (4*a) -> () 351 | testProxy14 = proxyInEq' 352 | 353 | testProxy14Errors = 354 | #if __GLASGOW_HASKELL__ >= 912 355 | [$(do localeEncoding <- runIO (getLocaleEncoding) 356 | if textEncodingName localeEncoding == textEncodingName utf8 357 | then litE $ stringL "Couldn't match type ‘ghc-internal-9.1201.0:GHC.Internal.Data.Type.Ord.OrdCond" 358 | else litE $ stringL "Couldn't match type `ghc-internal-9.1201.0:GHC.Internal.Data.Type.Ord.OrdCond" 359 | ) 360 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 361 | if textEncodingName localeEncoding == textEncodingName utf8 362 | then litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False’" 363 | else litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False'" 364 | ) 365 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 366 | if textEncodingName localeEncoding == textEncodingName utf8 367 | then litE $ stringL "with ‘False" 368 | else litE $ stringL "with `False" 369 | ) 370 | ] 371 | #elif __GLASGOW_HASKELL__ >= 910 372 | [$(do localeEncoding <- runIO (getLocaleEncoding) 373 | if textEncodingName localeEncoding == textEncodingName utf8 374 | then litE $ stringL "Couldn't match type ‘ghc-internal-9.1001.0:GHC.Internal.Data.Type.Ord.OrdCond" 375 | else litE $ stringL "Couldn't match type `ghc-internal-9.1001.0:GHC.Internal.Data.Type.Ord.OrdCond" 376 | ) 377 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 378 | if textEncodingName localeEncoding == textEncodingName utf8 379 | then litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False’" 380 | else litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False'" 381 | ) 382 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 383 | if textEncodingName localeEncoding == textEncodingName utf8 384 | then litE $ stringL "with ‘False" 385 | else litE $ stringL "with `False" 386 | ) 387 | ] 388 | #elif __GLASGOW_HASKELL__ >= 906 389 | [$(do localeEncoding <- runIO (getLocaleEncoding) 390 | if textEncodingName localeEncoding == textEncodingName utf8 391 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 392 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 393 | ) 394 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 395 | if textEncodingName localeEncoding == textEncodingName utf8 396 | then litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False’" 397 | else litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False'" 398 | ) 399 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 400 | if textEncodingName localeEncoding == textEncodingName utf8 401 | then litE $ stringL "with ‘False" 402 | else litE $ stringL "with False" 403 | ) 404 | ] 405 | #elif __GLASGOW_HASKELL__ >= 902 406 | [$(do localeEncoding <- runIO (getLocaleEncoding) 407 | if textEncodingName localeEncoding == textEncodingName utf8 408 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 409 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 410 | ) 411 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 412 | if textEncodingName localeEncoding == textEncodingName utf8 413 | then litE $ stringL "(CmpNat (2 * a) (4 * a)) 'True 'True 'False’" 414 | else litE $ stringL "(CmpNat (2 * a) (4 * a)) 'True 'True 'False'" 415 | ) 416 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 417 | if textEncodingName localeEncoding == textEncodingName utf8 418 | then litE $ stringL "with ‘'False" 419 | else litE $ stringL "with 'False" 420 | ) 421 | ] 422 | #else 423 | [$(do localeEncoding <- runIO (getLocaleEncoding) 424 | if textEncodingName localeEncoding == textEncodingName utf8 425 | then litE $ stringL "Couldn't match type ‘(2 * a) <=? (4 * a)’ with ‘'False’" 426 | else litE $ stringL "Couldn't match type `(2 * a) <=? (4 * a)' with 'False" 427 | )] 428 | #endif 429 | 430 | type family CLog (b :: Nat) (x :: Nat) :: Nat 431 | type instance CLog 2 2 = 1 432 | 433 | testProxy15 :: (CLog 2 (2 ^ n) ~ n, (1 <=? n) ~ True) => Proxy n -> Proxy (n+d) 434 | testProxy15 = id 435 | 436 | testProxy15Errors = 437 | #if __GLASGOW_HASKELL__ >= 900 438 | ["Expected: Proxy n -> Proxy (n + d)" 439 | ," Actual: Proxy n -> Proxy n" 440 | ] 441 | #else 442 | ["Expected type: Proxy n -> Proxy (n + d)" 443 | ,"Actual type: Proxy n -> Proxy n" 444 | ] 445 | #endif 446 | 447 | data Fin (n :: Nat) where 448 | FZ :: Fin (n + 1) 449 | FS :: Fin n -> Fin (n + 1) 450 | 451 | test16 :: forall n . Integer -> Fin n 452 | test16 n = case n of 453 | 0 -> FZ 454 | x -> FS (test16 @(n-1) (x-1)) 455 | 456 | test16Errors = 457 | #if __GLASGOW_HASKELL__ >= 904 458 | ["Cannot satisfy: 1 <= n"] 459 | #elif __GLASGOW_HASKELL__ >= 902 460 | [$(do localeEncoding <- runIO (getLocaleEncoding) 461 | if textEncodingName localeEncoding == textEncodingName utf8 462 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 463 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 464 | ) 465 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 466 | if textEncodingName localeEncoding == textEncodingName utf8 467 | then litE $ stringL "(CmpNat 1 n) 'True 'True 'False’" 468 | else litE $ stringL "(CmpNat 1 n) 'True 'True 'False'" 469 | ) 470 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 471 | if textEncodingName localeEncoding == textEncodingName utf8 472 | then litE $ stringL "with ‘'True’" 473 | else litE $ stringL "with 'True" 474 | ) 475 | ] 476 | #else 477 | [$(do localeEncoding <- runIO (getLocaleEncoding) 478 | if textEncodingName localeEncoding == textEncodingName utf8 479 | then litE $ stringL "Couldn't match type ‘1 <=? n’ with ‘'True’" 480 | else litE $ stringL "Couldn't match type `1 <=? n' with 'True" 481 | )] 482 | #endif 483 | 484 | data Dict c where 485 | Dict :: c => Dict c 486 | deriving instance Show (Dict c) 487 | data Boo (n :: Nat) = Boo 488 | 489 | test17 :: Show (Boo n) => Proxy n -> Boo (n - 1 + 1) -> String 490 | test17 = const show 491 | 492 | testProxy17 :: String 493 | 494 | testProxy17 = test17 (Proxy :: Proxy 17) Boo 495 | test17Errors = test16Errors 496 | 497 | #if __GLASGOW_HASKELL__ >= 904 498 | test19f :: ((1 <= n) ~ (() :: Constraint)) 499 | #else 500 | test19f :: (1 <= n) 501 | #endif 502 | => Proxy n -> Proxy n 503 | test19f = id 504 | 505 | testProxy19 :: (1 <= m, m <= rp) 506 | => Proxy m 507 | -> Proxy rp 508 | -> Proxy (rp - m) 509 | -> Proxy (rp - m) 510 | testProxy19 _ _ = test19f 511 | 512 | test19Errors = 513 | #if __GLASGOW_HASKELL__ >= 904 514 | [ "Cannot satisfy: 1 <= rp - m" ] 515 | #elif __GLASGOW_HASKELL__ >= 902 516 | [ "Could not deduce: Data.Type.Ord.OrdCond" 517 | , "(CmpNat 1 (rp - m)) 'True 'True 'False" 518 | , "~ 'True" 519 | ] 520 | #else 521 | ["Could not deduce: (1 <=? (rp - m)) ~ 'True"] 522 | #endif 523 | 524 | testProxy20 :: Proxy 1 -> Proxy (m ^ 2) -> () 525 | testProxy20 = proxyInEq 526 | 527 | testProxy20Errors = 528 | #if __GLASGOW_HASKELL__ >= 904 529 | ["Cannot satisfy: 1 <= m ^ 2"] 530 | #elif __GLASGOW_HASKELL__ >= 902 531 | [$(do localeEncoding <- runIO (getLocaleEncoding) 532 | if textEncodingName localeEncoding == textEncodingName utf8 533 | then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" 534 | else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" 535 | ) 536 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 537 | if textEncodingName localeEncoding == textEncodingName utf8 538 | then litE $ stringL "(CmpNat 1 (m ^ 2)) 'True 'True 'False’" 539 | else litE $ stringL "(CmpNat 1 (m ^ 2)) 'True 'True 'False'" 540 | ) 541 | ,$(do localeEncoding <- runIO (getLocaleEncoding) 542 | if textEncodingName localeEncoding == textEncodingName utf8 543 | then litE $ stringL "with ‘'True’" 544 | else litE $ stringL "with 'True" 545 | ) 546 | ] 547 | #else 548 | [$(do localeEncoding <- runIO (getLocaleEncoding) 549 | if textEncodingName localeEncoding == textEncodingName utf8 550 | then litE $ stringL "Couldn't match type ‘1 <=? (m ^ 2)’ with ‘'True’" 551 | else litE $ stringL "Couldn't match type `1 <=? (m ^ 2)' with 'True" 552 | )] 553 | #endif 554 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE NoImplicitPrelude #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE RoleAnnotations #-} 13 | {-# LANGUAGE Rank2Types #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | {-# LANGUAGE TypeOperators #-} 18 | {-# LANGUAGE UndecidableInstances #-} 19 | 20 | #if __GLASGOW_HASKELL__ >= 805 21 | {-# LANGUAGE NoStarIsType #-} 22 | #endif 23 | 24 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} 25 | {-# OPTIONS_GHC -dcore-lint #-} 26 | 27 | import GHC.TypeLits 28 | #if MIN_VERSION_base(4,18,0) 29 | hiding (type SNat) 30 | #endif 31 | 32 | import Unsafe.Coerce 33 | import Prelude hiding (head,tail,init,(++),splitAt,concat,drop) 34 | import qualified Prelude as P 35 | 36 | import Data.Kind (Type) 37 | import Data.List (isInfixOf) 38 | import Data.Proxy 39 | import Control.Exception 40 | import Test.Tasty 41 | import Test.Tasty.HUnit 42 | 43 | import ErrorTests 44 | 45 | data Vec :: Nat -> Type -> Type where 46 | Nil :: Vec 0 a 47 | (:>) :: a -> Vec n a -> Vec (n + 1) a 48 | 49 | instance Show a => Show (Vec n a) where 50 | show vs = "<" P.++ punc vs P.++ ">" 51 | where 52 | punc :: Vec m a -> String 53 | punc Nil = "" 54 | punc (x :> Nil) = show x 55 | punc (x :> xs) = show x P.++ "," P.++ punc xs 56 | 57 | infixr 5 :> 58 | 59 | data SNat (n :: Nat) = KnownNat n => SNat (Proxy n) 60 | 61 | instance Show (SNat n) where 62 | show (SNat p) = 'd' : show (natVal p) 63 | 64 | {-# INLINE snat #-} 65 | -- | Create a singleton literal for a type-level natural number 66 | snat :: KnownNat n => SNat n 67 | snat = SNat Proxy 68 | 69 | {-# INLINE withSNat #-} 70 | -- | Supply a function with a singleton natural 'n' according to the context 71 | withSNat :: KnownNat n => (SNat n -> a) -> a 72 | withSNat f = f (SNat Proxy) 73 | 74 | {-# INLINE snatToInteger #-} 75 | snatToInteger :: SNat n -> Integer 76 | snatToInteger (SNat p) = natVal p 77 | 78 | data UNat :: Nat -> Type where 79 | UZero :: UNat 0 80 | USucc :: UNat n -> UNat (n + 1) 81 | 82 | -- | Convert a singleton natural number to its unary representation 83 | -- 84 | -- __NB__: Not synthesisable 85 | toUNat :: SNat n -> UNat n 86 | toUNat (SNat p) = fromI (natVal p) 87 | where 88 | fromI :: Integer -> UNat m 89 | fromI 0 = unsafeCoerce UZero 90 | fromI n = unsafeCoerce (USucc (fromI (n - 1))) 91 | 92 | -- | Add two singleton natural numbers 93 | -- 94 | -- __NB__: Not synthesisable 95 | addUNat :: UNat n -> UNat m -> UNat (n + m) 96 | addUNat UZero y = y 97 | addUNat x UZero = x 98 | addUNat (USucc x) y = USucc (addUNat x y) 99 | 100 | -- | Multiply two singleton natural numbers 101 | -- 102 | -- __NB__: Not synthesisable 103 | multUNat :: UNat n -> UNat m -> UNat (n * m) 104 | multUNat UZero _ = UZero 105 | multUNat _ UZero = UZero 106 | multUNat (USucc x) y = addUNat y (multUNat x y) 107 | 108 | -- | Exponential of two singleton natural numbers 109 | -- 110 | -- __NB__: Not synthesisable 111 | powUNat :: UNat n -> UNat m -> UNat (n ^ m) 112 | powUNat _ UZero = USucc UZero 113 | powUNat x (USucc y) = multUNat x (powUNat x y) 114 | 115 | -- | Extract the first element of a vector 116 | -- 117 | -- >>> head (1:>2:>3:>Nil) 118 | -- 1 119 | head :: Vec (n + 1) a -> a 120 | head (x :> _) = x 121 | 122 | head' 123 | :: forall n a 124 | . (1 <= n) 125 | => Vec n a 126 | -> a 127 | head' = head @(n-1) 128 | 129 | -- | Extract the elements after the head of a vector 130 | -- 131 | -- >>> tail (1:>2:>3:>Nil) 132 | -- <2,3> 133 | tail :: Vec (n + 1) a -> Vec n a 134 | tail (_ :> xs) = xs 135 | 136 | tail' :: (1 <= m) => Vec m a -> Vec (m-1) a 137 | tail' = tail 138 | 139 | -- | Extract all the elements of a vector except the last element 140 | -- 141 | -- >>> init (1:>2:>3:>Nil) 142 | -- <1,2> 143 | init :: Vec (n + 1) a -> Vec n a 144 | init (_ :> Nil) = Nil 145 | init (x :> y :> ys) = x :> init (y :> ys) 146 | 147 | init' :: (1 <= m) => Vec m a -> Vec (m-1) a 148 | init' = init 149 | 150 | infixr 5 ++ 151 | -- | Append two vectors 152 | -- 153 | -- >>> (1:>2:>3:>Nil) ++ (7:>8:>Nil) 154 | -- <1,2,3,7,8> 155 | (++) :: Vec n a -> Vec m a -> Vec (n + m) a 156 | Nil ++ ys = ys 157 | (x :> xs) ++ ys = x :> xs ++ ys 158 | 159 | -- | Split a vector into two vectors at the given point 160 | -- 161 | -- >>> splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil) 162 | -- (<1,2,3>, <7,8>) 163 | -- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil) 164 | -- (<1,2,3>, <7,8>) 165 | splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a) 166 | splitAt n xs = splitAtU (toUNat n) xs 167 | 168 | splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a) 169 | splitAtU UZero ys = (Nil,ys) 170 | splitAtU (USucc s) (y :> ys) = let (as,bs) = splitAtU s ys 171 | in (y :> as, bs) 172 | 173 | {-# INLINE splitAtI #-} 174 | -- | Split a vector into two vectors where the length of the two is determined 175 | -- by the context 176 | -- 177 | -- >>> splitAtI (1:>2:>3:>7:>8:>Nil) :: (Vec 2 Int, Vec 3 Int) 178 | -- (<1,2>,<3,7,8>) 179 | splitAtI :: KnownNat m => Vec (m + n) a -> (Vec m a, Vec n a) 180 | splitAtI = withSNat splitAt 181 | 182 | -- | Shift in elements to the head of a vector, bumping out elements at the 183 | -- tail. The result is a tuple containing: 184 | -- 185 | -- * The new vector 186 | -- * The shifted out elements 187 | -- 188 | -- >>> shiftInAt0 (1 :> 2 :> 3 :> 4 :> Nil) ((-1) :> 0 :> Nil) 189 | -- (<-1,0,1,2,>,<3,4>) 190 | -- >>> shiftInAt0 (1 :> Nil) ((-1) :> 0 :> Nil) 191 | -- (<-1>,<0,1>) 192 | shiftInAt0 :: KnownNat n 193 | => Vec n a -- ^ The old vector 194 | -> Vec m a -- ^ The elements to shift in at the head 195 | -> (Vec n a, Vec m a) -- ^ (The new vector, shifted out elements) 196 | shiftInAt0 xs ys = splitAtI zs 197 | where 198 | zs = ys ++ xs 199 | 200 | -- | Shift in element to the tail of a vector, bumping out elements at the head. 201 | -- The result is a tuple containing: 202 | -- 203 | -- * The new vector 204 | -- * The shifted out elements 205 | -- 206 | -- >>> shiftInAtN (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> Nil) 207 | -- (<3,4,5,6>,<1,2>) 208 | -- >>> shiftInAtN (1 :> Nil) (2 :> 3 :> Nil) 209 | -- (<3>,<1,2>) 210 | shiftInAtN :: KnownNat m 211 | => Vec n a -- ^ The old vector 212 | -> Vec m a -- ^ The elements to shift in at the tail 213 | -> (Vec n a,Vec m a) -- ^ (The new vector, shifted out elements) 214 | shiftInAtN xs ys = (zsR, zsL) 215 | where 216 | zs = xs ++ ys 217 | (zsL,zsR) = splitAtI zs 218 | 219 | -- | Concatenate a vector of vectors 220 | -- 221 | -- >>> concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil) 222 | -- <1,2,3,4,5,6,7,8,9,10,11,12> 223 | concat :: Vec n (Vec m a) -> Vec (n * m) a 224 | concat Nil = Nil 225 | concat (x :> xs) = x ++ concat xs 226 | 227 | -- | Split a vector of (n * m) elements into a vector of vectors with length m, 228 | -- where m is given 229 | -- 230 | -- >>> unconcat d4 (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) 231 | -- <<1,2,3,4>,<5,6,7,8>,<9,10,11,12>> 232 | unconcat :: KnownNat n => SNat m -> Vec (n * m) a -> Vec n (Vec m a) 233 | unconcat n xs = unconcatU (withSNat toUNat) (toUNat n) xs 234 | 235 | unconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a) 236 | unconcatU UZero _ _ = Nil 237 | unconcatU (USucc n') m ys = let (as,bs) = splitAtU m ys 238 | in as :> unconcatU n' m bs 239 | 240 | -- | Merge two vectors, alternating their elements, i.e., 241 | -- 242 | -- >>> merge (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> 7 :> 8 :> Nil) 243 | -- <1,5,2,6,3,7,4,8> 244 | merge :: Vec n a -> Vec n a -> Vec (n + n) a 245 | merge Nil Nil = Nil 246 | merge (x :> xs) (y :> ys) = x :> y :> merge xs ys 247 | 248 | -- | 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ elements 249 | -- 250 | -- >>> drop (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil) 251 | -- <4,5> 252 | -- >>> drop d3 (1:>2:>3:>4:>5:>Nil) 253 | -- <4,5> 254 | -- >>> drop d0 (1:>2:>Nil) 255 | -- <1,2> 256 | drop :: SNat m -> Vec (m + n) a -> Vec n a 257 | drop n = snd . splitAt n 258 | 259 | drop' :: (m <= k) => SNat m -> Vec k a -> Vec (k - m) a 260 | drop' = drop 261 | 262 | -- | 'at' @n xs@ returns @n@'th element of @xs@ 263 | -- 264 | -- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and 265 | -- ending at 'maxIndex'. 266 | -- 267 | -- >>> at (snat :: SNat 1) (1:>2:>3:>4:>5:>Nil) 268 | -- 2 269 | -- >>> at d1 (1:>2:>3:>4:>5:>Nil) 270 | -- 2 271 | at :: SNat m -> Vec (m + (n + 1)) a -> a 272 | at n xs = head $ snd $ splitAt n xs 273 | 274 | at' 275 | :: forall k m a 276 | . (1 <= k, m <= (k-1)) 277 | => SNat m 278 | -> Vec k a 279 | -> a 280 | at' = at @m @(k - 1 - m) 281 | 282 | leToPlus 283 | :: forall (k :: Nat) (n :: Nat) (f :: Nat -> Type) (r :: Type) 284 | . (k <= n) 285 | => Proxy k 286 | -> f n 287 | -- ^ Argument with the @(k <= n)@ constraint 288 | -> (forall (m :: Nat) . f (m + k) -> r) 289 | -- ^ Function with the @(n + k)@ constraint 290 | -> r 291 | leToPlus _ a f = f @(n-k) a 292 | 293 | data BNat :: Nat -> Type where 294 | BT :: BNat 0 295 | B0 :: BNat n -> BNat (2*n) 296 | B1 :: BNat n -> BNat ((2*n) + 1) 297 | 298 | instance KnownNat n => Show (BNat n) where 299 | show x = 'b':show (natVal x) 300 | 301 | predBNat :: (1 <= n) => BNat n -> BNat (n-1) 302 | predBNat (B1 a) = case a of 303 | BT -> BT 304 | a' -> B0 a' 305 | predBNat (B0 x) = B1 (predBNat x) 306 | 307 | -- issue 52 begin 308 | type role Signal nominal representational 309 | data Signal (dom :: Symbol) a = a :- Signal dom a 310 | 311 | type role BitVector nominal 312 | newtype BitVector (n :: Nat) = BV { unsafeToNatural :: Integer } 313 | 314 | class Bundle (f :: Type -> Type) a res | f a -> res, f res -> a, a res -> f 315 | bundle :: Bundle f a res => res -> f a 316 | bundle = bundle 317 | 318 | instance Bundle (Signal dom) (a,b) (Signal dom a, Signal dom b) 319 | 320 | issue52 :: (1 <= n, KnownNat n) => (Signal dom (),Signal dom (BitVector (n-1+1))) -> Signal dom ((),BitVector n) 321 | issue52 = bundle 322 | -- issue 52 end 323 | 324 | proxyInEq1 :: Proxy a -> Proxy (a+1) -> () 325 | proxyInEq1 = proxyInEq 326 | 327 | proxyInEq2 :: Proxy ((a+1) :: Nat) -> Proxy a -> () 328 | proxyInEq2 = proxyInEq' 329 | 330 | proxyInEq3 :: Proxy (a :: Nat) -> Proxy (a+b) -> () 331 | proxyInEq3 = proxyInEq 332 | 333 | proxyInEq4 :: Proxy (2*a) -> Proxy (4*a) -> () 334 | proxyInEq4 = proxyInEq 335 | 336 | proxyInEq5 :: Proxy 1 -> Proxy (2^a) -> () 337 | proxyInEq5 = proxyInEq 338 | 339 | proxyInEq6 :: Proxy 1 -> Proxy (a + 3) -> () 340 | proxyInEq6 = proxyInEq 341 | 342 | proxyInEq7 :: Proxy 1 -> Proxy (2^(a + 3)) -> () 343 | proxyInEq7 = proxyInEq 344 | 345 | proxyEq1 346 | :: (1 <= x) 347 | => Proxy ((2 ^ x) * (2 ^ (x + x))) 348 | -> Proxy (2 * (2 ^ ((x + (x + x)) - 1))) 349 | proxyEq1 = id 350 | 351 | proxyEq2 352 | :: (2 <= x) 353 | => Proxy (((2 ^ x) - 2) * (2 ^ (x + x))) 354 | -> Proxy ((2 ^ ((x + (x + x)) - 1)) + ((2 ^ ((x + (x + x)) - 1)) - (2 ^ ((x + x) + 1)))) 355 | proxyEq2 = id 356 | 357 | proxyEq3 358 | :: forall x y 359 | . ((x + 1) ~ (2 * y), 1 <= y) 360 | => Proxy x 361 | -> Proxy y 362 | -> Proxy (((2 * (y - 1)) + 1)) 363 | -> Proxy x 364 | proxyEq3 _ _ x = x 365 | 366 | -- Would yield (b <=? c) ~ 'True 367 | proxyEq4 368 | :: forall a b c 369 | . (KnownNat a, c <= b, b <= a) 370 | => Proxy b 371 | -> Proxy c 372 | -> Proxy a 373 | -> Proxy (((a - b) + c) + (b - c)) 374 | proxyEq4 = theProxy 375 | where 376 | theProxy 377 | :: forall a b c 378 | . (KnownNat (((a - b) + c) + (b - c)), c <= b, b <= a) 379 | => Proxy b 380 | -> Proxy c 381 | -> Proxy a 382 | -> Proxy (((a - b) + c) + (b - c)) 383 | theProxy _ _ = id 384 | 385 | proxyInEqImplication :: (2 <= (2 ^ (n + d))) 386 | => Proxy d 387 | -> Proxy n 388 | -> Proxy n 389 | proxyInEqImplication = proxyInEqImplication' 390 | 391 | proxyInEqImplication' :: (2 <= (2 ^ (d + n))) 392 | => Proxy d 393 | -> Proxy n 394 | -> Proxy n 395 | proxyInEqImplication' _ = id 396 | 397 | proxyEqSubst 398 | :: ((n+1) ~ ((n1 + m) + 1), m ~ n1, n1 ~ ((n2 + m1) + 1)) 399 | => Proxy n1 400 | -> Proxy n2 401 | -> Proxy m1 402 | -> Proxy n 403 | -> Proxy m 404 | -> Proxy (1 + (n2 + m1)) 405 | -> Proxy n1 406 | proxyEqSubst _ _ _ _ _ = id 407 | 408 | proxyInEqImplication2 409 | :: forall n n1 n2 410 | . (n1 ~ (n2 + 1), (2^n) ~ (n1 + 1)) 411 | => Proxy n1 412 | -> Proxy n2 413 | -> Proxy n 414 | -> Proxy ((n - 1) + 1) 415 | -> Proxy n 416 | proxyInEqImplication2 _ _ _ x = x 417 | 418 | type family F (n :: Nat) :: Nat 419 | type instance F 3 = 8 420 | 421 | proxyInEqImplication3 :: (KnownNat (F n)) 422 | => Proxy (n :: Nat) 423 | -> Proxy (n :: Nat) 424 | proxyInEqImplication3 = proxyInEqImplication3' 425 | 426 | proxyInEqImplication3' :: (F n <= (3 * (F n))) 427 | => Proxy (n :: Nat) 428 | -> Proxy (n :: Nat) 429 | proxyInEqImplication3' = id 430 | 431 | type family G (n :: Nat) :: Nat 432 | type instance G 2 = 3 433 | 434 | proxyInEqImplication4 :: (1 <= (G n)) 435 | => Proxy (n :: Nat) 436 | -> Proxy (n :: Nat) 437 | proxyInEqImplication4 = proxyInEqImplication4' 438 | 439 | proxyInEqImplication4' :: (F n <= ((G n) * (F n))) 440 | => Proxy (n :: Nat) 441 | -> Proxy (n :: Nat) 442 | proxyInEqImplication4' = id 443 | 444 | data AtMost n = forall a. (KnownNat a, a <= n) => AtMost (Proxy a) 445 | 446 | instance Show (AtMost n) where 447 | show (AtMost (x :: Proxy a)) = "AtMost " P.++ show (natVal x) 448 | 449 | succAtMost :: AtMost n -> AtMost (n + 1) 450 | succAtMost (AtMost (Proxy :: Proxy a)) = AtMost (Proxy :: Proxy a) 451 | 452 | eqReduceForward 453 | :: Eq (Boo (n + 1)) 454 | => Dict (Eq (Boo (n + 2 - 1))) 455 | eqReduceForward = Dict 456 | 457 | eqReduceForwardMinusPlus 458 | :: (Eq (Boo (0 + n + 1)), 1 <= n) 459 | => Dict (Eq (Boo (n - 1 + 2))) 460 | eqReduceForwardMinusPlus = Dict 461 | 462 | eqReduceBackward 463 | :: (Eq (Boo (m + 2 - 1))) 464 | => Dict (Eq (Boo (m + 1))) 465 | eqReduceBackward = Dict 466 | 467 | eqReduceBackward' 468 | :: (Eq (Boo (1 + m + 2))) 469 | => Dict (Eq (Boo (m + 3))) 470 | eqReduceBackward' = Dict 471 | 472 | proxyInEq8fun 473 | :: (1 <= (n + CLog 2 n)) 474 | => Proxy n 475 | -> Proxy n 476 | proxyInEq8fun = id 477 | 478 | proxyInEq8 479 | :: (1 <= n, KnownNat (CLog 2 n)) 480 | => Proxy n 481 | -> Proxy n 482 | proxyInEq8 = proxyInEq8fun 483 | 484 | data H2 = H2 { p :: Nat } 485 | 486 | class Q (dom :: Symbol) where 487 | type G2 dom :: H2 488 | 489 | type family P (c :: H2) :: Nat where 490 | P ('H2 p) = p 491 | 492 | type F2 (dom :: Symbol) = P (G2 dom) 493 | 494 | type Dom = "System" 495 | 496 | instance Q Dom where 497 | type G2 Dom = 'H2 2 498 | 499 | tyFamMonotonicityFun :: (1 <= F2 dom) => Proxy (dom :: Symbol) -> () 500 | tyFamMonotonicityFun _ = () 501 | 502 | tyFamMonotonicity :: (2 <= F2 dom) => Proxy (dom :: Symbol) -> () 503 | tyFamMonotonicity dom = tyFamMonotonicityFun dom 504 | 505 | oneLtPowSubst :: forall a b. (b ~ (2^a)) => Proxy a -> Proxy a 506 | oneLtPowSubst = go 507 | where 508 | go :: 1 <= b => Proxy a -> Proxy a 509 | go = id 510 | 511 | main :: IO () 512 | main = defaultMain tests 513 | 514 | tests :: TestTree 515 | tests = testGroup "ghc-typelits-natnormalise" 516 | [ testGroup "Basic functionality" 517 | [ testCase "show (head (1:>2:>3:>Nil))" $ 518 | show (head (1:>2:>3:>Nil)) @?= 519 | "1" 520 | , testCase "show (tail (1:>2:>3:>Nil))" $ 521 | show (tail (1:>2:>3:>Nil)) @?= 522 | "<2,3>" 523 | , testCase "show (init (1:>2:>3:>Nil))" $ 524 | show (init (1:>2:>3:>Nil)) @?= 525 | "<1,2>" 526 | , testCase "show ((1:>2:>3:>Nil) ++ (7:>8:>Nil))" $ 527 | show ((1:>2:>3:>Nil) ++ (7:>8:>Nil)) @?= 528 | "<1,2,3,7,8>" 529 | , testCase "show (splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil))" $ 530 | show (splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil)) @?= 531 | "(<1,2,3>,<7,8>)" 532 | , testCase "show (concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil))" $ 533 | show (concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil)) @?= 534 | "<1,2,3,4,5,6,7,8,9,10,11,12>" 535 | , testCase "show (unconcat (snat :: SNat 4) (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil))" $ 536 | show (unconcat (snat :: SNat 4) (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil)) @?= 537 | "<<1,2,3,4>,<5,6,7,8>,<9,10,11,12>>" 538 | , testCase "show (proxyFun3 (Proxy :: Proxy 9))" $ 539 | show (proxyFun3 (Proxy :: Proxy 9)) @?= 540 | "()" 541 | , testCase "show (proxyFun4 (Proxy :: Proxy 8))" $ 542 | show (proxyFun4 (Proxy :: Proxy 8)) @?= 543 | "()" 544 | , testCase "show (proxyFun7 (Proxy :: Proxy 8) :: Proxy 3)" $ 545 | show (proxyFun7 (Proxy :: Proxy 8) :: Proxy 3) @?= 546 | "Proxy" 547 | ] 548 | , testGroup "Equality" 549 | [ testCase "((2 ^ x) * (2 ^ (x + x))) ~ (2 * (2 ^ ((x + (x + x)) - 1)))" $ 550 | show (proxyEq1 @1 Proxy) @?= 551 | "Proxy" 552 | , testCase "(((2 ^ x) - 2) * (2 ^ (x + x))) ~ ((2 ^ ((x + (x + x)) - 1)) + ((2 ^ ((x + (x + x)) - 1)) - (2 ^ ((x + x) + 1))))" $ 553 | show (proxyEq2 @2 Proxy) @?= 554 | "Proxy" 555 | ] 556 | , testGroup "Implications" 557 | [ testCase "(x + 1) ~ (2 * y)) implies (((2 * (y - 1)) + 1)) ~ x" $ 558 | show (proxyEq3 (Proxy :: Proxy 3) (Proxy :: Proxy 2) Proxy) @?= 559 | "Proxy" 560 | , testCase "(n+1) ~ ((n1 + m) + 1), m ~ n1, n1 ~ ((n2 + m1) + 1) implies n1 ~ 1 + (n2 + m1)" $ 561 | show (proxyEqSubst (Proxy :: Proxy 6) (Proxy :: Proxy 2) (Proxy :: Proxy 3) 562 | (Proxy :: Proxy 12) (Proxy :: Proxy 6) (Proxy :: Proxy 6)) @?= 563 | "Proxy" 564 | ] 565 | , testGroup "Inequality" 566 | [ testCase "a <= a+1" $ 567 | show (proxyInEq1 (Proxy :: Proxy 2) (Proxy :: Proxy 3)) @?= 568 | "()" 569 | , testCase "(a+1 <=? a) ~ False" $ 570 | show (proxyInEq2 (Proxy :: Proxy 3) (Proxy :: Proxy 2)) @?= 571 | "()" 572 | , testCase "a <= a+b" $ 573 | show (proxyInEq3 (Proxy :: Proxy 2) (Proxy :: Proxy 2)) @?= 574 | "()" 575 | , testCase "2a <= 4a" $ 576 | show (proxyInEq4 (Proxy :: Proxy 2) (Proxy :: Proxy 4)) @?= 577 | "()" 578 | , testCase "1 <= 2^a" $ 579 | show (proxyInEq5 (Proxy :: Proxy 1) (Proxy :: Proxy 1)) @?= 580 | "()" 581 | , testCase "`(2 <= (2 ^ (n + d)))` implies `(2 <= (2 ^ (d + n)))`" $ 582 | show (proxyInEqImplication (Proxy :: Proxy 3) (Proxy :: Proxy 4)) @?= 583 | "Proxy" 584 | , testCase "1 <= a+3" $ 585 | show (proxyInEq6 (Proxy :: Proxy 1) (Proxy :: Proxy 8)) @?= 586 | "()" 587 | , testCase "`1 <= 2*x` implies `1 <= x`" $ 588 | show (predBNat (B1 (B1 BT))) @?= 589 | "b2" 590 | , testCase "`x + 2 <= y` implies `x <= y` and `2 <= y`" $ 591 | show (proxyInEqImplication2 (Proxy :: Proxy 3) (Proxy :: Proxy 2) (Proxy :: Proxy 2) Proxy) @?= 592 | "Proxy" 593 | , testCase "`a <= n` implies `a <= (n+1)`" $ 594 | show (succAtMost (AtMost (Proxy :: Proxy 3) :: AtMost 5)) @?= 595 | "AtMost 3" 596 | , testCase "1 <= 2^(a+3)" $ 597 | show (proxyInEq7 (Proxy :: Proxy 1) (Proxy :: Proxy 8)) @?= 598 | "()" 599 | , testCase "KnownNat (F a) implies F a <= 3 * F a" $ 600 | show (proxyInEqImplication3 (Proxy :: Proxy 3)) @?= 601 | "Proxy" 602 | , testCase "1 <= G a implies F a <= G a * F a" $ 603 | show (proxyInEqImplication4 (Proxy :: Proxy 2)) @?= 604 | "Proxy" 605 | , testCase "`(1 <= n)` only implies `(1 <= n + F n)` when `KnownNat (F n)`" $ 606 | show (proxyInEq8 (Proxy :: Proxy 2)) @?= 607 | "Proxy" 608 | , testCase "2 <= P (G2 dom) implies 1 <= P (G2 dom)" $ 609 | show (tyFamMonotonicity (Proxy :: Proxy Dom)) @?= 610 | "()" 611 | , testCase "b ~ (2^a) => 1 <= b" $ 612 | show (oneLtPowSubst (Proxy :: Proxy 0)) @?= 613 | "Proxy" 614 | ] 615 | , testGroup "errors" 616 | [ testCase "x + 2 ~ 3 + x" $ testProxy1 `throws` testProxy1Errors 617 | , testCase "GCD 6 8 + x ~ x + GCD 9 6" $ testProxy2 `throws` testProxy2Errors 618 | , testCase "Unify \"x + x + x\" with \"8\"" $ testProxy3 `throws` testProxy3Errors 619 | , testCase "Unify \"(2*x)+4\" with \"2\"" $ testProxy4 `throws` testProxy4Errors 620 | , testCase "Unify \"(2*x)+4\" with \"7\"" $ testProxy5 `throws` testProxy5Errors 621 | , testCase "Unify \"2^k\" with \"7\"" $ testProxy6 `throws` testProxy6Errors 622 | , testCase "x ~ y + x" $ testProxy8 `throws` testProxy8Errors 623 | , testCase "(CLog 2 (2 ^ n) ~ n, (1 <=? n) ~ True) => n ~ (n+d)" $ 624 | testProxy15 (Proxy :: Proxy 1) `throws` testProxy15Errors 625 | , testCase "(n - 1) + 1 ~ n implies (1 <= n)" $ test16 `throws` test16Errors 626 | , testGroup "Inequality" 627 | [ testCase "a+1 <= a" $ testProxy9 `throws` testProxy9Errors 628 | , testCase "(a <=? a+1) ~ False" $ testProxy10 `throws` testProxy10Errors 629 | , testCase "(a <=? a) ~ False" $ testProxy11 `throws` testProxy11Errors 630 | , testCase "() => (a+b <= a+c)" $ testProxy12 `throws` testProxy12Errors 631 | , testCase "4a <= 2a" $ testProxy13 `throws` testProxy13Errors 632 | , testCase "2a <=? 4a ~ False" $ testProxy14 `throws` testProxy14Errors 633 | , testCase "Show (Boo n) => Show (Boo (n - 1 + 1))" $ 634 | testProxy17 `throws` test17Errors 635 | , testCase "1 <= m, m <= rp implies 1 <= rp - m" $ (testProxy19 (Proxy @1) (Proxy @1)) `throws` test19Errors 636 | , testCase "Vacuously: 1 <= m ^ 2 ~ True" $ testProxy20 `throws` testProxy20Errors 637 | ] 638 | ] 639 | ] 640 | 641 | -- | Assert that evaluation of the first argument (to WHNF) will throw 642 | -- an exception whose string representation contains the given 643 | -- substrings. 644 | throws :: a -> [String] -> Assertion 645 | throws v xs = do 646 | result <- try (evaluate v) 647 | case result of 648 | Right _ -> assertFailure "No exception!" 649 | Left (TypeError msg) -> 650 | if all (`isInfixOf` msg) xs 651 | then return () 652 | else assertFailure msg 653 | 654 | showFin :: forall n. KnownNat n => Fin n -> String 655 | showFin f = mconcat [ 656 | show (finToInt f) 657 | , "/" 658 | , show (natVal (Proxy :: Proxy n)) 659 | ] 660 | 661 | finToInt :: Fin n -> Int 662 | finToInt FZ = 0 663 | finToInt (FS fn) = finToInt fn + 1 664 | 665 | predFin :: Fin (n + 2) -> Fin (n + 1) 666 | predFin (FS fn) = fn 667 | predFin FZ = FZ 668 | 669 | showSucPred :: KnownNat (n + 2) => Fin (n + 2) -> String 670 | showSucPred = showFin . FS . predFin 671 | 672 | class Up env (n :: Nat) where 673 | up :: env -> Fin n -> Fin (n + 1) 674 | 675 | class Down env (n :: Nat) where 676 | down :: env -> Fin n -> Fin (n - 1) 677 | 678 | class ShowWith env (n :: Nat) where 679 | showWith :: env -> Fin n -> String 680 | 681 | showDownUp 682 | :: (Up env n, Down env (n + 1), ShowWith env n) 683 | => env -> Fin n -> String 684 | showDownUp env fn = showWith env $ down env $ up env fn 685 | 686 | showDownUp' 687 | :: (Up env n, Down env (n + 1), KnownNat n) 688 | => env -> Fin n -> String 689 | showDownUp' env fn = showFin $ down env $ up env fn 690 | 691 | data family FakeUVector (n :: Nat) :: Type 692 | data family FakeMUVector (n :: Nat) :: Type 693 | type family Mutable (v :: Nat -> Type) :: Nat -> Type 694 | type instance Mutable FakeUVector = FakeMUVector 695 | 696 | class (IsMVector FakeMUVector n, IsVector FakeUVector n) 697 | => FakeUnbox n 698 | class IsMVector (v :: Nat -> Type) a where 699 | touchMVector :: v a -> v a 700 | class IsMVector (Mutable v) a => IsVector v a where 701 | touchVector :: v a -> v a 702 | 703 | newtype WrapFakeVector n = WFV { unWrap :: FakeUVector (1 + n) } 704 | newtype WrapFakeMVector n = MWFV { unWrapM :: FakeMUVector (1 + n) } 705 | type instance Mutable WrapFakeVector = WrapFakeMVector 706 | 707 | -- The following two instances cannot be derived without simplification phase! 708 | instance FakeUnbox (n + 1) => IsVector WrapFakeVector n where 709 | touchVector = WFV . touchVector . unWrap 710 | instance FakeUnbox (n + 1) => IsMVector WrapFakeMVector n where 711 | touchMVector = MWFV . touchMVector . unWrapM 712 | --------------------------------------------------------------------------------