ghc-typelits-natnormalise 0.7.10 → 0.7.11
raw patch · 12 files changed
+4827/−4047 lines, 12 filesdep ~ghcdep ~ghc-tcplugins-extradep ~template-haskellsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc, ghc-tcplugins-extra, template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +188/−185
- LICENSE +27/−27
- README.md +39/−39
- Setup.hs +2/−2
- ghc-typelits-natnormalise.cabal +120/−116
- src-ghc-9.12/GHC/TypeLits/Normalise.hs +739/−0
- src-ghc-9.4/GHC/TypeLits/Normalise.hs +740/−740
- src-pre-ghc-9.4/GHC/TypeLits/Normalise.hs +862/−862
- src/GHC/TypeLits/Normalise/SOP.hs +342/−342
- src/GHC/TypeLits/Normalise/Unify.hs +1021/−1021
- tests/ErrorTests.hs +36/−2
- tests/Tests.hs +711/−711
CHANGELOG.md view
@@ -1,185 +1,188 @@-# Changelog for the [`ghc-typelits-natnormalise`](http://hackage.haskell.org/package/ghc-typelits-natnormalise) package - -## 0.7.10 *May 22nd 2024* -* Support for GHC 9.10.1 - -## 0.7.9 *October 10th 2023* -* Support for GHC 9.8.1 - -## 0.7.8 *February 20th 2023* -* 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). -* Support for GHC-9.6.0.20230210 - -## 0.7.7 *October 10th 2022* -* Solve unflattened wanteds instead of the wanteds passed to the plugin. Fixes [#1901]https://github.com/clash-lang/clash-compiler/issues/1901. -* Add support for GHC 9.4 - -## 0.7.6 *June 20th 2021* -* Do not vacuously solve `forall a b . 1 <=? a^b ~ True` -* Do not solve constraints within `KnownNat`, leave that to https://hackage.haskell.org/package/ghc-typelits-knonwnnat - -## 0.7.5 *June 17th 2021* -* Fixes [#52](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/50) Plugin doesn't solve inside arbitrary class constraints -* Build on GHC 9.2.0.20210422 - -## 0.7.4 *February 12th 2021* -* 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 +,-,*,^ - -## 0.7.3 *January 1st 2021* -* Build on GHC 9.0.1-rc1 - -## 0.7.2 *March 9 2020* -* Fixes [#44](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/44) infinite loop due to boxed equality - -## 0.7.1 *February 6th 2020* -* Add support for GHC 8.10.1-alpha2 -* 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 -* Fixes [#28](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/28): Using the solver seems to break GHC -* Fixes [#34](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/34): inequality solver mishandles subtraction - -## 0.7 *August 26th 2019* -* Require KnownNat constraints when solving with constants - -## 0.6.2 *July 10th 2018* -* Add support for GHC 8.6.1-alpha1 -* Solve larger inequalities from smaller inequalities, e.g. - * `a <= n` implies `a <= n + 1` - -## 0.6.1 *May 9th 2018* -* Stop solving `x + y ~ a + b` by asking GHC to solve `x ~ a` and `y ~ b` as - this leads to a situation where we find a solution that is not the most - general. -* Stop using the smallest solution to an inequality to solve an equality, as - this leads to finding solutions that are not the most general. -* Solve smaller inequalities from larger inequalities, e.g. - * `1 <= 2*x` implies `1 <= x` - * `x + 2 <= y` implies `x <= y` and `2 <= y` - -## 0.6 *April 23rd 2018* -* Solving constraints with `a-b` will emit `b <= a` constraints. e.g. solving - `n-1+1 ~ n` will emit a `1 <= n` constraint. - * If you need subtraction to be treated as addition with a negated operarand - run with `-fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers`, and - the `b <= a` constraint won't be emitted. Note that doing so can lead to - unsound behaviour. -* Try to solve equalities using smallest solution of inequalities: - * Solve `x + 1 ~ y` using `1 <= y` => `x + 1 ~ 1` => `x ~ 0` -* Solve inequalities using simple transitivity rules: - * `2 <= x` implies `1 <= x` - * `x <= 9` implies `x <= 10` -* Solve inequalities using _simple_ monotonicity of addition rules: - * `2 <= x` implies `2 + 2*x <= 3*x` -* Solve inequalities using _simple_ monotonicity of multiplication rules: - * `1 <= x` implies `1 <= 3*x` -* Solve inequalities using _simple_ monotonicity of exponentiation rules: - * `1 <= x` implies `2 <= 2^x` -* Solve inequalities using powers of 2 and monotonicity of exponentiation: - * `2 <= x` implies `2^(2 + 2*x) <= 2^(3*x)` - -## 0.5.10 *April 15th 2018* -* Add support for GHC 8.5.20180306 - -## 0.5.9 *March 17th 2018* -* Add support for GHC 8.4.1 - -## 0.5.8 *January 4th 2018* -* Add support for GHC 8.4.1-alpha1 - -## 0.5.7 *November 7th 2017* -* Solve inequalities such as: `1 <= a + 3` - -## 0.5.6 *October 31st 2017* -* Fixes bugs: - * `(x + 1) ~ (2 * y)` no longer implies `((2 * (y - 1)) + 1) ~ x` - -## 0.5.5 *October 22nd 2017* -* Solve inequalities when their normal forms are the same, i.e. - * `(2 <= (2 ^ (n + d)))` implies `(2 <= (2 ^ (d + n)))` -* Find more unifications: - * `8^x - 2*4^x ~ 8^y - 2*4^y ==> [x := y]` - -## 0.5.4 *October 14th 2017* -* Perform normalisations such as: `2^x * 4^x ==> 8^x` - -## 0.5.3 *May 15th 2017* -* Add support for GHC 8.2 - -## 0.5.2 *January 15th 2017* -* Fixes bugs: - * Reification from SOP to Type sometimes loses product terms - -## 0.5.1 *September 29th 2016* -* Fixes bugs: - * Cannot solve an equality for the second time in a definition group - -## 0.5 *August 17th 2016* -* Solve simple inequalities, i.e.: - * `a <= a + 1` - * `2a <= 3a` - * `1 <= a^b` - -## 0.4.6 *July 21th 2016* -* Reduce "x^(-y) * x^y" to 1 -* Fixes bugs: - * Subtraction in exponent induces infinite loop - -## 0.4.5 *July 20th 2016* -* Fixes bugs: - * Reifying negative exponent causes GHC panic - -## 0.4.4 *July 19th 2016* -* Fixes bugs: - * Rounding error in `logBase` calculation - -## 0.4.3 *July 18th 2016* -* Fixes bugs: - * False positive: "f :: (CLog 2 (2 ^ n) ~ n, (1 <=? n) ~ True) => Proxy n -> Proxy (n+d)" - -## 0.4.2 *July 8th 2016* -* Find more unifications: - * `(2*e ^ d) ~ (2*e*a*c) ==> [a*c := 2*e ^ (d-1)]` - * `a^d * a^e ~ a^c ==> [c := d + e]` - * `x+5 ~ y ==> [x := y - 5]`, but only when `x+5 ~ y` is a given constraint - -## 0.4.1 *February 4th 2016* -* Find more unifications: - * `F x y k z ~ F x y (k-1+1) z` ==> [k := k], where `F` can be any type function - -## 0.4 *January 19th 2016* -* Stop using 'provenance' hack to create conditional evidence (GHC 8.0+ only) -* Find more unifications: - * `F x + 2 - 1 - 1 ~ F x` ==> [F x := F x], where `F` can be any type function with result `Nat`. - -## 0.3.2 -* Find more unifications: - * `(z ^ a) ~ (z ^ b) ==> [a := b]` - * `(i ^ a) ~ j ==> [a := round (logBase i j)]`, when `i` and `j` are integers, and `ceiling (logBase i j) == floor (logBase i j)`. - -## 0.3.1 *October 19th 2015* -* Find more unifications: - * `(i * a) ~ j ==> [a := div j i]`, when `i` and `j` are integers, and `mod j i == 0`. - * `(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`. - -## 0.3 *June 3rd 2015* -* Find more unifications: - * `<TyApp xs> + x ~ 2 + x ==> [<TyApp xs> ~ 2]` -* Fixes bugs: - * Unifying `a*b ~ b` now returns `[a ~ 1]`; before it erroneously returned `[a ~ ]`, which is interpred as `[a ~ 0]`... - * Unifying `a+b ~ b` now returns `[a ~ 0]`; before it returned the undesirable, though equal, `[a ~ ]` - -## 0.2.1 *May 6th 2015* -* Update `Eq` instance of `SOP`: Empty SOP is equal to 0 - -## 0.2 *April 22nd 2015* -* Finds more unifications: - * `(2 + a) ~ 5 ==> [a := 3]` - * `(3 * a) ~ 0 ==> [a := 0]` - -## 0.1.2 *April 21st 2015* -* Don't simplify expressions with negative exponents - -## 0.1.1 *April 17th 2015* -* Add workaround for https://ghc.haskell.org/trac/ghc/ticket/10301 - -## 0.1 *March 30th 2015* -* Initial release +# Changelog for the [`ghc-typelits-natnormalise`](http://hackage.haskell.org/package/ghc-typelits-natnormalise) package++## 0.7.11 *March 4th 2025*+* Support for GHC 9.12.1++## 0.7.10 *May 22nd 2024*+* Support for GHC 9.10.1++## 0.7.9 *October 10th 2023*+* Support for GHC 9.8.1++## 0.7.8 *February 20th 2023*+* 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).+* Support for GHC-9.6.0.20230210++## 0.7.7 *October 10th 2022*+* Solve unflattened wanteds instead of the wanteds passed to the plugin. Fixes [#1901]https://github.com/clash-lang/clash-compiler/issues/1901.+* Add support for GHC 9.4++## 0.7.6 *June 20th 2021*+* Do not vacuously solve `forall a b . 1 <=? a^b ~ True`+* Do not solve constraints within `KnownNat`, leave that to https://hackage.haskell.org/package/ghc-typelits-knonwnnat++## 0.7.5 *June 17th 2021*+* Fixes [#52](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/50) Plugin doesn't solve inside arbitrary class constraints+* Build on GHC 9.2.0.20210422++## 0.7.4 *February 12th 2021*+* 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 +,-,*,^++## 0.7.3 *January 1st 2021*+* Build on GHC 9.0.1-rc1++## 0.7.2 *March 9 2020*+* Fixes [#44](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/44) infinite loop due to boxed equality++## 0.7.1 *February 6th 2020*+* Add support for GHC 8.10.1-alpha2+* 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+* Fixes [#28](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/28): Using the solver seems to break GHC+* Fixes [#34](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/34): inequality solver mishandles subtraction++## 0.7 *August 26th 2019*+* Require KnownNat constraints when solving with constants++## 0.6.2 *July 10th 2018*+* Add support for GHC 8.6.1-alpha1+* Solve larger inequalities from smaller inequalities, e.g.+ * `a <= n` implies `a <= n + 1`++## 0.6.1 *May 9th 2018*+* Stop solving `x + y ~ a + b` by asking GHC to solve `x ~ a` and `y ~ b` as+ this leads to a situation where we find a solution that is not the most+ general.+* Stop using the smallest solution to an inequality to solve an equality, as+ this leads to finding solutions that are not the most general.+* Solve smaller inequalities from larger inequalities, e.g.+ * `1 <= 2*x` implies `1 <= x`+ * `x + 2 <= y` implies `x <= y` and `2 <= y`++## 0.6 *April 23rd 2018*+* Solving constraints with `a-b` will emit `b <= a` constraints. e.g. solving+ `n-1+1 ~ n` will emit a `1 <= n` constraint.+ * If you need subtraction to be treated as addition with a negated operarand+ run with `-fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers`, and+ the `b <= a` constraint won't be emitted. Note that doing so can lead to+ unsound behaviour.+* Try to solve equalities using smallest solution of inequalities:+ * Solve `x + 1 ~ y` using `1 <= y` => `x + 1 ~ 1` => `x ~ 0`+* Solve inequalities using simple transitivity rules:+ * `2 <= x` implies `1 <= x`+ * `x <= 9` implies `x <= 10`+* Solve inequalities using _simple_ monotonicity of addition rules:+ * `2 <= x` implies `2 + 2*x <= 3*x`+* Solve inequalities using _simple_ monotonicity of multiplication rules:+ * `1 <= x` implies `1 <= 3*x`+* Solve inequalities using _simple_ monotonicity of exponentiation rules:+ * `1 <= x` implies `2 <= 2^x`+* Solve inequalities using powers of 2 and monotonicity of exponentiation:+ * `2 <= x` implies `2^(2 + 2*x) <= 2^(3*x)`++## 0.5.10 *April 15th 2018*+* Add support for GHC 8.5.20180306++## 0.5.9 *March 17th 2018*+* Add support for GHC 8.4.1++## 0.5.8 *January 4th 2018*+* Add support for GHC 8.4.1-alpha1++## 0.5.7 *November 7th 2017*+* Solve inequalities such as: `1 <= a + 3`++## 0.5.6 *October 31st 2017*+* Fixes bugs:+ * `(x + 1) ~ (2 * y)` no longer implies `((2 * (y - 1)) + 1) ~ x`++## 0.5.5 *October 22nd 2017*+* Solve inequalities when their normal forms are the same, i.e.+ * `(2 <= (2 ^ (n + d)))` implies `(2 <= (2 ^ (d + n)))`+* Find more unifications:+ * `8^x - 2*4^x ~ 8^y - 2*4^y ==> [x := y]`++## 0.5.4 *October 14th 2017*+* Perform normalisations such as: `2^x * 4^x ==> 8^x`++## 0.5.3 *May 15th 2017*+* Add support for GHC 8.2++## 0.5.2 *January 15th 2017*+* Fixes bugs:+ * Reification from SOP to Type sometimes loses product terms++## 0.5.1 *September 29th 2016*+* Fixes bugs:+ * Cannot solve an equality for the second time in a definition group++## 0.5 *August 17th 2016*+* Solve simple inequalities, i.e.:+ * `a <= a + 1`+ * `2a <= 3a`+ * `1 <= a^b`++## 0.4.6 *July 21th 2016*+* Reduce "x^(-y) * x^y" to 1+* Fixes bugs:+ * Subtraction in exponent induces infinite loop++## 0.4.5 *July 20th 2016*+* Fixes bugs:+ * Reifying negative exponent causes GHC panic++## 0.4.4 *July 19th 2016*+* Fixes bugs:+ * Rounding error in `logBase` calculation++## 0.4.3 *July 18th 2016*+* Fixes bugs:+ * False positive: "f :: (CLog 2 (2 ^ n) ~ n, (1 <=? n) ~ True) => Proxy n -> Proxy (n+d)"++## 0.4.2 *July 8th 2016*+* Find more unifications:+ * `(2*e ^ d) ~ (2*e*a*c) ==> [a*c := 2*e ^ (d-1)]`+ * `a^d * a^e ~ a^c ==> [c := d + e]`+ * `x+5 ~ y ==> [x := y - 5]`, but only when `x+5 ~ y` is a given constraint++## 0.4.1 *February 4th 2016*+* Find more unifications:+ * `F x y k z ~ F x y (k-1+1) z` ==> [k := k], where `F` can be any type function++## 0.4 *January 19th 2016*+* Stop using 'provenance' hack to create conditional evidence (GHC 8.0+ only)+* Find more unifications:+ * `F x + 2 - 1 - 1 ~ F x` ==> [F x := F x], where `F` can be any type function with result `Nat`.++## 0.3.2+* Find more unifications:+ * `(z ^ a) ~ (z ^ b) ==> [a := b]`+ * `(i ^ a) ~ j ==> [a := round (logBase i j)]`, when `i` and `j` are integers, and `ceiling (logBase i j) == floor (logBase i j)`.++## 0.3.1 *October 19th 2015*+* Find more unifications:+ * `(i * a) ~ j ==> [a := div j i]`, when `i` and `j` are integers, and `mod j i == 0`.+ * `(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`.++## 0.3 *June 3rd 2015*+* Find more unifications:+ * `<TyApp xs> + x ~ 2 + x ==> [<TyApp xs> ~ 2]`+* Fixes bugs:+ * Unifying `a*b ~ b` now returns `[a ~ 1]`; before it erroneously returned `[a ~ ]`, which is interpred as `[a ~ 0]`...+ * Unifying `a+b ~ b` now returns `[a ~ 0]`; before it returned the undesirable, though equal, `[a ~ ]`++## 0.2.1 *May 6th 2015*+* Update `Eq` instance of `SOP`: Empty SOP is equal to 0++## 0.2 *April 22nd 2015*+* Finds more unifications:+ * `(2 + a) ~ 5 ==> [a := 3]`+ * `(3 * a) ~ 0 ==> [a := 0]`++## 0.1.2 *April 21st 2015*+* Don't simplify expressions with negative exponents++## 0.1.1 *April 17th 2015*+* Add workaround for https://ghc.haskell.org/trac/ghc/ticket/10301++## 0.1 *March 30th 2015*+* Initial release
LICENSE view
@@ -1,27 +1,27 @@-Copyright (c) 2015-2016, University of Twente, - 2017-2018, QBayLogic B.V. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the - distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2015-2016, University of Twente,+ 2017-2018, QBayLogic B.V.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,39 +1,39 @@-# ghc-typelits-natnormalise - -[](https://github.com/clash-lang/ghc-typelits-natnormalise/actions) -[](https://hackage.haskell.org/package/ghc-typelits-natnormalise) -[](http://packdeps.haskellers.com/feed?needle=exact%3Aghc-typelits-natnormalise) - -A type checker plugin for GHC that can solve _equalities_ and _inequalities_ -of types of kind `Nat`, where these types are either: - -* Type-level naturals -* Type variables -* Applications of the arithmetic expressions `(+,-,*,^)`. - -It solves these equalities by normalising them to _sort-of_ -`SOP` (Sum-of-Products) form, and then perform a -simple syntactic equality. - -For example, this solver can prove the equality between: - -``` -(x + 2)^(y + 2) -``` - -and - -``` -4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 -``` - -Because the latter is actually the `SOP` normal form -of the former. - -To use the plugin, add - -``` -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -``` - -To the header of your file. +# ghc-typelits-natnormalise++[](https://github.com/clash-lang/ghc-typelits-natnormalise/actions)+[](https://hackage.haskell.org/package/ghc-typelits-natnormalise)+[](http://packdeps.haskellers.com/feed?needle=exact%3Aghc-typelits-natnormalise)++A type checker plugin for GHC that can solve _equalities_ and _inequalities_+of types of kind `Nat`, where these types are either:++* Type-level naturals+* Type variables+* Applications of the arithmetic expressions `(+,-,*,^)`.++It solves these equalities by normalising them to _sort-of_+`SOP` (Sum-of-Products) form, and then perform a+simple syntactic equality.++For example, this solver can prove the equality between:++```+(x + 2)^(y + 2)+```++and++```+4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2+```++Because the latter is actually the `SOP` normal form+of the former.++To use the plugin, add++```+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+```++To the header of your file.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
ghc-typelits-natnormalise.cabal view
@@ -1,116 +1,120 @@-name: ghc-typelits-natnormalise -version: 0.7.10 -synopsis: GHC typechecker plugin for types of kind GHC.TypeLits.Nat -description: - A type checker plugin for GHC that can solve /equalities/ and /inequalities/ - of types of kind @Nat@, where these types are either: - . - * Type-level naturals - . - * Type variables - . - * Applications of the arithmetic expressions @(+,-,*,^)@. - . - It solves these equalities by normalising them to /sort-of/ @SOP@ - (Sum-of-Products) form, and then perform a simple syntactic equality. - . - For example, this solver can prove the equality between: - . - @ - (x + 2)^(y + 2) - @ - . - and - . - @ - 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 - @ - . - Because the latter is actually the @SOP@ normal form of the former. - . - To use the plugin, add the - . - @ - OPTIONS_GHC -fplugin GHC.TypeLits.Normalise - @ - . - Pragma to the header of your file. -homepage: http://www.clash-lang.org/ -bug-reports: http://github.com/clash-lang/ghc-typelits-natnormalise/issues -license: BSD2 -license-file: LICENSE -author: Christiaan Baaij -maintainer: christiaan.baaij@gmail.com -copyright: Copyright © 2015-2016, University of Twente, - 2017-2018, QBayLogic B.V. -category: Type System -build-type: Simple -extra-source-files: README.md - CHANGELOG.md -cabal-version: >=1.10 -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, - GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, - GHC == 9.4.7, GHC == 9.6.3, GHC == 9.8.2, GHC == 9.10.1 - -source-repository head - type: git - location: https://github.com/clash-lang/ghc-typelits-natnormalise.git - -flag deverror - description: - Enables `-Werror` for development mode and TravisCI - default: False - manual: True - -library - exposed-modules: GHC.TypeLits.Normalise, - GHC.TypeLits.Normalise.SOP, - GHC.TypeLits.Normalise.Unify - build-depends: base >=4.9 && <5, - containers >=0.5.7.1 && <0.8, - ghc >=8.0.1 && <9.12, - ghc-tcplugins-extra >=0.3.1, - transformers >=0.5.2.0 && < 0.7 - if impl(ghc >= 9.0.0) - build-depends: ghc-bignum >=1.0 && <1.4 - else - build-depends: integer-gmp >=1.0 && <1.1 - hs-source-dirs: src - if impl(ghc >= 8.0) && impl(ghc < 9.4) - hs-source-dirs: src-pre-ghc-9.4 - if impl(ghc >= 9.4) && impl(ghc < 9.12) - hs-source-dirs: src-ghc-9.4 - build-depends: template-haskell >=2.17 && <2.23 - default-language: Haskell2010 - other-extensions: CPP - LambdaCase - RecordWildCards - TupleSections - if flag(deverror) - ghc-options: -Wall -Werror - else - ghc-options: -Wall - -test-suite unit-tests - type: exitcode-stdio-1.0 - main-is: Tests.hs - Other-Modules: ErrorTests - build-depends: base >=4.8 && <5, - ghc-typelits-natnormalise, - tasty >= 0.10, - tasty-hunit >= 0.9, - template-haskell >= 2.11.0.0 - if impl(ghc >= 9.4) - build-depends: ghc-prim >= 0.9 - hs-source-dirs: tests - default-language: Haskell2010 - other-extensions: DataKinds - GADTs - KindSignatures - NoImplicitPrelude - TemplateHaskell - TypeFamilies - TypeOperators - ScopedTypeVariables - if flag(deverror) - ghc-options: -dcore-lint +name: ghc-typelits-natnormalise+version: 0.7.11+synopsis: GHC typechecker plugin for types of kind GHC.TypeLits.Nat+description:+ A type checker plugin for GHC that can solve /equalities/ and /inequalities/+ of types of kind @Nat@, where these types are either:+ .+ * Type-level naturals+ .+ * Type variables+ .+ * Applications of the arithmetic expressions @(+,-,*,^)@.+ .+ It solves these equalities by normalising them to /sort-of/ @SOP@+ (Sum-of-Products) form, and then perform a simple syntactic equality.+ .+ For example, this solver can prove the equality between:+ .+ @+ (x + 2)^(y + 2)+ @+ .+ and+ .+ @+ 4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2+ @+ .+ Because the latter is actually the @SOP@ normal form of the former.+ .+ To use the plugin, add the+ .+ @+ OPTIONS_GHC -fplugin GHC.TypeLits.Normalise+ @+ .+ Pragma to the header of your file.+homepage: http://www.clash-lang.org/+bug-reports: http://github.com/clash-lang/ghc-typelits-natnormalise/issues+license: BSD2+license-file: LICENSE+author: Christiaan Baaij+maintainer: christiaan.baaij@gmail.com+copyright: Copyright © 2015-2016, University of Twente,+ 2017-2018, QBayLogic B.V.+category: Type System+build-type: Simple+extra-source-files: README.md+ CHANGELOG.md+cabal-version: >=1.10+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5,+ GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8,+ GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1,+ GHC == 9.12.1++source-repository head+ type: git+ location: https://github.com/clash-lang/ghc-typelits-natnormalise.git++flag deverror+ description:+ Enables `-Werror` for development mode and TravisCI+ default: False+ manual: True++library+ exposed-modules: GHC.TypeLits.Normalise,+ GHC.TypeLits.Normalise.SOP,+ GHC.TypeLits.Normalise.Unify+ build-depends: base >=4.9 && <5,+ containers >=0.5.7.1 && <0.8,+ ghc >=8.0.1 && <9.13,+ ghc-tcplugins-extra >=0.5,+ transformers >=0.5.2.0 && < 0.7+ if impl(ghc >= 9.0.0)+ build-depends: ghc-bignum >=1.0 && <1.4+ else+ build-depends: integer-gmp >=1.0 && <1.1+ hs-source-dirs: src+ if impl(ghc >= 8.0) && impl(ghc < 9.4)+ hs-source-dirs: src-pre-ghc-9.4+ if impl(ghc >= 9.4) && impl(ghc < 9.11)+ hs-source-dirs: src-ghc-9.4+ build-depends: template-haskell >=2.17 && <2.23+ if impl(ghc >= 9.11) && impl(ghc < 9.13)+ hs-source-dirs: src-ghc-9.12+ build-depends: template-haskell >=2.17 && <2.24+ default-language: Haskell2010+ other-extensions: CPP+ LambdaCase+ RecordWildCards+ TupleSections+ if flag(deverror)+ ghc-options: -Wall -Werror+ else+ ghc-options: -Wall++test-suite unit-tests+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ Other-Modules: ErrorTests+ build-depends: base >=4.8 && <5,+ ghc-typelits-natnormalise,+ tasty >= 0.10,+ tasty-hunit >= 0.9,+ template-haskell >= 2.11.0.0+ if impl(ghc >= 9.4)+ build-depends: ghc-prim >= 0.9+ hs-source-dirs: tests+ default-language: Haskell2010+ other-extensions: DataKinds+ GADTs+ KindSignatures+ NoImplicitPrelude+ TemplateHaskell+ TypeFamilies+ TypeOperators+ ScopedTypeVariables+ if flag(deverror)+ ghc-options: -dcore-lint
+ src-ghc-9.12/GHC/TypeLits/Normalise.hs view
@@ -0,0 +1,739 @@+{-|+Copyright : (C) 2015-2016, University of Twente,+ 2017 , QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>++A type checker plugin for GHC that can solve /equalities/ of types of kind+'GHC.TypeLits.Nat', where these types are either:++* Type-level naturals+* Type variables+* Applications of the arithmetic expressions @(+,-,*,^)@.++It solves these equalities by normalising them to /sort-of/+'GHC.TypeLits.Normalise.SOP.SOP' (Sum-of-Products) form, and then perform a+simple syntactic equality.++For example, this solver can prove the equality between:++@+(x + 2)^(y + 2)+@++and++@+4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2+@++Because the latter is actually the 'GHC.TypeLits.Normalise.SOP.SOP' normal form+of the former.++To use the plugin, add++@+{\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\}+@++To the header of your file.++== Treating subtraction as addition with a negated number++If you are absolutely sure that your subtractions can /never/ lead to (a locally)+negative number, you can ask the plugin to treat subtraction as addition with+a negated operand by additionally adding:++@+{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\}+@++to the header of your file, thereby allowing to use associativity and+commutativity rules when proving constraints involving subtractions. Note that+this option can lead to unsound behaviour and should be handled with extreme+care.++=== When it leads to unsound behaviour++For example, enabling the /allow-negated-numbers/ feature would allow+you to prove:++@+(n - 1) + 1 ~ n+@++/without/ a @(1 <= n)@ constraint, even though when /n/ is set to /0/ the+subtraction @n-1@ would be locally negative and hence not be a natural number.++This would allow the following erroneous definition:++@+data Fin (n :: Nat) where+ FZ :: Fin (n + 1)+ FS :: Fin n -> Fin (n + 1)++f :: forall n . Natural -> Fin n+f n = case of+ 0 -> FZ+ x -> FS (f \@(n-1) (x - 1))++fs :: [Fin 0]+fs = f \<$\> [0..]+@++=== When it might be Okay++This example is taken from the <http://hackage.haskell.org/package/mezzo mezzo>+library.++When you have:++@+-- | Singleton type for the number of repetitions of an element.+data Times (n :: Nat) where+ T :: Times n++-- | An element of a "run-length encoded" vector, containing the value and+-- the number of repetitions+data Elem :: Type -> Nat -> Type where+ (:*) :: t -> Times n -> Elem t n++-- | A length-indexed vector, optimised for repetitions.+data OptVector :: Type -> Nat -> Type where+ End :: OptVector t 0+ (:-) :: Elem t l -> OptVector t (n - l) -> OptVector t n+@++And you want to define:++@+-- | Append two optimised vectors.+type family (x :: OptVector t n) ++ (y :: OptVector t m) :: OptVector t (n + m) where+ ys ++ End = ys+ End ++ ys = ys+ (x :- xs) ++ ys = x :- (xs ++ ys)+@++then the last line will give rise to the constraint:++@+(n-l)+m ~ (n+m)-l+@++because:++@+x :: Elem t l+xs :: OptVector t (n-l)+ys :: OptVector t m+@++In this case it's okay to add++@+{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\}+@++if you can convince yourself you will never be able to construct a:++@+xs :: OptVector t (n-l)+@++where /n-l/ is a negative number.+-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module GHC.TypeLits.Normalise+ ( plugin )+where++-- external+import Control.Arrow (second)+import Control.Monad ((<=<), forM)+import Control.Monad.Trans.Writer.Strict+import Data.Either (partitionEithers, rights)+import Data.IORef+import Data.List (intersect, partition, stripPrefix, find)+import Data.Maybe (mapMaybe, catMaybes)+import Data.Set (Set, empty, toList, notMember, fromList, union)+import Text.Read (readMaybe)+import qualified Data.Type.Ord+import qualified GHC.TypeError++import GHC.TcPluginM.Extra (tracePlugin, newGiven, newWanted)++-- GHC API+import GHC.Builtin.Names (knownNatClassName, eqTyConKey, heqTyConKey, hasKey)+import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon)+import GHC.Builtin.Types.Literals+ (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon)+import GHC.Builtin.Types (naturalTy, cTupleDataCon, cTupleTyCon)+import GHC.Builtin.Types.Literals (typeNatCmpTyCon)+import GHC.Core (Expr (..))+import GHC.Core.Class (className)+import GHC.Core.Coercion (Coercion, Role (..), mkUnivCo)+import GHC.Core.DataCon (dataConWrapId)+import GHC.Core.Predicate+ (EqRel (NomEq), Pred (EqPred, IrredPred), classifyPredType, mkClassPred,+ mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe)+import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..))+import GHC.Core.TyCon (TyCon)+import GHC.Core.Type+ (Kind, PredType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp)+import GHC.Core.TyCo.Compare+ (eqType)+import GHC.Data.IOEnv (getEnv)+import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin)+import GHC.Plugins (thNameToGhcNameIO, HscEnv (hsc_NC))+import GHC.Tc.Plugin+ (TcPluginM, tcLookupClass, tcPluginTrace, tcPluginIO, newEvVar)+import GHC.Tc.Plugin (tcLookupTyCon, unsafeTcPluginTcM)+import GHC.Tc.Types (TcPlugin (..), TcPluginSolveResult(..), Env (env_top))+import GHC.Tc.Types.Constraint+ (Ct, CtEvidence (..), TcEvDest (..), ctEvidence, ctEvCoercion, ctLoc, isGiven,+ isWanted, mkNonCanonical, isWantedCt, ctEvLoc, ctEvPred, ctEvExpr,+ emptyRewriterSet, setCtEvLoc)+import GHC.Tc.Types.CtLoc (CtLoc, ctLocSpan, setCtLocSpan)+import GHC.Tc.Types.Evidence (EvBindsVar, EvTerm (..), evCast, evId, mkEvCast)+import GHC.Types.Unique.FM (emptyUFM)+import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text)+import GHC (Name)++-- template-haskell+import qualified Language.Haskell.TH as TH++-- internal+import GHC.TypeLits.Normalise.SOP+import GHC.TypeLits.Normalise.Unify hiding (subtractionToPred)++isEqPredClass :: PredType -> Bool+isEqPredClass ty = case tyConAppTyCon_maybe ty of+ Just tc -> tc `hasKey` eqTyConKey || tc `hasKey` heqTyConKey+ _ -> False++-- | To use the plugin, add+--+-- @+-- {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\}+-- @+--+-- To the header of your file.+plugin :: Plugin+plugin+ = defaultPlugin+ { tcPlugin = fmap (normalisePlugin . foldr id defaultOpts) . traverse parseArgument+ , pluginRecompile = purePlugin+ }+ where+ parseArgument "allow-negated-numbers" = Just (\ opts -> opts { negNumbers = True })+ parseArgument (readMaybe <=< stripPrefix "depth=" -> Just depth) = Just (\ opts -> opts { depth })+ parseArgument _ = Nothing+ defaultOpts = Opts { negNumbers = False, depth = 5 }++data Opts = Opts { negNumbers :: Bool, depth :: Word }++normalisePlugin :: Opts -> TcPlugin+normalisePlugin opts = tracePlugin "ghc-typelits-natnormalise"+ TcPlugin { tcPluginInit = lookupExtraDefs+ , tcPluginSolve = decideEqualSOP opts+ , tcPluginRewrite = const emptyUFM+ , tcPluginStop = const (return ())+ }++type ExtraDefs = (IORef (Set CType), (TyCon,TyCon,TyCon))++lookupExtraDefs :: TcPluginM ExtraDefs+lookupExtraDefs = do+ ref <- tcPluginIO (newIORef empty)+ ordCond <- lookupTHName ''Data.Type.Ord.OrdCond >>= tcLookupTyCon+ leqT <- lookupTHName ''(Data.Type.Ord.<=) >>= tcLookupTyCon+ assertT <- lookupTHName ''GHC.TypeError.Assert >>= tcLookupTyCon+ return (ref, (leqT,assertT,ordCond))++lookupTHName :: TH.Name -> TcPluginM Name+lookupTHName th = do+ nc <- unsafeTcPluginTcM (hsc_NC . env_top <$> getEnv)+ res <- tcPluginIO $ thNameToGhcNameIO nc th+ maybe (fail $ "Failed to lookup " ++ show th) return res++decideEqualSOP+ :: Opts+ -> ExtraDefs+ -- ^ 1. Givens that is already generated.+ -- We have to generate new givens at most once;+ -- otherwise GHC will loop indefinitely.+ --+ --+ -- 2. For GHc 9.2: TyCon of Data.Type.Ord.OrdCond+ -- For older: TyCon of GHC.TypeLits.<=?+ -> EvBindsVar+ -> [Ct]+ -> [Ct]+ -> TcPluginM TcPluginSolveResult++-- Simplification phase: Derives /simplified/ givens;+-- we can reduce given constraints like @Show (Foo (n + 2))@+-- to its normal form @Show (Foo (2 + n))@, which is eventually+-- useful in solving phase.+--+-- This helps us to solve /indirect/ constraints;+-- without this phase, we cannot derive, e.g.,+-- @IsVector UVector (Fin (n + 1))@ from+-- @Unbox (1 + n)@!+decideEqualSOP opts (gen'd,(leqT,_,_)) ev givens [] = do+ done <- tcPluginIO $ readIORef gen'd+ let reds =+ filter (\(_,(_,_,v)) -> null v || negNumbers opts) $+ reduceGivens opts leqT done givens+ newlyDone = map (\(_,(prd, _,_)) -> CType prd) reds+ tcPluginIO $+ modifyIORef' gen'd $ union (fromList newlyDone)+ newGivens <- forM reds $ \(origCt, (pred', evTerm, _)) ->+ mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm+ return (TcPluginOk [] newGivens)++-- Solving phase.+-- Solves in/equalities on Nats and simplifiable constraints+-- containing naturals.+decideEqualSOP opts (gen'd,tcs@(leqT,_,_)) ev givens wanteds = do+ let unit_wanteds = mapMaybe (toNatEquality tcs) wanteds+ nonEqs = filter ( not+ . (\p -> isEqPred p || isEqPrimPred p)+ . ctEvPred+ . ctEvidence )+ wanteds+ done <- tcPluginIO $ readIORef gen'd+ let redGs = reduceGivens opts leqT done givens+ newlyDone = map (\(_,(prd, _,_)) -> CType prd) redGs+ redGivens <- forM redGs $ \(origCt, (pred', evTerm, _)) ->+ mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm+ reducible_wanteds+ <- catMaybes <$> mapM (\ct -> fmap (ct,) <$>+ reduceNatConstr (givens ++ redGivens) ct)+ nonEqs+ if null unit_wanteds && null reducible_wanteds+ then return $ TcPluginOk [] []+ else do+ -- Since reducible wanteds also can have some negation/subtraction+ -- subterms, we have to make sure appropriate inequalities to hold.+ -- Here, we generate such additional inequalities for reduction+ -- that is to be added to new [W]anteds.+ ineqForRedWants <- fmap concat $ forM redGs $ \(ct, (_,_, ws)) -> forM ws $+ fmap (mkNonCanonical' (ctLoc ct)) . newWanted (ctLoc ct)+ tcPluginIO $+ modifyIORef' gen'd $ union (fromList newlyDone)+ let unit_givens = mapMaybe+ (toNatEquality tcs)+ givens+ sr <- simplifyNats opts leqT unit_givens unit_wanteds+ tcPluginTrace "normalised" (ppr sr)+ reds <- forM reducible_wanteds $ \(origCt,(term, ws, wDicts)) -> do+ wants <- evSubtPreds (ctLoc origCt) $ subToPred opts leqT ws+ return ((term, origCt), wDicts ++ wants)+ case sr of+ Simplified evs -> do+ let simpld = filter (not . isGiven . ctEvidence . (\((_,x),_) -> x)) evs+ -- Only solve derived when we solved a wanted+ simpld1 = case filter (isWanted . ctEvidence . (\((_,x),_) -> x)) evs ++ reds of+ [] -> []+ _ -> simpld+ (solved',newWanteds) = second concat (unzip $ simpld1 ++ reds)+ return (TcPluginOk solved' $ newWanteds ++ ineqForRedWants)+ Impossible eq -> return (TcPluginContradiction [fromNatEquality eq])++type NatEquality = (Ct,CoreSOP,CoreSOP)+type NatInEquality = (Ct,(CoreSOP,CoreSOP,Bool))++reduceGivens :: Opts -> TyCon -> Set CType -> [Ct] -> [(Ct, (Type, EvTerm, [PredType]))]+reduceGivens opts leqT done givens =+ let nonEqs =+ [ ct+ | ct <- givens+ , let ev = ctEvidence ct+ prd = ctEvPred ev+ , isGiven ev+ , not $ (\p -> isEqPred p || isEqPrimPred p || isEqPredClass p) prd+ ]+ in filter+ (\(_, (prd, _, _)) ->+ notMember (CType prd) done+ )+ $ mapMaybe+ (\ct -> (ct,) <$> tryReduceGiven opts leqT givens ct)+ nonEqs++tryReduceGiven+ :: Opts -> TyCon -> [Ct] -> Ct+ -> Maybe (PredType, EvTerm, [PredType])+tryReduceGiven opts leqT simplGivens ct = do+ let (mans, ws) =+ runWriter $ normaliseNatEverywhere $+ ctEvPred $ ctEvidence ct+ ws' = [ p+ | p <- subToPred opts leqT ws+ , all (not . (`eqType` p). ctEvPred . ctEvidence) simplGivens+ ]+ -- deps = unitDVarSet (ctEvId ct)+ pred' <- mans+ return (pred', toReducedDict (ctEvidence ct) pred', ws')++fromNatEquality :: Either NatEquality NatInEquality -> Ct+fromNatEquality (Left (ct, _, _)) = ct+fromNatEquality (Right (ct, _)) = ct++reduceNatConstr :: [Ct] -> Ct -> TcPluginM (Maybe (EvTerm, [(Type, Type)], [Ct]))+reduceNatConstr givens ct = do+ let pred0 = ctEvPred $ ctEvidence ct+ (mans, tests) = runWriter $ normaliseNatEverywhere pred0+ case mans of+ Nothing -> return Nothing+ Just pred' -> do+ case find ((`eqType` pred') .ctEvPred . ctEvidence) givens of+ -- No existing evidence found+ Nothing -> case getClassPredTys_maybe pred' of+ -- Are we trying to solve a class instance?+ Just (cls,_) | className cls /= knownNatClassName -> do+ -- Create new evidence binding for normalized class constraint+ evVar <- newEvVar pred'+ -- Bind the evidence to a new wanted normalized class constraint+ let wDict = mkNonCanonical+ (CtWanted pred' (EvVarDest evVar) (ctLoc ct) emptyRewriterSet)+ -- Evidence for current wanted is simply the coerced binding for+ -- the new binding+ evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") []+ Representational+ pred' pred0+ ev = mkEvCast (evId evVar) evCo+ -- Use newly created coerced wanted as evidence, and emit the+ -- normalized wanted as a new constraint to solve.+ return (Just (ev, tests, [wDict]))+ _ -> return Nothing+ -- Use existing evidence+ Just c -> return (Just (toReducedDict (ctEvidence c) pred0, tests, []))++toReducedDict :: CtEvidence -> PredType -> EvTerm+toReducedDict ct pred' =+ let pred0 = ctEvPred ct+ evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") []+ Representational+ pred0 pred'+ ev = mkEvCast (ctEvExpr ct) evCo+ in ev++data SimplifyResult+ = Simplified [((EvTerm,Ct),[Ct])]+ | Impossible (Either NatEquality NatInEquality)++instance Outputable SimplifyResult where+ ppr (Simplified evs) = text "Simplified" $$ ppr evs+ ppr (Impossible eq) = text "Impossible" <+> ppr eq++simplifyNats+ :: Opts+ -- ^ Allow negated numbers (potentially unsound!)+ -> TyCon+ -- * TyCon of Data.Type.Ord.<=+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -- ^ Given constraints+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -- ^ Wanted constraints+ -> TcPluginM SimplifyResult+simplifyNats opts@Opts {..} leqT eqsG eqsW = do+ let eqsG1 = map (second (const ([] :: [(Type,Type)]))) eqsG+ (varEqs,otherEqs) = partition isVarEqs eqsG1+ fancyGivens = concatMap (makeGivensSet otherEqs) varEqs+ case varEqs of+ [] -> do+ let eqs = otherEqs ++ eqsW+ tcPluginTrace "simplifyNats" (ppr eqs)+ simples [] [] [] [] [] eqs+ _ -> do+ tcPluginTrace ("simplifyNats(backtrack: " ++ show (length fancyGivens) ++ ")")+ (ppr varEqs)++ allSimplified <- forM fancyGivens $ \v -> do+ let eqs = v ++ eqsW+ tcPluginTrace "simplifyNats" (ppr eqs)+ simples [] [] [] [] [] eqs++ pure (foldr findFirstSimpliedWanted (Simplified []) allSimplified)+ where+ simples :: [Coercion]+ -> [CoreUnify]+ -> [((EvTerm, Ct), [Ct])]+ -> [(CoreSOP,CoreSOP,Bool)]+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -> TcPluginM SimplifyResult+ simples _ _subst evs _leqsG _xs [] = return (Simplified evs)+ simples deps subst evs leqsG xs (eq@(Left (ct,u,v),k):eqs') = do+ let u' = substsSOP subst u+ v' = substsSOP subst v+ ur <- unifyNats ct u' v'+ tcPluginTrace "unifyNats result" (ppr ur)+ case ur of+ Win -> do+ evs' <- maybe evs (:evs) <$> evMagic ct deps empty (subToPred opts leqT k)+ simples deps subst evs' leqsG [] (xs ++ eqs')+ Lose -> if null evs && null eqs'+ then return (Impossible (fst eq))+ else simples deps subst evs leqsG xs eqs'+ Draw [] -> simples deps subst evs [] (eq:xs) eqs'+ Draw subst' -> do+ evM <- evMagic ct deps empty (map unifyItemToPredType subst' +++ subToPred opts leqT k)+ let (leqsG1, deps1)+ | isGiven (ctEvidence ct) = ( eqToLeq u' v' ++ leqsG+ , ctEvCoercion (ctEvidence ct):deps)+ | otherwise = (leqsG, deps)+ case evM of+ Nothing -> simples deps1 subst evs leqsG1 xs eqs'+ Just ev ->+ simples (ctEvCoercion (ctEvidence ct):deps)+ (substsSubst subst' subst ++ subst')+ (ev:evs) leqsG1 [] (xs ++ eqs')+ simples deps subst evs leqsG xs (eq@(Right (ct,u@(x,y,b)),k):eqs') = do+ let u' = substsSOP subst (subtractIneq u)+ x' = substsSOP subst x+ y' = substsSOP subst y+ uS = (x',y',b)+ leqsG' | isGiven (ctEvidence ct) = (x',y',b):leqsG+ | otherwise = leqsG+ ineqs = concat [ leqsG+ , map (substLeq subst) leqsG+ , map snd (rights (map fst eqsG))+ ]+ tcPluginTrace "unifyNats(ineq) results" (ppr (ct,u,u',ineqs))+ case runWriterT (isNatural u') of+ Just (True,knW) -> do+ evs' <- maybe evs (:evs) <$> evMagic ct deps knW (subToPred opts leqT k)+ simples deps subst evs' leqsG' xs eqs'++ Just (False,_) | null k -> return (Impossible (fst eq))+ _ -> do+ let solvedIneq = mapMaybe runWriterT+ -- it is an inequality that can be instantly solved, such as+ -- `1 <= x^y`+ -- OR+ (instantSolveIneq depth u:+ instantSolveIneq depth uS:+ -- This inequality is either a given constraint, or it is a wanted+ -- constraint, which in normal form is equal to another given+ -- constraint, hence it can be solved.+ -- OR+ map (solveIneq depth u) ineqs +++ -- The above, but with valid substitutions applied to the wanted.+ map (solveIneq depth uS) ineqs)+ smallest = solvedInEqSmallestConstraint solvedIneq+ case smallest of+ (True,kW) -> do+ evs' <- maybe evs (:evs) <$> evMagic ct deps kW (subToPred opts leqT k)+ simples deps subst evs' leqsG' xs eqs'+ _ -> simples deps subst evs leqsG (eq:xs) eqs'++ eqToLeq x y = [(x,y,True),(y,x,True)]+ substLeq s (x,y,b) = (substsSOP s x, substsSOP s y, b)++ isVarEqs (Left (_,S [P [V _]], S [P [V _]]), _) = True+ isVarEqs _ = False++ makeGivensSet otherEqs varEq+ = let (noMentionsV,mentionsV) = partitionEithers+ (map (matchesVarEq varEq) otherEqs)+ (mentionsLHS,mentionsRHS) = partitionEithers mentionsV+ vS = swapVar varEq+ givensLHS = case mentionsLHS of+ [] -> []+ _ -> [mentionsLHS ++ ((varEq:mentionsRHS) ++ noMentionsV)]+ givensRHS = case mentionsRHS of+ [] -> []+ _ -> [mentionsRHS ++ (vS:mentionsLHS ++ noMentionsV)]+ in case mentionsV of+ [] -> [noMentionsV]+ _ -> givensLHS ++ givensRHS++ matchesVarEq (Left (_, S [P [V v1]], S [P [V v2]]),_) r = case r of+ (Left (_,S [P [V v3]],_),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Left (_,_,S [P [V v3]]),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Right (_,(S [P [V v3]],_,_)),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Right (_,(_,S [P [V v3]],_)),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ _ -> Left r+ matchesVarEq _ _ = error "internal error"++ swapVar (Left (ct,S [P [V v1]], S [P [V v2]]),ps) =+ (Left (ct,S [P [V v2]], S [P [V v1]]),ps)+ swapVar _ = error "internal error"++ findFirstSimpliedWanted (Impossible e) _ = Impossible e+ findFirstSimpliedWanted (Simplified evs) s2+ | any (isWantedCt . snd . fst) evs+ = Simplified evs+ | otherwise+ = s2++-- If we allow negated numbers we simply do not emit the inequalities+-- derived from the subtractions that are converted to additions with a+-- negated operand+subToPred :: Opts -> TyCon -> [(Type, Type)] -> [PredType]+subToPred Opts{..} leqT+ | negNumbers = const []+ | otherwise = map leq+ where+ leq (a,b) =+ let lhs = TyConApp leqT [naturalTy,b,a]+ rhs = TyConApp (cTupleTyCon 0) []+ in mkPrimEqPred lhs rhs++-- Extract the Nat equality constraints+toNatEquality :: (TyCon,TyCon,TyCon) -> Ct -> Maybe (Either NatEquality NatInEquality,[(Type,Type)])+toNatEquality (_,assertT,ordCond) ct = case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 t2+ -> go t1 t2+ IrredPred p+ -> go2 p+ _ -> Nothing+ where+ go (TyConApp tc xs) (TyConApp tc' ys)+ | tc == tc'+ , null ([tc,tc'] `intersect` [typeNatAddTyCon,typeNatSubTyCon+ ,typeNatMulTyCon,typeNatExpTyCon])+ = case filter (not . uncurry eqType) (zip xs ys) of+ [(x,y)]+ | isNatKind (typeKind x)+ , isNatKind (typeKind y)+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ -> Just (Left (ct, x', y'),k1 ++ k2)+ _ -> Nothing+ | tc == ordCond+ , [_,cmp,lt,eq,gt] <- xs+ , TyConApp tcCmpNat [x,y] <- cmp+ , tcCmpNat == typeNatCmpTyCon+ , TyConApp ltTc [] <- lt+ , ltTc == promotedTrueDataCon+ , TyConApp eqTc [] <- eq+ , eqTc == promotedTrueDataCon+ , TyConApp gtTc [] <- gt+ , gtTc == promotedFalseDataCon+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ , let ks = k1 ++ k2+ = case tc' of+ _ | tc' == promotedTrueDataCon+ -> Just (Right (ct, (x', y', True)), ks)+ _ | tc' == promotedFalseDataCon+ -> Just (Right (ct, (x', y', False)), ks)+ _ -> Nothing+ | tc == assertT+ , tc' == (cTupleTyCon 0)+ , [] <- ys+ , [TyConApp ordCondTc zs, _] <- xs+ , ordCondTc == ordCond+ , [_,cmp,lt,eq,gt] <- zs+ , TyConApp tcCmpNat [x,y] <- cmp+ , tcCmpNat == typeNatCmpTyCon+ , TyConApp ltTc [] <- lt+ , ltTc == promotedTrueDataCon+ , TyConApp eqTc [] <- eq+ , eqTc == promotedTrueDataCon+ , TyConApp gtTc [] <- gt+ , gtTc == promotedFalseDataCon+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ , let ks = k1 ++ k2+ = Just (Right (ct, (x', y', True)), ks)++ go x y+ | isNatKind (typeKind x)+ , isNatKind (typeKind y)+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ = Just (Left (ct,x',y'),k1 ++ k2)+ | otherwise+ = Nothing++ go2 (TyConApp tc ys)+ | tc == assertT+ , [TyConApp ordCondTc xs, _] <- ys+ , ordCondTc == ordCond+ , [_,cmp,lt,eq,gt] <- xs+ , TyConApp tcCmpNat [x,y] <- cmp+ , tcCmpNat == typeNatCmpTyCon+ , TyConApp ltTc [] <- lt+ , ltTc == promotedTrueDataCon+ , TyConApp eqTc [] <- eq+ , eqTc == promotedTrueDataCon+ , TyConApp gtTc [] <- gt+ , gtTc == promotedFalseDataCon+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ , let ks = k1 ++ k2+ = Just (Right (ct, (x', y', True)), ks)++ go2 _ = Nothing++ isNatKind :: Kind -> Bool+ isNatKind = (`eqType` naturalTy)++unifyItemToPredType :: CoreUnify -> PredType+unifyItemToPredType ui = mkPrimEqPred ty1 ty2+ where+ ty1 = case ui of+ SubstItem {..} -> mkTyVarTy siVar+ UnifyItem {..} -> reifySOP siLHS+ ty2 = case ui of+ SubstItem {..} -> reifySOP siSOP+ UnifyItem {..} -> reifySOP siRHS++evSubtPreds :: CtLoc -> [PredType] -> TcPluginM [Ct]+evSubtPreds loc = mapM (fmap mkNonCanonical . newWanted loc)++evMagic :: Ct -> [Coercion] -> Set CType -> [PredType] -> TcPluginM (Maybe ((EvTerm, Ct), [Ct]))+evMagic ct deps knW preds = do+ holeWanteds <- evSubtPreds (ctLoc ct) preds+ knWanted <- mapM (mkKnWanted (ctLoc ct)) (toList knW)+ let newWant = knWanted ++ holeWanteds+ case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 t2 ->+ let ctEv = mkUnivCo (PluginProv "ghc-typelits-natnormalise") deps Nominal t1 t2+ in return (Just ((EvExpr (Coercion ctEv), ct),newWant))+ IrredPred p ->+ let t1 = mkTyConApp (cTupleTyCon 0) []+ co = mkUnivCo (PluginProv "ghc-typelits-natnormalise") deps Representational t1 p+ dcApp = evId (dataConWrapId (cTupleDataCon 0))+ in return (Just ((evCast dcApp co, ct),newWant))+ _ -> return Nothing++mkNonCanonical' :: CtLoc -> CtEvidence -> Ct+mkNonCanonical' origCtl ev =+ let ct_ls = ctLocSpan origCtl+ ctl = ctEvLoc ev+ in mkNonCanonical (setCtEvLoc ev (setCtLocSpan ctl ct_ls))++mkKnWanted+ :: CtLoc+ -> CType+ -> TcPluginM Ct+mkKnWanted loc (CType ty) = do+ kc_clas <- tcLookupClass knownNatClassName+ let kn_pred = mkClassPred kc_clas [ty]+ wantedCtEv <- newWanted loc kn_pred+ let wanted' = mkNonCanonical' loc wantedCtEv+ return wanted'
src-ghc-9.4/GHC/TypeLits/Normalise.hs view
@@ -1,740 +1,740 @@-{-| -Copyright : (C) 2015-2016, University of Twente, - 2017 , QBayLogic B.V. -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> - -A type checker plugin for GHC that can solve /equalities/ of types of kind -'GHC.TypeLits.Nat', where these types are either: - -* Type-level naturals -* Type variables -* Applications of the arithmetic expressions @(+,-,*,^)@. - -It solves these equalities by normalising them to /sort-of/ -'GHC.TypeLits.Normalise.SOP.SOP' (Sum-of-Products) form, and then perform a -simple syntactic equality. - -For example, this solver can prove the equality between: - -@ -(x + 2)^(y + 2) -@ - -and - -@ -4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 -@ - -Because the latter is actually the 'GHC.TypeLits.Normalise.SOP.SOP' normal form -of the former. - -To use the plugin, add - -@ -{\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} -@ - -To the header of your file. - -== Treating subtraction as addition with a negated number - -If you are absolutely sure that your subtractions can /never/ lead to (a locally) -negative number, you can ask the plugin to treat subtraction as addition with -a negated operand by additionally adding: - -@ -{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} -@ - -to the header of your file, thereby allowing to use associativity and -commutativity rules when proving constraints involving subtractions. Note that -this option can lead to unsound behaviour and should be handled with extreme -care. - -=== When it leads to unsound behaviour - -For example, enabling the /allow-negated-numbers/ feature would allow -you to prove: - -@ -(n - 1) + 1 ~ n -@ - -/without/ a @(1 <= n)@ constraint, even though when /n/ is set to /0/ the -subtraction @n-1@ would be locally negative and hence not be a natural number. - -This would allow the following erroneous definition: - -@ -data Fin (n :: Nat) where - FZ :: Fin (n + 1) - FS :: Fin n -> Fin (n + 1) - -f :: forall n . Natural -> Fin n -f n = case of - 0 -> FZ - x -> FS (f \@(n-1) (x - 1)) - -fs :: [Fin 0] -fs = f \<$\> [0..] -@ - -=== When it might be Okay - -This example is taken from the <http://hackage.haskell.org/package/mezzo mezzo> -library. - -When you have: - -@ --- | Singleton type for the number of repetitions of an element. -data Times (n :: Nat) where - T :: Times n - --- | An element of a "run-length encoded" vector, containing the value and --- the number of repetitions -data Elem :: Type -> Nat -> Type where - (:*) :: t -> Times n -> Elem t n - --- | A length-indexed vector, optimised for repetitions. -data OptVector :: Type -> Nat -> Type where - End :: OptVector t 0 - (:-) :: Elem t l -> OptVector t (n - l) -> OptVector t n -@ - -And you want to define: - -@ --- | Append two optimised vectors. -type family (x :: OptVector t n) ++ (y :: OptVector t m) :: OptVector t (n + m) where - ys ++ End = ys - End ++ ys = ys - (x :- xs) ++ ys = x :- (xs ++ ys) -@ - -then the last line will give rise to the constraint: - -@ -(n-l)+m ~ (n+m)-l -@ - -because: - -@ -x :: Elem t l -xs :: OptVector t (n-l) -ys :: OptVector t m -@ - -In this case it's okay to add - -@ -{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} -@ - -if you can convince yourself you will never be able to construct a: - -@ -xs :: OptVector t (n-l) -@ - -where /n-l/ is a negative number. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TemplateHaskellQuotes #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module GHC.TypeLits.Normalise - ( plugin ) -where - --- external -import Control.Arrow (second) -import Control.Monad ((<=<), forM) -import Control.Monad.Trans.Writer.Strict -import Data.Either (partitionEithers, rights) -import Data.IORef -import Data.List (intersect, partition, stripPrefix, find) -import Data.Maybe (mapMaybe, catMaybes) -import Data.Set (Set, empty, toList, notMember, fromList, union) -import Text.Read (readMaybe) -import qualified Data.Type.Ord -import qualified GHC.TypeError - -import GHC.TcPluginM.Extra (tracePlugin, newGiven, newWanted) - --- GHC API -import GHC.Builtin.Names (knownNatClassName, eqTyConKey, heqTyConKey, hasKey) -import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon) -import GHC.Builtin.Types.Literals - (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon) -import GHC.Builtin.Types (naturalTy, cTupleDataCon, cTupleTyCon) -import GHC.Builtin.Types.Literals (typeNatCmpTyCon) -import GHC.Core (Expr (..)) -import GHC.Core.Class (className) -import GHC.Core.Coercion (Role (..), mkUnivCo) -import GHC.Core.DataCon (dataConWrapId) -import GHC.Core.Predicate - (EqRel (NomEq), Pred (EqPred, IrredPred), classifyPredType, mkClassPred, - mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe) -import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..)) -import GHC.Core.TyCon (TyCon) -#if MIN_VERSION_ghc(9,6,0) -import GHC.Core.Type - (Kind, PredType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp) -import GHC.Core.TyCo.Compare - (eqType) -#else -import GHC.Core.Type - (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp) -#endif -import GHC.Data.IOEnv (getEnv) -import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin) -import GHC.Plugins (thNameToGhcNameIO, HscEnv (hsc_NC)) -import GHC.Tc.Plugin - (TcPluginM, tcLookupClass, tcPluginTrace, tcPluginIO, newEvVar) -import GHC.Tc.Plugin (tcLookupTyCon, unsafeTcPluginTcM) -import GHC.Tc.Types (TcPlugin (..), TcPluginSolveResult(..), Env (env_top)) -import GHC.Tc.Types.Constraint - (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence, - ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLocSpan, - isWantedCt, ctEvLoc, ctEvPred, ctEvExpr, emptyRewriterSet, setCtEvLoc) -import GHC.Tc.Types.Evidence (EvBindsVar, EvTerm (..), evCast, evId) -import GHC.Types.Unique.FM (emptyUFM) -import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text) -import GHC (Name) - --- template-haskell -import qualified Language.Haskell.TH as TH - --- internal -import GHC.TypeLits.Normalise.SOP -import GHC.TypeLits.Normalise.Unify hiding (subtractionToPred) - -isEqPredClass :: PredType -> Bool -isEqPredClass ty = case tyConAppTyCon_maybe ty of - Just tc -> tc `hasKey` eqTyConKey || tc `hasKey` heqTyConKey - _ -> False - --- | To use the plugin, add --- --- @ --- {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} --- @ --- --- To the header of your file. -plugin :: Plugin -plugin - = defaultPlugin - { tcPlugin = fmap (normalisePlugin . foldr id defaultOpts) . traverse parseArgument - , pluginRecompile = purePlugin - } - where - parseArgument "allow-negated-numbers" = Just (\ opts -> opts { negNumbers = True }) - parseArgument (readMaybe <=< stripPrefix "depth=" -> Just depth) = Just (\ opts -> opts { depth }) - parseArgument _ = Nothing - defaultOpts = Opts { negNumbers = False, depth = 5 } - -data Opts = Opts { negNumbers :: Bool, depth :: Word } - -normalisePlugin :: Opts -> TcPlugin -normalisePlugin opts = tracePlugin "ghc-typelits-natnormalise" - TcPlugin { tcPluginInit = lookupExtraDefs - , tcPluginSolve = decideEqualSOP opts - , tcPluginRewrite = const emptyUFM - , tcPluginStop = const (return ()) - } - -type ExtraDefs = (IORef (Set CType), (TyCon,TyCon,TyCon)) - -lookupExtraDefs :: TcPluginM ExtraDefs -lookupExtraDefs = do - ref <- tcPluginIO (newIORef empty) - ordCond <- lookupTHName ''Data.Type.Ord.OrdCond >>= tcLookupTyCon - leqT <- lookupTHName ''(Data.Type.Ord.<=) >>= tcLookupTyCon - assertT <- lookupTHName ''GHC.TypeError.Assert >>= tcLookupTyCon - return (ref, (leqT,assertT,ordCond)) - -lookupTHName :: TH.Name -> TcPluginM Name -lookupTHName th = do - nc <- unsafeTcPluginTcM (hsc_NC . env_top <$> getEnv) - res <- tcPluginIO $ thNameToGhcNameIO nc th - maybe (fail $ "Failed to lookup " ++ show th) return res - -decideEqualSOP - :: Opts - -> ExtraDefs - -- ^ 1. Givens that is already generated. - -- We have to generate new givens at most once; - -- otherwise GHC will loop indefinitely. - -- - -- - -- 2. For GHc 9.2: TyCon of Data.Type.Ord.OrdCond - -- For older: TyCon of GHC.TypeLits.<=? - -> EvBindsVar - -> [Ct] - -> [Ct] - -> TcPluginM TcPluginSolveResult - --- Simplification phase: Derives /simplified/ givens; --- we can reduce given constraints like @Show (Foo (n + 2))@ --- to its normal form @Show (Foo (2 + n))@, which is eventually --- useful in solving phase. --- --- This helps us to solve /indirect/ constraints; --- without this phase, we cannot derive, e.g., --- @IsVector UVector (Fin (n + 1))@ from --- @Unbox (1 + n)@! -decideEqualSOP opts (gen'd,(leqT,_,_)) ev givens [] = do - done <- tcPluginIO $ readIORef gen'd - let reds = - filter (\(_,(_,_,v)) -> null v || negNumbers opts) $ - reduceGivens opts leqT done givens - newlyDone = map (\(_,(prd, _,_)) -> CType prd) reds - tcPluginIO $ - modifyIORef' gen'd $ union (fromList newlyDone) - newGivens <- forM reds $ \(origCt, (pred', evTerm, _)) -> - mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm - return (TcPluginOk [] newGivens) - --- Solving phase. --- Solves in/equalities on Nats and simplifiable constraints --- containing naturals. -decideEqualSOP opts (gen'd,tcs@(leqT,_,_)) ev givens wanteds = do - let unit_wanteds = mapMaybe (toNatEquality tcs) wanteds - nonEqs = filter ( not - . (\p -> isEqPred p || isEqPrimPred p) - . ctEvPred - . ctEvidence ) - wanteds - done <- tcPluginIO $ readIORef gen'd - let redGs = reduceGivens opts leqT done givens - newlyDone = map (\(_,(prd, _,_)) -> CType prd) redGs - redGivens <- forM redGs $ \(origCt, (pred', evTerm, _)) -> - mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm - reducible_wanteds - <- catMaybes <$> mapM (\ct -> fmap (ct,) <$> - reduceNatConstr (givens ++ redGivens) ct) - nonEqs - if null unit_wanteds && null reducible_wanteds - then return $ TcPluginOk [] [] - else do - -- Since reducible wanteds also can have some negation/subtraction - -- subterms, we have to make sure appropriate inequalities to hold. - -- Here, we generate such additional inequalities for reduction - -- that is to be added to new [W]anteds. - ineqForRedWants <- fmap concat $ forM redGs $ \(ct, (_,_, ws)) -> forM ws $ - fmap (mkNonCanonical' (ctLoc ct)) . newWanted (ctLoc ct) - tcPluginIO $ - modifyIORef' gen'd $ union (fromList newlyDone) - let unit_givens = mapMaybe - (toNatEquality tcs) - givens - sr <- simplifyNats opts leqT unit_givens unit_wanteds - tcPluginTrace "normalised" (ppr sr) - reds <- forM reducible_wanteds $ \(origCt,(term, ws, wDicts)) -> do - wants <- evSubtPreds (ctLoc origCt) $ subToPred opts leqT ws - return ((term, origCt), wDicts ++ wants) - case sr of - Simplified evs -> do - let simpld = filter (not . isGiven . ctEvidence . (\((_,x),_) -> x)) evs - -- Only solve derived when we solved a wanted - simpld1 = case filter (isWanted . ctEvidence . (\((_,x),_) -> x)) evs ++ reds of - [] -> [] - _ -> simpld - (solved',newWanteds) = second concat (unzip $ simpld1 ++ reds) - return (TcPluginOk solved' $ newWanteds ++ ineqForRedWants) - Impossible eq -> return (TcPluginContradiction [fromNatEquality eq]) - -type NatEquality = (Ct,CoreSOP,CoreSOP) -type NatInEquality = (Ct,(CoreSOP,CoreSOP,Bool)) - -reduceGivens :: Opts -> TyCon -> Set CType -> [Ct] -> [(Ct, (Type, EvTerm, [PredType]))] -reduceGivens opts leqT done givens = - let nonEqs = - [ ct - | ct <- givens - , let ev = ctEvidence ct - prd = ctEvPred ev - , isGiven ev - , not $ (\p -> isEqPred p || isEqPrimPred p || isEqPredClass p) prd - ] - in filter - (\(_, (prd, _, _)) -> - notMember (CType prd) done - ) - $ mapMaybe - (\ct -> (ct,) <$> tryReduceGiven opts leqT givens ct) - nonEqs - -tryReduceGiven - :: Opts -> TyCon -> [Ct] -> Ct - -> Maybe (PredType, EvTerm, [PredType]) -tryReduceGiven opts leqT simplGivens ct = do - let (mans, ws) = - runWriter $ normaliseNatEverywhere $ - ctEvPred $ ctEvidence ct - ws' = [ p - | p <- subToPred opts leqT ws - , all (not . (`eqType` p). ctEvPred . ctEvidence) simplGivens - ] - pred' <- mans - return (pred', toReducedDict (ctEvidence ct) pred', ws') - -fromNatEquality :: Either NatEquality NatInEquality -> Ct -fromNatEquality (Left (ct, _, _)) = ct -fromNatEquality (Right (ct, _)) = ct - -reduceNatConstr :: [Ct] -> Ct -> TcPluginM (Maybe (EvTerm, [(Type, Type)], [Ct])) -reduceNatConstr givens ct = do - let pred0 = ctEvPred $ ctEvidence ct - (mans, tests) = runWriter $ normaliseNatEverywhere pred0 - case mans of - Nothing -> return Nothing - Just pred' -> do - case find ((`eqType` pred') .ctEvPred . ctEvidence) givens of - -- No existing evidence found - Nothing -> case getClassPredTys_maybe pred' of - -- Are we trying to solve a class instance? - Just (cls,_) | className cls /= knownNatClassName -> do - -- Create new evidence binding for normalized class constraint - evVar <- newEvVar pred' - -- Bind the evidence to a new wanted normalized class constraint - let wDict = mkNonCanonical - (CtWanted pred' (EvVarDest evVar) (ctLoc ct) emptyRewriterSet) - -- Evidence for current wanted is simply the coerced binding for - -- the new binding - evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") - Representational - pred' pred0 - ev = evId evVar `evCast` evCo - -- Use newly created coerced wanted as evidence, and emit the - -- normalized wanted as a new constraint to solve. - return (Just (ev, tests, [wDict])) - _ -> return Nothing - -- Use existing evidence - Just c -> return (Just (toReducedDict (ctEvidence c) pred0, tests, [])) - -toReducedDict :: CtEvidence -> PredType -> EvTerm -toReducedDict ct pred' = - let pred0 = ctEvPred ct - evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") - Representational - pred0 pred' - ev = ctEvExpr ct - `evCast` evCo - in ev - -data SimplifyResult - = Simplified [((EvTerm,Ct),[Ct])] - | Impossible (Either NatEquality NatInEquality) - -instance Outputable SimplifyResult where - ppr (Simplified evs) = text "Simplified" $$ ppr evs - ppr (Impossible eq) = text "Impossible" <+> ppr eq - -simplifyNats - :: Opts - -- ^ Allow negated numbers (potentially unsound!) - -> TyCon - -- * TyCon of Data.Type.Ord.<= - -> [(Either NatEquality NatInEquality,[(Type,Type)])] - -- ^ Given constraints - -> [(Either NatEquality NatInEquality,[(Type,Type)])] - -- ^ Wanted constraints - -> TcPluginM SimplifyResult -simplifyNats opts@Opts {..} leqT eqsG eqsW = do - let eqsG1 = map (second (const ([] :: [(Type,Type)]))) eqsG - (varEqs,otherEqs) = partition isVarEqs eqsG1 - fancyGivens = concatMap (makeGivensSet otherEqs) varEqs - case varEqs of - [] -> do - let eqs = otherEqs ++ eqsW - tcPluginTrace "simplifyNats" (ppr eqs) - simples [] [] [] [] eqs - _ -> do - tcPluginTrace ("simplifyNats(backtrack: " ++ show (length fancyGivens) ++ ")") - (ppr varEqs) - - allSimplified <- forM fancyGivens $ \v -> do - let eqs = v ++ eqsW - tcPluginTrace "simplifyNats" (ppr eqs) - simples [] [] [] [] eqs - - pure (foldr findFirstSimpliedWanted (Simplified []) allSimplified) - where - simples :: [CoreUnify] - -> [((EvTerm, Ct), [Ct])] - -> [(CoreSOP,CoreSOP,Bool)] - -> [(Either NatEquality NatInEquality,[(Type,Type)])] - -> [(Either NatEquality NatInEquality,[(Type,Type)])] - -> TcPluginM SimplifyResult - simples _subst evs _leqsG _xs [] = return (Simplified evs) - simples subst evs leqsG xs (eq@(Left (ct,u,v),k):eqs') = do - let u' = substsSOP subst u - v' = substsSOP subst v - ur <- unifyNats ct u' v' - tcPluginTrace "unifyNats result" (ppr ur) - case ur of - Win -> do - evs' <- maybe evs (:evs) <$> evMagic ct empty (subToPred opts leqT k) - simples subst evs' leqsG [] (xs ++ eqs') - Lose -> if null evs && null eqs' - then return (Impossible (fst eq)) - else simples subst evs leqsG xs eqs' - Draw [] -> simples subst evs [] (eq:xs) eqs' - Draw subst' -> do - evM <- evMagic ct empty (map unifyItemToPredType subst' ++ - subToPred opts leqT k) - let leqsG' | isGiven (ctEvidence ct) = eqToLeq u' v' ++ leqsG - | otherwise = leqsG - case evM of - Nothing -> simples subst evs leqsG' xs eqs' - Just ev -> - simples (substsSubst subst' subst ++ subst') - (ev:evs) leqsG' [] (xs ++ eqs') - simples subst evs leqsG xs (eq@(Right (ct,u@(x,y,b)),k):eqs') = do - let u' = substsSOP subst (subtractIneq u) - x' = substsSOP subst x - y' = substsSOP subst y - uS = (x',y',b) - leqsG' | isGiven (ctEvidence ct) = (x',y',b):leqsG - | otherwise = leqsG - ineqs = concat [ leqsG - , map (substLeq subst) leqsG - , map snd (rights (map fst eqsG)) - ] - tcPluginTrace "unifyNats(ineq) results" (ppr (ct,u,u',ineqs)) - case runWriterT (isNatural u') of - Just (True,knW) -> do - evs' <- maybe evs (:evs) <$> evMagic ct knW (subToPred opts leqT k) - simples subst evs' leqsG' xs eqs' - - Just (False,_) | null k -> return (Impossible (fst eq)) - _ -> do - let solvedIneq = mapMaybe runWriterT - -- it is an inequality that can be instantly solved, such as - -- `1 <= x^y` - -- OR - (instantSolveIneq depth u: - instantSolveIneq depth uS: - -- This inequality is either a given constraint, or it is a wanted - -- constraint, which in normal form is equal to another given - -- constraint, hence it can be solved. - -- OR - map (solveIneq depth u) ineqs ++ - -- The above, but with valid substitutions applied to the wanted. - map (solveIneq depth uS) ineqs) - smallest = solvedInEqSmallestConstraint solvedIneq - case smallest of - (True,kW) -> do - evs' <- maybe evs (:evs) <$> evMagic ct kW (subToPred opts leqT k) - simples subst evs' leqsG' xs eqs' - _ -> simples subst evs leqsG (eq:xs) eqs' - - eqToLeq x y = [(x,y,True),(y,x,True)] - substLeq s (x,y,b) = (substsSOP s x, substsSOP s y, b) - - isVarEqs (Left (_,S [P [V _]], S [P [V _]]), _) = True - isVarEqs _ = False - - makeGivensSet otherEqs varEq - = let (noMentionsV,mentionsV) = partitionEithers - (map (matchesVarEq varEq) otherEqs) - (mentionsLHS,mentionsRHS) = partitionEithers mentionsV - vS = swapVar varEq - givensLHS = case mentionsLHS of - [] -> [] - _ -> [mentionsLHS ++ ((varEq:mentionsRHS) ++ noMentionsV)] - givensRHS = case mentionsRHS of - [] -> [] - _ -> [mentionsRHS ++ (vS:mentionsLHS ++ noMentionsV)] - in case mentionsV of - [] -> [noMentionsV] - _ -> givensLHS ++ givensRHS - - matchesVarEq (Left (_, S [P [V v1]], S [P [V v2]]),_) r = case r of - (Left (_,S [P [V v3]],_),_) - | v1 == v3 -> Right (Left r) - | v2 == v3 -> Right (Right r) - (Left (_,_,S [P [V v3]]),_) - | v1 == v3 -> Right (Left r) - | v2 == v3 -> Right (Right r) - (Right (_,(S [P [V v3]],_,_)),_) - | v1 == v3 -> Right (Left r) - | v2 == v3 -> Right (Right r) - (Right (_,(_,S [P [V v3]],_)),_) - | v1 == v3 -> Right (Left r) - | v2 == v3 -> Right (Right r) - _ -> Left r - matchesVarEq _ _ = error "internal error" - - swapVar (Left (ct,S [P [V v1]], S [P [V v2]]),ps) = - (Left (ct,S [P [V v2]], S [P [V v1]]),ps) - swapVar _ = error "internal error" - - findFirstSimpliedWanted (Impossible e) _ = Impossible e - findFirstSimpliedWanted (Simplified evs) s2 - | any (isWantedCt . snd . fst) evs - = Simplified evs - | otherwise - = s2 - --- If we allow negated numbers we simply do not emit the inequalities --- derived from the subtractions that are converted to additions with a --- negated operand -subToPred :: Opts -> TyCon -> [(Type, Type)] -> [PredType] -subToPred Opts{..} leqT - | negNumbers = const [] - | otherwise = map leq - where - leq (a,b) = - let lhs = TyConApp leqT [naturalTy,b,a] - rhs = TyConApp (cTupleTyCon 0) [] - in mkPrimEqPred lhs rhs - --- Extract the Nat equality constraints -toNatEquality :: (TyCon,TyCon,TyCon) -> Ct -> Maybe (Either NatEquality NatInEquality,[(Type,Type)]) -toNatEquality (_,assertT,ordCond) ct = case classifyPredType $ ctEvPred $ ctEvidence ct of - EqPred NomEq t1 t2 - -> go t1 t2 - IrredPred p - -> go2 p - _ -> Nothing - where - go (TyConApp tc xs) (TyConApp tc' ys) - | tc == tc' - , null ([tc,tc'] `intersect` [typeNatAddTyCon,typeNatSubTyCon - ,typeNatMulTyCon,typeNatExpTyCon]) - = case filter (not . uncurry eqType) (zip xs ys) of - [(x,y)] - | isNatKind (typeKind x) - , isNatKind (typeKind y) - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - -> Just (Left (ct, x', y'),k1 ++ k2) - _ -> Nothing - | tc == ordCond - , [_,cmp,lt,eq,gt] <- xs - , TyConApp tcCmpNat [x,y] <- cmp - , tcCmpNat == typeNatCmpTyCon - , TyConApp ltTc [] <- lt - , ltTc == promotedTrueDataCon - , TyConApp eqTc [] <- eq - , eqTc == promotedTrueDataCon - , TyConApp gtTc [] <- gt - , gtTc == promotedFalseDataCon - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - , let ks = k1 ++ k2 - = case tc' of - _ | tc' == promotedTrueDataCon - -> Just (Right (ct, (x', y', True)), ks) - _ | tc' == promotedFalseDataCon - -> Just (Right (ct, (x', y', False)), ks) - _ -> Nothing - | tc == assertT - , tc' == (cTupleTyCon 0) - , [] <- ys - , [TyConApp ordCondTc zs, _] <- xs - , ordCondTc == ordCond - , [_,cmp,lt,eq,gt] <- zs - , TyConApp tcCmpNat [x,y] <- cmp - , tcCmpNat == typeNatCmpTyCon - , TyConApp ltTc [] <- lt - , ltTc == promotedTrueDataCon - , TyConApp eqTc [] <- eq - , eqTc == promotedTrueDataCon - , TyConApp gtTc [] <- gt - , gtTc == promotedFalseDataCon - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - , let ks = k1 ++ k2 - = Just (Right (ct, (x', y', True)), ks) - - go x y - | isNatKind (typeKind x) - , isNatKind (typeKind y) - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - = Just (Left (ct,x',y'),k1 ++ k2) - | otherwise - = Nothing - - go2 (TyConApp tc ys) - | tc == assertT - , [TyConApp ordCondTc xs, _] <- ys - , ordCondTc == ordCond - , [_,cmp,lt,eq,gt] <- xs - , TyConApp tcCmpNat [x,y] <- cmp - , tcCmpNat == typeNatCmpTyCon - , TyConApp ltTc [] <- lt - , ltTc == promotedTrueDataCon - , TyConApp eqTc [] <- eq - , eqTc == promotedTrueDataCon - , TyConApp gtTc [] <- gt - , gtTc == promotedFalseDataCon - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - , let ks = k1 ++ k2 - = Just (Right (ct, (x', y', True)), ks) - - go2 _ = Nothing - - isNatKind :: Kind -> Bool - isNatKind = (`eqType` naturalTy) - -unifyItemToPredType :: CoreUnify -> PredType -unifyItemToPredType ui = mkPrimEqPred ty1 ty2 - where - ty1 = case ui of - SubstItem {..} -> mkTyVarTy siVar - UnifyItem {..} -> reifySOP siLHS - ty2 = case ui of - SubstItem {..} -> reifySOP siSOP - UnifyItem {..} -> reifySOP siRHS - -evSubtPreds :: CtLoc -> [PredType] -> TcPluginM [Ct] -evSubtPreds loc = mapM (fmap mkNonCanonical . newWanted loc) - -evMagic :: Ct -> Set CType -> [PredType] -> TcPluginM (Maybe ((EvTerm, Ct), [Ct])) -evMagic ct knW preds = do - holeWanteds <- evSubtPreds (ctLoc ct) preds - knWanted <- mapM (mkKnWanted (ctLoc ct)) (toList knW) - let newWant = knWanted ++ holeWanteds - case classifyPredType $ ctEvPred $ ctEvidence ct of - EqPred NomEq t1 t2 -> - let ctEv = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Nominal t1 t2 - in return (Just ((EvExpr (Coercion ctEv), ct),newWant)) - IrredPred p -> - let t1 = mkTyConApp (cTupleTyCon 0) [] - co = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Representational t1 p - dcApp = evId (dataConWrapId (cTupleDataCon 0)) - in return (Just ((evCast dcApp co, ct),newWant)) - _ -> return Nothing - -mkNonCanonical' :: CtLoc -> CtEvidence -> Ct -mkNonCanonical' origCtl ev = - let ct_ls = ctLocSpan origCtl - ctl = ctEvLoc ev - in mkNonCanonical (setCtEvLoc ev (setCtLocSpan ctl ct_ls)) - -mkKnWanted - :: CtLoc - -> CType - -> TcPluginM Ct -mkKnWanted loc (CType ty) = do - kc_clas <- tcLookupClass knownNatClassName - let kn_pred = mkClassPred kc_clas [ty] - wantedCtEv <- newWanted loc kn_pred - let wanted' = mkNonCanonical' loc wantedCtEv - return wanted' +{-|+Copyright : (C) 2015-2016, University of Twente,+ 2017 , QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>++A type checker plugin for GHC that can solve /equalities/ of types of kind+'GHC.TypeLits.Nat', where these types are either:++* Type-level naturals+* Type variables+* Applications of the arithmetic expressions @(+,-,*,^)@.++It solves these equalities by normalising them to /sort-of/+'GHC.TypeLits.Normalise.SOP.SOP' (Sum-of-Products) form, and then perform a+simple syntactic equality.++For example, this solver can prove the equality between:++@+(x + 2)^(y + 2)+@++and++@+4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2+@++Because the latter is actually the 'GHC.TypeLits.Normalise.SOP.SOP' normal form+of the former.++To use the plugin, add++@+{\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\}+@++To the header of your file.++== Treating subtraction as addition with a negated number++If you are absolutely sure that your subtractions can /never/ lead to (a locally)+negative number, you can ask the plugin to treat subtraction as addition with+a negated operand by additionally adding:++@+{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\}+@++to the header of your file, thereby allowing to use associativity and+commutativity rules when proving constraints involving subtractions. Note that+this option can lead to unsound behaviour and should be handled with extreme+care.++=== When it leads to unsound behaviour++For example, enabling the /allow-negated-numbers/ feature would allow+you to prove:++@+(n - 1) + 1 ~ n+@++/without/ a @(1 <= n)@ constraint, even though when /n/ is set to /0/ the+subtraction @n-1@ would be locally negative and hence not be a natural number.++This would allow the following erroneous definition:++@+data Fin (n :: Nat) where+ FZ :: Fin (n + 1)+ FS :: Fin n -> Fin (n + 1)++f :: forall n . Natural -> Fin n+f n = case of+ 0 -> FZ+ x -> FS (f \@(n-1) (x - 1))++fs :: [Fin 0]+fs = f \<$\> [0..]+@++=== When it might be Okay++This example is taken from the <http://hackage.haskell.org/package/mezzo mezzo>+library.++When you have:++@+-- | Singleton type for the number of repetitions of an element.+data Times (n :: Nat) where+ T :: Times n++-- | An element of a "run-length encoded" vector, containing the value and+-- the number of repetitions+data Elem :: Type -> Nat -> Type where+ (:*) :: t -> Times n -> Elem t n++-- | A length-indexed vector, optimised for repetitions.+data OptVector :: Type -> Nat -> Type where+ End :: OptVector t 0+ (:-) :: Elem t l -> OptVector t (n - l) -> OptVector t n+@++And you want to define:++@+-- | Append two optimised vectors.+type family (x :: OptVector t n) ++ (y :: OptVector t m) :: OptVector t (n + m) where+ ys ++ End = ys+ End ++ ys = ys+ (x :- xs) ++ ys = x :- (xs ++ ys)+@++then the last line will give rise to the constraint:++@+(n-l)+m ~ (n+m)-l+@++because:++@+x :: Elem t l+xs :: OptVector t (n-l)+ys :: OptVector t m+@++In this case it's okay to add++@+{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\}+@++if you can convince yourself you will never be able to construct a:++@+xs :: OptVector t (n-l)+@++where /n-l/ is a negative number.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module GHC.TypeLits.Normalise+ ( plugin )+where++-- external+import Control.Arrow (second)+import Control.Monad ((<=<), forM)+import Control.Monad.Trans.Writer.Strict+import Data.Either (partitionEithers, rights)+import Data.IORef+import Data.List (intersect, partition, stripPrefix, find)+import Data.Maybe (mapMaybe, catMaybes)+import Data.Set (Set, empty, toList, notMember, fromList, union)+import Text.Read (readMaybe)+import qualified Data.Type.Ord+import qualified GHC.TypeError++import GHC.TcPluginM.Extra (tracePlugin, newGiven, newWanted)++-- GHC API+import GHC.Builtin.Names (knownNatClassName, eqTyConKey, heqTyConKey, hasKey)+import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon)+import GHC.Builtin.Types.Literals+ (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon)+import GHC.Builtin.Types (naturalTy, cTupleDataCon, cTupleTyCon)+import GHC.Builtin.Types.Literals (typeNatCmpTyCon)+import GHC.Core (Expr (..))+import GHC.Core.Class (className)+import GHC.Core.Coercion (Role (..), mkUnivCo)+import GHC.Core.DataCon (dataConWrapId)+import GHC.Core.Predicate+ (EqRel (NomEq), Pred (EqPred, IrredPred), classifyPredType, mkClassPred,+ mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe)+import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..))+import GHC.Core.TyCon (TyCon)+#if MIN_VERSION_ghc(9,6,0)+import GHC.Core.Type+ (Kind, PredType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp)+import GHC.Core.TyCo.Compare+ (eqType)+#else+import GHC.Core.Type+ (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp)+#endif+import GHC.Data.IOEnv (getEnv)+import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin)+import GHC.Plugins (thNameToGhcNameIO, HscEnv (hsc_NC))+import GHC.Tc.Plugin+ (TcPluginM, tcLookupClass, tcPluginTrace, tcPluginIO, newEvVar)+import GHC.Tc.Plugin (tcLookupTyCon, unsafeTcPluginTcM)+import GHC.Tc.Types (TcPlugin (..), TcPluginSolveResult(..), Env (env_top))+import GHC.Tc.Types.Constraint+ (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence,+ ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLocSpan,+ isWantedCt, ctEvLoc, ctEvPred, ctEvExpr, emptyRewriterSet, setCtEvLoc)+import GHC.Tc.Types.Evidence (EvBindsVar, EvTerm (..), evCast, evId)+import GHC.Types.Unique.FM (emptyUFM)+import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text)+import GHC (Name)++-- template-haskell+import qualified Language.Haskell.TH as TH++-- internal+import GHC.TypeLits.Normalise.SOP+import GHC.TypeLits.Normalise.Unify hiding (subtractionToPred)++isEqPredClass :: PredType -> Bool+isEqPredClass ty = case tyConAppTyCon_maybe ty of+ Just tc -> tc `hasKey` eqTyConKey || tc `hasKey` heqTyConKey+ _ -> False++-- | To use the plugin, add+--+-- @+-- {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\}+-- @+--+-- To the header of your file.+plugin :: Plugin+plugin+ = defaultPlugin+ { tcPlugin = fmap (normalisePlugin . foldr id defaultOpts) . traverse parseArgument+ , pluginRecompile = purePlugin+ }+ where+ parseArgument "allow-negated-numbers" = Just (\ opts -> opts { negNumbers = True })+ parseArgument (readMaybe <=< stripPrefix "depth=" -> Just depth) = Just (\ opts -> opts { depth })+ parseArgument _ = Nothing+ defaultOpts = Opts { negNumbers = False, depth = 5 }++data Opts = Opts { negNumbers :: Bool, depth :: Word }++normalisePlugin :: Opts -> TcPlugin+normalisePlugin opts = tracePlugin "ghc-typelits-natnormalise"+ TcPlugin { tcPluginInit = lookupExtraDefs+ , tcPluginSolve = decideEqualSOP opts+ , tcPluginRewrite = const emptyUFM+ , tcPluginStop = const (return ())+ }++type ExtraDefs = (IORef (Set CType), (TyCon,TyCon,TyCon))++lookupExtraDefs :: TcPluginM ExtraDefs+lookupExtraDefs = do+ ref <- tcPluginIO (newIORef empty)+ ordCond <- lookupTHName ''Data.Type.Ord.OrdCond >>= tcLookupTyCon+ leqT <- lookupTHName ''(Data.Type.Ord.<=) >>= tcLookupTyCon+ assertT <- lookupTHName ''GHC.TypeError.Assert >>= tcLookupTyCon+ return (ref, (leqT,assertT,ordCond))++lookupTHName :: TH.Name -> TcPluginM Name+lookupTHName th = do+ nc <- unsafeTcPluginTcM (hsc_NC . env_top <$> getEnv)+ res <- tcPluginIO $ thNameToGhcNameIO nc th+ maybe (fail $ "Failed to lookup " ++ show th) return res++decideEqualSOP+ :: Opts+ -> ExtraDefs+ -- ^ 1. Givens that is already generated.+ -- We have to generate new givens at most once;+ -- otherwise GHC will loop indefinitely.+ --+ --+ -- 2. For GHc 9.2: TyCon of Data.Type.Ord.OrdCond+ -- For older: TyCon of GHC.TypeLits.<=?+ -> EvBindsVar+ -> [Ct]+ -> [Ct]+ -> TcPluginM TcPluginSolveResult++-- Simplification phase: Derives /simplified/ givens;+-- we can reduce given constraints like @Show (Foo (n + 2))@+-- to its normal form @Show (Foo (2 + n))@, which is eventually+-- useful in solving phase.+--+-- This helps us to solve /indirect/ constraints;+-- without this phase, we cannot derive, e.g.,+-- @IsVector UVector (Fin (n + 1))@ from+-- @Unbox (1 + n)@!+decideEqualSOP opts (gen'd,(leqT,_,_)) ev givens [] = do+ done <- tcPluginIO $ readIORef gen'd+ let reds =+ filter (\(_,(_,_,v)) -> null v || negNumbers opts) $+ reduceGivens opts leqT done givens+ newlyDone = map (\(_,(prd, _,_)) -> CType prd) reds+ tcPluginIO $+ modifyIORef' gen'd $ union (fromList newlyDone)+ newGivens <- forM reds $ \(origCt, (pred', evTerm, _)) ->+ mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm+ return (TcPluginOk [] newGivens)++-- Solving phase.+-- Solves in/equalities on Nats and simplifiable constraints+-- containing naturals.+decideEqualSOP opts (gen'd,tcs@(leqT,_,_)) ev givens wanteds = do+ let unit_wanteds = mapMaybe (toNatEquality tcs) wanteds+ nonEqs = filter ( not+ . (\p -> isEqPred p || isEqPrimPred p)+ . ctEvPred+ . ctEvidence )+ wanteds+ done <- tcPluginIO $ readIORef gen'd+ let redGs = reduceGivens opts leqT done givens+ newlyDone = map (\(_,(prd, _,_)) -> CType prd) redGs+ redGivens <- forM redGs $ \(origCt, (pred', evTerm, _)) ->+ mkNonCanonical' (ctLoc origCt) <$> newGiven ev (ctLoc origCt) pred' evTerm+ reducible_wanteds+ <- catMaybes <$> mapM (\ct -> fmap (ct,) <$>+ reduceNatConstr (givens ++ redGivens) ct)+ nonEqs+ if null unit_wanteds && null reducible_wanteds+ then return $ TcPluginOk [] []+ else do+ -- Since reducible wanteds also can have some negation/subtraction+ -- subterms, we have to make sure appropriate inequalities to hold.+ -- Here, we generate such additional inequalities for reduction+ -- that is to be added to new [W]anteds.+ ineqForRedWants <- fmap concat $ forM redGs $ \(ct, (_,_, ws)) -> forM ws $+ fmap (mkNonCanonical' (ctLoc ct)) . newWanted (ctLoc ct)+ tcPluginIO $+ modifyIORef' gen'd $ union (fromList newlyDone)+ let unit_givens = mapMaybe+ (toNatEquality tcs)+ givens+ sr <- simplifyNats opts leqT unit_givens unit_wanteds+ tcPluginTrace "normalised" (ppr sr)+ reds <- forM reducible_wanteds $ \(origCt,(term, ws, wDicts)) -> do+ wants <- evSubtPreds (ctLoc origCt) $ subToPred opts leqT ws+ return ((term, origCt), wDicts ++ wants)+ case sr of+ Simplified evs -> do+ let simpld = filter (not . isGiven . ctEvidence . (\((_,x),_) -> x)) evs+ -- Only solve derived when we solved a wanted+ simpld1 = case filter (isWanted . ctEvidence . (\((_,x),_) -> x)) evs ++ reds of+ [] -> []+ _ -> simpld+ (solved',newWanteds) = second concat (unzip $ simpld1 ++ reds)+ return (TcPluginOk solved' $ newWanteds ++ ineqForRedWants)+ Impossible eq -> return (TcPluginContradiction [fromNatEquality eq])++type NatEquality = (Ct,CoreSOP,CoreSOP)+type NatInEquality = (Ct,(CoreSOP,CoreSOP,Bool))++reduceGivens :: Opts -> TyCon -> Set CType -> [Ct] -> [(Ct, (Type, EvTerm, [PredType]))]+reduceGivens opts leqT done givens =+ let nonEqs =+ [ ct+ | ct <- givens+ , let ev = ctEvidence ct+ prd = ctEvPred ev+ , isGiven ev+ , not $ (\p -> isEqPred p || isEqPrimPred p || isEqPredClass p) prd+ ]+ in filter+ (\(_, (prd, _, _)) ->+ notMember (CType prd) done+ )+ $ mapMaybe+ (\ct -> (ct,) <$> tryReduceGiven opts leqT givens ct)+ nonEqs++tryReduceGiven+ :: Opts -> TyCon -> [Ct] -> Ct+ -> Maybe (PredType, EvTerm, [PredType])+tryReduceGiven opts leqT simplGivens ct = do+ let (mans, ws) =+ runWriter $ normaliseNatEverywhere $+ ctEvPred $ ctEvidence ct+ ws' = [ p+ | p <- subToPred opts leqT ws+ , all (not . (`eqType` p). ctEvPred . ctEvidence) simplGivens+ ]+ pred' <- mans+ return (pred', toReducedDict (ctEvidence ct) pred', ws')++fromNatEquality :: Either NatEquality NatInEquality -> Ct+fromNatEquality (Left (ct, _, _)) = ct+fromNatEquality (Right (ct, _)) = ct++reduceNatConstr :: [Ct] -> Ct -> TcPluginM (Maybe (EvTerm, [(Type, Type)], [Ct]))+reduceNatConstr givens ct = do+ let pred0 = ctEvPred $ ctEvidence ct+ (mans, tests) = runWriter $ normaliseNatEverywhere pred0+ case mans of+ Nothing -> return Nothing+ Just pred' -> do+ case find ((`eqType` pred') .ctEvPred . ctEvidence) givens of+ -- No existing evidence found+ Nothing -> case getClassPredTys_maybe pred' of+ -- Are we trying to solve a class instance?+ Just (cls,_) | className cls /= knownNatClassName -> do+ -- Create new evidence binding for normalized class constraint+ evVar <- newEvVar pred'+ -- Bind the evidence to a new wanted normalized class constraint+ let wDict = mkNonCanonical+ (CtWanted pred' (EvVarDest evVar) (ctLoc ct) emptyRewriterSet)+ -- Evidence for current wanted is simply the coerced binding for+ -- the new binding+ evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise")+ Representational+ pred' pred0+ ev = evId evVar `evCast` evCo+ -- Use newly created coerced wanted as evidence, and emit the+ -- normalized wanted as a new constraint to solve.+ return (Just (ev, tests, [wDict]))+ _ -> return Nothing+ -- Use existing evidence+ Just c -> return (Just (toReducedDict (ctEvidence c) pred0, tests, []))++toReducedDict :: CtEvidence -> PredType -> EvTerm+toReducedDict ct pred' =+ let pred0 = ctEvPred ct+ evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise")+ Representational+ pred0 pred'+ ev = ctEvExpr ct+ `evCast` evCo+ in ev++data SimplifyResult+ = Simplified [((EvTerm,Ct),[Ct])]+ | Impossible (Either NatEquality NatInEquality)++instance Outputable SimplifyResult where+ ppr (Simplified evs) = text "Simplified" $$ ppr evs+ ppr (Impossible eq) = text "Impossible" <+> ppr eq++simplifyNats+ :: Opts+ -- ^ Allow negated numbers (potentially unsound!)+ -> TyCon+ -- * TyCon of Data.Type.Ord.<=+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -- ^ Given constraints+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -- ^ Wanted constraints+ -> TcPluginM SimplifyResult+simplifyNats opts@Opts {..} leqT eqsG eqsW = do+ let eqsG1 = map (second (const ([] :: [(Type,Type)]))) eqsG+ (varEqs,otherEqs) = partition isVarEqs eqsG1+ fancyGivens = concatMap (makeGivensSet otherEqs) varEqs+ case varEqs of+ [] -> do+ let eqs = otherEqs ++ eqsW+ tcPluginTrace "simplifyNats" (ppr eqs)+ simples [] [] [] [] eqs+ _ -> do+ tcPluginTrace ("simplifyNats(backtrack: " ++ show (length fancyGivens) ++ ")")+ (ppr varEqs)++ allSimplified <- forM fancyGivens $ \v -> do+ let eqs = v ++ eqsW+ tcPluginTrace "simplifyNats" (ppr eqs)+ simples [] [] [] [] eqs++ pure (foldr findFirstSimpliedWanted (Simplified []) allSimplified)+ where+ simples :: [CoreUnify]+ -> [((EvTerm, Ct), [Ct])]+ -> [(CoreSOP,CoreSOP,Bool)]+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -> TcPluginM SimplifyResult+ simples _subst evs _leqsG _xs [] = return (Simplified evs)+ simples subst evs leqsG xs (eq@(Left (ct,u,v),k):eqs') = do+ let u' = substsSOP subst u+ v' = substsSOP subst v+ ur <- unifyNats ct u' v'+ tcPluginTrace "unifyNats result" (ppr ur)+ case ur of+ Win -> do+ evs' <- maybe evs (:evs) <$> evMagic ct empty (subToPred opts leqT k)+ simples subst evs' leqsG [] (xs ++ eqs')+ Lose -> if null evs && null eqs'+ then return (Impossible (fst eq))+ else simples subst evs leqsG xs eqs'+ Draw [] -> simples subst evs [] (eq:xs) eqs'+ Draw subst' -> do+ evM <- evMagic ct empty (map unifyItemToPredType subst' +++ subToPred opts leqT k)+ let leqsG' | isGiven (ctEvidence ct) = eqToLeq u' v' ++ leqsG+ | otherwise = leqsG+ case evM of+ Nothing -> simples subst evs leqsG' xs eqs'+ Just ev ->+ simples (substsSubst subst' subst ++ subst')+ (ev:evs) leqsG' [] (xs ++ eqs')+ simples subst evs leqsG xs (eq@(Right (ct,u@(x,y,b)),k):eqs') = do+ let u' = substsSOP subst (subtractIneq u)+ x' = substsSOP subst x+ y' = substsSOP subst y+ uS = (x',y',b)+ leqsG' | isGiven (ctEvidence ct) = (x',y',b):leqsG+ | otherwise = leqsG+ ineqs = concat [ leqsG+ , map (substLeq subst) leqsG+ , map snd (rights (map fst eqsG))+ ]+ tcPluginTrace "unifyNats(ineq) results" (ppr (ct,u,u',ineqs))+ case runWriterT (isNatural u') of+ Just (True,knW) -> do+ evs' <- maybe evs (:evs) <$> evMagic ct knW (subToPred opts leqT k)+ simples subst evs' leqsG' xs eqs'++ Just (False,_) | null k -> return (Impossible (fst eq))+ _ -> do+ let solvedIneq = mapMaybe runWriterT+ -- it is an inequality that can be instantly solved, such as+ -- `1 <= x^y`+ -- OR+ (instantSolveIneq depth u:+ instantSolveIneq depth uS:+ -- This inequality is either a given constraint, or it is a wanted+ -- constraint, which in normal form is equal to another given+ -- constraint, hence it can be solved.+ -- OR+ map (solveIneq depth u) ineqs +++ -- The above, but with valid substitutions applied to the wanted.+ map (solveIneq depth uS) ineqs)+ smallest = solvedInEqSmallestConstraint solvedIneq+ case smallest of+ (True,kW) -> do+ evs' <- maybe evs (:evs) <$> evMagic ct kW (subToPred opts leqT k)+ simples subst evs' leqsG' xs eqs'+ _ -> simples subst evs leqsG (eq:xs) eqs'++ eqToLeq x y = [(x,y,True),(y,x,True)]+ substLeq s (x,y,b) = (substsSOP s x, substsSOP s y, b)++ isVarEqs (Left (_,S [P [V _]], S [P [V _]]), _) = True+ isVarEqs _ = False++ makeGivensSet otherEqs varEq+ = let (noMentionsV,mentionsV) = partitionEithers+ (map (matchesVarEq varEq) otherEqs)+ (mentionsLHS,mentionsRHS) = partitionEithers mentionsV+ vS = swapVar varEq+ givensLHS = case mentionsLHS of+ [] -> []+ _ -> [mentionsLHS ++ ((varEq:mentionsRHS) ++ noMentionsV)]+ givensRHS = case mentionsRHS of+ [] -> []+ _ -> [mentionsRHS ++ (vS:mentionsLHS ++ noMentionsV)]+ in case mentionsV of+ [] -> [noMentionsV]+ _ -> givensLHS ++ givensRHS++ matchesVarEq (Left (_, S [P [V v1]], S [P [V v2]]),_) r = case r of+ (Left (_,S [P [V v3]],_),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Left (_,_,S [P [V v3]]),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Right (_,(S [P [V v3]],_,_)),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Right (_,(_,S [P [V v3]],_)),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ _ -> Left r+ matchesVarEq _ _ = error "internal error"++ swapVar (Left (ct,S [P [V v1]], S [P [V v2]]),ps) =+ (Left (ct,S [P [V v2]], S [P [V v1]]),ps)+ swapVar _ = error "internal error"++ findFirstSimpliedWanted (Impossible e) _ = Impossible e+ findFirstSimpliedWanted (Simplified evs) s2+ | any (isWantedCt . snd . fst) evs+ = Simplified evs+ | otherwise+ = s2++-- If we allow negated numbers we simply do not emit the inequalities+-- derived from the subtractions that are converted to additions with a+-- negated operand+subToPred :: Opts -> TyCon -> [(Type, Type)] -> [PredType]+subToPred Opts{..} leqT+ | negNumbers = const []+ | otherwise = map leq+ where+ leq (a,b) =+ let lhs = TyConApp leqT [naturalTy,b,a]+ rhs = TyConApp (cTupleTyCon 0) []+ in mkPrimEqPred lhs rhs++-- Extract the Nat equality constraints+toNatEquality :: (TyCon,TyCon,TyCon) -> Ct -> Maybe (Either NatEquality NatInEquality,[(Type,Type)])+toNatEquality (_,assertT,ordCond) ct = case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 t2+ -> go t1 t2+ IrredPred p+ -> go2 p+ _ -> Nothing+ where+ go (TyConApp tc xs) (TyConApp tc' ys)+ | tc == tc'+ , null ([tc,tc'] `intersect` [typeNatAddTyCon,typeNatSubTyCon+ ,typeNatMulTyCon,typeNatExpTyCon])+ = case filter (not . uncurry eqType) (zip xs ys) of+ [(x,y)]+ | isNatKind (typeKind x)+ , isNatKind (typeKind y)+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ -> Just (Left (ct, x', y'),k1 ++ k2)+ _ -> Nothing+ | tc == ordCond+ , [_,cmp,lt,eq,gt] <- xs+ , TyConApp tcCmpNat [x,y] <- cmp+ , tcCmpNat == typeNatCmpTyCon+ , TyConApp ltTc [] <- lt+ , ltTc == promotedTrueDataCon+ , TyConApp eqTc [] <- eq+ , eqTc == promotedTrueDataCon+ , TyConApp gtTc [] <- gt+ , gtTc == promotedFalseDataCon+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ , let ks = k1 ++ k2+ = case tc' of+ _ | tc' == promotedTrueDataCon+ -> Just (Right (ct, (x', y', True)), ks)+ _ | tc' == promotedFalseDataCon+ -> Just (Right (ct, (x', y', False)), ks)+ _ -> Nothing+ | tc == assertT+ , tc' == (cTupleTyCon 0)+ , [] <- ys+ , [TyConApp ordCondTc zs, _] <- xs+ , ordCondTc == ordCond+ , [_,cmp,lt,eq,gt] <- zs+ , TyConApp tcCmpNat [x,y] <- cmp+ , tcCmpNat == typeNatCmpTyCon+ , TyConApp ltTc [] <- lt+ , ltTc == promotedTrueDataCon+ , TyConApp eqTc [] <- eq+ , eqTc == promotedTrueDataCon+ , TyConApp gtTc [] <- gt+ , gtTc == promotedFalseDataCon+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ , let ks = k1 ++ k2+ = Just (Right (ct, (x', y', True)), ks)++ go x y+ | isNatKind (typeKind x)+ , isNatKind (typeKind y)+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ = Just (Left (ct,x',y'),k1 ++ k2)+ | otherwise+ = Nothing++ go2 (TyConApp tc ys)+ | tc == assertT+ , [TyConApp ordCondTc xs, _] <- ys+ , ordCondTc == ordCond+ , [_,cmp,lt,eq,gt] <- xs+ , TyConApp tcCmpNat [x,y] <- cmp+ , tcCmpNat == typeNatCmpTyCon+ , TyConApp ltTc [] <- lt+ , ltTc == promotedTrueDataCon+ , TyConApp eqTc [] <- eq+ , eqTc == promotedTrueDataCon+ , TyConApp gtTc [] <- gt+ , gtTc == promotedFalseDataCon+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ , let ks = k1 ++ k2+ = Just (Right (ct, (x', y', True)), ks)++ go2 _ = Nothing++ isNatKind :: Kind -> Bool+ isNatKind = (`eqType` naturalTy)++unifyItemToPredType :: CoreUnify -> PredType+unifyItemToPredType ui = mkPrimEqPred ty1 ty2+ where+ ty1 = case ui of+ SubstItem {..} -> mkTyVarTy siVar+ UnifyItem {..} -> reifySOP siLHS+ ty2 = case ui of+ SubstItem {..} -> reifySOP siSOP+ UnifyItem {..} -> reifySOP siRHS++evSubtPreds :: CtLoc -> [PredType] -> TcPluginM [Ct]+evSubtPreds loc = mapM (fmap mkNonCanonical . newWanted loc)++evMagic :: Ct -> Set CType -> [PredType] -> TcPluginM (Maybe ((EvTerm, Ct), [Ct]))+evMagic ct knW preds = do+ holeWanteds <- evSubtPreds (ctLoc ct) preds+ knWanted <- mapM (mkKnWanted (ctLoc ct)) (toList knW)+ let newWant = knWanted ++ holeWanteds+ case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 t2 ->+ let ctEv = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Nominal t1 t2+ in return (Just ((EvExpr (Coercion ctEv), ct),newWant))+ IrredPred p ->+ let t1 = mkTyConApp (cTupleTyCon 0) []+ co = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Representational t1 p+ dcApp = evId (dataConWrapId (cTupleDataCon 0))+ in return (Just ((evCast dcApp co, ct),newWant))+ _ -> return Nothing++mkNonCanonical' :: CtLoc -> CtEvidence -> Ct+mkNonCanonical' origCtl ev =+ let ct_ls = ctLocSpan origCtl+ ctl = ctEvLoc ev+ in mkNonCanonical (setCtEvLoc ev (setCtLocSpan ctl ct_ls))++mkKnWanted+ :: CtLoc+ -> CType+ -> TcPluginM Ct+mkKnWanted loc (CType ty) = do+ kc_clas <- tcLookupClass knownNatClassName+ let kn_pred = mkClassPred kc_clas [ty]+ wantedCtEv <- newWanted loc kn_pred+ let wanted' = mkNonCanonical' loc wantedCtEv+ return wanted'
src-pre-ghc-9.4/GHC/TypeLits/Normalise.hs view
@@ -1,862 +1,862 @@-{-| -Copyright : (C) 2015-2016, University of Twente, - 2017 , QBayLogic B.V. -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> - -A type checker plugin for GHC that can solve /equalities/ of types of kind -'GHC.TypeLits.Nat', where these types are either: - -* Type-level naturals -* Type variables -* Applications of the arithmetic expressions @(+,-,*,^)@. - -It solves these equalities by normalising them to /sort-of/ -'GHC.TypeLits.Normalise.SOP.SOP' (Sum-of-Products) form, and then perform a -simple syntactic equality. - -For example, this solver can prove the equality between: - -@ -(x + 2)^(y + 2) -@ - -and - -@ -4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 -@ - -Because the latter is actually the 'GHC.TypeLits.Normalise.SOP.SOP' normal form -of the former. - -To use the plugin, add - -@ -{\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} -@ - -To the header of your file. - -== Treating subtraction as addition with a negated number - -If you are absolutely sure that your subtractions can /never/ lead to (a locally) -negative number, you can ask the plugin to treat subtraction as addition with -a negated operand by additionally adding: - -@ -{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} -@ - -to the header of your file, thereby allowing to use associativity and -commutativity rules when proving constraints involving subtractions. Note that -this option can lead to unsound behaviour and should be handled with extreme -care. - -=== When it leads to unsound behaviour - -For example, enabling the /allow-negated-numbers/ feature would allow -you to prove: - -@ -(n - 1) + 1 ~ n -@ - -/without/ a @(1 <= n)@ constraint, even though when /n/ is set to /0/ the -subtraction @n-1@ would be locally negative and hence not be a natural number. - -This would allow the following erroneous definition: - -@ -data Fin (n :: Nat) where - FZ :: Fin (n + 1) - FS :: Fin n -> Fin (n + 1) - -f :: forall n . Natural -> Fin n -f n = case of - 0 -> FZ - x -> FS (f \@(n-1) (x - 1)) - -fs :: [Fin 0] -fs = f \<$\> [0..] -@ - -=== When it might be Okay - -This example is taken from the <http://hackage.haskell.org/package/mezzo mezzo> -library. - -When you have: - -@ --- | Singleton type for the number of repetitions of an element. -data Times (n :: Nat) where - T :: Times n - --- | An element of a "run-length encoded" vector, containing the value and --- the number of repetitions -data Elem :: Type -> Nat -> Type where - (:*) :: t -> Times n -> Elem t n - --- | A length-indexed vector, optimised for repetitions. -data OptVector :: Type -> Nat -> Type where - End :: OptVector t 0 - (:-) :: Elem t l -> OptVector t (n - l) -> OptVector t n -@ - -And you want to define: - -@ --- | Append two optimised vectors. -type family (x :: OptVector t n) ++ (y :: OptVector t m) :: OptVector t (n + m) where - ys ++ End = ys - End ++ ys = ys - (x :- xs) ++ ys = x :- (xs ++ ys) -@ - -then the last line will give rise to the constraint: - -@ -(n-l)+m ~ (n+m)-l -@ - -because: - -@ -x :: Elem t l -xs :: OptVector t (n-l) -ys :: OptVector t m -@ - -In this case it's okay to add - -@ -{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\} -@ - -if you can convince yourself you will never be able to construct a: - -@ -xs :: OptVector t (n-l) -@ - -where /n-l/ is a negative number. --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module GHC.TypeLits.Normalise - ( plugin ) -where - --- external -import Control.Arrow (second) -import Control.Monad ((<=<), forM) -#if !MIN_VERSION_ghc(8,4,1) -import Control.Monad (replicateM) -#endif -import Control.Monad.Trans.Writer.Strict -import Data.Either (partitionEithers, rights) -import Data.IORef -import Data.List (intersect, partition, stripPrefix, find) -import Data.Maybe (mapMaybe, catMaybes) -import Data.Set (Set, empty, toList, notMember, fromList, union) -import GHC.TcPluginM.Extra (tracePlugin, newGiven, newWanted) -#if MIN_VERSION_ghc(9,2,0) -import GHC.TcPluginM.Extra (lookupModule, lookupName) -#endif -import qualified GHC.TcPluginM.Extra as TcPluginM -#if MIN_VERSION_ghc(8,4,0) -import GHC.TcPluginM.Extra (flattenGivens) -#endif -import Text.Read (readMaybe) - --- GHC API -#if MIN_VERSION_ghc(9,0,0) -import GHC.Builtin.Names (knownNatClassName, eqTyConKey, heqTyConKey, hasKey) -import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon) -import GHC.Builtin.Types.Literals - (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Builtin.Types (naturalTy) -import GHC.Builtin.Types.Literals (typeNatCmpTyCon) -#else -import GHC.Builtin.Types (typeNatKind) -import GHC.Builtin.Types.Literals (typeNatLeqTyCon) -#endif -import GHC.Core (Expr (..)) -import GHC.Core.Class (className) -import GHC.Core.Coercion (CoercionHole, Role (..), mkUnivCo) -import GHC.Core.Predicate - (EqRel (NomEq), Pred (EqPred), classifyPredType, getEqPredTys, mkClassPred, - mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe) -import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..)) -import GHC.Core.TyCon (TyCon) -import GHC.Core.Type - (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe, typeKind) -import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin) -import GHC.Tc.Plugin - (TcPluginM, newCoercionHole, tcLookupClass, tcPluginTrace, tcPluginIO, - newEvVar) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Tc.Plugin (tcLookupTyCon) -#endif -import GHC.Tc.Types (TcPlugin (..), TcPluginResult (..)) -import GHC.Tc.Types.Constraint - (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ShadowInfo (WDeriv), ctEvidence, - ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan, - isWantedCt, ctEvLoc, ctEvPred, ctEvExpr) -import GHC.Tc.Types.Evidence (EvTerm (..), evCast, evId) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Data.FastString (fsLit) -import GHC.Types.Name.Occurrence (mkTcOcc) -import GHC.Unit.Module (mkModuleName) -#endif -import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text) -#else -#if MIN_VERSION_ghc(8,5,0) -import CoreSyn (Expr (..)) -#endif -import Outputable (Outputable (..), (<+>), ($$), text) -import Plugins (Plugin (..), defaultPlugin) -#if MIN_VERSION_ghc(8,6,0) -import Plugins (purePlugin) -#endif -import PrelNames (hasKey, knownNatClassName) -import PrelNames (eqTyConKey, heqTyConKey) -import TcEvidence (EvTerm (..)) -#if MIN_VERSION_ghc(8,6,0) -import TcEvidence (evCast, evId) -#endif -#if !MIN_VERSION_ghc(8,4,0) -import TcPluginM (zonkCt) -#endif -import TcPluginM (TcPluginM, tcPluginTrace, tcPluginIO) -import Type - (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe) -import TysWiredIn (typeNatKind) - -import Coercion (CoercionHole, Role (..), mkUnivCo) -import Class (className) -import TcPluginM (newCoercionHole, tcLookupClass, newEvVar) -import TcRnTypes (TcPlugin (..), TcPluginResult(..)) -import TyCoRep (UnivCoProvenance (..)) -import TcType (isEqPred) -import TyCon (TyCon) -import TyCoRep (Type (..)) -import TcTypeNats (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, - typeNatSubTyCon) - -import TcTypeNats (typeNatLeqTyCon) -import TysWiredIn (promotedFalseDataCon, promotedTrueDataCon) - -#if MIN_VERSION_ghc(8,10,0) -import Constraint - (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence, ctEvLoc, ctEvPred, - ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan, - isWantedCt) -import Predicate - (EqRel (NomEq), Pred (EqPred), classifyPredType, getEqPredTys, mkClassPred, - mkPrimEqPred, getClassPredTys_maybe) -import Type (typeKind) -#else -import TcRnTypes - (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence, ctEvLoc, ctEvPred, - ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan, - isWantedCt) -import TcType (typeKind) -import Type - (EqRel (NomEq), PredTree (EqPred), classifyPredType, mkClassPred, mkPrimEqPred, - getClassPredTys_maybe) -#if MIN_VERSION_ghc(8,4,0) -import Type (getEqPredTys) -#endif -#endif - -#if MIN_VERSION_ghc(8,10,0) -import Constraint (ctEvExpr) -#elif MIN_VERSION_ghc(8,6,0) -import TcRnTypes (ctEvExpr) -#else -import TcRnTypes (ctEvTerm) -#endif - -#if MIN_VERSION_ghc(8,2,0) -#if MIN_VERSION_ghc(8,10,0) -import Constraint (ShadowInfo (WDeriv)) -#else -import TcRnTypes (ShadowInfo (WDeriv)) -#endif -#endif - -#if MIN_VERSION_ghc(8,10,0) -import TcType (isEqPrimPred) -#endif -#endif - --- internal -import GHC.TypeLits.Normalise.SOP -import GHC.TypeLits.Normalise.Unify - -#if MIN_VERSION_ghc(9,2,0) -typeNatKind :: Type -typeNatKind = naturalTy -#endif - -#if !MIN_VERSION_ghc(8,10,0) -isEqPrimPred :: PredType -> Bool -isEqPrimPred = isEqPred -#endif - -isEqPredClass :: PredType -> Bool -isEqPredClass ty = case tyConAppTyCon_maybe ty of - Just tc -> tc `hasKey` eqTyConKey || tc `hasKey` heqTyConKey - _ -> False - --- | To use the plugin, add --- --- @ --- {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\} --- @ --- --- To the header of your file. -plugin :: Plugin -plugin - = defaultPlugin - { tcPlugin = fmap (normalisePlugin . foldr id defaultOpts) . traverse parseArgument -#if MIN_VERSION_ghc(8,6,0) - , pluginRecompile = purePlugin -#endif - } - where - parseArgument "allow-negated-numbers" = Just (\ opts -> opts { negNumbers = True }) - parseArgument (readMaybe <=< stripPrefix "depth=" -> Just depth) = Just (\ opts -> opts { depth }) - parseArgument _ = Nothing - defaultOpts = Opts { negNumbers = False, depth = 5 } - -data Opts = Opts { negNumbers :: Bool, depth :: Word } - -normalisePlugin :: Opts -> TcPlugin -normalisePlugin opts = tracePlugin "ghc-typelits-natnormalise" - TcPlugin { tcPluginInit = lookupExtraDefs - , tcPluginSolve = decideEqualSOP opts - , tcPluginStop = const (return ()) - } -newtype OrigCt = OrigCt { runOrigCt :: Ct } - -type ExtraDefs = (IORef (Set CType), TyCon) - -lookupExtraDefs :: TcPluginM ExtraDefs -lookupExtraDefs = do - ref <- tcPluginIO (newIORef empty) -#if !MIN_VERSION_ghc(9,2,0) - return (ref, typeNatLeqTyCon) -#else - md <- lookupModule myModule myPackage - ordCond <- look md "OrdCond" - return (ref, ordCond) - where - look md s = tcLookupTyCon =<< lookupName md (mkTcOcc s) - myModule = mkModuleName "Data.Type.Ord" - myPackage = fsLit "base" -#endif - -decideEqualSOP - :: Opts - -> ExtraDefs - -- ^ 1. Givens that is already generated. - -- We have to generate new givens at most once; - -- otherwise GHC will loop indefinitely. - -- - -- - -- 2. For GHc 9.2: TyCon of Data.Type.Ord.OrdCond - -- For older: TyCon of GHC.TypeLits.<=? - -> [Ct] - -> [Ct] - -> [Ct] - -> TcPluginM TcPluginResult - --- Simplification phase: Derives /simplified/ givens; --- we can reduce given constraints like @Show (Foo (n + 2))@ --- to its normal form @Show (Foo (2 + n))@, which is eventually --- useful in solving phase. --- --- This helps us to solve /indirect/ constraints; --- without this phase, we cannot derive, e.g., --- @IsVector UVector (Fin (n + 1))@ from --- @Unbox (1 + n)@! -decideEqualSOP opts (gen'd,ordCond) givens _deriveds [] = do - done <- tcPluginIO $ readIORef gen'd -#if MIN_VERSION_ghc(8,4,0) - let simplGivens = flattenGivens givens -#else - simplGivens <- mapM zonkCt givens -#endif - let reds = - filter (\(_,(_,_,v)) -> null v || negNumbers opts) $ - reduceGivens opts ordCond done simplGivens - newlyDone = map (\(_,(prd, _,_)) -> CType prd) reds - tcPluginIO $ - modifyIORef' gen'd $ union (fromList newlyDone) - newGivens <- forM reds $ \(origCt, (pred', evTerm, _)) -> - mkNonCanonical' (ctLoc origCt) <$> newGiven (ctLoc origCt) pred' evTerm - return (TcPluginOk [] newGivens) - --- Solving phase. --- Solves in/equalities on Nats and simplifiable constraints --- containing naturals. -decideEqualSOP opts (gen'd,ordCond) givens deriveds wanteds = do - -- GHC 7.10.1 puts deriveds with the wanteds, so filter them out - let flat_wanteds0 = map (\ct -> (OrigCt ct, ct)) wanteds -#if MIN_VERSION_ghc(8,4,0) - -- flattenGivens should actually be called unflattenGivens - let simplGivens = givens ++ flattenGivens givens - subst = fst $ unzip $ TcPluginM.mkSubst' givens - unflattenWanted (oCt, ct) = (oCt, TcPluginM.substCt subst ct) - unflat_wanteds0 = map unflattenWanted flat_wanteds0 -#else - let unflat_wanteds0 = flat_wanteds0 - simplGivens <- mapM zonkCt givens -#endif - let unflat_wanteds1 = filter (isWanted . ctEvidence . snd) unflat_wanteds0 - -- only return solve deriveds when there are wanteds to solve - unflat_wanteds2 = case unflat_wanteds1 of - [] -> [] - w -> w ++ (map (\a -> (OrigCt a,a)) deriveds) - unit_wanteds = mapMaybe (toNatEquality ordCond) unflat_wanteds2 - nonEqs = filter (not . (\p -> isEqPred p || isEqPrimPred p) . ctEvPred . ctEvidence.snd) - $ filter (isWanted. ctEvidence.snd) unflat_wanteds0 - done <- tcPluginIO $ readIORef gen'd - let redGs = reduceGivens opts ordCond done simplGivens - newlyDone = map (\(_,(prd, _,_)) -> CType prd) redGs - redGivens <- forM redGs $ \(origCt, (pred', evTerm, _)) -> - mkNonCanonical' (ctLoc origCt) <$> newGiven (ctLoc origCt) pred' evTerm - reducible_wanteds - <- catMaybes <$> - mapM - (\(origCt, ct) -> fmap (runOrigCt origCt,) <$> - reduceNatConstr (simplGivens ++ redGivens) ct - ) - nonEqs - if null unit_wanteds && null reducible_wanteds - then return $ TcPluginOk [] [] - else do - -- Since reducible wanteds also can have some negation/subtraction - -- subterms, we have to make sure appropriate inequalities to hold. - -- Here, we generate such additional inequalities for reduction - -- that is to be added to new [W]anteds. - ineqForRedWants <- fmap concat $ forM redGs $ \(ct, (_,_, ws)) -> forM ws $ - fmap (mkNonCanonical' (ctLoc ct)) . newWanted (ctLoc ct) - tcPluginIO $ - modifyIORef' gen'd $ union (fromList newlyDone) - let unit_givens = mapMaybe - (toNatEquality ordCond) - (map (\a -> (OrigCt a, a)) simplGivens) - sr <- simplifyNats opts ordCond unit_givens unit_wanteds - tcPluginTrace "normalised" (ppr sr) - reds <- forM reducible_wanteds $ \(origCt,(term, ws, wDicts)) -> do - wants <- evSubtPreds origCt $ subToPred opts ordCond ws - return ((term, origCt), wDicts ++ wants) - case sr of - Simplified evs -> do - let simpld = filter (not . isGiven . ctEvidence . (\((_,x),_) -> x)) evs - -- Only solve derived when we solved a wanted - simpld1 = case filter (isWanted . ctEvidence . (\((_,x),_) -> x)) evs ++ reds of - [] -> [] - _ -> simpld - (solved',newWanteds) = second concat (unzip $ simpld1 ++ reds) - return (TcPluginOk solved' $ newWanteds ++ ineqForRedWants) - Impossible eq -> return (TcPluginContradiction [fromNatEquality eq]) - -type NatEquality = (Ct,CoreSOP,CoreSOP) -type NatInEquality = (Ct,(CoreSOP,CoreSOP,Bool)) - -reduceGivens :: Opts -> TyCon -> Set CType -> [Ct] -> [(Ct, (Type, EvTerm, [PredType]))] -reduceGivens opts ordCond done givens = - let nonEqs = - [ ct - | ct <- givens - , let ev = ctEvidence ct - prd = ctEvPred ev - , isGiven ev - , not $ (\p -> isEqPred p || isEqPrimPred p || isEqPredClass p) prd - ] - in filter - (\(_, (prd, _, _)) -> - notMember (CType prd) done - ) - $ mapMaybe - (\ct -> (ct,) <$> tryReduceGiven opts ordCond givens ct) - nonEqs - -tryReduceGiven - :: Opts -> TyCon -> [Ct] -> Ct - -> Maybe (PredType, EvTerm, [PredType]) -tryReduceGiven opts ordCond simplGivens ct = do - let (mans, ws) = - runWriter $ normaliseNatEverywhere $ - ctEvPred $ ctEvidence ct - ws' = [ p - | (p, _) <- subToPred opts ordCond ws - , all (not . (`eqType` p). ctEvPred . ctEvidence) simplGivens - ] - pred' <- mans - return (pred', toReducedDict (ctEvidence ct) pred', ws') - -fromNatEquality :: Either NatEquality NatInEquality -> Ct -fromNatEquality (Left (ct, _, _)) = ct -fromNatEquality (Right (ct, _)) = ct - -reduceNatConstr :: [Ct] -> Ct -> TcPluginM (Maybe (EvTerm, [(Type, Type)], [Ct])) -reduceNatConstr givens ct = do - let pred0 = ctEvPred $ ctEvidence ct - (mans, tests) = runWriter $ normaliseNatEverywhere pred0 - case mans of - Nothing -> return Nothing - Just pred' -> do - case find ((`eqType` pred') .ctEvPred . ctEvidence) givens of - -- No existing evidence found - Nothing -> case getClassPredTys_maybe pred' of - -- Are we trying to solve a class instance? - Just (cls,_) | className cls /= knownNatClassName -> do - -- Create new evidence binding for normalized class constraint - evVar <- newEvVar pred' - -- Bind the evidence to a new wanted normalized class constraint - let wDict = mkNonCanonical - (CtWanted pred' (EvVarDest evVar) -#if MIN_VERSION_ghc(8,2,0) - WDeriv -#endif - (ctLoc ct)) - -- Evidence for current wanted is simply the coerced binding for - -- the new binding - evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") - Representational - pred' pred0 -#if MIN_VERSION_ghc(8,6,0) - ev = evId evVar `evCast` evCo -#else - ev = EvId evVar `EvCast` evCo -#endif - -- Use newly created coerced wanted as evidence, and emit the - -- normalized wanted as a new constraint to solve. - return (Just (ev, tests, [wDict])) - _ -> return Nothing - -- Use existing evidence - Just c -> return (Just (toReducedDict (ctEvidence c) pred0, tests, [])) - -toReducedDict :: CtEvidence -> PredType -> EvTerm -toReducedDict ct pred' = - let pred0 = ctEvPred ct - evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise") - Representational - pred0 pred' -#if MIN_VERSION_ghc(8,6,0) - ev = ctEvExpr ct - `evCast` evCo -#else - ev = ctEvTerm ct `EvCast` evCo -#endif - in ev - -data SimplifyResult - = Simplified [((EvTerm,Ct),[Ct])] - | Impossible (Either NatEquality NatInEquality) - -instance Outputable SimplifyResult where - ppr (Simplified evs) = text "Simplified" $$ ppr evs - ppr (Impossible eq) = text "Impossible" <+> ppr eq - -simplifyNats - :: Opts - -- ^ Allow negated numbers (potentially unsound!) - -> TyCon - -- ^ For GHc 9.2: TyCon of Data.Type.Ord.OrdCond - -- For older: TyCon of GHC.TypeLits.<=? - -> [(Either NatEquality NatInEquality,[(Type,Type)])] - -- ^ Given constraints - -> [(Either NatEquality NatInEquality,[(Type,Type)])] - -- ^ Wanted constraints - -> TcPluginM SimplifyResult -simplifyNats opts@Opts {..} ordCond eqsG eqsW = do - let eqsG1 = map (second (const ([] :: [(Type,Type)]))) eqsG - (varEqs,otherEqs) = partition isVarEqs eqsG1 - fancyGivens = concatMap (makeGivensSet otherEqs) varEqs - case varEqs of - [] -> do - let eqs = otherEqs ++ eqsW - tcPluginTrace "simplifyNats" (ppr eqs) - simples [] [] [] [] eqs - _ -> do - tcPluginTrace ("simplifyNats(backtrack: " ++ show (length fancyGivens) ++ ")") - (ppr varEqs) - - allSimplified <- forM fancyGivens $ \v -> do - let eqs = v ++ eqsW - tcPluginTrace "simplifyNats" (ppr eqs) - simples [] [] [] [] eqs - - pure (foldr findFirstSimpliedWanted (Simplified []) allSimplified) - where - simples :: [CoreUnify] - -> [((EvTerm, Ct), [Ct])] - -> [(CoreSOP,CoreSOP,Bool)] - -> [(Either NatEquality NatInEquality,[(Type,Type)])] - -> [(Either NatEquality NatInEquality,[(Type,Type)])] - -> TcPluginM SimplifyResult - simples _subst evs _leqsG _xs [] = return (Simplified evs) - simples subst evs leqsG xs (eq@(Left (ct,u,v),k):eqs') = do - let u' = substsSOP subst u - v' = substsSOP subst v - ur <- unifyNats ct u' v' - tcPluginTrace "unifyNats result" (ppr ur) - case ur of - Win -> do - evs' <- maybe evs (:evs) <$> evMagic ct empty (subToPred opts ordCond k) - simples subst evs' leqsG [] (xs ++ eqs') - Lose -> if null evs && null eqs' - then return (Impossible (fst eq)) - else simples subst evs leqsG xs eqs' - Draw [] -> simples subst evs [] (eq:xs) eqs' - Draw subst' -> do - evM <- evMagic ct empty (map unifyItemToPredType subst' ++ - subToPred opts ordCond k) - let leqsG' | isGiven (ctEvidence ct) = eqToLeq u' v' ++ leqsG - | otherwise = leqsG - case evM of - Nothing -> simples subst evs leqsG' xs eqs' - Just ev -> - simples (substsSubst subst' subst ++ subst') - (ev:evs) leqsG' [] (xs ++ eqs') - simples subst evs leqsG xs (eq@(Right (ct,u@(x,y,b)),k):eqs') = do - let u' = substsSOP subst (subtractIneq u) - x' = substsSOP subst x - y' = substsSOP subst y - uS = (x',y',b) - leqsG' | isGiven (ctEvidence ct) = (x',y',b):leqsG - | otherwise = leqsG - ineqs = concat [ leqsG - , map (substLeq subst) leqsG - , map snd (rights (map fst eqsG)) - ] - tcPluginTrace "unifyNats(ineq) results" (ppr (ct,u,u',ineqs)) - case runWriterT (isNatural u') of - Just (True,knW) -> do - evs' <- maybe evs (:evs) <$> evMagic ct knW (subToPred opts ordCond k) - simples subst evs' leqsG' xs eqs' - - Just (False,_) | null k -> return (Impossible (fst eq)) - _ -> do - let solvedIneq = mapMaybe runWriterT - -- it is an inequality that can be instantly solved, such as - -- `1 <= x^y` - -- OR - (instantSolveIneq depth u: - instantSolveIneq depth uS: - -- This inequality is either a given constraint, or it is a wanted - -- constraint, which in normal form is equal to another given - -- constraint, hence it can be solved. - -- OR - map (solveIneq depth u) ineqs ++ - -- The above, but with valid substitutions applied to the wanted. - map (solveIneq depth uS) ineqs) - smallest = solvedInEqSmallestConstraint solvedIneq - case smallest of - (True,kW) -> do - evs' <- maybe evs (:evs) <$> evMagic ct kW (subToPred opts ordCond k) - simples subst evs' leqsG' xs eqs' - _ -> simples subst evs leqsG (eq:xs) eqs' - - eqToLeq x y = [(x,y,True),(y,x,True)] - substLeq s (x,y,b) = (substsSOP s x, substsSOP s y, b) - - isVarEqs (Left (_,S [P [V _]], S [P [V _]]), _) = True - isVarEqs _ = False - - makeGivensSet otherEqs varEq - = let (noMentionsV,mentionsV) = partitionEithers - (map (matchesVarEq varEq) otherEqs) - (mentionsLHS,mentionsRHS) = partitionEithers mentionsV - vS = swapVar varEq - givensLHS = case mentionsLHS of - [] -> [] - _ -> [mentionsLHS ++ ((varEq:mentionsRHS) ++ noMentionsV)] - givensRHS = case mentionsRHS of - [] -> [] - _ -> [mentionsRHS ++ (vS:mentionsLHS ++ noMentionsV)] - in case mentionsV of - [] -> [noMentionsV] - _ -> givensLHS ++ givensRHS - - matchesVarEq (Left (_, S [P [V v1]], S [P [V v2]]),_) r = case r of - (Left (_,S [P [V v3]],_),_) - | v1 == v3 -> Right (Left r) - | v2 == v3 -> Right (Right r) - (Left (_,_,S [P [V v3]]),_) - | v1 == v3 -> Right (Left r) - | v2 == v3 -> Right (Right r) - (Right (_,(S [P [V v3]],_,_)),_) - | v1 == v3 -> Right (Left r) - | v2 == v3 -> Right (Right r) - (Right (_,(_,S [P [V v3]],_)),_) - | v1 == v3 -> Right (Left r) - | v2 == v3 -> Right (Right r) - _ -> Left r - matchesVarEq _ _ = error "internal error" - - swapVar (Left (ct,S [P [V v1]], S [P [V v2]]),ps) = - (Left (ct,S [P [V v2]], S [P [V v1]]),ps) - swapVar _ = error "internal error" - - findFirstSimpliedWanted (Impossible e) _ = Impossible e - findFirstSimpliedWanted (Simplified evs) s2 - | any (isWantedCt . snd . fst) evs - = Simplified evs - | otherwise - = s2 - --- If we allow negated numbers we simply do not emit the inequalities --- derived from the subtractions that are converted to additions with a --- negated operand -subToPred :: Opts -> TyCon -> [(Type, Type)] -> [(PredType, Kind)] -subToPred Opts{..} ordCond - | negNumbers = const [] - | otherwise = map (subtractionToPred ordCond) - --- Extract the Nat equality constraints -toNatEquality :: TyCon -> (OrigCt, Ct) -> Maybe (Either NatEquality NatInEquality,[(Type,Type)]) -toNatEquality ordCond (OrigCt oCt, ct) = case classifyPredType $ ctEvPred $ ctEvidence ct of - EqPred NomEq t1 t2 - -> go t1 t2 - _ -> Nothing - where - go (TyConApp tc xs) (TyConApp tc' ys) - | tc == tc' - , null ([tc,tc'] `intersect` [typeNatAddTyCon,typeNatSubTyCon - ,typeNatMulTyCon,typeNatExpTyCon]) - = case filter (not . uncurry eqType) (zip xs ys) of - [(x,y)] - | isNatKind (typeKind x) - , isNatKind (typeKind y) - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - -> Just (Left (oCt, x', y'),k1 ++ k2) - _ -> Nothing -#if MIN_VERSION_ghc(9,2,0) - | tc == ordCond - , [_,cmp,lt,eq,gt] <- xs - , TyConApp tcCmpNat [x,y] <- cmp - , tcCmpNat == typeNatCmpTyCon - , TyConApp ltTc [] <- lt - , ltTc == promotedTrueDataCon - , TyConApp eqTc [] <- eq - , eqTc == promotedTrueDataCon - , TyConApp gtTc [] <- gt - , gtTc == promotedFalseDataCon - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - , let ks = k1 ++ k2 - = case tc' of - _ | tc' == promotedTrueDataCon - -> Just (Right (oCt, (x', y', True)), ks) - _ | tc' == promotedFalseDataCon - -> Just (Right (oCt, (x', y', False)), ks) - _ -> Nothing -#else - | tc == ordCond - , [x,y] <- xs - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - , let ks = k1 ++ k2 - = case tc' of - _ | tc' == promotedTrueDataCon - -> Just (Right (oCt, (x', y', True)), ks) - _ | tc' == promotedFalseDataCon - -> Just (Right (oCt, (x', y', False)), ks) - _ -> Nothing -#endif - - go x y - | isNatKind (typeKind x) - , isNatKind (typeKind y) - , let (x',k1) = runWriter (normaliseNat x) - , let (y',k2) = runWriter (normaliseNat y) - = Just (Left (oCt,x',y'),k1 ++ k2) - | otherwise - = Nothing - - isNatKind :: Kind -> Bool - isNatKind = (`eqType` typeNatKind) - -unifyItemToPredType :: CoreUnify -> (PredType,Kind) -unifyItemToPredType ui = - (mkPrimEqPred ty1 ty2,typeNatKind) - where - ty1 = case ui of - SubstItem {..} -> mkTyVarTy siVar - UnifyItem {..} -> reifySOP siLHS - ty2 = case ui of - SubstItem {..} -> reifySOP siSOP - UnifyItem {..} -> reifySOP siRHS - -evSubtPreds :: Ct -> [(PredType,Kind)] -> TcPluginM [Ct] -evSubtPreds ct preds = do - let predTypes = map fst preds -#if MIN_VERSION_ghc(8,4,1) - holes <- mapM (newCoercionHole . uncurry mkPrimEqPred . getEqPredTys) predTypes -#else - holes <- replicateM (length preds) newCoercionHole -#endif - return (zipWith (unifyItemToCt (ctLoc ct)) predTypes holes) - -evMagic :: Ct -> Set CType -> [(PredType,Kind)] -> TcPluginM (Maybe ((EvTerm, Ct), [Ct])) -evMagic ct knW preds = case classifyPredType $ ctEvPred $ ctEvidence ct of - EqPred NomEq t1 t2 -> do - holeWanteds <- evSubtPreds ct preds - knWanted <- mapM (mkKnWanted ct) (toList knW) - let newWant = knWanted ++ holeWanteds - ctEv = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Nominal t1 t2 -#if MIN_VERSION_ghc(8,5,0) - return (Just ((EvExpr (Coercion ctEv), ct),newWant)) -#else - return (Just ((EvCoercion ctEv, ct),newWant)) -#endif - _ -> return Nothing - -mkNonCanonical' :: CtLoc -> CtEvidence -> Ct -mkNonCanonical' origCtl ev = - let ct_ls = ctLocSpan origCtl - ctl = ctEvLoc ev - in setCtLoc (mkNonCanonical ev) (setCtLocSpan ctl ct_ls) - -mkKnWanted - :: Ct - -> CType - -> TcPluginM Ct -mkKnWanted ct (CType ty) = do - kc_clas <- tcLookupClass knownNatClassName - let kn_pred = mkClassPred kc_clas [ty] - wantedCtEv <- TcPluginM.newWanted (ctLoc ct) kn_pred - let wanted' = mkNonCanonical' (ctLoc ct) wantedCtEv - return wanted' - -unifyItemToCt :: CtLoc - -> PredType - -> CoercionHole - -> Ct -unifyItemToCt loc pred_type hole = - mkNonCanonical - (CtWanted - pred_type - (HoleDest hole) -#if MIN_VERSION_ghc(8,2,0) - WDeriv -#endif - loc) +{-|+Copyright : (C) 2015-2016, University of Twente,+ 2017 , QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>++A type checker plugin for GHC that can solve /equalities/ of types of kind+'GHC.TypeLits.Nat', where these types are either:++* Type-level naturals+* Type variables+* Applications of the arithmetic expressions @(+,-,*,^)@.++It solves these equalities by normalising them to /sort-of/+'GHC.TypeLits.Normalise.SOP.SOP' (Sum-of-Products) form, and then perform a+simple syntactic equality.++For example, this solver can prove the equality between:++@+(x + 2)^(y + 2)+@++and++@+4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2+@++Because the latter is actually the 'GHC.TypeLits.Normalise.SOP.SOP' normal form+of the former.++To use the plugin, add++@+{\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\}+@++To the header of your file.++== Treating subtraction as addition with a negated number++If you are absolutely sure that your subtractions can /never/ lead to (a locally)+negative number, you can ask the plugin to treat subtraction as addition with+a negated operand by additionally adding:++@+{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\}+@++to the header of your file, thereby allowing to use associativity and+commutativity rules when proving constraints involving subtractions. Note that+this option can lead to unsound behaviour and should be handled with extreme+care.++=== When it leads to unsound behaviour++For example, enabling the /allow-negated-numbers/ feature would allow+you to prove:++@+(n - 1) + 1 ~ n+@++/without/ a @(1 <= n)@ constraint, even though when /n/ is set to /0/ the+subtraction @n-1@ would be locally negative and hence not be a natural number.++This would allow the following erroneous definition:++@+data Fin (n :: Nat) where+ FZ :: Fin (n + 1)+ FS :: Fin n -> Fin (n + 1)++f :: forall n . Natural -> Fin n+f n = case of+ 0 -> FZ+ x -> FS (f \@(n-1) (x - 1))++fs :: [Fin 0]+fs = f \<$\> [0..]+@++=== When it might be Okay++This example is taken from the <http://hackage.haskell.org/package/mezzo mezzo>+library.++When you have:++@+-- | Singleton type for the number of repetitions of an element.+data Times (n :: Nat) where+ T :: Times n++-- | An element of a "run-length encoded" vector, containing the value and+-- the number of repetitions+data Elem :: Type -> Nat -> Type where+ (:*) :: t -> Times n -> Elem t n++-- | A length-indexed vector, optimised for repetitions.+data OptVector :: Type -> Nat -> Type where+ End :: OptVector t 0+ (:-) :: Elem t l -> OptVector t (n - l) -> OptVector t n+@++And you want to define:++@+-- | Append two optimised vectors.+type family (x :: OptVector t n) ++ (y :: OptVector t m) :: OptVector t (n + m) where+ ys ++ End = ys+ End ++ ys = ys+ (x :- xs) ++ ys = x :- (xs ++ ys)+@++then the last line will give rise to the constraint:++@+(n-l)+m ~ (n+m)-l+@++because:++@+x :: Elem t l+xs :: OptVector t (n-l)+ys :: OptVector t m+@++In this case it's okay to add++@+{\-\# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers \#-\}+@++if you can convince yourself you will never be able to construct a:++@+xs :: OptVector t (n-l)+@++where /n-l/ is a negative number.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module GHC.TypeLits.Normalise+ ( plugin )+where++-- external+import Control.Arrow (second)+import Control.Monad ((<=<), forM)+#if !MIN_VERSION_ghc(8,4,1)+import Control.Monad (replicateM)+#endif+import Control.Monad.Trans.Writer.Strict+import Data.Either (partitionEithers, rights)+import Data.IORef+import Data.List (intersect, partition, stripPrefix, find)+import Data.Maybe (mapMaybe, catMaybes)+import Data.Set (Set, empty, toList, notMember, fromList, union)+import GHC.TcPluginM.Extra (tracePlugin, newGiven, newWanted)+#if MIN_VERSION_ghc(9,2,0)+import GHC.TcPluginM.Extra (lookupModule, lookupName)+#endif+import qualified GHC.TcPluginM.Extra as TcPluginM+#if MIN_VERSION_ghc(8,4,0)+import GHC.TcPluginM.Extra (flattenGivens)+#endif+import Text.Read (readMaybe)++-- GHC API+#if MIN_VERSION_ghc(9,0,0)+import GHC.Builtin.Names (knownNatClassName, eqTyConKey, heqTyConKey, hasKey)+import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon)+import GHC.Builtin.Types.Literals+ (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Builtin.Types (naturalTy)+import GHC.Builtin.Types.Literals (typeNatCmpTyCon)+#else+import GHC.Builtin.Types (typeNatKind)+import GHC.Builtin.Types.Literals (typeNatLeqTyCon)+#endif+import GHC.Core (Expr (..))+import GHC.Core.Class (className)+import GHC.Core.Coercion (CoercionHole, Role (..), mkUnivCo)+import GHC.Core.Predicate+ (EqRel (NomEq), Pred (EqPred), classifyPredType, getEqPredTys, mkClassPred,+ mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe)+import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..))+import GHC.Core.TyCon (TyCon)+import GHC.Core.Type+ (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe, typeKind)+import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin)+import GHC.Tc.Plugin+ (TcPluginM, newCoercionHole, tcLookupClass, tcPluginTrace, tcPluginIO,+ newEvVar)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Tc.Plugin (tcLookupTyCon)+#endif+import GHC.Tc.Types (TcPlugin (..), TcPluginResult (..))+import GHC.Tc.Types.Constraint+ (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ShadowInfo (WDeriv), ctEvidence,+ ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan,+ isWantedCt, ctEvLoc, ctEvPred, ctEvExpr)+import GHC.Tc.Types.Evidence (EvTerm (..), evCast, evId)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Data.FastString (fsLit)+import GHC.Types.Name.Occurrence (mkTcOcc)+import GHC.Unit.Module (mkModuleName)+#endif+import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text)+#else+#if MIN_VERSION_ghc(8,5,0)+import CoreSyn (Expr (..))+#endif+import Outputable (Outputable (..), (<+>), ($$), text)+import Plugins (Plugin (..), defaultPlugin)+#if MIN_VERSION_ghc(8,6,0)+import Plugins (purePlugin)+#endif+import PrelNames (hasKey, knownNatClassName)+import PrelNames (eqTyConKey, heqTyConKey)+import TcEvidence (EvTerm (..))+#if MIN_VERSION_ghc(8,6,0)+import TcEvidence (evCast, evId)+#endif+#if !MIN_VERSION_ghc(8,4,0)+import TcPluginM (zonkCt)+#endif+import TcPluginM (TcPluginM, tcPluginTrace, tcPluginIO)+import Type+ (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe)+import TysWiredIn (typeNatKind)++import Coercion (CoercionHole, Role (..), mkUnivCo)+import Class (className)+import TcPluginM (newCoercionHole, tcLookupClass, newEvVar)+import TcRnTypes (TcPlugin (..), TcPluginResult(..))+import TyCoRep (UnivCoProvenance (..))+import TcType (isEqPred)+import TyCon (TyCon)+import TyCoRep (Type (..))+import TcTypeNats (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon,+ typeNatSubTyCon)++import TcTypeNats (typeNatLeqTyCon)+import TysWiredIn (promotedFalseDataCon, promotedTrueDataCon)++#if MIN_VERSION_ghc(8,10,0)+import Constraint+ (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence, ctEvLoc, ctEvPred,+ ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan,+ isWantedCt)+import Predicate+ (EqRel (NomEq), Pred (EqPred), classifyPredType, getEqPredTys, mkClassPred,+ mkPrimEqPred, getClassPredTys_maybe)+import Type (typeKind)+#else+import TcRnTypes+ (Ct, CtEvidence (..), CtLoc, TcEvDest (..), ctEvidence, ctEvLoc, ctEvPred,+ ctLoc, ctLocSpan, isGiven, isWanted, mkNonCanonical, setCtLoc, setCtLocSpan,+ isWantedCt)+import TcType (typeKind)+import Type+ (EqRel (NomEq), PredTree (EqPred), classifyPredType, mkClassPred, mkPrimEqPred,+ getClassPredTys_maybe)+#if MIN_VERSION_ghc(8,4,0)+import Type (getEqPredTys)+#endif+#endif++#if MIN_VERSION_ghc(8,10,0)+import Constraint (ctEvExpr)+#elif MIN_VERSION_ghc(8,6,0)+import TcRnTypes (ctEvExpr)+#else+import TcRnTypes (ctEvTerm)+#endif++#if MIN_VERSION_ghc(8,2,0)+#if MIN_VERSION_ghc(8,10,0)+import Constraint (ShadowInfo (WDeriv))+#else+import TcRnTypes (ShadowInfo (WDeriv))+#endif+#endif++#if MIN_VERSION_ghc(8,10,0)+import TcType (isEqPrimPred)+#endif+#endif++-- internal+import GHC.TypeLits.Normalise.SOP+import GHC.TypeLits.Normalise.Unify++#if MIN_VERSION_ghc(9,2,0)+typeNatKind :: Type+typeNatKind = naturalTy+#endif++#if !MIN_VERSION_ghc(8,10,0)+isEqPrimPred :: PredType -> Bool+isEqPrimPred = isEqPred+#endif++isEqPredClass :: PredType -> Bool+isEqPredClass ty = case tyConAppTyCon_maybe ty of+ Just tc -> tc `hasKey` eqTyConKey || tc `hasKey` heqTyConKey+ _ -> False++-- | To use the plugin, add+--+-- @+-- {\-\# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise \#-\}+-- @+--+-- To the header of your file.+plugin :: Plugin+plugin+ = defaultPlugin+ { tcPlugin = fmap (normalisePlugin . foldr id defaultOpts) . traverse parseArgument+#if MIN_VERSION_ghc(8,6,0)+ , pluginRecompile = purePlugin+#endif+ }+ where+ parseArgument "allow-negated-numbers" = Just (\ opts -> opts { negNumbers = True })+ parseArgument (readMaybe <=< stripPrefix "depth=" -> Just depth) = Just (\ opts -> opts { depth })+ parseArgument _ = Nothing+ defaultOpts = Opts { negNumbers = False, depth = 5 }++data Opts = Opts { negNumbers :: Bool, depth :: Word }++normalisePlugin :: Opts -> TcPlugin+normalisePlugin opts = tracePlugin "ghc-typelits-natnormalise"+ TcPlugin { tcPluginInit = lookupExtraDefs+ , tcPluginSolve = decideEqualSOP opts+ , tcPluginStop = const (return ())+ }+newtype OrigCt = OrigCt { runOrigCt :: Ct }++type ExtraDefs = (IORef (Set CType), TyCon)++lookupExtraDefs :: TcPluginM ExtraDefs+lookupExtraDefs = do+ ref <- tcPluginIO (newIORef empty)+#if !MIN_VERSION_ghc(9,2,0)+ return (ref, typeNatLeqTyCon)+#else+ md <- lookupModule myModule myPackage+ ordCond <- look md "OrdCond"+ return (ref, ordCond)+ where+ look md s = tcLookupTyCon =<< lookupName md (mkTcOcc s)+ myModule = mkModuleName "Data.Type.Ord"+ myPackage = fsLit "base"+#endif++decideEqualSOP+ :: Opts+ -> ExtraDefs+ -- ^ 1. Givens that is already generated.+ -- We have to generate new givens at most once;+ -- otherwise GHC will loop indefinitely.+ --+ --+ -- 2. For GHc 9.2: TyCon of Data.Type.Ord.OrdCond+ -- For older: TyCon of GHC.TypeLits.<=?+ -> [Ct]+ -> [Ct]+ -> [Ct]+ -> TcPluginM TcPluginResult++-- Simplification phase: Derives /simplified/ givens;+-- we can reduce given constraints like @Show (Foo (n + 2))@+-- to its normal form @Show (Foo (2 + n))@, which is eventually+-- useful in solving phase.+--+-- This helps us to solve /indirect/ constraints;+-- without this phase, we cannot derive, e.g.,+-- @IsVector UVector (Fin (n + 1))@ from+-- @Unbox (1 + n)@!+decideEqualSOP opts (gen'd,ordCond) givens _deriveds [] = do+ done <- tcPluginIO $ readIORef gen'd+#if MIN_VERSION_ghc(8,4,0)+ let simplGivens = flattenGivens givens+#else+ simplGivens <- mapM zonkCt givens+#endif+ let reds =+ filter (\(_,(_,_,v)) -> null v || negNumbers opts) $+ reduceGivens opts ordCond done simplGivens+ newlyDone = map (\(_,(prd, _,_)) -> CType prd) reds+ tcPluginIO $+ modifyIORef' gen'd $ union (fromList newlyDone)+ newGivens <- forM reds $ \(origCt, (pred', evTerm, _)) ->+ mkNonCanonical' (ctLoc origCt) <$> newGiven (ctLoc origCt) pred' evTerm+ return (TcPluginOk [] newGivens)++-- Solving phase.+-- Solves in/equalities on Nats and simplifiable constraints+-- containing naturals.+decideEqualSOP opts (gen'd,ordCond) givens deriveds wanteds = do+ -- GHC 7.10.1 puts deriveds with the wanteds, so filter them out+ let flat_wanteds0 = map (\ct -> (OrigCt ct, ct)) wanteds+#if MIN_VERSION_ghc(8,4,0)+ -- flattenGivens should actually be called unflattenGivens+ let simplGivens = givens ++ flattenGivens givens+ subst = fst $ unzip $ TcPluginM.mkSubst' givens+ unflattenWanted (oCt, ct) = (oCt, TcPluginM.substCt subst ct)+ unflat_wanteds0 = map unflattenWanted flat_wanteds0+#else+ let unflat_wanteds0 = flat_wanteds0+ simplGivens <- mapM zonkCt givens+#endif+ let unflat_wanteds1 = filter (isWanted . ctEvidence . snd) unflat_wanteds0+ -- only return solve deriveds when there are wanteds to solve+ unflat_wanteds2 = case unflat_wanteds1 of+ [] -> []+ w -> w ++ (map (\a -> (OrigCt a,a)) deriveds)+ unit_wanteds = mapMaybe (toNatEquality ordCond) unflat_wanteds2+ nonEqs = filter (not . (\p -> isEqPred p || isEqPrimPred p) . ctEvPred . ctEvidence.snd)+ $ filter (isWanted. ctEvidence.snd) unflat_wanteds0+ done <- tcPluginIO $ readIORef gen'd+ let redGs = reduceGivens opts ordCond done simplGivens+ newlyDone = map (\(_,(prd, _,_)) -> CType prd) redGs+ redGivens <- forM redGs $ \(origCt, (pred', evTerm, _)) ->+ mkNonCanonical' (ctLoc origCt) <$> newGiven (ctLoc origCt) pred' evTerm+ reducible_wanteds+ <- catMaybes <$>+ mapM+ (\(origCt, ct) -> fmap (runOrigCt origCt,) <$>+ reduceNatConstr (simplGivens ++ redGivens) ct+ )+ nonEqs+ if null unit_wanteds && null reducible_wanteds+ then return $ TcPluginOk [] []+ else do+ -- Since reducible wanteds also can have some negation/subtraction+ -- subterms, we have to make sure appropriate inequalities to hold.+ -- Here, we generate such additional inequalities for reduction+ -- that is to be added to new [W]anteds.+ ineqForRedWants <- fmap concat $ forM redGs $ \(ct, (_,_, ws)) -> forM ws $+ fmap (mkNonCanonical' (ctLoc ct)) . newWanted (ctLoc ct)+ tcPluginIO $+ modifyIORef' gen'd $ union (fromList newlyDone)+ let unit_givens = mapMaybe+ (toNatEquality ordCond)+ (map (\a -> (OrigCt a, a)) simplGivens)+ sr <- simplifyNats opts ordCond unit_givens unit_wanteds+ tcPluginTrace "normalised" (ppr sr)+ reds <- forM reducible_wanteds $ \(origCt,(term, ws, wDicts)) -> do+ wants <- evSubtPreds origCt $ subToPred opts ordCond ws+ return ((term, origCt), wDicts ++ wants)+ case sr of+ Simplified evs -> do+ let simpld = filter (not . isGiven . ctEvidence . (\((_,x),_) -> x)) evs+ -- Only solve derived when we solved a wanted+ simpld1 = case filter (isWanted . ctEvidence . (\((_,x),_) -> x)) evs ++ reds of+ [] -> []+ _ -> simpld+ (solved',newWanteds) = second concat (unzip $ simpld1 ++ reds)+ return (TcPluginOk solved' $ newWanteds ++ ineqForRedWants)+ Impossible eq -> return (TcPluginContradiction [fromNatEquality eq])++type NatEquality = (Ct,CoreSOP,CoreSOP)+type NatInEquality = (Ct,(CoreSOP,CoreSOP,Bool))++reduceGivens :: Opts -> TyCon -> Set CType -> [Ct] -> [(Ct, (Type, EvTerm, [PredType]))]+reduceGivens opts ordCond done givens =+ let nonEqs =+ [ ct+ | ct <- givens+ , let ev = ctEvidence ct+ prd = ctEvPred ev+ , isGiven ev+ , not $ (\p -> isEqPred p || isEqPrimPred p || isEqPredClass p) prd+ ]+ in filter+ (\(_, (prd, _, _)) ->+ notMember (CType prd) done+ )+ $ mapMaybe+ (\ct -> (ct,) <$> tryReduceGiven opts ordCond givens ct)+ nonEqs++tryReduceGiven+ :: Opts -> TyCon -> [Ct] -> Ct+ -> Maybe (PredType, EvTerm, [PredType])+tryReduceGiven opts ordCond simplGivens ct = do+ let (mans, ws) =+ runWriter $ normaliseNatEverywhere $+ ctEvPred $ ctEvidence ct+ ws' = [ p+ | (p, _) <- subToPred opts ordCond ws+ , all (not . (`eqType` p). ctEvPred . ctEvidence) simplGivens+ ]+ pred' <- mans+ return (pred', toReducedDict (ctEvidence ct) pred', ws')++fromNatEquality :: Either NatEquality NatInEquality -> Ct+fromNatEquality (Left (ct, _, _)) = ct+fromNatEquality (Right (ct, _)) = ct++reduceNatConstr :: [Ct] -> Ct -> TcPluginM (Maybe (EvTerm, [(Type, Type)], [Ct]))+reduceNatConstr givens ct = do+ let pred0 = ctEvPred $ ctEvidence ct+ (mans, tests) = runWriter $ normaliseNatEverywhere pred0+ case mans of+ Nothing -> return Nothing+ Just pred' -> do+ case find ((`eqType` pred') .ctEvPred . ctEvidence) givens of+ -- No existing evidence found+ Nothing -> case getClassPredTys_maybe pred' of+ -- Are we trying to solve a class instance?+ Just (cls,_) | className cls /= knownNatClassName -> do+ -- Create new evidence binding for normalized class constraint+ evVar <- newEvVar pred'+ -- Bind the evidence to a new wanted normalized class constraint+ let wDict = mkNonCanonical+ (CtWanted pred' (EvVarDest evVar)+#if MIN_VERSION_ghc(8,2,0)+ WDeriv+#endif+ (ctLoc ct))+ -- Evidence for current wanted is simply the coerced binding for+ -- the new binding+ evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise")+ Representational+ pred' pred0+#if MIN_VERSION_ghc(8,6,0)+ ev = evId evVar `evCast` evCo+#else+ ev = EvId evVar `EvCast` evCo+#endif+ -- Use newly created coerced wanted as evidence, and emit the+ -- normalized wanted as a new constraint to solve.+ return (Just (ev, tests, [wDict]))+ _ -> return Nothing+ -- Use existing evidence+ Just c -> return (Just (toReducedDict (ctEvidence c) pred0, tests, []))++toReducedDict :: CtEvidence -> PredType -> EvTerm+toReducedDict ct pred' =+ let pred0 = ctEvPred ct+ evCo = mkUnivCo (PluginProv "ghc-typelits-natnormalise")+ Representational+ pred0 pred'+#if MIN_VERSION_ghc(8,6,0)+ ev = ctEvExpr ct+ `evCast` evCo+#else+ ev = ctEvTerm ct `EvCast` evCo+#endif+ in ev++data SimplifyResult+ = Simplified [((EvTerm,Ct),[Ct])]+ | Impossible (Either NatEquality NatInEquality)++instance Outputable SimplifyResult where+ ppr (Simplified evs) = text "Simplified" $$ ppr evs+ ppr (Impossible eq) = text "Impossible" <+> ppr eq++simplifyNats+ :: Opts+ -- ^ Allow negated numbers (potentially unsound!)+ -> TyCon+ -- ^ For GHc 9.2: TyCon of Data.Type.Ord.OrdCond+ -- For older: TyCon of GHC.TypeLits.<=?+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -- ^ Given constraints+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -- ^ Wanted constraints+ -> TcPluginM SimplifyResult+simplifyNats opts@Opts {..} ordCond eqsG eqsW = do+ let eqsG1 = map (second (const ([] :: [(Type,Type)]))) eqsG+ (varEqs,otherEqs) = partition isVarEqs eqsG1+ fancyGivens = concatMap (makeGivensSet otherEqs) varEqs+ case varEqs of+ [] -> do+ let eqs = otherEqs ++ eqsW+ tcPluginTrace "simplifyNats" (ppr eqs)+ simples [] [] [] [] eqs+ _ -> do+ tcPluginTrace ("simplifyNats(backtrack: " ++ show (length fancyGivens) ++ ")")+ (ppr varEqs)++ allSimplified <- forM fancyGivens $ \v -> do+ let eqs = v ++ eqsW+ tcPluginTrace "simplifyNats" (ppr eqs)+ simples [] [] [] [] eqs++ pure (foldr findFirstSimpliedWanted (Simplified []) allSimplified)+ where+ simples :: [CoreUnify]+ -> [((EvTerm, Ct), [Ct])]+ -> [(CoreSOP,CoreSOP,Bool)]+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -> [(Either NatEquality NatInEquality,[(Type,Type)])]+ -> TcPluginM SimplifyResult+ simples _subst evs _leqsG _xs [] = return (Simplified evs)+ simples subst evs leqsG xs (eq@(Left (ct,u,v),k):eqs') = do+ let u' = substsSOP subst u+ v' = substsSOP subst v+ ur <- unifyNats ct u' v'+ tcPluginTrace "unifyNats result" (ppr ur)+ case ur of+ Win -> do+ evs' <- maybe evs (:evs) <$> evMagic ct empty (subToPred opts ordCond k)+ simples subst evs' leqsG [] (xs ++ eqs')+ Lose -> if null evs && null eqs'+ then return (Impossible (fst eq))+ else simples subst evs leqsG xs eqs'+ Draw [] -> simples subst evs [] (eq:xs) eqs'+ Draw subst' -> do+ evM <- evMagic ct empty (map unifyItemToPredType subst' +++ subToPred opts ordCond k)+ let leqsG' | isGiven (ctEvidence ct) = eqToLeq u' v' ++ leqsG+ | otherwise = leqsG+ case evM of+ Nothing -> simples subst evs leqsG' xs eqs'+ Just ev ->+ simples (substsSubst subst' subst ++ subst')+ (ev:evs) leqsG' [] (xs ++ eqs')+ simples subst evs leqsG xs (eq@(Right (ct,u@(x,y,b)),k):eqs') = do+ let u' = substsSOP subst (subtractIneq u)+ x' = substsSOP subst x+ y' = substsSOP subst y+ uS = (x',y',b)+ leqsG' | isGiven (ctEvidence ct) = (x',y',b):leqsG+ | otherwise = leqsG+ ineqs = concat [ leqsG+ , map (substLeq subst) leqsG+ , map snd (rights (map fst eqsG))+ ]+ tcPluginTrace "unifyNats(ineq) results" (ppr (ct,u,u',ineqs))+ case runWriterT (isNatural u') of+ Just (True,knW) -> do+ evs' <- maybe evs (:evs) <$> evMagic ct knW (subToPred opts ordCond k)+ simples subst evs' leqsG' xs eqs'++ Just (False,_) | null k -> return (Impossible (fst eq))+ _ -> do+ let solvedIneq = mapMaybe runWriterT+ -- it is an inequality that can be instantly solved, such as+ -- `1 <= x^y`+ -- OR+ (instantSolveIneq depth u:+ instantSolveIneq depth uS:+ -- This inequality is either a given constraint, or it is a wanted+ -- constraint, which in normal form is equal to another given+ -- constraint, hence it can be solved.+ -- OR+ map (solveIneq depth u) ineqs +++ -- The above, but with valid substitutions applied to the wanted.+ map (solveIneq depth uS) ineqs)+ smallest = solvedInEqSmallestConstraint solvedIneq+ case smallest of+ (True,kW) -> do+ evs' <- maybe evs (:evs) <$> evMagic ct kW (subToPred opts ordCond k)+ simples subst evs' leqsG' xs eqs'+ _ -> simples subst evs leqsG (eq:xs) eqs'++ eqToLeq x y = [(x,y,True),(y,x,True)]+ substLeq s (x,y,b) = (substsSOP s x, substsSOP s y, b)++ isVarEqs (Left (_,S [P [V _]], S [P [V _]]), _) = True+ isVarEqs _ = False++ makeGivensSet otherEqs varEq+ = let (noMentionsV,mentionsV) = partitionEithers+ (map (matchesVarEq varEq) otherEqs)+ (mentionsLHS,mentionsRHS) = partitionEithers mentionsV+ vS = swapVar varEq+ givensLHS = case mentionsLHS of+ [] -> []+ _ -> [mentionsLHS ++ ((varEq:mentionsRHS) ++ noMentionsV)]+ givensRHS = case mentionsRHS of+ [] -> []+ _ -> [mentionsRHS ++ (vS:mentionsLHS ++ noMentionsV)]+ in case mentionsV of+ [] -> [noMentionsV]+ _ -> givensLHS ++ givensRHS++ matchesVarEq (Left (_, S [P [V v1]], S [P [V v2]]),_) r = case r of+ (Left (_,S [P [V v3]],_),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Left (_,_,S [P [V v3]]),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Right (_,(S [P [V v3]],_,_)),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ (Right (_,(_,S [P [V v3]],_)),_)+ | v1 == v3 -> Right (Left r)+ | v2 == v3 -> Right (Right r)+ _ -> Left r+ matchesVarEq _ _ = error "internal error"++ swapVar (Left (ct,S [P [V v1]], S [P [V v2]]),ps) =+ (Left (ct,S [P [V v2]], S [P [V v1]]),ps)+ swapVar _ = error "internal error"++ findFirstSimpliedWanted (Impossible e) _ = Impossible e+ findFirstSimpliedWanted (Simplified evs) s2+ | any (isWantedCt . snd . fst) evs+ = Simplified evs+ | otherwise+ = s2++-- If we allow negated numbers we simply do not emit the inequalities+-- derived from the subtractions that are converted to additions with a+-- negated operand+subToPred :: Opts -> TyCon -> [(Type, Type)] -> [(PredType, Kind)]+subToPred Opts{..} ordCond+ | negNumbers = const []+ | otherwise = map (subtractionToPred ordCond)++-- Extract the Nat equality constraints+toNatEquality :: TyCon -> (OrigCt, Ct) -> Maybe (Either NatEquality NatInEquality,[(Type,Type)])+toNatEquality ordCond (OrigCt oCt, ct) = case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 t2+ -> go t1 t2+ _ -> Nothing+ where+ go (TyConApp tc xs) (TyConApp tc' ys)+ | tc == tc'+ , null ([tc,tc'] `intersect` [typeNatAddTyCon,typeNatSubTyCon+ ,typeNatMulTyCon,typeNatExpTyCon])+ = case filter (not . uncurry eqType) (zip xs ys) of+ [(x,y)]+ | isNatKind (typeKind x)+ , isNatKind (typeKind y)+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ -> Just (Left (oCt, x', y'),k1 ++ k2)+ _ -> Nothing+#if MIN_VERSION_ghc(9,2,0)+ | tc == ordCond+ , [_,cmp,lt,eq,gt] <- xs+ , TyConApp tcCmpNat [x,y] <- cmp+ , tcCmpNat == typeNatCmpTyCon+ , TyConApp ltTc [] <- lt+ , ltTc == promotedTrueDataCon+ , TyConApp eqTc [] <- eq+ , eqTc == promotedTrueDataCon+ , TyConApp gtTc [] <- gt+ , gtTc == promotedFalseDataCon+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ , let ks = k1 ++ k2+ = case tc' of+ _ | tc' == promotedTrueDataCon+ -> Just (Right (oCt, (x', y', True)), ks)+ _ | tc' == promotedFalseDataCon+ -> Just (Right (oCt, (x', y', False)), ks)+ _ -> Nothing+#else+ | tc == ordCond+ , [x,y] <- xs+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ , let ks = k1 ++ k2+ = case tc' of+ _ | tc' == promotedTrueDataCon+ -> Just (Right (oCt, (x', y', True)), ks)+ _ | tc' == promotedFalseDataCon+ -> Just (Right (oCt, (x', y', False)), ks)+ _ -> Nothing+#endif++ go x y+ | isNatKind (typeKind x)+ , isNatKind (typeKind y)+ , let (x',k1) = runWriter (normaliseNat x)+ , let (y',k2) = runWriter (normaliseNat y)+ = Just (Left (oCt,x',y'),k1 ++ k2)+ | otherwise+ = Nothing++ isNatKind :: Kind -> Bool+ isNatKind = (`eqType` typeNatKind)++unifyItemToPredType :: CoreUnify -> (PredType,Kind)+unifyItemToPredType ui =+ (mkPrimEqPred ty1 ty2,typeNatKind)+ where+ ty1 = case ui of+ SubstItem {..} -> mkTyVarTy siVar+ UnifyItem {..} -> reifySOP siLHS+ ty2 = case ui of+ SubstItem {..} -> reifySOP siSOP+ UnifyItem {..} -> reifySOP siRHS++evSubtPreds :: Ct -> [(PredType,Kind)] -> TcPluginM [Ct]+evSubtPreds ct preds = do+ let predTypes = map fst preds+#if MIN_VERSION_ghc(8,4,1)+ holes <- mapM (newCoercionHole . uncurry mkPrimEqPred . getEqPredTys) predTypes+#else+ holes <- replicateM (length preds) newCoercionHole+#endif+ return (zipWith (unifyItemToCt (ctLoc ct)) predTypes holes)++evMagic :: Ct -> Set CType -> [(PredType,Kind)] -> TcPluginM (Maybe ((EvTerm, Ct), [Ct]))+evMagic ct knW preds = case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 t2 -> do+ holeWanteds <- evSubtPreds ct preds+ knWanted <- mapM (mkKnWanted ct) (toList knW)+ let newWant = knWanted ++ holeWanteds+ ctEv = mkUnivCo (PluginProv "ghc-typelits-natnormalise") Nominal t1 t2+#if MIN_VERSION_ghc(8,5,0)+ return (Just ((EvExpr (Coercion ctEv), ct),newWant))+#else+ return (Just ((EvCoercion ctEv, ct),newWant))+#endif+ _ -> return Nothing++mkNonCanonical' :: CtLoc -> CtEvidence -> Ct+mkNonCanonical' origCtl ev =+ let ct_ls = ctLocSpan origCtl+ ctl = ctEvLoc ev+ in setCtLoc (mkNonCanonical ev) (setCtLocSpan ctl ct_ls)++mkKnWanted+ :: Ct+ -> CType+ -> TcPluginM Ct+mkKnWanted ct (CType ty) = do+ kc_clas <- tcLookupClass knownNatClassName+ let kn_pred = mkClassPred kc_clas [ty]+ wantedCtEv <- TcPluginM.newWanted (ctLoc ct) kn_pred+ let wanted' = mkNonCanonical' (ctLoc ct) wantedCtEv+ return wanted'++unifyItemToCt :: CtLoc+ -> PredType+ -> CoercionHole+ -> Ct+unifyItemToCt loc pred_type hole =+ mkNonCanonical+ (CtWanted+ pred_type+ (HoleDest hole)+#if MIN_VERSION_ghc(8,2,0)+ WDeriv+#endif+ loc)
src/GHC/TypeLits/Normalise/SOP.hs view
@@ -1,342 +1,342 @@-{-| -Copyright : (C) 2015-2016, University of Twente, - 2017 , QBayLogic B.V. -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> - -= SOP: Sum-of-Products, sorta - -The arithmetic operation for 'GHC.TypeLits.Nat' are, addition -(@'GHC.TypeLits.+'@), subtraction (@'GHC.TypeLits.-'@), multiplication -(@'GHC.TypeLits.*'@), and exponentiation (@'GHC.TypeLits.^'@). This means we -cannot write expressions in a canonical SOP normal form. We can get rid of -subtraction by working with integers, and translating @a - b@ to @a + (-1)*b@. -Exponentation cannot be getten rid of that way. So we define the following -grammar for our canonical SOP-like normal form of arithmetic expressions: - -@ -SOP ::= Product \'+\' SOP | Product -Product ::= Symbol \'*\' Product | Symbol -Symbol ::= Integer - | Var - | Var \'^\' Product - | SOP \'^\' ProductE - -ProductE ::= SymbolE \'*\' ProductE | SymbolE -SymbolE ::= Var - | Var \'^\' Product - | SOP \'^\' ProductE -@ - -So a valid SOP terms are: - -@ -x*y + y^2 -(x+y)^(k*z) -@ - -, but, - -@ -(x*y)^2 -@ - -is not, and should be: - -@ -x^2 * y^2 -@ - -Exponents are thus not allowed to have products, so for example, the expression: - -@ -(x + 2)^(y + 2) -@ - -in valid SOP form is: - -@ -4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2 -@ - -Also, exponents can only be integer values when the base is a variable. Although -not enforced by the grammar, the exponentials are flatted as far as possible in -SOP form. So: - -@ -(x^y)^z -@ - -is flattened to: - -@ -x^(y*z) -@ --} - -{-# LANGUAGE CPP #-} - -module GHC.TypeLits.Normalise.SOP - ( -- * SOP types - Symbol (..) - , Product (..) - , SOP (..) - -- * Simplification - , reduceExp - , mergeS - , mergeP - , mergeSOPAdd - , mergeSOPMul - , normaliseExp - , simplifySOP - ) -where - --- External -import Data.Either (partitionEithers) -import Data.List (sort) - --- GHC API -#if MIN_VERSION_ghc(9,0,0) -import GHC.Utils.Outputable (Outputable (..), (<+>), text, hcat, integer, punctuate) -#else -import Outputable (Outputable (..), (<+>), text, hcat, integer, punctuate) -#endif - -data Symbol v c - = I Integer -- ^ Integer constant - | C c -- ^ Non-integer constant - | E (SOP v c) (Product v c) -- ^ Exponentiation - | V v -- ^ Variable - deriving (Eq,Ord) - -newtype Product v c = P { unP :: [Symbol v c] } - deriving (Eq) - -instance (Ord v, Ord c) => Ord (Product v c) where - compare (P [x]) (P [y]) = compare x y - compare (P [_]) (P (_:_)) = LT - compare (P (_:_)) (P [_]) = GT - compare (P xs) (P ys) = compare xs ys - -newtype SOP v c = S { unS :: [Product v c] } - deriving (Ord) - -instance (Eq v, Eq c) => Eq (SOP v c) where - (S []) == (S [P [I 0]]) = True - (S [P [I 0]]) == (S []) = True - (S ps1) == (S ps2) = ps1 == ps2 - -instance (Outputable v, Outputable c) => Outputable (SOP v c) where - ppr = hcat . punctuate (text " + ") . map ppr . unS - -instance (Outputable v, Outputable c) => Outputable (Product v c) where - ppr = hcat . punctuate (text " * ") . map ppr . unP - -instance (Outputable v, Outputable c) => Outputable (Symbol v c) where - ppr (I i) = integer i - ppr (C c) = ppr c - ppr (V s) = ppr s - ppr (E b e) = case (pprSimple b, pprSimple (S [e])) of - (bS,eS) -> bS <+> text "^" <+> eS - where - pprSimple (S [P [I i]]) = integer i - pprSimple (S [P [V v]]) = ppr v - pprSimple sop = text "(" <+> ppr sop <+> text ")" - -mergeWith :: (a -> a -> Either a a) -> [a] -> [a] -mergeWith _ [] = [] -mergeWith op (f:fs) = case partitionEithers $ map (`op` f) fs of - ([],_) -> f : mergeWith op fs - (updated,untouched) -> mergeWith op (updated ++ untouched) - --- | reduce exponentials --- --- Performs the following rewrites: --- --- @ --- x^0 ==> 1 --- 0^x ==> 0 --- 2^3 ==> 8 --- (k ^ i) ^ j ==> k ^ (i * j) --- @ -reduceExp :: (Ord v, Ord c) => Symbol v c -> Symbol v c -reduceExp (E _ (P [(I 0)])) = I 1 -- x^0 ==> 1 -reduceExp (E (S [P [I 0]]) _ ) = I 0 -- 0^x ==> 0 -reduceExp (E (S [P [(I i)]]) (P [(I j)])) - | j >= 0 = I (i ^ j) -- 2^3 ==> 8 - --- (k ^ i) ^ j ==> k ^ (i * j) -reduceExp (E (S [P [(E k i)]]) j) = case normaliseExp k (S [e]) of - (S [P [s]]) -> s - _ -> E k e - where - e = P . sort . map reduceExp $ mergeWith mergeS (unP i ++ unP j) - -reduceExp s = s - --- | Merge two symbols of a Product term --- --- Performs the following rewrites: --- --- @ --- 8 * 7 ==> 56 --- 1 * x ==> x --- x * 1 ==> x --- 0 * x ==> 0 --- x * 0 ==> 0 --- x * x^4 ==> x^5 --- x^4 * x ==> x^5 --- y*y ==> y^2 --- @ -mergeS :: (Ord v, Ord c) => Symbol v c -> Symbol v c - -> Either (Symbol v c) (Symbol v c) -mergeS (I i) (I j) = Left (I (i * j)) -- 8 * 7 ==> 56 -mergeS (I 1) r = Left r -- 1 * x ==> x -mergeS l (I 1) = Left l -- x * 1 ==> x -mergeS (I 0) _ = Left (I 0) -- 0 * x ==> 0 -mergeS _ (I 0) = Left (I 0) -- x * 0 ==> 0 - --- x * x^4 ==> x^5 -mergeS s (E (S [P [s']]) (P [I i])) - | s == s' - = Left (E (S [P [s']]) (P [I (i + 1)])) - --- x^4 * x ==> x^5 -mergeS (E (S [P [s']]) (P [I i])) s - | s == s' - = Left (E (S [P [s']]) (P [I (i + 1)])) - --- 4^x * 2^x ==> 8^x -mergeS (E (S [P [I i]]) p) (E (S [P [I j]]) p') - | p == p' - = Left (E (S [P [I (i*j)]]) p) - --- y*y ==> y^2 -mergeS l r - | l == r - = case normaliseExp (S [P [l]]) (S [P [I 2]]) of - (S [P [e]]) -> Left e - _ -> Right l - --- x^y * x^(-y) ==> 1 -mergeS (E s1 (P p1)) (E s2 (P (I i:p2))) - | i == (-1) - , s1 == s2 - , p1 == p2 - = Left (I 1) - --- x^(-y) * x^y ==> 1 -mergeS (E s1 (P (I i:p1))) (E s2 (P p2)) - | i == (-1) - , s1 == s2 - , p1 == p2 - = Left (I 1) - -mergeS l _ = Right l - --- | Merge two products of a SOP term --- --- Performs the following rewrites: --- --- @ --- 2xy + 3xy ==> 5xy --- 2xy + xy ==> 3xy --- xy + 2xy ==> 3xy --- xy + xy ==> 2xy --- @ -mergeP :: (Eq v, Eq c) => Product v c -> Product v c - -> Either (Product v c) (Product v c) --- 2xy + 3xy ==> 5xy -mergeP (P ((I i):is)) (P ((I j):js)) - | is == js = Left . P $ (I (i + j)) : is --- 2xy + xy ==> 3xy -mergeP (P ((I i):is)) (P js) - | is == js = Left . P $ (I (i + 1)) : is --- xy + 2xy ==> 3xy -mergeP (P is) (P ((I j):js)) - | is == js = Left . P $ (I (j + 1)) : is --- xy + xy ==> 2xy -mergeP (P is) (P js) - | is == js = Left . P $ (I 2) : is - | otherwise = Right $ P is - --- | Expand or Simplify 'complex' exponentials --- --- Performs the following rewrites: --- --- @ --- b^1 ==> b --- 2^(y^2) ==> 4^y --- (x + 2)^2 ==> x^2 + 4xy + 4 --- (x + 2)^(2x) ==> (x^2 + 4xy + 4)^x --- (x + 2)^(y + 2) ==> 4x(2 + x)^y + 4(2 + x)^y + (2 + x)^yx^2 --- @ -normaliseExp :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c --- b^1 ==> b -normaliseExp b (S [P [I 1]]) = b - --- x^(2xy) ==> x^(2xy) -normaliseExp b@(S [P [V _]]) (S [e]) = S [P [E b e]] - --- 2^(y^2) ==> 4^y -normaliseExp b@(S [P [_]]) (S [e@(P [_])]) = S [P [reduceExp (E b e)]] - --- (x + 2)^2 ==> x^2 + 4xy + 4 -normaliseExp b (S [P [(I i)]]) | i > 0 = - foldr1 mergeSOPMul (replicate (fromInteger i) b) - --- (x + 2)^(2x) ==> (x^2 + 4xy + 4)^x -normaliseExp b (S [P (e@(I i):es)]) | i >= 0 = - -- Without the "| i >= 0" guard, normaliseExp can loop with itself - -- for exponentials such as: 2^(n-k) - normaliseExp (normaliseExp b (S [P [e]])) (S [P es]) - --- (x + 2)^(xy) ==> (x+2)^(xy) -normaliseExp b (S [e]) = S [P [reduceExp (E b e)]] - --- (x + 2)^(y + 2) ==> 4x(2 + x)^y + 4(2 + x)^y + (2 + x)^yx^2 -normaliseExp b (S e) = foldr1 mergeSOPMul (map (normaliseExp b . S . (:[])) e) - -zeroP :: Product v c -> Bool -zeroP (P ((I 0):_)) = True -zeroP _ = False - -mkNonEmpty :: SOP v c -> SOP v c -mkNonEmpty (S []) = S [P [(I 0)]] -mkNonEmpty s = s - --- | Simplifies SOP terms using --- --- * 'mergeS' --- * 'mergeP' --- * 'reduceExp' -simplifySOP :: (Ord v, Ord c) => SOP v c -> SOP v c -simplifySOP = repeatF go - where - go = mkNonEmpty - . S - . sort . filter (not . zeroP) - . mergeWith mergeP - . map (P . sort . map reduceExp . mergeWith mergeS . unP) - . unS - - repeatF f x = - let x' = f x - in if x' == x - then x - else repeatF f x' -{-# INLINEABLE simplifySOP #-} - --- | Merge two SOP terms by additions -mergeSOPAdd :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c -mergeSOPAdd (S sop1) (S sop2) = simplifySOP $ S (sop1 ++ sop2) -{-# INLINEABLE mergeSOPAdd #-} - --- | Merge two SOP terms by multiplication -mergeSOPMul :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c -mergeSOPMul (S sop1) (S sop2) - = simplifySOP - . S - $ concatMap (zipWith (\p1 p2 -> P (unP p1 ++ unP p2)) sop1 . repeat) sop2 -{-# INLINEABLE mergeSOPMul #-} +{-|+Copyright : (C) 2015-2016, University of Twente,+ 2017 , QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>++= SOP: Sum-of-Products, sorta++The arithmetic operation for 'GHC.TypeLits.Nat' are, addition+(@'GHC.TypeLits.+'@), subtraction (@'GHC.TypeLits.-'@), multiplication+(@'GHC.TypeLits.*'@), and exponentiation (@'GHC.TypeLits.^'@). This means we+cannot write expressions in a canonical SOP normal form. We can get rid of+subtraction by working with integers, and translating @a - b@ to @a + (-1)*b@.+Exponentation cannot be getten rid of that way. So we define the following+grammar for our canonical SOP-like normal form of arithmetic expressions:++@+SOP ::= Product \'+\' SOP | Product+Product ::= Symbol \'*\' Product | Symbol+Symbol ::= Integer+ | Var+ | Var \'^\' Product+ | SOP \'^\' ProductE++ProductE ::= SymbolE \'*\' ProductE | SymbolE+SymbolE ::= Var+ | Var \'^\' Product+ | SOP \'^\' ProductE+@++So a valid SOP terms are:++@+x*y + y^2+(x+y)^(k*z)+@++, but,++@+(x*y)^2+@++is not, and should be:++@+x^2 * y^2+@++Exponents are thus not allowed to have products, so for example, the expression:++@+(x + 2)^(y + 2)+@++in valid SOP form is:++@+4*x*(2 + x)^y + 4*(2 + x)^y + (2 + x)^y*x^2+@++Also, exponents can only be integer values when the base is a variable. Although+not enforced by the grammar, the exponentials are flatted as far as possible in+SOP form. So:++@+(x^y)^z+@++is flattened to:++@+x^(y*z)+@+-}++{-# LANGUAGE CPP #-}++module GHC.TypeLits.Normalise.SOP+ ( -- * SOP types+ Symbol (..)+ , Product (..)+ , SOP (..)+ -- * Simplification+ , reduceExp+ , mergeS+ , mergeP+ , mergeSOPAdd+ , mergeSOPMul+ , normaliseExp+ , simplifySOP+ )+where++-- External+import Data.Either (partitionEithers)+import Data.List (sort)++-- GHC API+#if MIN_VERSION_ghc(9,0,0)+import GHC.Utils.Outputable (Outputable (..), (<+>), text, hcat, integer, punctuate)+#else+import Outputable (Outputable (..), (<+>), text, hcat, integer, punctuate)+#endif++data Symbol v c+ = I Integer -- ^ Integer constant+ | C c -- ^ Non-integer constant+ | E (SOP v c) (Product v c) -- ^ Exponentiation+ | V v -- ^ Variable+ deriving (Eq,Ord)++newtype Product v c = P { unP :: [Symbol v c] }+ deriving (Eq)++instance (Ord v, Ord c) => Ord (Product v c) where+ compare (P [x]) (P [y]) = compare x y+ compare (P [_]) (P (_:_)) = LT+ compare (P (_:_)) (P [_]) = GT+ compare (P xs) (P ys) = compare xs ys++newtype SOP v c = S { unS :: [Product v c] }+ deriving (Ord)++instance (Eq v, Eq c) => Eq (SOP v c) where+ (S []) == (S [P [I 0]]) = True+ (S [P [I 0]]) == (S []) = True+ (S ps1) == (S ps2) = ps1 == ps2++instance (Outputable v, Outputable c) => Outputable (SOP v c) where+ ppr = hcat . punctuate (text " + ") . map ppr . unS++instance (Outputable v, Outputable c) => Outputable (Product v c) where+ ppr = hcat . punctuate (text " * ") . map ppr . unP++instance (Outputable v, Outputable c) => Outputable (Symbol v c) where+ ppr (I i) = integer i+ ppr (C c) = ppr c+ ppr (V s) = ppr s+ ppr (E b e) = case (pprSimple b, pprSimple (S [e])) of+ (bS,eS) -> bS <+> text "^" <+> eS+ where+ pprSimple (S [P [I i]]) = integer i+ pprSimple (S [P [V v]]) = ppr v+ pprSimple sop = text "(" <+> ppr sop <+> text ")"++mergeWith :: (a -> a -> Either a a) -> [a] -> [a]+mergeWith _ [] = []+mergeWith op (f:fs) = case partitionEithers $ map (`op` f) fs of+ ([],_) -> f : mergeWith op fs+ (updated,untouched) -> mergeWith op (updated ++ untouched)++-- | reduce exponentials+--+-- Performs the following rewrites:+--+-- @+-- x^0 ==> 1+-- 0^x ==> 0+-- 2^3 ==> 8+-- (k ^ i) ^ j ==> k ^ (i * j)+-- @+reduceExp :: (Ord v, Ord c) => Symbol v c -> Symbol v c+reduceExp (E _ (P [(I 0)])) = I 1 -- x^0 ==> 1+reduceExp (E (S [P [I 0]]) _ ) = I 0 -- 0^x ==> 0+reduceExp (E (S [P [(I i)]]) (P [(I j)]))+ | j >= 0 = I (i ^ j) -- 2^3 ==> 8++-- (k ^ i) ^ j ==> k ^ (i * j)+reduceExp (E (S [P [(E k i)]]) j) = case normaliseExp k (S [e]) of+ (S [P [s]]) -> s+ _ -> E k e+ where+ e = P . sort . map reduceExp $ mergeWith mergeS (unP i ++ unP j)++reduceExp s = s++-- | Merge two symbols of a Product term+--+-- Performs the following rewrites:+--+-- @+-- 8 * 7 ==> 56+-- 1 * x ==> x+-- x * 1 ==> x+-- 0 * x ==> 0+-- x * 0 ==> 0+-- x * x^4 ==> x^5+-- x^4 * x ==> x^5+-- y*y ==> y^2+-- @+mergeS :: (Ord v, Ord c) => Symbol v c -> Symbol v c+ -> Either (Symbol v c) (Symbol v c)+mergeS (I i) (I j) = Left (I (i * j)) -- 8 * 7 ==> 56+mergeS (I 1) r = Left r -- 1 * x ==> x+mergeS l (I 1) = Left l -- x * 1 ==> x+mergeS (I 0) _ = Left (I 0) -- 0 * x ==> 0+mergeS _ (I 0) = Left (I 0) -- x * 0 ==> 0++-- x * x^4 ==> x^5+mergeS s (E (S [P [s']]) (P [I i]))+ | s == s'+ = Left (E (S [P [s']]) (P [I (i + 1)]))++-- x^4 * x ==> x^5+mergeS (E (S [P [s']]) (P [I i])) s+ | s == s'+ = Left (E (S [P [s']]) (P [I (i + 1)]))++-- 4^x * 2^x ==> 8^x+mergeS (E (S [P [I i]]) p) (E (S [P [I j]]) p')+ | p == p'+ = Left (E (S [P [I (i*j)]]) p)++-- y*y ==> y^2+mergeS l r+ | l == r+ = case normaliseExp (S [P [l]]) (S [P [I 2]]) of+ (S [P [e]]) -> Left e+ _ -> Right l++-- x^y * x^(-y) ==> 1+mergeS (E s1 (P p1)) (E s2 (P (I i:p2)))+ | i == (-1)+ , s1 == s2+ , p1 == p2+ = Left (I 1)++-- x^(-y) * x^y ==> 1+mergeS (E s1 (P (I i:p1))) (E s2 (P p2))+ | i == (-1)+ , s1 == s2+ , p1 == p2+ = Left (I 1)++mergeS l _ = Right l++-- | Merge two products of a SOP term+--+-- Performs the following rewrites:+--+-- @+-- 2xy + 3xy ==> 5xy+-- 2xy + xy ==> 3xy+-- xy + 2xy ==> 3xy+-- xy + xy ==> 2xy+-- @+mergeP :: (Eq v, Eq c) => Product v c -> Product v c+ -> Either (Product v c) (Product v c)+-- 2xy + 3xy ==> 5xy+mergeP (P ((I i):is)) (P ((I j):js))+ | is == js = Left . P $ (I (i + j)) : is+-- 2xy + xy ==> 3xy+mergeP (P ((I i):is)) (P js)+ | is == js = Left . P $ (I (i + 1)) : is+-- xy + 2xy ==> 3xy+mergeP (P is) (P ((I j):js))+ | is == js = Left . P $ (I (j + 1)) : is+-- xy + xy ==> 2xy+mergeP (P is) (P js)+ | is == js = Left . P $ (I 2) : is+ | otherwise = Right $ P is++-- | Expand or Simplify 'complex' exponentials+--+-- Performs the following rewrites:+--+-- @+-- b^1 ==> b+-- 2^(y^2) ==> 4^y+-- (x + 2)^2 ==> x^2 + 4xy + 4+-- (x + 2)^(2x) ==> (x^2 + 4xy + 4)^x+-- (x + 2)^(y + 2) ==> 4x(2 + x)^y + 4(2 + x)^y + (2 + x)^yx^2+-- @+normaliseExp :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c+-- b^1 ==> b+normaliseExp b (S [P [I 1]]) = b++-- x^(2xy) ==> x^(2xy)+normaliseExp b@(S [P [V _]]) (S [e]) = S [P [E b e]]++-- 2^(y^2) ==> 4^y+normaliseExp b@(S [P [_]]) (S [e@(P [_])]) = S [P [reduceExp (E b e)]]++-- (x + 2)^2 ==> x^2 + 4xy + 4+normaliseExp b (S [P [(I i)]]) | i > 0 =+ foldr1 mergeSOPMul (replicate (fromInteger i) b)++-- (x + 2)^(2x) ==> (x^2 + 4xy + 4)^x+normaliseExp b (S [P (e@(I i):es)]) | i >= 0 =+ -- Without the "| i >= 0" guard, normaliseExp can loop with itself+ -- for exponentials such as: 2^(n-k)+ normaliseExp (normaliseExp b (S [P [e]])) (S [P es])++-- (x + 2)^(xy) ==> (x+2)^(xy)+normaliseExp b (S [e]) = S [P [reduceExp (E b e)]]++-- (x + 2)^(y + 2) ==> 4x(2 + x)^y + 4(2 + x)^y + (2 + x)^yx^2+normaliseExp b (S e) = foldr1 mergeSOPMul (map (normaliseExp b . S . (:[])) e)++zeroP :: Product v c -> Bool+zeroP (P ((I 0):_)) = True+zeroP _ = False++mkNonEmpty :: SOP v c -> SOP v c+mkNonEmpty (S []) = S [P [(I 0)]]+mkNonEmpty s = s++-- | Simplifies SOP terms using+--+-- * 'mergeS'+-- * 'mergeP'+-- * 'reduceExp'+simplifySOP :: (Ord v, Ord c) => SOP v c -> SOP v c+simplifySOP = repeatF go+ where+ go = mkNonEmpty+ . S+ . sort . filter (not . zeroP)+ . mergeWith mergeP+ . map (P . sort . map reduceExp . mergeWith mergeS . unP)+ . unS++ repeatF f x =+ let x' = f x+ in if x' == x+ then x+ else repeatF f x'+{-# INLINEABLE simplifySOP #-}++-- | Merge two SOP terms by additions+mergeSOPAdd :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c+mergeSOPAdd (S sop1) (S sop2) = simplifySOP $ S (sop1 ++ sop2)+{-# INLINEABLE mergeSOPAdd #-}++-- | Merge two SOP terms by multiplication+mergeSOPMul :: (Ord v, Ord c) => SOP v c -> SOP v c -> SOP v c+mergeSOPMul (S sop1) (S sop2)+ = simplifySOP+ . S+ $ concatMap (zipWith (\p1 p2 -> P (unP p1 ++ unP p2)) sop1 . repeat) sop2+{-# INLINEABLE mergeSOPMul #-}
src/GHC/TypeLits/Normalise/Unify.hs view
@@ -1,1021 +1,1021 @@-{-| -Copyright : (C) 2015-2016, University of Twente, - 2017 , QBayLogic B.V. -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -#if __GLASGOW_HASKELL__ < 801 -#define nonDetCmpType cmpType -#endif - -module GHC.TypeLits.Normalise.Unify - ( -- * 'Nat' expressions \<-\> 'SOP' terms - CType (..) - , CoreSOP - , normaliseNat - , normaliseNatEverywhere - , normaliseSimplifyNat - , reifySOP - -- * Substitution on 'SOP' terms - , UnifyItem (..) - , CoreUnify - , substsSOP - , substsSubst - -- * Find unifiers - , UnifyResult (..) - , unifyNats - , unifiers - -- * Free variables in 'SOP' terms - , fvSOP - -- * Inequalities - , subtractIneq - , solveIneq - , ineqToSubst - , subtractionToPred - , instantSolveIneq - , solvedInEqSmallestConstraint - -- * Properties - , isNatural - ) -where - --- External -import Control.Arrow (first, second) -import Control.Monad.Trans.Writer.Strict -import Data.Function (on) -import Data.List ((\\), intersect, nub) -import Data.Maybe (fromMaybe, mapMaybe, isJust) -import Data.Set (Set) -import qualified Data.Set as Set - -import GHC.Base (isTrue#,(==#)) -import GHC.Integer (smallInteger) -import GHC.Integer.Logarithms (integerLogBase#) - --- GHC API -#if MIN_VERSION_ghc(9,0,0) -import GHC.Builtin.Types (boolTy, promotedTrueDataCon) -import GHC.Builtin.Types.Literals - (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Builtin.Types (naturalTy, promotedFalseDataCon) -import GHC.Builtin.Types.Literals (typeNatCmpTyCon) -#else -import GHC.Builtin.Types (typeNatKind) -import GHC.Builtin.Types.Literals (typeNatLeqTyCon) -#endif -import GHC.Core.Predicate (EqRel (NomEq), Pred (EqPred), classifyPredType, mkPrimEqPred) -import GHC.Core.TyCon (TyCon) -#if MIN_VERSION_ghc(9,6,0) -import GHC.Core.Type - (PredType, TyVar, coreView, mkNumLitTy, mkTyConApp, mkTyVarTy, typeKind) -import GHC.Core.TyCo.Compare - (eqType, nonDetCmpType) -#else -import GHC.Core.Type - (PredType, TyVar, coreView, eqType, mkNumLitTy, mkTyConApp, mkTyVarTy, nonDetCmpType, typeKind) -#endif -import GHC.Core.TyCo.Rep (Kind, Type (..), TyLit (..)) -import GHC.Tc.Plugin (TcPluginM, tcPluginTrace) -import GHC.Tc.Types.Constraint (Ct, ctEvidence, ctEvId, ctEvPred, isGiven) -import GHC.Types.Unique.Set - (UniqSet, unionManyUniqSets, emptyUniqSet, unionUniqSets, unitUniqSet) -import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text) -#else -import Outputable (Outputable (..), (<+>), ($$), text) -import TcPluginM (TcPluginM, tcPluginTrace) -import TcTypeNats (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, - typeNatSubTyCon, typeNatLeqTyCon) -import TyCon (TyCon) -import Type (TyVar, - coreView, eqType, mkNumLitTy, mkTyConApp, mkTyVarTy, - nonDetCmpType, PredType, typeKind) -import TyCoRep (Kind, Type (..), TyLit (..)) -import TysWiredIn (boolTy, promotedTrueDataCon, typeNatKind) -import UniqSet (UniqSet, unionManyUniqSets, emptyUniqSet, unionUniqSets, - unitUniqSet) - -#if MIN_VERSION_ghc(8,10,0) -import Constraint (Ct, ctEvidence, ctEvId, ctEvPred, isGiven) -import Predicate (EqRel (NomEq), Pred (EqPred), classifyPredType, mkPrimEqPred) -#else -import TcRnMonad (Ct, ctEvidence, isGiven) -import TcRnTypes (ctEvPred) -import Type (EqRel (NomEq), PredTree (EqPred), classifyPredType, mkPrimEqPred) -#endif -#endif - --- Internal -import GHC.TypeLits.Normalise.SOP - --- Used for haddock -import GHC.TypeLits (Nat) - -#if MIN_VERSION_ghc(9,2,0) -typeNatKind :: Type -typeNatKind = naturalTy -#endif - -newtype CType = CType { unCType :: Type } - deriving Outputable - -instance Eq CType where - (CType ty1) == (CType ty2) = eqType ty1 ty2 - -instance Ord CType where - compare (CType ty1) (CType ty2) = nonDetCmpType ty1 ty2 - --- | 'SOP' with 'TyVar' variables -type CoreSOP = SOP TyVar CType -type CoreProduct = Product TyVar CType -type CoreSymbol = Symbol TyVar CType - --- | Convert a type of /kind/ 'GHC.TypeLits.Nat' to an 'SOP' term, but --- only when the type is constructed out of: --- --- * literals --- * type variables --- * Applications of the arithmetic operators @(+,-,*,^)@ -normaliseNat :: Type -> Writer [(Type,Type)] CoreSOP -normaliseNat ty | Just ty1 <- coreView ty = normaliseNat ty1 -normaliseNat (TyVarTy v) = return (S [P [V v]]) -normaliseNat (LitTy (NumTyLit i)) = return (S [P [I i]]) -normaliseNat (TyConApp tc [x,y]) - | tc == typeNatAddTyCon = mergeSOPAdd <$> normaliseNat x <*> normaliseNat y - | tc == typeNatSubTyCon = do - tell [(x,y)] - mergeSOPAdd <$> normaliseNat x - <*> (mergeSOPMul (S [P [I (-1)]]) <$> normaliseNat y) - | tc == typeNatMulTyCon = mergeSOPMul <$> normaliseNat x <*> normaliseNat y - | tc == typeNatExpTyCon = normaliseExp <$> normaliseNat x <*> normaliseNat y -normaliseNat t = return (S [P [C (CType t)]]) - --- | Runs writer action. If the result /Nothing/ writer actions will be --- discarded. -maybeRunWriter - :: Monoid a - => Writer a (Maybe b) - -> Writer a (Maybe b) -maybeRunWriter w = - case runWriter w of - (Nothing, _) -> pure Nothing - (b, a) -> tell a >> pure b - --- | Applies 'normaliseNat' and 'simplifySOP' to type or predicates to reduce --- any occurrences of sub-terms of /kind/ 'GHC.TypeLits.Nat'. If the result is --- the same as input, returns @'Nothing'@. -normaliseNatEverywhere :: Type -> Writer [(Type, Type)] (Maybe Type) -normaliseNatEverywhere ty0 - | TyConApp tc _fields <- ty0 - , tc `elem` knownTyCons = do - -- Normalize under current type constructor application. 'go' skips all - -- known type constructors. - ty1M <- maybeRunWriter (go ty0) - let ty1 = fromMaybe ty0 ty1M - - -- Normalize (subterm-normalized) type given to 'normaliseNatEverywhere' - ty2 <- normaliseSimplifyNat ty1 - -- TODO: 'normaliseNat' could keep track whether it changed anything. That's - -- TODO: probably cheaper than checking for equality here. - pure (if ty2 `eqType` ty1 then ty1M else Just ty2) - | otherwise = go ty0 - where - knownTyCons :: [TyCon] - knownTyCons = [typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon, typeNatAddTyCon] - - -- Normalize given type, but ignore all top-level - go :: Type -> Writer [(Type, Type)] (Maybe Type) - go (TyConApp tc_ fields0_) = do - fields1_ <- mapM (maybeRunWriter . cont) fields0_ - if any isJust fields1_ then - pure (Just (TyConApp tc_ (zipWith fromMaybe fields0_ fields1_))) - else - pure Nothing - where - cont = if tc_ `elem` knownTyCons then go else normaliseNatEverywhere - go _ = pure Nothing - -normaliseSimplifyNat :: Type -> Writer [(Type, Type)] Type -normaliseSimplifyNat ty - | typeKind ty `eqType` typeNatKind = do - ty' <- normaliseNat ty - return $ reifySOP $ simplifySOP ty' - | otherwise = return ty - --- | Convert a 'SOP' term back to a type of /kind/ 'GHC.TypeLits.Nat' -reifySOP :: CoreSOP -> Type -reifySOP = combineP . map negateP . unS - where - negateP :: CoreProduct -> Either CoreProduct CoreProduct - negateP (P ((I i):ps@(_:_))) | i == (-1) = Left (P ps) - negateP (P ((I i):ps)) | i < 0 = Left (P ((I (abs i)):ps)) - negateP ps = Right ps - - combineP :: [Either CoreProduct CoreProduct] -> Type - combineP [] = mkNumLitTy 0 - combineP [p] = either (\p' -> mkTyConApp typeNatSubTyCon - [mkNumLitTy 0, reifyProduct p']) - reifyProduct p - combineP [p1,p2] = either - (\x -> either - -- x neg, y neg - (\y -> let r = mkTyConApp typeNatSubTyCon [reifyProduct x - ,reifyProduct y] - in mkTyConApp typeNatSubTyCon [mkNumLitTy 0, r]) - -- x neg, y pos - (\y -> mkTyConApp typeNatSubTyCon [reifyProduct y, reifyProduct x]) - p2) - (\x -> either - -- x pos, y neg - (\y -> mkTyConApp typeNatSubTyCon [reifyProduct x, reifyProduct y]) - -- x pos, y pos - (\y -> mkTyConApp typeNatAddTyCon [reifyProduct x, reifyProduct y]) - p2) - p1 - - - combineP (p:ps) = let es = combineP ps - in either (\x -> mkTyConApp typeNatSubTyCon - [es, reifyProduct x]) - (\x -> mkTyConApp typeNatAddTyCon - [reifyProduct x, es]) - p - -reifyProduct :: CoreProduct -> Type -reifyProduct (P ps) = - let ps' = map reifySymbol (foldr mergeExp [] ps) - in foldr1 (\t1 t2 -> mkTyConApp typeNatMulTyCon [t1,t2]) ps' - where - -- "2 ^ -1 * 2 ^ a" must be merged into "2 ^ (a-1)", otherwise GHC barfs - -- at the "2 ^ -1" because of the negative exponent. - mergeExp :: CoreSymbol -> [Either CoreSymbol (CoreSOP,[CoreProduct])] - -> [Either CoreSymbol (CoreSOP,[CoreProduct])] - mergeExp (E s p) [] = [Right (s,[p])] - mergeExp (E s1 p1) (y:ys) - | Right (s2,p2) <- y - , s1 == s2 - = Right (s1,(p1:p2)) : ys - | otherwise - = Right (s1,[p1]) : y : ys - mergeExp x ys = Left x : ys - -reifySymbol :: Either CoreSymbol (CoreSOP,[CoreProduct]) -> Type -reifySymbol (Left (I i) ) = mkNumLitTy i -reifySymbol (Left (C c) ) = unCType c -reifySymbol (Left (V v) ) = mkTyVarTy v -reifySymbol (Left (E s p)) = mkTyConApp typeNatExpTyCon [reifySOP s,reifyProduct p] -reifySymbol (Right (s1,s2)) = mkTyConApp typeNatExpTyCon - [reifySOP s1 - ,reifySOP (S s2) - ] - --- | Subtract an inequality, in order to either: --- --- * See if the smallest solution is a natural number --- * Cancel sums, i.e. monotonicity of addition --- --- @ --- subtractIneq (2*y <=? 3*x ~ True) = (-2*y + 3*x) --- subtractIneq (2*y <=? 3*x ~ False) = (-3*x + (-1) + 2*y) --- @ -subtractIneq - :: (CoreSOP, CoreSOP, Bool) - -> CoreSOP -subtractIneq (x,y,isLE) - | isLE - = mergeSOPAdd y (mergeSOPMul (S [P [I (-1)]]) x) - | otherwise - = mergeSOPAdd x (mergeSOPMul (S [P [I (-1)]]) (mergeSOPAdd y (S [P [I 1]]))) - --- | Try to reverse the process of 'subtractIneq' --- --- E.g. --- --- @ --- subtractIneq (2*y <=? 3*x ~ True) = (-2*y + 3*x) --- sopToIneq (-2*y+3*x) = Just (2*x <=? 3*x ~ True) --- @ -sopToIneq - :: CoreSOP - -> Maybe Ineq -sopToIneq (S [P ((I i):l),r]) - | i < 0 - = Just (mergeSOPMul (S [P [I (negate i)]]) (S [P l]),S [r],True) -sopToIneq (S [r,P ((I i:l))]) - | i < 0 - = Just (mergeSOPMul (S [P [I (negate i)]]) (S [P l]),S [r],True) -sopToIneq _ = Nothing - --- | Give the smallest solution for an inequality -ineqToSubst - :: Ineq - -> Maybe CoreUnify -ineqToSubst (x,S [P [V v]],True) - = Just (SubstItem v x) -ineqToSubst _ - = Nothing - -subtractionToPred - :: TyCon - -> (Type,Type) - -> (PredType, Kind) -subtractionToPred ordCond (x,y) = -#if MIN_VERSION_ghc(9,2,0) - let cmpNat = mkTyConApp typeNatCmpTyCon [y,x] - trueTc = mkTyConApp promotedTrueDataCon [] - falseTc = mkTyConApp promotedFalseDataCon [] - ordCmp = mkTyConApp ordCond - [boolTy,cmpNat,trueTc,trueTc,falseTc] - predTy = mkPrimEqPred ordCmp trueTc - in (predTy,boolTy) -#else - (mkPrimEqPred (mkTyConApp ordCond [y,x]) - (mkTyConApp promotedTrueDataCon []) - ,boolTy) -#endif - --- | A substitution is essentially a list of (variable, 'SOP') pairs, --- but we keep the original 'Ct' that lead to the substitution being --- made, for use when turning the substitution back into constraints. -type CoreUnify = UnifyItem TyVar CType - -data UnifyItem v c = SubstItem { siVar :: v - , siSOP :: SOP v c - } - | UnifyItem { siLHS :: SOP v c - , siRHS :: SOP v c - } - deriving Eq - -instance (Outputable v, Outputable c) => Outputable (UnifyItem v c) where - ppr (SubstItem {..}) = ppr siVar <+> text " := " <+> ppr siSOP - ppr (UnifyItem {..}) = ppr siLHS <+> text " :~ " <+> ppr siRHS - --- | Apply a substitution to a single normalised 'SOP' term -substsSOP :: (Ord v, Ord c) => [UnifyItem v c] -> SOP v c -> SOP v c -substsSOP [] u = u -substsSOP ((SubstItem {..}):s) u = substsSOP s (substSOP siVar siSOP u) -substsSOP ((UnifyItem {}):s) u = substsSOP s u - -substSOP :: (Ord v, Ord c) => v -> SOP v c -> SOP v c -> SOP v c -substSOP tv e = foldr1 mergeSOPAdd . map (substProduct tv e) . unS - -substProduct :: (Ord v, Ord c) => v -> SOP v c -> Product v c -> SOP v c -substProduct tv e = foldr1 mergeSOPMul . map (substSymbol tv e) . unP - -substSymbol :: (Ord v, Ord c) => v -> SOP v c -> Symbol v c -> SOP v c -substSymbol _ _ s@(I _) = S [P [s]] -substSymbol _ _ s@(C _) = S [P [s]] -substSymbol tv e (V tv') - | tv == tv' = e - | otherwise = S [P [V tv']] -substSymbol tv e (E s p) = normaliseExp (substSOP tv e s) (substProduct tv e p) - --- | Apply a substitution to a substitution -substsSubst :: (Ord v, Ord c) => [UnifyItem v c] -> [UnifyItem v c] -> [UnifyItem v c] -substsSubst s = map subt - where - subt si@(SubstItem {..}) = si {siSOP = substsSOP s siSOP} - subt si@(UnifyItem {..}) = si {siLHS = substsSOP s siLHS, siRHS = substsSOP s siRHS} -{-# INLINEABLE substsSubst #-} - --- | Result of comparing two 'SOP' terms, returning a potential substitution --- list under which the two terms are equal. -data UnifyResult - = Win -- ^ Two terms are equal - | Lose -- ^ Two terms are /not/ equal - | Draw [CoreUnify] -- ^ Two terms are only equal if the given substitution holds - -instance Outputable UnifyResult where - ppr Win = text "Win" - ppr (Draw subst) = text "Draw" <+> ppr subst - ppr Lose = text "Lose" - --- | Given two 'SOP's @u@ and @v@, when their free variables ('fvSOP') are the --- same, then we 'Win' if @u@ and @v@ are equal, and 'Lose' otherwise. --- --- If @u@ and @v@ do not have the same free variables, we result in a 'Draw', --- ware @u@ and @v@ are only equal when the returned 'CoreSubst' holds. -unifyNats :: Ct -> CoreSOP -> CoreSOP -> TcPluginM UnifyResult -unifyNats ct u v = do - tcPluginTrace "unifyNats" (ppr ct $$ ppr u $$ ppr v) - return (unifyNats' ct u v) - -unifyNats' :: Ct -> CoreSOP -> CoreSOP -> UnifyResult -unifyNats' ct u v - = if eqFV u v - then if containsConstants u || containsConstants v - then if u == v - then Win - else Draw (filter diffFromConstraint (unifiers ct u v)) - else if u == v - then Win - else Lose - else Draw (filter diffFromConstraint (unifiers ct u v)) - where - -- A unifier is only a unifier if differs from the original constraint - diffFromConstraint (UnifyItem x y) = not (x == u && y == v) - diffFromConstraint _ = True - --- | Find unifiers for two SOP terms --- --- Can find the following unifiers: --- --- @ --- t ~ a + b ==> [t := a + b] --- a + b ~ t ==> [t := a + b] --- (a + c) ~ (b + c) ==> \[a := b\] --- (2*a) ~ (2*b) ==> [a := b] --- (2 + a) ~ 5 ==> [a := 3] --- (i * a) ~ j ==> [a := div j i], when (mod j i == 0) --- @ --- --- However, given a wanted: --- --- @ --- [W] t ~ a + b --- @ --- --- this function returns @[]@, or otherwise we \"solve\" the constraint by --- finding a unifier equal to the constraint. --- --- However, given a wanted: --- --- @ --- [W] (a + c) ~ (b + c) --- @ --- --- we do return the unifier: --- --- @ --- [a := b] --- @ -unifiers :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify] -unifiers ct u@(S [P [V x]]) v - = case classifyPredType $ ctEvPred $ ctEvidence ct of - EqPred NomEq t1 _ - | CType (reifySOP u) /= CType t1 || isGiven (ctEvidence ct) -> [SubstItem x v] - _ -> [] -unifiers ct u v@(S [P [V x]]) - = case classifyPredType $ ctEvPred $ ctEvidence ct of - EqPred NomEq _ t2 - | CType (reifySOP v) /= CType t2 || isGiven (ctEvidence ct) -> [SubstItem x u] - _ -> [] -unifiers ct u@(S [P [C _]]) v - = case classifyPredType $ ctEvPred $ ctEvidence ct of - EqPred NomEq t1 t2 - | CType (reifySOP u) /= CType t1 || CType (reifySOP v) /= CType t2 -> [UnifyItem u v] - _ -> [] -unifiers ct u v@(S [P [C _]]) - = case classifyPredType $ ctEvPred $ ctEvidence ct of - EqPred NomEq t1 t2 - | CType (reifySOP u) /= CType t1 || CType (reifySOP v) /= CType t2 -> [UnifyItem u v] - _ -> [] -unifiers ct u v = unifiers' ct u v - -unifiers' :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify] -unifiers' _ct (S [P [V x]]) (S []) = [SubstItem x (S [P [I 0]])] -unifiers' _ct (S []) (S [P [V x]]) = [SubstItem x (S [P [I 0]])] - -unifiers' _ct (S [P [V x]]) s = [SubstItem x s] -unifiers' _ct s (S [P [V x]]) = [SubstItem x s] - -unifiers' _ct s1@(S [P [C _]]) s2 = [UnifyItem s1 s2] -unifiers' _ct s1 s2@(S [P [C _]]) = [UnifyItem s1 s2] - - --- (z ^ a) ~ (z ^ b) ==> [a := b] -unifiers' ct (S [P [E s1 p1]]) (S [P [E s2 p2]]) - | s1 == s2 = unifiers' ct (S [p1]) (S [p2]) - --- (2*e ^ d) ~ (2*e*a*c) ==> [a*c := 2*e ^ (d-1)] -unifiers' ct (S [P [E (S [P s1]) p1]]) (S [P p2]) - | all (`elem` p2) s1 - = let base = intersect s1 p2 - diff = p2 \\ s1 - in unifiers ct (S [P diff]) (S [P [E (S [P base]) (P [I (-1)]),E (S [P base]) p1]]) - -unifiers' ct (S [P p2]) (S [P [E (S [P s1]) p1]]) - | all (`elem` p2) s1 - = let base = intersect s1 p2 - diff = p2 \\ s1 - in unifiers ct (S [P [E (S [P base]) (P [I (-1)]),E (S [P base]) p1]]) (S [P diff]) - --- (i ^ a) ~ j ==> [a := round (logBase i j)], when `i` and `j` are integers, --- and `ceiling (logBase i j) == floor (logBase i j)` -unifiers' ct (S [P [E (S [P [I i]]) p]]) (S [P [I j]]) - = case integerLogBase i j of - Just k -> unifiers' ct (S [p]) (S [P [I k]]) - Nothing -> [] - -unifiers' ct (S [P [I j]]) (S [P [E (S [P [I i]]) p]]) - = case integerLogBase i j of - Just k -> unifiers' ct (S [p]) (S [P [I k]]) - Nothing -> [] - --- a^d * a^e ~ a^c ==> [c := d + e] -unifiers' ct (S [P [E s1 p1]]) (S [p2]) = case collectBases p2 of - Just (b:bs,ps) | all (== s1) (b:bs) -> - unifiers' ct (S [p1]) (S ps) - _ -> [] - -unifiers' ct (S [p2]) (S [P [E s1 p1]]) = case collectBases p2 of - Just (b:bs,ps) | all (== s1) (b:bs) -> - unifiers' ct (S ps) (S [p1]) - _ -> [] - --- (i * a) ~ j ==> [a := div j i] --- Where 'a' is a variable, 'i' and 'j' are integer literals, and j `mod` i == 0 -unifiers' ct (S [P ((I i):ps)]) (S [P [I j]]) = - case safeDiv j i of - Just k -> unifiers' ct (S [P ps]) (S [P [I k]]) - _ -> [] - -unifiers' ct (S [P [I j]]) (S [P ((I i):ps)]) = - case safeDiv j i of - Just k -> unifiers' ct (S [P ps]) (S [P [I k]]) - _ -> [] - --- (2*a) ~ (2*b) ==> [a := b] --- unifiers' ct (S [P (p:ps1)]) (S [P (p':ps2)]) --- | p == p' = unifiers' ct (S [P ps1]) (S [P ps2]) --- | otherwise = [] -unifiers' ct (S [P ps1]) (S [P ps2]) - | null psx = [] - | otherwise = unifiers' ct (S [P ps1'']) (S [P ps2'']) - where - ps1' = ps1 \\ psx - ps2' = ps2 \\ psx - ps1'' | null ps1' = [I 1] - | otherwise = ps1' - ps2'' | null ps2' = [I 1] - | otherwise = ps2' - psx = intersect ps1 ps2 - --- (2 + a) ~ 5 ==> [a := 3] -unifiers' ct (S ((P [I i]):ps1)) (S ((P [I j]):ps2)) - | i < j = unifiers' ct (S ps1) (S ((P [I (j-i)]):ps2)) - | i > j = unifiers' ct (S ((P [I (i-j)]):ps1)) (S ps2) - --- (a + c) ~ (b + c) ==> [a := b] -unifiers' ct s1@(S ps1) s2@(S ps2) = case sopToIneq k1 of - Just (s1',s2',_) - | s1' /= s1 || s2' /= s1 - , maybe True (uncurry (&&) . second Set.null) (runWriterT (isNatural s1')) - , maybe True (uncurry (&&) . second Set.null) (runWriterT (isNatural s2')) - -> unifiers' ct s1' s2' - _ | null psx - , length ps1 == length ps2 - -> case nub (concat (zipWith (\x y -> unifiers' ct (S [x]) (S [y])) ps1 ps2)) of - [] -> unifiers'' ct (S ps1) (S ps2) - [k] | length ps1 == length ps2 -> [k] - _ -> [] - | null psx - , isGiven (ctEvidence ct) - -> unifiers'' ct (S ps1) (S ps2) - | null psx - -> [] - _ -> unifiers' ct (S ps1'') (S ps2'') - where - k1 = subtractIneq (s1,s2,True) - ps1' = ps1 \\ psx - ps2' = ps2 \\ psx - ps1'' | null ps1' = [P [I 0]] - | otherwise = ps1' - ps2'' | null ps2' = [P [I 0]] - | otherwise = ps2' - psx = intersect ps1 ps2 - -unifiers'' :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify] -unifiers'' ct (S [P [I i],P [V v]]) s2 - | isGiven (ctEvidence ct) = [SubstItem v (mergeSOPAdd s2 (S [P [I (negate i)]]))] -unifiers'' ct s1 (S [P [I i],P [V v]]) - | isGiven (ctEvidence ct) = [SubstItem v (mergeSOPAdd s1 (S [P [I (negate i)]]))] -unifiers'' _ _ _ = [] - -collectBases :: CoreProduct -> Maybe ([CoreSOP],[CoreProduct]) -collectBases = fmap unzip . traverse go . unP - where - go (E s1 p1) = Just (s1,p1) - go _ = Nothing - --- | Find the 'TyVar' in a 'CoreSOP' -fvSOP :: CoreSOP -> UniqSet TyVar -fvSOP = unionManyUniqSets . map fvProduct . unS - -fvProduct :: CoreProduct -> UniqSet TyVar -fvProduct = unionManyUniqSets . map fvSymbol . unP - -fvSymbol :: CoreSymbol -> UniqSet TyVar -fvSymbol (I _) = emptyUniqSet -fvSymbol (C _) = emptyUniqSet -fvSymbol (V v) = unitUniqSet v -fvSymbol (E s p) = fvSOP s `unionUniqSets` fvProduct p - -eqFV :: CoreSOP -> CoreSOP -> Bool -eqFV = (==) `on` fvSOP - -containsConstants :: CoreSOP -> Bool -containsConstants = - any (any symbolContainsConstant . unP) . unS - where - symbolContainsConstant c = case c of - C {} -> True - E s p -> containsConstants s || containsConstants (S [p]) - _ -> False - -safeDiv :: Integer -> Integer -> Maybe Integer -safeDiv i j - | j == 0 = Just 0 - | otherwise = case divMod i j of - (k,0) -> Just k - _ -> Nothing - --- | Given `x` and `y`, return `Just n` when --- --- `ceiling (logBase x y) == floor (logBase x y)` -integerLogBase :: Integer -> Integer -> Maybe Integer -integerLogBase x y | x > 1 && y > 0 = - let z1 = integerLogBase# x y - z2 = integerLogBase# x (y-1) - in if isTrue# (z1 ==# z2) - then Nothing - else Just (smallInteger z1) -integerLogBase _ _ = Nothing - -isNatural :: CoreSOP -> WriterT (Set CType) Maybe Bool -isNatural (S []) = return True -isNatural (S [P []]) = return True -isNatural (S [P (I i:ps)]) - | i >= 0 = isNatural (S [P ps]) - | otherwise = return False -isNatural (S [P (V _:ps)]) = isNatural (S [P ps]) -isNatural (S [P (E s p:ps)]) = do - sN <- isNatural s - pN <- isNatural (S [p]) - if sN && pN - then isNatural (S [P ps]) - else WriterT Nothing --- We give up for all other products for now -isNatural (S [P (C c:ps)]) = do - tell (Set.singleton c) - isNatural (S [P ps]) --- Adding two natural numbers is also a natural number -isNatural (S (p:ps)) = do - pN <- isNatural (S [p]) - pK <- isNatural (S ps) - case (pN,pK) of - (True,True) -> return True -- both are natural - (False,False) -> return False -- both are non-natural - _ -> WriterT Nothing - -- if one is natural and the other isn't, then their sum *might* be natural, - -- but we simply cant be sure. - --- | Try to solve inequalities -solveIneq - :: Word - -- ^ Solving depth - -> Ineq - -- ^ Inequality we want to solve - -> Ineq - -- ^ Given/proven inequality - -> WriterT (Set CType) Maybe Bool - -- ^ Solver result - -- - -- * /Nothing/: exhausted solver steps - -- - -- * /Just True/: inequality is solved - -- - -- * /Just False/: solver is unable to solve inequality, note that this does - -- __not__ mean the wanted inequality does not hold. -solveIneq 0 _ _ = noRewrite -solveIneq k want@(_,_,True) have@(_,_,True) - | want == have - = pure True - | otherwise - = do - let -- Apply all the rules, and get all the successful ones - new = mapMaybe (\f -> runWriterT (f want have)) ineqRules - -- Recurse down with all the transformed equations - solved = map (first (mapMaybe (runWriterT . uncurry (solveIneq (k-1))))) new - -- For the results of every recursive call, find the one that yields - -- 'True' and has the smallest set of constraints. - solved1 = map (first solvedInEqSmallestConstraint) solved - -- Union the constraints from the corresponding rewrites with the - -- constraints from the recursive results - solved2 = map (\((b,s1),s2) -> (b,Set.union s1 s2)) solved1 - -- From these results, again find the single result that yields 'True' - -- and has the smallest set of constraints. - solved3 = solvedInEqSmallestConstraint solved2 - if null solved then - noRewrite - else do - WriterT (Just solved3) - -solveIneq _ _ _ = pure False - --- Find the solved inequality with the fewest number of constraints -solvedInEqSmallestConstraint :: [(Bool,Set a)] -> (Bool, Set a) -solvedInEqSmallestConstraint = go (False, Set.empty) - where - go bs [] = bs - go (b,s) ((b1,s1):solved) - | not b && b1 - = go (b1,s1) solved - | b && b1 - , Set.size s > Set.size s1 - = go (b1,s1) solved - | otherwise - = go (b,s) solved - --- | Try to instantly solve an inequality by using the inequality solver using --- @1 <=? 1 ~ True@ as the given constraint. -instantSolveIneq - :: Word - -- ^ Solving depth - -> Ineq - -- ^ Inequality we want to solve - -> WriterT (Set CType) Maybe Bool -instantSolveIneq k u = solveIneq k u (one,one,True) - where - one = S [P [I 1]] - -type Ineq = (CoreSOP, CoreSOP, Bool) -type IneqRule = Ineq -> Ineq -> WriterT (Set CType) Maybe [(Ineq,Ineq)] - -noRewrite :: WriterT (Set CType) Maybe a -noRewrite = WriterT Nothing - -ineqRules - :: [IneqRule] -ineqRules = - [ leTrans - , plusMonotone - , timesMonotone - , powMonotone - , pow2MonotoneSpecial - , haveSmaller - , haveBigger - ] - --- | Transitivity of inequality -leTrans :: IneqRule -leTrans want@(a,b,le) (x,y,_) - -- want: 1 <=? y ~ True - -- have: 2 <=? y ~ True - -- - -- new want: want - -- new have: 1 <=? y ~ True - | S [P [I a']] <- a - , S [P [I x']] <- x - , x' >= a' - = pure [(want,(a,y,le))] - -- want: y <=? 10 ~ True - -- have: y <=? 9 ~ True - -- - -- new want: want - -- new have: y <=? 10 ~ True - | S [P [I b']] <- b - , S [P [I y']] <- y - , y' < b' - = pure [(want,(x,b,le))] -leTrans _ _ = noRewrite - --- | Monotonicity of addition --- --- We use SOP normalization to apply this rule by e.g.: --- --- * Given: (2*x+1) <= (3*x-1) --- * Turn to: (3*x-1) - (2*x+1) --- * SOP version: -2 + x --- * Convert back to inequality: 2 <= x -plusMonotone :: IneqRule -plusMonotone want have - | Just want' <- sopToIneq (subtractIneq want) - , want' /= want - = pure [(want',have)] - | Just have' <- sopToIneq (subtractIneq have) - , have' /= have - = pure [(want,have')] -plusMonotone _ _ = noRewrite - --- | Make the `a` of a given `a <= b` smaller -haveSmaller :: IneqRule -haveSmaller want have - | (S (x:y:ys),us,True) <- have - = pure [(want,(S (x:ys),us,True)) - ,(want,(S (y:ys),us,True)) - ] - | (S [P [I 1]], S [P (I _:p@(_:_))],True) <- have - = pure [(want,(S [P [I 1]],S [P p],True))] -haveSmaller _ _ = noRewrite - --- | Make the `b` of a given `a <= b` bigger -haveBigger :: IneqRule -haveBigger want have - | (_ ,S vs,True) <- want - , (as,S bs,True) <- have - , let vs' = vs \\ bs - , not (null vs') - -- want : a <= x + 1 - -- have : y <= x - -- - -- new want: want - -- new have: y <= x + 1 - = do - -- Ensure that we're actually making the RHS larger - b <- isNatural (S vs') - if b then - pure [(want,(as,mergeSOPAdd (S bs) (S vs'),True))] - else - noRewrite -haveBigger _ _ = noRewrite - --- | Monotonicity of multiplication -timesMonotone :: IneqRule -timesMonotone want@(a,b,le) have@(x,y,_) - -- want: C*a <=? b ~ True - -- have: x <=? y ~ True - -- - -- new want: want - -- new have: C*a <=? C*y ~ True - | S [P a'@(_:_:_)] <- a - , S [P x'] <- x - , S [P y'] <- y - , let ax = a' \\ x' - , let ay = a' \\ y' - -- Ensure we don't repeat this rule over and over - , not (null ax) - , not (null ay) - -- Pick the smallest product - , let az = if length ax <= length ay then S [P ax] else S [P ay] - = pure [(want,(mergeSOPMul az x, mergeSOPMul az y,le))] - - -- want: a <=? C*b ~ True - -- have: x <=? y ~ True - -- - -- new want: want - -- new have: C*a <=? C*y ~ True - | S [P b'@(_:_:_)] <- b - , S [P x'] <- x - , S [P y'] <- y - , let bx = b' \\ x' - , let by = b' \\ y' - -- Ensure we don't repeat this rule over and over - , not (null bx) - , not (null by) - -- Pick the smallest product - , let bz = if length bx <= length by then S [P bx] else S [P by] - = pure [(want,(mergeSOPMul bz x, mergeSOPMul bz y,le))] - - -- want: a <=? b ~ True - -- have: C*x <=? y ~ True - -- - -- new want: C*a <=? C*b ~ True - -- new have: have - | S [P x'@(_:_:_)] <- x - , S [P a'] <- a - , S [P b'] <- b - , let xa = x' \\ a' - , let xb = x' \\ b' - -- Ensure we don't repeat this rule over and over - , not (null xa) - , not (null xb) - -- Pick the smallest product - , let xz = if length xa <= length xb then S [P xa] else S [P xb] - = pure [((mergeSOPMul xz a, mergeSOPMul xz b,le),have)] - - -- want: a <=? b ~ True - -- have: x <=? C*y ~ True - -- - -- new want: C*a <=? C*b ~ True - -- new have: have - | S [P y'@(_:_:_)] <- y - , S [P a'] <- a - , S [P b'] <- b - , let ya = y' \\ a' - , let yb = y' \\ b' - -- Ensure we don't repeat this rule over and over - , not (null ya) - , not (null yb) - -- Pick the smallest product - , let yz = if length ya <= length yb then S [P ya] else S [P yb] - = pure [((mergeSOPMul yz a, mergeSOPMul yz b,le),have)] - -timesMonotone _ _ = noRewrite - --- | Monotonicity of exponentiation -powMonotone :: IneqRule -powMonotone want (x, S [P [E yS yP]],le) - = case x of - S [P [E xS xP]] - -- want: XXX - -- have: 2^x <=? 2^y ~ True - -- - -- new want: want - -- new have: x <=? y ~ True - | xS == yS - -> pure [(want,(S [xP],S [yP],le))] - -- want: XXX - -- have: x^2 <=? y^2 ~ True - -- - -- new want: want - -- new have: x <=? y ~ True - | xP == yP - -> pure [(want,(xS,yS,le))] - -- want: XXX - -- have: 2 <=? 2 ^ x ~ True - -- - -- new want: want - -- new have: 1 <=? x ~ True - _ | x == yS - -> pure [(want,(S [P [I 1]],S [yP],le))] - _ -> noRewrite - -powMonotone (a,S [P [E bS bP]],le) have - = case a of - S [P [E aS aP]] - -- want: 2^x <=? 2^y ~ True - -- have: XXX - -- - -- new want: x <=? y ~ True - -- new have: have - | aS == bS - -> pure [((S [aP],S [bP],le),have)] - -- want: x^2 <=? y^2 ~ True - -- have: XXX - -- - -- new want: x <=? y ~ True - -- new have: have - | aP == bP - -> pure [((aS,bS,le),have)] - -- want: 2 <=? 2 ^ x ~ True - -- have: XXX - -- - -- new want: 1 <=? x ~ True - -- new have: XXX - _ | a == bS - -> pure [((S [P [I 1]],S [bP],le),have)] - _ -> noRewrite - -powMonotone _ _ = noRewrite - --- | Try to get the power-of-2 factors, and apply the monotonicity of --- exponentiation rule. --- --- TODO: I wish we could generalize to find arbitrary factors, but currently --- I don't know how. -pow2MonotoneSpecial :: IneqRule -pow2MonotoneSpecial (a,b,le) have - -- want: 4 * 4^x <=? 8^x ~ True - -- have: XXX - -- - -- want as pow 2 factors: 2^(2+2*x) <=? 2^(3*x) ~ True - -- - -- new want: 2+2*x <=? 3*x ~ True - -- new have: have - | Just a' <- facSOP 2 a - , Just b' <- facSOP 2 b - = pure [((a',b',le),have)] -pow2MonotoneSpecial want (x,y,le) - -- want: XXX - -- have:4 * 4^x <=? 8^x ~ True - -- - -- have as pow 2 factors: 2^(2+2*x) <=? 2^(3*x) ~ True - -- - -- new want: want - -- new have: 2+2*x <=? 3*x ~ True - | Just x' <- facSOP 2 x - , Just y' <- facSOP 2 y - = pure [(want,(x',y',le))] -pow2MonotoneSpecial _ _ = noRewrite - --- | Get the power of /N/ factors of a SOP term -facSOP - :: Integer - -- ^ The power /N/ - -> CoreSOP - -> Maybe CoreSOP -facSOP n (S [P ps]) = fmap (S . concat . map unS) (traverse (facSymbol n) ps) -facSOP _ _ = Nothing - --- | Get the power of /N/ factors of a Symbol -facSymbol - :: Integer - -- ^ The power - -> CoreSymbol - -> Maybe CoreSOP -facSymbol n (I i) - | Just j <- integerLogBase n i - = Just (S [P [I j]]) -facSymbol n (E s p) - | Just s' <- facSOP n s - = Just (mergeSOPMul s' (S [p])) -facSymbol _ _ = Nothing +{-|+Copyright : (C) 2015-2016, University of Twente,+ 2017 , QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}+#if __GLASGOW_HASKELL__ < 801+#define nonDetCmpType cmpType+#endif++module GHC.TypeLits.Normalise.Unify+ ( -- * 'Nat' expressions \<-\> 'SOP' terms+ CType (..)+ , CoreSOP+ , normaliseNat+ , normaliseNatEverywhere+ , normaliseSimplifyNat+ , reifySOP+ -- * Substitution on 'SOP' terms+ , UnifyItem (..)+ , CoreUnify+ , substsSOP+ , substsSubst+ -- * Find unifiers+ , UnifyResult (..)+ , unifyNats+ , unifiers+ -- * Free variables in 'SOP' terms+ , fvSOP+ -- * Inequalities+ , subtractIneq+ , solveIneq+ , ineqToSubst+ , subtractionToPred+ , instantSolveIneq+ , solvedInEqSmallestConstraint+ -- * Properties+ , isNatural+ )+where++-- External+import Control.Arrow (first, second)+import Control.Monad.Trans.Writer.Strict+import Data.Function (on)+import Data.List ((\\), intersect, nub)+import Data.Maybe (fromMaybe, mapMaybe, isJust)+import Data.Set (Set)+import qualified Data.Set as Set++import GHC.Base (isTrue#,(==#))+import GHC.Integer (smallInteger)+import GHC.Integer.Logarithms (integerLogBase#)++-- GHC API+#if MIN_VERSION_ghc(9,0,0)+import GHC.Builtin.Types (boolTy, promotedTrueDataCon)+import GHC.Builtin.Types.Literals+ (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Builtin.Types (naturalTy, promotedFalseDataCon)+import GHC.Builtin.Types.Literals (typeNatCmpTyCon)+#else+import GHC.Builtin.Types (typeNatKind)+import GHC.Builtin.Types.Literals (typeNatLeqTyCon)+#endif+import GHC.Core.Predicate (EqRel (NomEq), Pred (EqPred), classifyPredType, mkPrimEqPred)+import GHC.Core.TyCon (TyCon)+#if MIN_VERSION_ghc(9,6,0)+import GHC.Core.Type+ (PredType, TyVar, coreView, mkNumLitTy, mkTyConApp, mkTyVarTy, typeKind)+import GHC.Core.TyCo.Compare+ (eqType, nonDetCmpType)+#else+import GHC.Core.Type+ (PredType, TyVar, coreView, eqType, mkNumLitTy, mkTyConApp, mkTyVarTy, nonDetCmpType, typeKind)+#endif+import GHC.Core.TyCo.Rep (Kind, Type (..), TyLit (..))+import GHC.Tc.Plugin (TcPluginM, tcPluginTrace)+import GHC.Tc.Types.Constraint (Ct, ctEvidence, ctEvId, ctEvPred, isGiven)+import GHC.Types.Unique.Set+ (UniqSet, unionManyUniqSets, emptyUniqSet, unionUniqSets, unitUniqSet)+import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text)+#else+import Outputable (Outputable (..), (<+>), ($$), text)+import TcPluginM (TcPluginM, tcPluginTrace)+import TcTypeNats (typeNatAddTyCon, typeNatExpTyCon, typeNatMulTyCon,+ typeNatSubTyCon, typeNatLeqTyCon)+import TyCon (TyCon)+import Type (TyVar,+ coreView, eqType, mkNumLitTy, mkTyConApp, mkTyVarTy,+ nonDetCmpType, PredType, typeKind)+import TyCoRep (Kind, Type (..), TyLit (..))+import TysWiredIn (boolTy, promotedTrueDataCon, typeNatKind)+import UniqSet (UniqSet, unionManyUniqSets, emptyUniqSet, unionUniqSets,+ unitUniqSet)++#if MIN_VERSION_ghc(8,10,0)+import Constraint (Ct, ctEvidence, ctEvId, ctEvPred, isGiven)+import Predicate (EqRel (NomEq), Pred (EqPred), classifyPredType, mkPrimEqPred)+#else+import TcRnMonad (Ct, ctEvidence, isGiven)+import TcRnTypes (ctEvPred)+import Type (EqRel (NomEq), PredTree (EqPred), classifyPredType, mkPrimEqPred)+#endif+#endif++-- Internal+import GHC.TypeLits.Normalise.SOP++-- Used for haddock+import GHC.TypeLits (Nat)++#if MIN_VERSION_ghc(9,2,0)+typeNatKind :: Type+typeNatKind = naturalTy+#endif++newtype CType = CType { unCType :: Type }+ deriving Outputable++instance Eq CType where+ (CType ty1) == (CType ty2) = eqType ty1 ty2++instance Ord CType where+ compare (CType ty1) (CType ty2) = nonDetCmpType ty1 ty2++-- | 'SOP' with 'TyVar' variables+type CoreSOP = SOP TyVar CType+type CoreProduct = Product TyVar CType+type CoreSymbol = Symbol TyVar CType++-- | Convert a type of /kind/ 'GHC.TypeLits.Nat' to an 'SOP' term, but+-- only when the type is constructed out of:+--+-- * literals+-- * type variables+-- * Applications of the arithmetic operators @(+,-,*,^)@+normaliseNat :: Type -> Writer [(Type,Type)] CoreSOP+normaliseNat ty | Just ty1 <- coreView ty = normaliseNat ty1+normaliseNat (TyVarTy v) = return (S [P [V v]])+normaliseNat (LitTy (NumTyLit i)) = return (S [P [I i]])+normaliseNat (TyConApp tc [x,y])+ | tc == typeNatAddTyCon = mergeSOPAdd <$> normaliseNat x <*> normaliseNat y+ | tc == typeNatSubTyCon = do+ tell [(x,y)]+ mergeSOPAdd <$> normaliseNat x+ <*> (mergeSOPMul (S [P [I (-1)]]) <$> normaliseNat y)+ | tc == typeNatMulTyCon = mergeSOPMul <$> normaliseNat x <*> normaliseNat y+ | tc == typeNatExpTyCon = normaliseExp <$> normaliseNat x <*> normaliseNat y+normaliseNat t = return (S [P [C (CType t)]])++-- | Runs writer action. If the result /Nothing/ writer actions will be+-- discarded.+maybeRunWriter+ :: Monoid a+ => Writer a (Maybe b)+ -> Writer a (Maybe b)+maybeRunWriter w =+ case runWriter w of+ (Nothing, _) -> pure Nothing+ (b, a) -> tell a >> pure b++-- | Applies 'normaliseNat' and 'simplifySOP' to type or predicates to reduce+-- any occurrences of sub-terms of /kind/ 'GHC.TypeLits.Nat'. If the result is+-- the same as input, returns @'Nothing'@.+normaliseNatEverywhere :: Type -> Writer [(Type, Type)] (Maybe Type)+normaliseNatEverywhere ty0+ | TyConApp tc _fields <- ty0+ , tc `elem` knownTyCons = do+ -- Normalize under current type constructor application. 'go' skips all+ -- known type constructors.+ ty1M <- maybeRunWriter (go ty0)+ let ty1 = fromMaybe ty0 ty1M++ -- Normalize (subterm-normalized) type given to 'normaliseNatEverywhere'+ ty2 <- normaliseSimplifyNat ty1+ -- TODO: 'normaliseNat' could keep track whether it changed anything. That's+ -- TODO: probably cheaper than checking for equality here.+ pure (if ty2 `eqType` ty1 then ty1M else Just ty2)+ | otherwise = go ty0+ where+ knownTyCons :: [TyCon]+ knownTyCons = [typeNatExpTyCon, typeNatMulTyCon, typeNatSubTyCon, typeNatAddTyCon]++ -- Normalize given type, but ignore all top-level+ go :: Type -> Writer [(Type, Type)] (Maybe Type)+ go (TyConApp tc_ fields0_) = do+ fields1_ <- mapM (maybeRunWriter . cont) fields0_+ if any isJust fields1_ then+ pure (Just (TyConApp tc_ (zipWith fromMaybe fields0_ fields1_)))+ else+ pure Nothing+ where+ cont = if tc_ `elem` knownTyCons then go else normaliseNatEverywhere+ go _ = pure Nothing++normaliseSimplifyNat :: Type -> Writer [(Type, Type)] Type+normaliseSimplifyNat ty+ | typeKind ty `eqType` typeNatKind = do+ ty' <- normaliseNat ty+ return $ reifySOP $ simplifySOP ty'+ | otherwise = return ty++-- | Convert a 'SOP' term back to a type of /kind/ 'GHC.TypeLits.Nat'+reifySOP :: CoreSOP -> Type+reifySOP = combineP . map negateP . unS+ where+ negateP :: CoreProduct -> Either CoreProduct CoreProduct+ negateP (P ((I i):ps@(_:_))) | i == (-1) = Left (P ps)+ negateP (P ((I i):ps)) | i < 0 = Left (P ((I (abs i)):ps))+ negateP ps = Right ps++ combineP :: [Either CoreProduct CoreProduct] -> Type+ combineP [] = mkNumLitTy 0+ combineP [p] = either (\p' -> mkTyConApp typeNatSubTyCon+ [mkNumLitTy 0, reifyProduct p'])+ reifyProduct p+ combineP [p1,p2] = either+ (\x -> either+ -- x neg, y neg+ (\y -> let r = mkTyConApp typeNatSubTyCon [reifyProduct x+ ,reifyProduct y]+ in mkTyConApp typeNatSubTyCon [mkNumLitTy 0, r])+ -- x neg, y pos+ (\y -> mkTyConApp typeNatSubTyCon [reifyProduct y, reifyProduct x])+ p2)+ (\x -> either+ -- x pos, y neg+ (\y -> mkTyConApp typeNatSubTyCon [reifyProduct x, reifyProduct y])+ -- x pos, y pos+ (\y -> mkTyConApp typeNatAddTyCon [reifyProduct x, reifyProduct y])+ p2)+ p1+++ combineP (p:ps) = let es = combineP ps+ in either (\x -> mkTyConApp typeNatSubTyCon+ [es, reifyProduct x])+ (\x -> mkTyConApp typeNatAddTyCon+ [reifyProduct x, es])+ p++reifyProduct :: CoreProduct -> Type+reifyProduct (P ps) =+ let ps' = map reifySymbol (foldr mergeExp [] ps)+ in foldr1 (\t1 t2 -> mkTyConApp typeNatMulTyCon [t1,t2]) ps'+ where+ -- "2 ^ -1 * 2 ^ a" must be merged into "2 ^ (a-1)", otherwise GHC barfs+ -- at the "2 ^ -1" because of the negative exponent.+ mergeExp :: CoreSymbol -> [Either CoreSymbol (CoreSOP,[CoreProduct])]+ -> [Either CoreSymbol (CoreSOP,[CoreProduct])]+ mergeExp (E s p) [] = [Right (s,[p])]+ mergeExp (E s1 p1) (y:ys)+ | Right (s2,p2) <- y+ , s1 == s2+ = Right (s1,(p1:p2)) : ys+ | otherwise+ = Right (s1,[p1]) : y : ys+ mergeExp x ys = Left x : ys++reifySymbol :: Either CoreSymbol (CoreSOP,[CoreProduct]) -> Type+reifySymbol (Left (I i) ) = mkNumLitTy i+reifySymbol (Left (C c) ) = unCType c+reifySymbol (Left (V v) ) = mkTyVarTy v+reifySymbol (Left (E s p)) = mkTyConApp typeNatExpTyCon [reifySOP s,reifyProduct p]+reifySymbol (Right (s1,s2)) = mkTyConApp typeNatExpTyCon+ [reifySOP s1+ ,reifySOP (S s2)+ ]++-- | Subtract an inequality, in order to either:+--+-- * See if the smallest solution is a natural number+-- * Cancel sums, i.e. monotonicity of addition+--+-- @+-- subtractIneq (2*y <=? 3*x ~ True) = (-2*y + 3*x)+-- subtractIneq (2*y <=? 3*x ~ False) = (-3*x + (-1) + 2*y)+-- @+subtractIneq+ :: (CoreSOP, CoreSOP, Bool)+ -> CoreSOP+subtractIneq (x,y,isLE)+ | isLE+ = mergeSOPAdd y (mergeSOPMul (S [P [I (-1)]]) x)+ | otherwise+ = mergeSOPAdd x (mergeSOPMul (S [P [I (-1)]]) (mergeSOPAdd y (S [P [I 1]])))++-- | Try to reverse the process of 'subtractIneq'+--+-- E.g.+--+-- @+-- subtractIneq (2*y <=? 3*x ~ True) = (-2*y + 3*x)+-- sopToIneq (-2*y+3*x) = Just (2*x <=? 3*x ~ True)+-- @+sopToIneq+ :: CoreSOP+ -> Maybe Ineq+sopToIneq (S [P ((I i):l),r])+ | i < 0+ = Just (mergeSOPMul (S [P [I (negate i)]]) (S [P l]),S [r],True)+sopToIneq (S [r,P ((I i:l))])+ | i < 0+ = Just (mergeSOPMul (S [P [I (negate i)]]) (S [P l]),S [r],True)+sopToIneq _ = Nothing++-- | Give the smallest solution for an inequality+ineqToSubst+ :: Ineq+ -> Maybe CoreUnify+ineqToSubst (x,S [P [V v]],True)+ = Just (SubstItem v x)+ineqToSubst _+ = Nothing++subtractionToPred+ :: TyCon+ -> (Type,Type)+ -> (PredType, Kind)+subtractionToPred ordCond (x,y) =+#if MIN_VERSION_ghc(9,2,0)+ let cmpNat = mkTyConApp typeNatCmpTyCon [y,x]+ trueTc = mkTyConApp promotedTrueDataCon []+ falseTc = mkTyConApp promotedFalseDataCon []+ ordCmp = mkTyConApp ordCond+ [boolTy,cmpNat,trueTc,trueTc,falseTc]+ predTy = mkPrimEqPred ordCmp trueTc+ in (predTy,boolTy)+#else+ (mkPrimEqPred (mkTyConApp ordCond [y,x])+ (mkTyConApp promotedTrueDataCon [])+ ,boolTy)+#endif++-- | A substitution is essentially a list of (variable, 'SOP') pairs,+-- but we keep the original 'Ct' that lead to the substitution being+-- made, for use when turning the substitution back into constraints.+type CoreUnify = UnifyItem TyVar CType++data UnifyItem v c = SubstItem { siVar :: v+ , siSOP :: SOP v c+ }+ | UnifyItem { siLHS :: SOP v c+ , siRHS :: SOP v c+ }+ deriving Eq++instance (Outputable v, Outputable c) => Outputable (UnifyItem v c) where+ ppr (SubstItem {..}) = ppr siVar <+> text " := " <+> ppr siSOP+ ppr (UnifyItem {..}) = ppr siLHS <+> text " :~ " <+> ppr siRHS++-- | Apply a substitution to a single normalised 'SOP' term+substsSOP :: (Ord v, Ord c) => [UnifyItem v c] -> SOP v c -> SOP v c+substsSOP [] u = u+substsSOP ((SubstItem {..}):s) u = substsSOP s (substSOP siVar siSOP u)+substsSOP ((UnifyItem {}):s) u = substsSOP s u++substSOP :: (Ord v, Ord c) => v -> SOP v c -> SOP v c -> SOP v c+substSOP tv e = foldr1 mergeSOPAdd . map (substProduct tv e) . unS++substProduct :: (Ord v, Ord c) => v -> SOP v c -> Product v c -> SOP v c+substProduct tv e = foldr1 mergeSOPMul . map (substSymbol tv e) . unP++substSymbol :: (Ord v, Ord c) => v -> SOP v c -> Symbol v c -> SOP v c+substSymbol _ _ s@(I _) = S [P [s]]+substSymbol _ _ s@(C _) = S [P [s]]+substSymbol tv e (V tv')+ | tv == tv' = e+ | otherwise = S [P [V tv']]+substSymbol tv e (E s p) = normaliseExp (substSOP tv e s) (substProduct tv e p)++-- | Apply a substitution to a substitution+substsSubst :: (Ord v, Ord c) => [UnifyItem v c] -> [UnifyItem v c] -> [UnifyItem v c]+substsSubst s = map subt+ where+ subt si@(SubstItem {..}) = si {siSOP = substsSOP s siSOP}+ subt si@(UnifyItem {..}) = si {siLHS = substsSOP s siLHS, siRHS = substsSOP s siRHS}+{-# INLINEABLE substsSubst #-}++-- | Result of comparing two 'SOP' terms, returning a potential substitution+-- list under which the two terms are equal.+data UnifyResult+ = Win -- ^ Two terms are equal+ | Lose -- ^ Two terms are /not/ equal+ | Draw [CoreUnify] -- ^ Two terms are only equal if the given substitution holds++instance Outputable UnifyResult where+ ppr Win = text "Win"+ ppr (Draw subst) = text "Draw" <+> ppr subst+ ppr Lose = text "Lose"++-- | Given two 'SOP's @u@ and @v@, when their free variables ('fvSOP') are the+-- same, then we 'Win' if @u@ and @v@ are equal, and 'Lose' otherwise.+--+-- If @u@ and @v@ do not have the same free variables, we result in a 'Draw',+-- ware @u@ and @v@ are only equal when the returned 'CoreSubst' holds.+unifyNats :: Ct -> CoreSOP -> CoreSOP -> TcPluginM UnifyResult+unifyNats ct u v = do+ tcPluginTrace "unifyNats" (ppr ct $$ ppr u $$ ppr v)+ return (unifyNats' ct u v)++unifyNats' :: Ct -> CoreSOP -> CoreSOP -> UnifyResult+unifyNats' ct u v+ = if eqFV u v+ then if containsConstants u || containsConstants v+ then if u == v+ then Win+ else Draw (filter diffFromConstraint (unifiers ct u v))+ else if u == v+ then Win+ else Lose+ else Draw (filter diffFromConstraint (unifiers ct u v))+ where+ -- A unifier is only a unifier if differs from the original constraint+ diffFromConstraint (UnifyItem x y) = not (x == u && y == v)+ diffFromConstraint _ = True++-- | Find unifiers for two SOP terms+--+-- Can find the following unifiers:+--+-- @+-- t ~ a + b ==> [t := a + b]+-- a + b ~ t ==> [t := a + b]+-- (a + c) ~ (b + c) ==> \[a := b\]+-- (2*a) ~ (2*b) ==> [a := b]+-- (2 + a) ~ 5 ==> [a := 3]+-- (i * a) ~ j ==> [a := div j i], when (mod j i == 0)+-- @+--+-- However, given a wanted:+--+-- @+-- [W] t ~ a + b+-- @+--+-- this function returns @[]@, or otherwise we \"solve\" the constraint by+-- finding a unifier equal to the constraint.+--+-- However, given a wanted:+--+-- @+-- [W] (a + c) ~ (b + c)+-- @+--+-- we do return the unifier:+--+-- @+-- [a := b]+-- @+unifiers :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify]+unifiers ct u@(S [P [V x]]) v+ = case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 _+ | CType (reifySOP u) /= CType t1 || isGiven (ctEvidence ct) -> [SubstItem x v]+ _ -> []+unifiers ct u v@(S [P [V x]])+ = case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq _ t2+ | CType (reifySOP v) /= CType t2 || isGiven (ctEvidence ct) -> [SubstItem x u]+ _ -> []+unifiers ct u@(S [P [C _]]) v+ = case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 t2+ | CType (reifySOP u) /= CType t1 || CType (reifySOP v) /= CType t2 -> [UnifyItem u v]+ _ -> []+unifiers ct u v@(S [P [C _]])+ = case classifyPredType $ ctEvPred $ ctEvidence ct of+ EqPred NomEq t1 t2+ | CType (reifySOP u) /= CType t1 || CType (reifySOP v) /= CType t2 -> [UnifyItem u v]+ _ -> []+unifiers ct u v = unifiers' ct u v++unifiers' :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify]+unifiers' _ct (S [P [V x]]) (S []) = [SubstItem x (S [P [I 0]])]+unifiers' _ct (S []) (S [P [V x]]) = [SubstItem x (S [P [I 0]])]++unifiers' _ct (S [P [V x]]) s = [SubstItem x s]+unifiers' _ct s (S [P [V x]]) = [SubstItem x s]++unifiers' _ct s1@(S [P [C _]]) s2 = [UnifyItem s1 s2]+unifiers' _ct s1 s2@(S [P [C _]]) = [UnifyItem s1 s2]+++-- (z ^ a) ~ (z ^ b) ==> [a := b]+unifiers' ct (S [P [E s1 p1]]) (S [P [E s2 p2]])+ | s1 == s2 = unifiers' ct (S [p1]) (S [p2])++-- (2*e ^ d) ~ (2*e*a*c) ==> [a*c := 2*e ^ (d-1)]+unifiers' ct (S [P [E (S [P s1]) p1]]) (S [P p2])+ | all (`elem` p2) s1+ = let base = intersect s1 p2+ diff = p2 \\ s1+ in unifiers ct (S [P diff]) (S [P [E (S [P base]) (P [I (-1)]),E (S [P base]) p1]])++unifiers' ct (S [P p2]) (S [P [E (S [P s1]) p1]])+ | all (`elem` p2) s1+ = let base = intersect s1 p2+ diff = p2 \\ s1+ in unifiers ct (S [P [E (S [P base]) (P [I (-1)]),E (S [P base]) p1]]) (S [P diff])++-- (i ^ a) ~ j ==> [a := round (logBase i j)], when `i` and `j` are integers,+-- and `ceiling (logBase i j) == floor (logBase i j)`+unifiers' ct (S [P [E (S [P [I i]]) p]]) (S [P [I j]])+ = case integerLogBase i j of+ Just k -> unifiers' ct (S [p]) (S [P [I k]])+ Nothing -> []++unifiers' ct (S [P [I j]]) (S [P [E (S [P [I i]]) p]])+ = case integerLogBase i j of+ Just k -> unifiers' ct (S [p]) (S [P [I k]])+ Nothing -> []++-- a^d * a^e ~ a^c ==> [c := d + e]+unifiers' ct (S [P [E s1 p1]]) (S [p2]) = case collectBases p2 of+ Just (b:bs,ps) | all (== s1) (b:bs) ->+ unifiers' ct (S [p1]) (S ps)+ _ -> []++unifiers' ct (S [p2]) (S [P [E s1 p1]]) = case collectBases p2 of+ Just (b:bs,ps) | all (== s1) (b:bs) ->+ unifiers' ct (S ps) (S [p1])+ _ -> []++-- (i * a) ~ j ==> [a := div j i]+-- Where 'a' is a variable, 'i' and 'j' are integer literals, and j `mod` i == 0+unifiers' ct (S [P ((I i):ps)]) (S [P [I j]]) =+ case safeDiv j i of+ Just k -> unifiers' ct (S [P ps]) (S [P [I k]])+ _ -> []++unifiers' ct (S [P [I j]]) (S [P ((I i):ps)]) =+ case safeDiv j i of+ Just k -> unifiers' ct (S [P ps]) (S [P [I k]])+ _ -> []++-- (2*a) ~ (2*b) ==> [a := b]+-- unifiers' ct (S [P (p:ps1)]) (S [P (p':ps2)])+-- | p == p' = unifiers' ct (S [P ps1]) (S [P ps2])+-- | otherwise = []+unifiers' ct (S [P ps1]) (S [P ps2])+ | null psx = []+ | otherwise = unifiers' ct (S [P ps1'']) (S [P ps2''])+ where+ ps1' = ps1 \\ psx+ ps2' = ps2 \\ psx+ ps1'' | null ps1' = [I 1]+ | otherwise = ps1'+ ps2'' | null ps2' = [I 1]+ | otherwise = ps2'+ psx = intersect ps1 ps2++-- (2 + a) ~ 5 ==> [a := 3]+unifiers' ct (S ((P [I i]):ps1)) (S ((P [I j]):ps2))+ | i < j = unifiers' ct (S ps1) (S ((P [I (j-i)]):ps2))+ | i > j = unifiers' ct (S ((P [I (i-j)]):ps1)) (S ps2)++-- (a + c) ~ (b + c) ==> [a := b]+unifiers' ct s1@(S ps1) s2@(S ps2) = case sopToIneq k1 of+ Just (s1',s2',_)+ | s1' /= s1 || s2' /= s1+ , maybe True (uncurry (&&) . second Set.null) (runWriterT (isNatural s1'))+ , maybe True (uncurry (&&) . second Set.null) (runWriterT (isNatural s2'))+ -> unifiers' ct s1' s2'+ _ | null psx+ , length ps1 == length ps2+ -> case nub (concat (zipWith (\x y -> unifiers' ct (S [x]) (S [y])) ps1 ps2)) of+ [] -> unifiers'' ct (S ps1) (S ps2)+ [k] | length ps1 == length ps2 -> [k]+ _ -> []+ | null psx+ , isGiven (ctEvidence ct)+ -> unifiers'' ct (S ps1) (S ps2)+ | null psx+ -> []+ _ -> unifiers' ct (S ps1'') (S ps2'')+ where+ k1 = subtractIneq (s1,s2,True)+ ps1' = ps1 \\ psx+ ps2' = ps2 \\ psx+ ps1'' | null ps1' = [P [I 0]]+ | otherwise = ps1'+ ps2'' | null ps2' = [P [I 0]]+ | otherwise = ps2'+ psx = intersect ps1 ps2++unifiers'' :: Ct -> CoreSOP -> CoreSOP -> [CoreUnify]+unifiers'' ct (S [P [I i],P [V v]]) s2+ | isGiven (ctEvidence ct) = [SubstItem v (mergeSOPAdd s2 (S [P [I (negate i)]]))]+unifiers'' ct s1 (S [P [I i],P [V v]])+ | isGiven (ctEvidence ct) = [SubstItem v (mergeSOPAdd s1 (S [P [I (negate i)]]))]+unifiers'' _ _ _ = []++collectBases :: CoreProduct -> Maybe ([CoreSOP],[CoreProduct])+collectBases = fmap unzip . traverse go . unP+ where+ go (E s1 p1) = Just (s1,p1)+ go _ = Nothing++-- | Find the 'TyVar' in a 'CoreSOP'+fvSOP :: CoreSOP -> UniqSet TyVar+fvSOP = unionManyUniqSets . map fvProduct . unS++fvProduct :: CoreProduct -> UniqSet TyVar+fvProduct = unionManyUniqSets . map fvSymbol . unP++fvSymbol :: CoreSymbol -> UniqSet TyVar+fvSymbol (I _) = emptyUniqSet+fvSymbol (C _) = emptyUniqSet+fvSymbol (V v) = unitUniqSet v+fvSymbol (E s p) = fvSOP s `unionUniqSets` fvProduct p++eqFV :: CoreSOP -> CoreSOP -> Bool+eqFV = (==) `on` fvSOP++containsConstants :: CoreSOP -> Bool+containsConstants =+ any (any symbolContainsConstant . unP) . unS+ where+ symbolContainsConstant c = case c of+ C {} -> True+ E s p -> containsConstants s || containsConstants (S [p])+ _ -> False++safeDiv :: Integer -> Integer -> Maybe Integer+safeDiv i j+ | j == 0 = Just 0+ | otherwise = case divMod i j of+ (k,0) -> Just k+ _ -> Nothing++-- | Given `x` and `y`, return `Just n` when+--+-- `ceiling (logBase x y) == floor (logBase x y)`+integerLogBase :: Integer -> Integer -> Maybe Integer+integerLogBase x y | x > 1 && y > 0 =+ let z1 = integerLogBase# x y+ z2 = integerLogBase# x (y-1)+ in if isTrue# (z1 ==# z2)+ then Nothing+ else Just (smallInteger z1)+integerLogBase _ _ = Nothing++isNatural :: CoreSOP -> WriterT (Set CType) Maybe Bool+isNatural (S []) = return True+isNatural (S [P []]) = return True+isNatural (S [P (I i:ps)])+ | i >= 0 = isNatural (S [P ps])+ | otherwise = return False+isNatural (S [P (V _:ps)]) = isNatural (S [P ps])+isNatural (S [P (E s p:ps)]) = do+ sN <- isNatural s+ pN <- isNatural (S [p])+ if sN && pN+ then isNatural (S [P ps])+ else WriterT Nothing+-- We give up for all other products for now+isNatural (S [P (C c:ps)]) = do+ tell (Set.singleton c)+ isNatural (S [P ps])+-- Adding two natural numbers is also a natural number+isNatural (S (p:ps)) = do+ pN <- isNatural (S [p])+ pK <- isNatural (S ps)+ case (pN,pK) of+ (True,True) -> return True -- both are natural+ (False,False) -> return False -- both are non-natural+ _ -> WriterT Nothing+ -- if one is natural and the other isn't, then their sum *might* be natural,+ -- but we simply cant be sure.++-- | Try to solve inequalities+solveIneq+ :: Word+ -- ^ Solving depth+ -> Ineq+ -- ^ Inequality we want to solve+ -> Ineq+ -- ^ Given/proven inequality+ -> WriterT (Set CType) Maybe Bool+ -- ^ Solver result+ --+ -- * /Nothing/: exhausted solver steps+ --+ -- * /Just True/: inequality is solved+ --+ -- * /Just False/: solver is unable to solve inequality, note that this does+ -- __not__ mean the wanted inequality does not hold.+solveIneq 0 _ _ = noRewrite+solveIneq k want@(_,_,True) have@(_,_,True)+ | want == have+ = pure True+ | otherwise+ = do+ let -- Apply all the rules, and get all the successful ones+ new = mapMaybe (\f -> runWriterT (f want have)) ineqRules+ -- Recurse down with all the transformed equations+ solved = map (first (mapMaybe (runWriterT . uncurry (solveIneq (k-1))))) new+ -- For the results of every recursive call, find the one that yields+ -- 'True' and has the smallest set of constraints.+ solved1 = map (first solvedInEqSmallestConstraint) solved+ -- Union the constraints from the corresponding rewrites with the+ -- constraints from the recursive results+ solved2 = map (\((b,s1),s2) -> (b,Set.union s1 s2)) solved1+ -- From these results, again find the single result that yields 'True'+ -- and has the smallest set of constraints.+ solved3 = solvedInEqSmallestConstraint solved2+ if null solved then+ noRewrite+ else do+ WriterT (Just solved3)++solveIneq _ _ _ = pure False++-- Find the solved inequality with the fewest number of constraints+solvedInEqSmallestConstraint :: [(Bool,Set a)] -> (Bool, Set a)+solvedInEqSmallestConstraint = go (False, Set.empty)+ where+ go bs [] = bs+ go (b,s) ((b1,s1):solved)+ | not b && b1+ = go (b1,s1) solved+ | b && b1+ , Set.size s > Set.size s1+ = go (b1,s1) solved+ | otherwise+ = go (b,s) solved++-- | Try to instantly solve an inequality by using the inequality solver using+-- @1 <=? 1 ~ True@ as the given constraint.+instantSolveIneq+ :: Word+ -- ^ Solving depth+ -> Ineq+ -- ^ Inequality we want to solve+ -> WriterT (Set CType) Maybe Bool+instantSolveIneq k u = solveIneq k u (one,one,True)+ where+ one = S [P [I 1]]++type Ineq = (CoreSOP, CoreSOP, Bool)+type IneqRule = Ineq -> Ineq -> WriterT (Set CType) Maybe [(Ineq,Ineq)]++noRewrite :: WriterT (Set CType) Maybe a+noRewrite = WriterT Nothing++ineqRules+ :: [IneqRule]+ineqRules =+ [ leTrans+ , plusMonotone+ , timesMonotone+ , powMonotone+ , pow2MonotoneSpecial+ , haveSmaller+ , haveBigger+ ]++-- | Transitivity of inequality+leTrans :: IneqRule+leTrans want@(a,b,le) (x,y,_)+ -- want: 1 <=? y ~ True+ -- have: 2 <=? y ~ True+ --+ -- new want: want+ -- new have: 1 <=? y ~ True+ | S [P [I a']] <- a+ , S [P [I x']] <- x+ , x' >= a'+ = pure [(want,(a,y,le))]+ -- want: y <=? 10 ~ True+ -- have: y <=? 9 ~ True+ --+ -- new want: want+ -- new have: y <=? 10 ~ True+ | S [P [I b']] <- b+ , S [P [I y']] <- y+ , y' < b'+ = pure [(want,(x,b,le))]+leTrans _ _ = noRewrite++-- | Monotonicity of addition+--+-- We use SOP normalization to apply this rule by e.g.:+--+-- * Given: (2*x+1) <= (3*x-1)+-- * Turn to: (3*x-1) - (2*x+1)+-- * SOP version: -2 + x+-- * Convert back to inequality: 2 <= x+plusMonotone :: IneqRule+plusMonotone want have+ | Just want' <- sopToIneq (subtractIneq want)+ , want' /= want+ = pure [(want',have)]+ | Just have' <- sopToIneq (subtractIneq have)+ , have' /= have+ = pure [(want,have')]+plusMonotone _ _ = noRewrite++-- | Make the `a` of a given `a <= b` smaller+haveSmaller :: IneqRule+haveSmaller want have+ | (S (x:y:ys),us,True) <- have+ = pure [(want,(S (x:ys),us,True))+ ,(want,(S (y:ys),us,True))+ ]+ | (S [P [I 1]], S [P (I _:p@(_:_))],True) <- have+ = pure [(want,(S [P [I 1]],S [P p],True))]+haveSmaller _ _ = noRewrite++-- | Make the `b` of a given `a <= b` bigger+haveBigger :: IneqRule+haveBigger want have+ | (_ ,S vs,True) <- want+ , (as,S bs,True) <- have+ , let vs' = vs \\ bs+ , not (null vs')+ -- want : a <= x + 1+ -- have : y <= x+ --+ -- new want: want+ -- new have: y <= x + 1+ = do+ -- Ensure that we're actually making the RHS larger+ b <- isNatural (S vs')+ if b then+ pure [(want,(as,mergeSOPAdd (S bs) (S vs'),True))]+ else+ noRewrite+haveBigger _ _ = noRewrite++-- | Monotonicity of multiplication+timesMonotone :: IneqRule+timesMonotone want@(a,b,le) have@(x,y,_)+ -- want: C*a <=? b ~ True+ -- have: x <=? y ~ True+ --+ -- new want: want+ -- new have: C*a <=? C*y ~ True+ | S [P a'@(_:_:_)] <- a+ , S [P x'] <- x+ , S [P y'] <- y+ , let ax = a' \\ x'+ , let ay = a' \\ y'+ -- Ensure we don't repeat this rule over and over+ , not (null ax)+ , not (null ay)+ -- Pick the smallest product+ , let az = if length ax <= length ay then S [P ax] else S [P ay]+ = pure [(want,(mergeSOPMul az x, mergeSOPMul az y,le))]++ -- want: a <=? C*b ~ True+ -- have: x <=? y ~ True+ --+ -- new want: want+ -- new have: C*a <=? C*y ~ True+ | S [P b'@(_:_:_)] <- b+ , S [P x'] <- x+ , S [P y'] <- y+ , let bx = b' \\ x'+ , let by = b' \\ y'+ -- Ensure we don't repeat this rule over and over+ , not (null bx)+ , not (null by)+ -- Pick the smallest product+ , let bz = if length bx <= length by then S [P bx] else S [P by]+ = pure [(want,(mergeSOPMul bz x, mergeSOPMul bz y,le))]++ -- want: a <=? b ~ True+ -- have: C*x <=? y ~ True+ --+ -- new want: C*a <=? C*b ~ True+ -- new have: have+ | S [P x'@(_:_:_)] <- x+ , S [P a'] <- a+ , S [P b'] <- b+ , let xa = x' \\ a'+ , let xb = x' \\ b'+ -- Ensure we don't repeat this rule over and over+ , not (null xa)+ , not (null xb)+ -- Pick the smallest product+ , let xz = if length xa <= length xb then S [P xa] else S [P xb]+ = pure [((mergeSOPMul xz a, mergeSOPMul xz b,le),have)]++ -- want: a <=? b ~ True+ -- have: x <=? C*y ~ True+ --+ -- new want: C*a <=? C*b ~ True+ -- new have: have+ | S [P y'@(_:_:_)] <- y+ , S [P a'] <- a+ , S [P b'] <- b+ , let ya = y' \\ a'+ , let yb = y' \\ b'+ -- Ensure we don't repeat this rule over and over+ , not (null ya)+ , not (null yb)+ -- Pick the smallest product+ , let yz = if length ya <= length yb then S [P ya] else S [P yb]+ = pure [((mergeSOPMul yz a, mergeSOPMul yz b,le),have)]++timesMonotone _ _ = noRewrite++-- | Monotonicity of exponentiation+powMonotone :: IneqRule+powMonotone want (x, S [P [E yS yP]],le)+ = case x of+ S [P [E xS xP]]+ -- want: XXX+ -- have: 2^x <=? 2^y ~ True+ --+ -- new want: want+ -- new have: x <=? y ~ True+ | xS == yS+ -> pure [(want,(S [xP],S [yP],le))]+ -- want: XXX+ -- have: x^2 <=? y^2 ~ True+ --+ -- new want: want+ -- new have: x <=? y ~ True+ | xP == yP+ -> pure [(want,(xS,yS,le))]+ -- want: XXX+ -- have: 2 <=? 2 ^ x ~ True+ --+ -- new want: want+ -- new have: 1 <=? x ~ True+ _ | x == yS+ -> pure [(want,(S [P [I 1]],S [yP],le))]+ _ -> noRewrite++powMonotone (a,S [P [E bS bP]],le) have+ = case a of+ S [P [E aS aP]]+ -- want: 2^x <=? 2^y ~ True+ -- have: XXX+ --+ -- new want: x <=? y ~ True+ -- new have: have+ | aS == bS+ -> pure [((S [aP],S [bP],le),have)]+ -- want: x^2 <=? y^2 ~ True+ -- have: XXX+ --+ -- new want: x <=? y ~ True+ -- new have: have+ | aP == bP+ -> pure [((aS,bS,le),have)]+ -- want: 2 <=? 2 ^ x ~ True+ -- have: XXX+ --+ -- new want: 1 <=? x ~ True+ -- new have: XXX+ _ | a == bS+ -> pure [((S [P [I 1]],S [bP],le),have)]+ _ -> noRewrite++powMonotone _ _ = noRewrite++-- | Try to get the power-of-2 factors, and apply the monotonicity of+-- exponentiation rule.+--+-- TODO: I wish we could generalize to find arbitrary factors, but currently+-- I don't know how.+pow2MonotoneSpecial :: IneqRule+pow2MonotoneSpecial (a,b,le) have+ -- want: 4 * 4^x <=? 8^x ~ True+ -- have: XXX+ --+ -- want as pow 2 factors: 2^(2+2*x) <=? 2^(3*x) ~ True+ --+ -- new want: 2+2*x <=? 3*x ~ True+ -- new have: have+ | Just a' <- facSOP 2 a+ , Just b' <- facSOP 2 b+ = pure [((a',b',le),have)]+pow2MonotoneSpecial want (x,y,le)+ -- want: XXX+ -- have:4 * 4^x <=? 8^x ~ True+ --+ -- have as pow 2 factors: 2^(2+2*x) <=? 2^(3*x) ~ True+ --+ -- new want: want+ -- new have: 2+2*x <=? 3*x ~ True+ | Just x' <- facSOP 2 x+ , Just y' <- facSOP 2 y+ = pure [(want,(x',y',le))]+pow2MonotoneSpecial _ _ = noRewrite++-- | Get the power of /N/ factors of a SOP term+facSOP+ :: Integer+ -- ^ The power /N/+ -> CoreSOP+ -> Maybe CoreSOP+facSOP n (S [P ps]) = fmap (S . concat . map unS) (traverse (facSymbol n) ps)+facSOP _ _ = Nothing++-- | Get the power of /N/ factors of a Symbol+facSymbol+ :: Integer+ -- ^ The power+ -> CoreSymbol+ -> Maybe CoreSOP+facSymbol n (I i)+ | Just j <- integerLogBase n i+ = Just (S [P [I j]])+facSymbol n (E s p)+ | Just s' <- facSOP n s+ = Just (mergeSOPMul s' (S [p]))+facSymbol _ _ = Nothing
tests/ErrorTests.hs view
@@ -191,9 +191,26 @@ testProxy10 = proxyInEq' testProxy10Errors =-#if __GLASGOW_HASKELL__ >= 910+#if __GLASGOW_HASKELL__ >= 912 [$(do localeEncoding <- runIO (getLocaleEncoding) if textEncodingName localeEncoding == textEncodingName utf8+ then litE $ stringL "Couldn't match type ‘ghc-internal-9.1201.0:GHC.Internal.Data.Type.Ord.OrdCond"+ else litE $ stringL "Couldn't match type `ghc-internal-9.1201.0:GHC.Internal.Data.Type.Ord.OrdCond"+ )+ ,$(do localeEncoding <- runIO (getLocaleEncoding)+ if textEncodingName localeEncoding == textEncodingName utf8+ then litE $ stringL "(CmpNat a (a + 2)) True True False’"+ else litE $ stringL "(CmpNat a (a + 2)) True True False'"+ )+ ,$(do localeEncoding <- runIO (getLocaleEncoding)+ if textEncodingName localeEncoding == textEncodingName utf8+ then litE $ stringL "with ‘False"+ else litE $ stringL "with `False"+ )+ ]+#elif __GLASGOW_HASKELL__ >= 910+ [$(do localeEncoding <- runIO (getLocaleEncoding)+ if textEncodingName localeEncoding == textEncodingName utf8 then litE $ stringL "Couldn't match type ‘ghc-internal-9.1001.0:GHC.Internal.Data.Type.Ord.OrdCond" else litE $ stringL "Couldn't match type `ghc-internal-9.1001.0:GHC.Internal.Data.Type.Ord.OrdCond" )@@ -334,7 +351,24 @@ testProxy14 = proxyInEq' testProxy14Errors =-#if __GLASGOW_HASKELL__ >= 910+#if __GLASGOW_HASKELL__ >= 912+ [$(do localeEncoding <- runIO (getLocaleEncoding)+ if textEncodingName localeEncoding == textEncodingName utf8+ then litE $ stringL "Couldn't match type ‘ghc-internal-9.1201.0:GHC.Internal.Data.Type.Ord.OrdCond"+ else litE $ stringL "Couldn't match type `ghc-internal-9.1201.0:GHC.Internal.Data.Type.Ord.OrdCond"+ )+ ,$(do localeEncoding <- runIO (getLocaleEncoding)+ if textEncodingName localeEncoding == textEncodingName utf8+ then litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False’"+ else litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False'"+ )+ ,$(do localeEncoding <- runIO (getLocaleEncoding)+ if textEncodingName localeEncoding == textEncodingName utf8+ then litE $ stringL "with ‘False"+ else litE $ stringL "with `False"+ )+ ]+#elif __GLASGOW_HASKELL__ >= 910 [$(do localeEncoding <- runIO (getLocaleEncoding) if textEncodingName localeEncoding == textEncodingName utf8 then litE $ stringL "Couldn't match type ‘ghc-internal-9.1001.0:GHC.Internal.Data.Type.Ord.OrdCond"
tests/Tests.hs view
@@ -1,711 +1,711 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ >= 805 -{-# LANGUAGE NoStarIsType #-} -#endif - -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_GHC -dcore-lint #-} - -import GHC.TypeLits -#if MIN_VERSION_base(4,18,0) - hiding (type SNat) -#endif - -import Unsafe.Coerce -import Prelude hiding (head,tail,init,(++),splitAt,concat,drop) -import qualified Prelude as P - -import Data.Kind (Type) -import Data.List (isInfixOf) -import Data.Proxy -import Control.Exception -import Test.Tasty -import Test.Tasty.HUnit - -import ErrorTests - -data Vec :: Nat -> Type -> Type where - Nil :: Vec 0 a - (:>) :: a -> Vec n a -> Vec (n + 1) a - -instance Show a => Show (Vec n a) where - show vs = "<" P.++ punc vs P.++ ">" - where - punc :: Vec m a -> String - punc Nil = "" - punc (x :> Nil) = show x - punc (x :> xs) = show x P.++ "," P.++ punc xs - -infixr 5 :> - -data SNat (n :: Nat) = KnownNat n => SNat (Proxy n) - -instance Show (SNat n) where - show (SNat p) = 'd' : show (natVal p) - -{-# INLINE snat #-} --- | Create a singleton literal for a type-level natural number -snat :: KnownNat n => SNat n -snat = SNat Proxy - -{-# INLINE withSNat #-} --- | Supply a function with a singleton natural 'n' according to the context -withSNat :: KnownNat n => (SNat n -> a) -> a -withSNat f = f (SNat Proxy) - -{-# INLINE snatToInteger #-} -snatToInteger :: SNat n -> Integer -snatToInteger (SNat p) = natVal p - -data UNat :: Nat -> Type where - UZero :: UNat 0 - USucc :: UNat n -> UNat (n + 1) - --- | Convert a singleton natural number to its unary representation --- --- __NB__: Not synthesisable -toUNat :: SNat n -> UNat n -toUNat (SNat p) = fromI (natVal p) - where - fromI :: Integer -> UNat m - fromI 0 = unsafeCoerce UZero - fromI n = unsafeCoerce (USucc (fromI (n - 1))) - --- | Add two singleton natural numbers --- --- __NB__: Not synthesisable -addUNat :: UNat n -> UNat m -> UNat (n + m) -addUNat UZero y = y -addUNat x UZero = x -addUNat (USucc x) y = USucc (addUNat x y) - --- | Multiply two singleton natural numbers --- --- __NB__: Not synthesisable -multUNat :: UNat n -> UNat m -> UNat (n * m) -multUNat UZero _ = UZero -multUNat _ UZero = UZero -multUNat (USucc x) y = addUNat y (multUNat x y) - --- | Exponential of two singleton natural numbers --- --- __NB__: Not synthesisable -powUNat :: UNat n -> UNat m -> UNat (n ^ m) -powUNat _ UZero = USucc UZero -powUNat x (USucc y) = multUNat x (powUNat x y) - --- | Extract the first element of a vector --- --- >>> head (1:>2:>3:>Nil) --- 1 -head :: Vec (n + 1) a -> a -head (x :> _) = x - -head' - :: forall n a - . (1 <= n) - => Vec n a - -> a -head' = head @(n-1) - --- | Extract the elements after the head of a vector --- --- >>> tail (1:>2:>3:>Nil) --- <2,3> -tail :: Vec (n + 1) a -> Vec n a -tail (_ :> xs) = xs - -tail' :: (1 <= m) => Vec m a -> Vec (m-1) a -tail' = tail - --- | Extract all the elements of a vector except the last element --- --- >>> init (1:>2:>3:>Nil) --- <1,2> -init :: Vec (n + 1) a -> Vec n a -init (_ :> Nil) = Nil -init (x :> y :> ys) = x :> init (y :> ys) - -init' :: (1 <= m) => Vec m a -> Vec (m-1) a -init' = init - -infixr 5 ++ --- | Append two vectors --- --- >>> (1:>2:>3:>Nil) ++ (7:>8:>Nil) --- <1,2,3,7,8> -(++) :: Vec n a -> Vec m a -> Vec (n + m) a -Nil ++ ys = ys -(x :> xs) ++ ys = x :> xs ++ ys - --- | Split a vector into two vectors at the given point --- --- >>> splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil) --- (<1,2,3>, <7,8>) --- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil) --- (<1,2,3>, <7,8>) -splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a) -splitAt n xs = splitAtU (toUNat n) xs - -splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a) -splitAtU UZero ys = (Nil,ys) -splitAtU (USucc s) (y :> ys) = let (as,bs) = splitAtU s ys - in (y :> as, bs) - -{-# INLINE splitAtI #-} --- | Split a vector into two vectors where the length of the two is determined --- by the context --- --- >>> splitAtI (1:>2:>3:>7:>8:>Nil) :: (Vec 2 Int, Vec 3 Int) --- (<1,2>,<3,7,8>) -splitAtI :: KnownNat m => Vec (m + n) a -> (Vec m a, Vec n a) -splitAtI = withSNat splitAt - --- | Shift in elements to the head of a vector, bumping out elements at the --- tail. The result is a tuple containing: --- --- * The new vector --- * The shifted out elements --- --- >>> shiftInAt0 (1 :> 2 :> 3 :> 4 :> Nil) ((-1) :> 0 :> Nil) --- (<-1,0,1,2,>,<3,4>) --- >>> shiftInAt0 (1 :> Nil) ((-1) :> 0 :> Nil) --- (<-1>,<0,1>) -shiftInAt0 :: KnownNat n - => Vec n a -- ^ The old vector - -> Vec m a -- ^ The elements to shift in at the head - -> (Vec n a, Vec m a) -- ^ (The new vector, shifted out elements) -shiftInAt0 xs ys = splitAtI zs - where - zs = ys ++ xs - --- | Shift in element to the tail of a vector, bumping out elements at the head. --- The result is a tuple containing: --- --- * The new vector --- * The shifted out elements --- --- >>> shiftInAtN (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> Nil) --- (<3,4,5,6>,<1,2>) --- >>> shiftInAtN (1 :> Nil) (2 :> 3 :> Nil) --- (<3>,<1,2>) -shiftInAtN :: KnownNat m - => Vec n a -- ^ The old vector - -> Vec m a -- ^ The elements to shift in at the tail - -> (Vec n a,Vec m a) -- ^ (The new vector, shifted out elements) -shiftInAtN xs ys = (zsR, zsL) - where - zs = xs ++ ys - (zsL,zsR) = splitAtI zs - --- | Concatenate a vector of vectors --- --- >>> concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil) --- <1,2,3,4,5,6,7,8,9,10,11,12> -concat :: Vec n (Vec m a) -> Vec (n * m) a -concat Nil = Nil -concat (x :> xs) = x ++ concat xs - --- | Split a vector of (n * m) elements into a vector of vectors with length m, --- where m is given --- --- >>> unconcat d4 (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) --- <<1,2,3,4>,<5,6,7,8>,<9,10,11,12>> -unconcat :: KnownNat n => SNat m -> Vec (n * m) a -> Vec n (Vec m a) -unconcat n xs = unconcatU (withSNat toUNat) (toUNat n) xs - -unconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a) -unconcatU UZero _ _ = Nil -unconcatU (USucc n') m ys = let (as,bs) = splitAtU m ys - in as :> unconcatU n' m bs - --- | Merge two vectors, alternating their elements, i.e., --- --- >>> merge (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> 7 :> 8 :> Nil) --- <1,5,2,6,3,7,4,8> -merge :: Vec n a -> Vec n a -> Vec (n + n) a -merge Nil Nil = Nil -merge (x :> xs) (y :> ys) = x :> y :> merge xs ys - --- | 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ elements --- --- >>> drop (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil) --- <4,5> --- >>> drop d3 (1:>2:>3:>4:>5:>Nil) --- <4,5> --- >>> drop d0 (1:>2:>Nil) --- <1,2> -drop :: SNat m -> Vec (m + n) a -> Vec n a -drop n = snd . splitAt n - -drop' :: (m <= k) => SNat m -> Vec k a -> Vec (k - m) a -drop' = drop - --- | 'at' @n xs@ returns @n@'th element of @xs@ --- --- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and --- ending at 'maxIndex'. --- --- >>> at (snat :: SNat 1) (1:>2:>3:>4:>5:>Nil) --- 2 --- >>> at d1 (1:>2:>3:>4:>5:>Nil) --- 2 -at :: SNat m -> Vec (m + (n + 1)) a -> a -at n xs = head $ snd $ splitAt n xs - -at' - :: forall k m a - . (1 <= k, m <= (k-1)) - => SNat m - -> Vec k a - -> a -at' = at @m @(k - 1 - m) - -leToPlus - :: forall (k :: Nat) (n :: Nat) (f :: Nat -> Type) (r :: Type) - . (k <= n) - => Proxy k - -> f n - -- ^ Argument with the @(k <= n)@ constraint - -> (forall (m :: Nat) . f (m + k) -> r) - -- ^ Function with the @(n + k)@ constraint - -> r -leToPlus _ a f = f @(n-k) a - -data BNat :: Nat -> Type where - BT :: BNat 0 - B0 :: BNat n -> BNat (2*n) - B1 :: BNat n -> BNat ((2*n) + 1) - -instance KnownNat n => Show (BNat n) where - show x = 'b':show (natVal x) - -predBNat :: (1 <= n) => BNat n -> BNat (n-1) -predBNat (B1 a) = case a of - BT -> BT - a' -> B0 a' -predBNat (B0 x) = B1 (predBNat x) - --- issue 52 begin -type role Signal nominal representational -data Signal (dom :: Symbol) a = a :- Signal dom a - -type role BitVector nominal -newtype BitVector (n :: Nat) = BV { unsafeToNatural :: Integer } - -class Bundle (f :: Type -> Type) a res | f a -> res, f res -> a, a res -> f -bundle :: Bundle f a res => res -> f a -bundle = bundle - -instance Bundle (Signal dom) (a,b) (Signal dom a, Signal dom b) - -issue52 :: (1 <= n, KnownNat n) => (Signal dom (),Signal dom (BitVector (n-1+1))) -> Signal dom ((),BitVector n) -issue52 = bundle --- issue 52 end - -proxyInEq1 :: Proxy a -> Proxy (a+1) -> () -proxyInEq1 = proxyInEq - -proxyInEq2 :: Proxy ((a+1) :: Nat) -> Proxy a -> () -proxyInEq2 = proxyInEq' - -proxyInEq3 :: Proxy (a :: Nat) -> Proxy (a+b) -> () -proxyInEq3 = proxyInEq - -proxyInEq4 :: Proxy (2*a) -> Proxy (4*a) -> () -proxyInEq4 = proxyInEq - -proxyInEq5 :: Proxy 1 -> Proxy (2^a) -> () -proxyInEq5 = proxyInEq - -proxyInEq6 :: Proxy 1 -> Proxy (a + 3) -> () -proxyInEq6 = proxyInEq - -proxyInEq7 :: Proxy 1 -> Proxy (2^(a + 3)) -> () -proxyInEq7 = proxyInEq - -proxyEq1 - :: (1 <= x) - => Proxy ((2 ^ x) * (2 ^ (x + x))) - -> Proxy (2 * (2 ^ ((x + (x + x)) - 1))) -proxyEq1 = id - -proxyEq2 - :: (2 <= x) - => Proxy (((2 ^ x) - 2) * (2 ^ (x + x))) - -> Proxy ((2 ^ ((x + (x + x)) - 1)) + ((2 ^ ((x + (x + x)) - 1)) - (2 ^ ((x + x) + 1)))) -proxyEq2 = id - -proxyEq3 - :: forall x y - . ((x + 1) ~ (2 * y), 1 <= y) - => Proxy x - -> Proxy y - -> Proxy (((2 * (y - 1)) + 1)) - -> Proxy x -proxyEq3 _ _ x = x - --- Would yield (b <=? c) ~ 'True -proxyEq4 - :: forall a b c - . (KnownNat a, c <= b, b <= a) - => Proxy b - -> Proxy c - -> Proxy a - -> Proxy (((a - b) + c) + (b - c)) -proxyEq4 = theProxy - where - theProxy - :: forall a b c - . (KnownNat (((a - b) + c) + (b - c)), c <= b, b <= a) - => Proxy b - -> Proxy c - -> Proxy a - -> Proxy (((a - b) + c) + (b - c)) - theProxy _ _ = id - -proxyInEqImplication :: (2 <= (2 ^ (n + d))) - => Proxy d - -> Proxy n - -> Proxy n -proxyInEqImplication = proxyInEqImplication' - -proxyInEqImplication' :: (2 <= (2 ^ (d + n))) - => Proxy d - -> Proxy n - -> Proxy n -proxyInEqImplication' _ = id - -proxyEqSubst - :: ((n+1) ~ ((n1 + m) + 1), m ~ n1, n1 ~ ((n2 + m1) + 1)) - => Proxy n1 - -> Proxy n2 - -> Proxy m1 - -> Proxy n - -> Proxy m - -> Proxy (1 + (n2 + m1)) - -> Proxy n1 -proxyEqSubst _ _ _ _ _ = id - -proxyInEqImplication2 - :: forall n n1 n2 - . (n1 ~ (n2 + 1), (2^n) ~ (n1 + 1)) - => Proxy n1 - -> Proxy n2 - -> Proxy n - -> Proxy ((n - 1) + 1) - -> Proxy n -proxyInEqImplication2 _ _ _ x = x - -type family F (n :: Nat) :: Nat -type instance F 3 = 8 - -proxyInEqImplication3 :: (KnownNat (F n)) - => Proxy (n :: Nat) - -> Proxy (n :: Nat) -proxyInEqImplication3 = proxyInEqImplication3' - -proxyInEqImplication3' :: (F n <= (3 * (F n))) - => Proxy (n :: Nat) - -> Proxy (n :: Nat) -proxyInEqImplication3' = id - -type family G (n :: Nat) :: Nat -type instance G 2 = 3 - -proxyInEqImplication4 :: (1 <= (G n)) - => Proxy (n :: Nat) - -> Proxy (n :: Nat) -proxyInEqImplication4 = proxyInEqImplication4' - -proxyInEqImplication4' :: (F n <= ((G n) * (F n))) - => Proxy (n :: Nat) - -> Proxy (n :: Nat) -proxyInEqImplication4' = id - -data AtMost n = forall a. (KnownNat a, a <= n) => AtMost (Proxy a) - -instance Show (AtMost n) where - show (AtMost (x :: Proxy a)) = "AtMost " P.++ show (natVal x) - -succAtMost :: AtMost n -> AtMost (n + 1) -succAtMost (AtMost (Proxy :: Proxy a)) = AtMost (Proxy :: Proxy a) - -eqReduceForward - :: Eq (Boo (n + 1)) - => Dict (Eq (Boo (n + 2 - 1))) -eqReduceForward = Dict - -eqReduceForwardMinusPlus - :: (Eq (Boo (0 + n + 1)), 1 <= n) - => Dict (Eq (Boo (n - 1 + 2))) -eqReduceForwardMinusPlus = Dict - -eqReduceBackward - :: (Eq (Boo (m + 2 - 1))) - => Dict (Eq (Boo (m + 1))) -eqReduceBackward = Dict - -eqReduceBackward' - :: (Eq (Boo (1 + m + 2))) - => Dict (Eq (Boo (m + 3))) -eqReduceBackward' = Dict - -proxyInEq8fun - :: (1 <= (n + CLog 2 n)) - => Proxy n - -> Proxy n -proxyInEq8fun = id - -proxyInEq8 - :: (1 <= n, KnownNat (CLog 2 n)) - => Proxy n - -> Proxy n -proxyInEq8 = proxyInEq8fun - -data H2 = H2 { p :: Nat } - -class Q (dom :: Symbol) where - type G2 dom :: H2 - -type family P (c :: H2) :: Nat where - P ('H2 p) = p - -type F2 (dom :: Symbol) = P (G2 dom) - -type Dom = "System" - -instance Q Dom where - type G2 Dom = 'H2 2 - -tyFamMonotonicityFun :: (1 <= F2 dom) => Proxy (dom :: Symbol) -> () -tyFamMonotonicityFun _ = () - -tyFamMonotonicity :: (2 <= F2 dom) => Proxy (dom :: Symbol) -> () -tyFamMonotonicity dom = tyFamMonotonicityFun dom - -oneLtPowSubst :: forall a b. (b ~ (2^a)) => Proxy a -> Proxy a -oneLtPowSubst = go - where - go :: 1 <= b => Proxy a -> Proxy a - go = id - -main :: IO () -main = defaultMain tests - -tests :: TestTree -tests = testGroup "ghc-typelits-natnormalise" - [ testGroup "Basic functionality" - [ testCase "show (head (1:>2:>3:>Nil))" $ - show (head (1:>2:>3:>Nil)) @?= - "1" - , testCase "show (tail (1:>2:>3:>Nil))" $ - show (tail (1:>2:>3:>Nil)) @?= - "<2,3>" - , testCase "show (init (1:>2:>3:>Nil))" $ - show (init (1:>2:>3:>Nil)) @?= - "<1,2>" - , testCase "show ((1:>2:>3:>Nil) ++ (7:>8:>Nil))" $ - show ((1:>2:>3:>Nil) ++ (7:>8:>Nil)) @?= - "<1,2,3,7,8>" - , testCase "show (splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil))" $ - show (splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil)) @?= - "(<1,2,3>,<7,8>)" - , testCase "show (concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil))" $ - show (concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil)) @?= - "<1,2,3,4,5,6,7,8,9,10,11,12>" - , testCase "show (unconcat (snat :: SNat 4) (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil))" $ - show (unconcat (snat :: SNat 4) (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil)) @?= - "<<1,2,3,4>,<5,6,7,8>,<9,10,11,12>>" - , testCase "show (proxyFun3 (Proxy :: Proxy 9))" $ - show (proxyFun3 (Proxy :: Proxy 9)) @?= - "()" - , testCase "show (proxyFun4 (Proxy :: Proxy 8))" $ - show (proxyFun4 (Proxy :: Proxy 8)) @?= - "()" - , testCase "show (proxyFun7 (Proxy :: Proxy 8) :: Proxy 3)" $ - show (proxyFun7 (Proxy :: Proxy 8) :: Proxy 3) @?= - "Proxy" - ] - , testGroup "Equality" - [ testCase "((2 ^ x) * (2 ^ (x + x))) ~ (2 * (2 ^ ((x + (x + x)) - 1)))" $ - show (proxyEq1 @1 Proxy) @?= - "Proxy" - , testCase "(((2 ^ x) - 2) * (2 ^ (x + x))) ~ ((2 ^ ((x + (x + x)) - 1)) + ((2 ^ ((x + (x + x)) - 1)) - (2 ^ ((x + x) + 1))))" $ - show (proxyEq2 @2 Proxy) @?= - "Proxy" - ] - , testGroup "Implications" - [ testCase "(x + 1) ~ (2 * y)) implies (((2 * (y - 1)) + 1)) ~ x" $ - show (proxyEq3 (Proxy :: Proxy 3) (Proxy :: Proxy 2) Proxy) @?= - "Proxy" - , testCase "(n+1) ~ ((n1 + m) + 1), m ~ n1, n1 ~ ((n2 + m1) + 1) implies n1 ~ 1 + (n2 + m1)" $ - show (proxyEqSubst (Proxy :: Proxy 6) (Proxy :: Proxy 2) (Proxy :: Proxy 3) - (Proxy :: Proxy 12) (Proxy :: Proxy 6) (Proxy :: Proxy 6)) @?= - "Proxy" - ] - , testGroup "Inequality" - [ testCase "a <= a+1" $ - show (proxyInEq1 (Proxy :: Proxy 2) (Proxy :: Proxy 3)) @?= - "()" - , testCase "(a+1 <=? a) ~ False" $ - show (proxyInEq2 (Proxy :: Proxy 3) (Proxy :: Proxy 2)) @?= - "()" - , testCase "a <= a+b" $ - show (proxyInEq3 (Proxy :: Proxy 2) (Proxy :: Proxy 2)) @?= - "()" - , testCase "2a <= 4a" $ - show (proxyInEq4 (Proxy :: Proxy 2) (Proxy :: Proxy 4)) @?= - "()" - , testCase "1 <= 2^a" $ - show (proxyInEq5 (Proxy :: Proxy 1) (Proxy :: Proxy 1)) @?= - "()" - , testCase "`(2 <= (2 ^ (n + d)))` implies `(2 <= (2 ^ (d + n)))`" $ - show (proxyInEqImplication (Proxy :: Proxy 3) (Proxy :: Proxy 4)) @?= - "Proxy" - , testCase "1 <= a+3" $ - show (proxyInEq6 (Proxy :: Proxy 1) (Proxy :: Proxy 8)) @?= - "()" - , testCase "`1 <= 2*x` implies `1 <= x`" $ - show (predBNat (B1 (B1 BT))) @?= - "b2" - , testCase "`x + 2 <= y` implies `x <= y` and `2 <= y`" $ - show (proxyInEqImplication2 (Proxy :: Proxy 3) (Proxy :: Proxy 2) (Proxy :: Proxy 2) Proxy) @?= - "Proxy" - , testCase "`a <= n` implies `a <= (n+1)`" $ - show (succAtMost (AtMost (Proxy :: Proxy 3) :: AtMost 5)) @?= - "AtMost 3" - , testCase "1 <= 2^(a+3)" $ - show (proxyInEq7 (Proxy :: Proxy 1) (Proxy :: Proxy 8)) @?= - "()" - , testCase "KnownNat (F a) implies F a <= 3 * F a" $ - show (proxyInEqImplication3 (Proxy :: Proxy 3)) @?= - "Proxy" - , testCase "1 <= G a implies F a <= G a * F a" $ - show (proxyInEqImplication4 (Proxy :: Proxy 2)) @?= - "Proxy" - , testCase "`(1 <= n)` only implies `(1 <= n + F n)` when `KnownNat (F n)`" $ - show (proxyInEq8 (Proxy :: Proxy 2)) @?= - "Proxy" - , testCase "2 <= P (G2 dom) implies 1 <= P (G2 dom)" $ - show (tyFamMonotonicity (Proxy :: Proxy Dom)) @?= - "()" - , testCase "b ~ (2^a) => 1 <= b" $ - show (oneLtPowSubst (Proxy :: Proxy 0)) @?= - "Proxy" - ] - , testGroup "errors" - [ testCase "x + 2 ~ 3 + x" $ testProxy1 `throws` testProxy1Errors - , testCase "GCD 6 8 + x ~ x + GCD 9 6" $ testProxy2 `throws` testProxy2Errors - , testCase "Unify \"x + x + x\" with \"8\"" $ testProxy3 `throws` testProxy3Errors - , testCase "Unify \"(2*x)+4\" with \"2\"" $ testProxy4 `throws` testProxy4Errors - , testCase "Unify \"(2*x)+4\" with \"7\"" $ testProxy5 `throws` testProxy5Errors - , testCase "Unify \"2^k\" with \"7\"" $ testProxy6 `throws` testProxy6Errors - , testCase "x ~ y + x" $ testProxy8 `throws` testProxy8Errors - , testCase "(CLog 2 (2 ^ n) ~ n, (1 <=? n) ~ True) => n ~ (n+d)" $ - testProxy15 (Proxy :: Proxy 1) `throws` testProxy15Errors - , testCase "(n - 1) + 1 ~ n implies (1 <= n)" $ test16 `throws` test16Errors - , testGroup "Inequality" - [ testCase "a+1 <= a" $ testProxy9 `throws` testProxy9Errors - , testCase "(a <=? a+1) ~ False" $ testProxy10 `throws` testProxy10Errors - , testCase "(a <=? a) ~ False" $ testProxy11 `throws` testProxy11Errors - , testCase "() => (a+b <= a+c)" $ testProxy12 `throws` testProxy12Errors - , testCase "4a <= 2a" $ testProxy13 `throws` testProxy13Errors - , testCase "2a <=? 4a ~ False" $ testProxy14 `throws` testProxy14Errors - , testCase "Show (Boo n) => Show (Boo (n - 1 + 1))" $ - testProxy17 `throws` test17Errors - , testCase "1 <= m, m <= rp implies 1 <= rp - m" $ (testProxy19 (Proxy @1) (Proxy @1)) `throws` test19Errors - , testCase "Vacuously: 1 <= m ^ 2 ~ True" $ testProxy20 `throws` testProxy20Errors - ] - ] - ] - --- | Assert that evaluation of the first argument (to WHNF) will throw --- an exception whose string representation contains the given --- substrings. -throws :: a -> [String] -> Assertion -throws v xs = do - result <- try (evaluate v) - case result of - Right _ -> assertFailure "No exception!" - Left (TypeError msg) -> - if all (`isInfixOf` msg) xs - then return () - else assertFailure msg - -showFin :: forall n. KnownNat n => Fin n -> String -showFin f = mconcat [ - show (finToInt f) - , "/" - , show (natVal (Proxy :: Proxy n)) - ] - -finToInt :: Fin n -> Int -finToInt FZ = 0 -finToInt (FS fn) = finToInt fn + 1 - -predFin :: Fin (n + 2) -> Fin (n + 1) -predFin (FS fn) = fn -predFin FZ = FZ - -showSucPred :: KnownNat (n + 2) => Fin (n + 2) -> String -showSucPred = showFin . FS . predFin - -class Up env (n :: Nat) where - up :: env -> Fin n -> Fin (n + 1) - -class Down env (n :: Nat) where - down :: env -> Fin n -> Fin (n - 1) - -class ShowWith env (n :: Nat) where - showWith :: env -> Fin n -> String - -showDownUp - :: (Up env n, Down env (n + 1), ShowWith env n) - => env -> Fin n -> String -showDownUp env fn = showWith env $ down env $ up env fn - -showDownUp' - :: (Up env n, Down env (n + 1), KnownNat n) - => env -> Fin n -> String -showDownUp' env fn = showFin $ down env $ up env fn - -data family FakeUVector (n :: Nat) :: Type -data family FakeMUVector (n :: Nat) :: Type -type family Mutable (v :: Nat -> Type) :: Nat -> Type -type instance Mutable FakeUVector = FakeMUVector - -class (IsMVector FakeMUVector n, IsVector FakeUVector n) - => FakeUnbox n -class IsMVector (v :: Nat -> Type) a where - touchMVector :: v a -> v a -class IsMVector (Mutable v) a => IsVector v a where - touchVector :: v a -> v a - -newtype WrapFakeVector n = WFV { unWrap :: FakeUVector (1 + n) } -newtype WrapFakeMVector n = MWFV { unWrapM :: FakeMUVector (1 + n) } -type instance Mutable WrapFakeVector = WrapFakeMVector - --- The following two instances cannot be derived without simplification phase! -instance FakeUnbox (n + 1) => IsVector WrapFakeVector n where - touchVector = WFV . touchVector . unWrap -instance FakeUnbox (n + 1) => IsMVector WrapFakeMVector n where - touchMVector = MWFV . touchMVector . unWrapM +{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE NoStarIsType #-}+#endif++{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -dcore-lint #-}++import GHC.TypeLits+#if MIN_VERSION_base(4,18,0)+ hiding (type SNat)+#endif++import Unsafe.Coerce+import Prelude hiding (head,tail,init,(++),splitAt,concat,drop)+import qualified Prelude as P++import Data.Kind (Type)+import Data.List (isInfixOf)+import Data.Proxy+import Control.Exception+import Test.Tasty+import Test.Tasty.HUnit++import ErrorTests++data Vec :: Nat -> Type -> Type where+ Nil :: Vec 0 a+ (:>) :: a -> Vec n a -> Vec (n + 1) a++instance Show a => Show (Vec n a) where+ show vs = "<" P.++ punc vs P.++ ">"+ where+ punc :: Vec m a -> String+ punc Nil = ""+ punc (x :> Nil) = show x+ punc (x :> xs) = show x P.++ "," P.++ punc xs++infixr 5 :>++data SNat (n :: Nat) = KnownNat n => SNat (Proxy n)++instance Show (SNat n) where+ show (SNat p) = 'd' : show (natVal p)++{-# INLINE snat #-}+-- | Create a singleton literal for a type-level natural number+snat :: KnownNat n => SNat n+snat = SNat Proxy++{-# INLINE withSNat #-}+-- | Supply a function with a singleton natural 'n' according to the context+withSNat :: KnownNat n => (SNat n -> a) -> a+withSNat f = f (SNat Proxy)++{-# INLINE snatToInteger #-}+snatToInteger :: SNat n -> Integer+snatToInteger (SNat p) = natVal p++data UNat :: Nat -> Type where+ UZero :: UNat 0+ USucc :: UNat n -> UNat (n + 1)++-- | Convert a singleton natural number to its unary representation+--+-- __NB__: Not synthesisable+toUNat :: SNat n -> UNat n+toUNat (SNat p) = fromI (natVal p)+ where+ fromI :: Integer -> UNat m+ fromI 0 = unsafeCoerce UZero+ fromI n = unsafeCoerce (USucc (fromI (n - 1)))++-- | Add two singleton natural numbers+--+-- __NB__: Not synthesisable+addUNat :: UNat n -> UNat m -> UNat (n + m)+addUNat UZero y = y+addUNat x UZero = x+addUNat (USucc x) y = USucc (addUNat x y)++-- | Multiply two singleton natural numbers+--+-- __NB__: Not synthesisable+multUNat :: UNat n -> UNat m -> UNat (n * m)+multUNat UZero _ = UZero+multUNat _ UZero = UZero+multUNat (USucc x) y = addUNat y (multUNat x y)++-- | Exponential of two singleton natural numbers+--+-- __NB__: Not synthesisable+powUNat :: UNat n -> UNat m -> UNat (n ^ m)+powUNat _ UZero = USucc UZero+powUNat x (USucc y) = multUNat x (powUNat x y)++-- | Extract the first element of a vector+--+-- >>> head (1:>2:>3:>Nil)+-- 1+head :: Vec (n + 1) a -> a+head (x :> _) = x++head'+ :: forall n a+ . (1 <= n)+ => Vec n a+ -> a+head' = head @(n-1)++-- | Extract the elements after the head of a vector+--+-- >>> tail (1:>2:>3:>Nil)+-- <2,3>+tail :: Vec (n + 1) a -> Vec n a+tail (_ :> xs) = xs++tail' :: (1 <= m) => Vec m a -> Vec (m-1) a+tail' = tail++-- | Extract all the elements of a vector except the last element+--+-- >>> init (1:>2:>3:>Nil)+-- <1,2>+init :: Vec (n + 1) a -> Vec n a+init (_ :> Nil) = Nil+init (x :> y :> ys) = x :> init (y :> ys)++init' :: (1 <= m) => Vec m a -> Vec (m-1) a+init' = init++infixr 5 +++-- | Append two vectors+--+-- >>> (1:>2:>3:>Nil) ++ (7:>8:>Nil)+-- <1,2,3,7,8>+(++) :: Vec n a -> Vec m a -> Vec (n + m) a+Nil ++ ys = ys+(x :> xs) ++ ys = x :> xs ++ ys++-- | Split a vector into two vectors at the given point+--+-- >>> splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil)+-- (<1,2,3>, <7,8>)+-- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil)+-- (<1,2,3>, <7,8>)+splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)+splitAt n xs = splitAtU (toUNat n) xs++splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a)+splitAtU UZero ys = (Nil,ys)+splitAtU (USucc s) (y :> ys) = let (as,bs) = splitAtU s ys+ in (y :> as, bs)++{-# INLINE splitAtI #-}+-- | Split a vector into two vectors where the length of the two is determined+-- by the context+--+-- >>> splitAtI (1:>2:>3:>7:>8:>Nil) :: (Vec 2 Int, Vec 3 Int)+-- (<1,2>,<3,7,8>)+splitAtI :: KnownNat m => Vec (m + n) a -> (Vec m a, Vec n a)+splitAtI = withSNat splitAt++-- | Shift in elements to the head of a vector, bumping out elements at the+-- tail. The result is a tuple containing:+--+-- * The new vector+-- * The shifted out elements+--+-- >>> shiftInAt0 (1 :> 2 :> 3 :> 4 :> Nil) ((-1) :> 0 :> Nil)+-- (<-1,0,1,2,>,<3,4>)+-- >>> shiftInAt0 (1 :> Nil) ((-1) :> 0 :> Nil)+-- (<-1>,<0,1>)+shiftInAt0 :: KnownNat n+ => Vec n a -- ^ The old vector+ -> Vec m a -- ^ The elements to shift in at the head+ -> (Vec n a, Vec m a) -- ^ (The new vector, shifted out elements)+shiftInAt0 xs ys = splitAtI zs+ where+ zs = ys ++ xs++-- | Shift in element to the tail of a vector, bumping out elements at the head.+-- The result is a tuple containing:+--+-- * The new vector+-- * The shifted out elements+--+-- >>> shiftInAtN (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> Nil)+-- (<3,4,5,6>,<1,2>)+-- >>> shiftInAtN (1 :> Nil) (2 :> 3 :> Nil)+-- (<3>,<1,2>)+shiftInAtN :: KnownNat m+ => Vec n a -- ^ The old vector+ -> Vec m a -- ^ The elements to shift in at the tail+ -> (Vec n a,Vec m a) -- ^ (The new vector, shifted out elements)+shiftInAtN xs ys = (zsR, zsL)+ where+ zs = xs ++ ys+ (zsL,zsR) = splitAtI zs++-- | Concatenate a vector of vectors+--+-- >>> concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil)+-- <1,2,3,4,5,6,7,8,9,10,11,12>+concat :: Vec n (Vec m a) -> Vec (n * m) a+concat Nil = Nil+concat (x :> xs) = x ++ concat xs++-- | Split a vector of (n * m) elements into a vector of vectors with length m,+-- where m is given+--+-- >>> unconcat d4 (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil)+-- <<1,2,3,4>,<5,6,7,8>,<9,10,11,12>>+unconcat :: KnownNat n => SNat m -> Vec (n * m) a -> Vec n (Vec m a)+unconcat n xs = unconcatU (withSNat toUNat) (toUNat n) xs++unconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a)+unconcatU UZero _ _ = Nil+unconcatU (USucc n') m ys = let (as,bs) = splitAtU m ys+ in as :> unconcatU n' m bs++-- | Merge two vectors, alternating their elements, i.e.,+--+-- >>> merge (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> 7 :> 8 :> Nil)+-- <1,5,2,6,3,7,4,8>+merge :: Vec n a -> Vec n a -> Vec (n + n) a+merge Nil Nil = Nil+merge (x :> xs) (y :> ys) = x :> y :> merge xs ys++-- | 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ elements+--+-- >>> drop (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil)+-- <4,5>+-- >>> drop d3 (1:>2:>3:>4:>5:>Nil)+-- <4,5>+-- >>> drop d0 (1:>2:>Nil)+-- <1,2>+drop :: SNat m -> Vec (m + n) a -> Vec n a+drop n = snd . splitAt n++drop' :: (m <= k) => SNat m -> Vec k a -> Vec (k - m) a+drop' = drop++-- | 'at' @n xs@ returns @n@'th element of @xs@+--+-- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and+-- ending at 'maxIndex'.+--+-- >>> at (snat :: SNat 1) (1:>2:>3:>4:>5:>Nil)+-- 2+-- >>> at d1 (1:>2:>3:>4:>5:>Nil)+-- 2+at :: SNat m -> Vec (m + (n + 1)) a -> a+at n xs = head $ snd $ splitAt n xs++at'+ :: forall k m a+ . (1 <= k, m <= (k-1))+ => SNat m+ -> Vec k a+ -> a+at' = at @m @(k - 1 - m)++leToPlus+ :: forall (k :: Nat) (n :: Nat) (f :: Nat -> Type) (r :: Type)+ . (k <= n)+ => Proxy k+ -> f n+ -- ^ Argument with the @(k <= n)@ constraint+ -> (forall (m :: Nat) . f (m + k) -> r)+ -- ^ Function with the @(n + k)@ constraint+ -> r+leToPlus _ a f = f @(n-k) a++data BNat :: Nat -> Type where+ BT :: BNat 0+ B0 :: BNat n -> BNat (2*n)+ B1 :: BNat n -> BNat ((2*n) + 1)++instance KnownNat n => Show (BNat n) where+ show x = 'b':show (natVal x)++predBNat :: (1 <= n) => BNat n -> BNat (n-1)+predBNat (B1 a) = case a of+ BT -> BT+ a' -> B0 a'+predBNat (B0 x) = B1 (predBNat x)++-- issue 52 begin+type role Signal nominal representational+data Signal (dom :: Symbol) a = a :- Signal dom a++type role BitVector nominal+newtype BitVector (n :: Nat) = BV { unsafeToNatural :: Integer }++class Bundle (f :: Type -> Type) a res | f a -> res, f res -> a, a res -> f+bundle :: Bundle f a res => res -> f a+bundle = bundle++instance Bundle (Signal dom) (a,b) (Signal dom a, Signal dom b)++issue52 :: (1 <= n, KnownNat n) => (Signal dom (),Signal dom (BitVector (n-1+1))) -> Signal dom ((),BitVector n)+issue52 = bundle+-- issue 52 end++proxyInEq1 :: Proxy a -> Proxy (a+1) -> ()+proxyInEq1 = proxyInEq++proxyInEq2 :: Proxy ((a+1) :: Nat) -> Proxy a -> ()+proxyInEq2 = proxyInEq'++proxyInEq3 :: Proxy (a :: Nat) -> Proxy (a+b) -> ()+proxyInEq3 = proxyInEq++proxyInEq4 :: Proxy (2*a) -> Proxy (4*a) -> ()+proxyInEq4 = proxyInEq++proxyInEq5 :: Proxy 1 -> Proxy (2^a) -> ()+proxyInEq5 = proxyInEq++proxyInEq6 :: Proxy 1 -> Proxy (a + 3) -> ()+proxyInEq6 = proxyInEq++proxyInEq7 :: Proxy 1 -> Proxy (2^(a + 3)) -> ()+proxyInEq7 = proxyInEq++proxyEq1+ :: (1 <= x)+ => Proxy ((2 ^ x) * (2 ^ (x + x)))+ -> Proxy (2 * (2 ^ ((x + (x + x)) - 1)))+proxyEq1 = id++proxyEq2+ :: (2 <= x)+ => Proxy (((2 ^ x) - 2) * (2 ^ (x + x)))+ -> Proxy ((2 ^ ((x + (x + x)) - 1)) + ((2 ^ ((x + (x + x)) - 1)) - (2 ^ ((x + x) + 1))))+proxyEq2 = id++proxyEq3+ :: forall x y+ . ((x + 1) ~ (2 * y), 1 <= y)+ => Proxy x+ -> Proxy y+ -> Proxy (((2 * (y - 1)) + 1))+ -> Proxy x+proxyEq3 _ _ x = x++-- Would yield (b <=? c) ~ 'True+proxyEq4+ :: forall a b c+ . (KnownNat a, c <= b, b <= a)+ => Proxy b+ -> Proxy c+ -> Proxy a+ -> Proxy (((a - b) + c) + (b - c))+proxyEq4 = theProxy+ where+ theProxy+ :: forall a b c+ . (KnownNat (((a - b) + c) + (b - c)), c <= b, b <= a)+ => Proxy b+ -> Proxy c+ -> Proxy a+ -> Proxy (((a - b) + c) + (b - c))+ theProxy _ _ = id++proxyInEqImplication :: (2 <= (2 ^ (n + d)))+ => Proxy d+ -> Proxy n+ -> Proxy n+proxyInEqImplication = proxyInEqImplication'++proxyInEqImplication' :: (2 <= (2 ^ (d + n)))+ => Proxy d+ -> Proxy n+ -> Proxy n+proxyInEqImplication' _ = id++proxyEqSubst+ :: ((n+1) ~ ((n1 + m) + 1), m ~ n1, n1 ~ ((n2 + m1) + 1))+ => Proxy n1+ -> Proxy n2+ -> Proxy m1+ -> Proxy n+ -> Proxy m+ -> Proxy (1 + (n2 + m1))+ -> Proxy n1+proxyEqSubst _ _ _ _ _ = id++proxyInEqImplication2+ :: forall n n1 n2+ . (n1 ~ (n2 + 1), (2^n) ~ (n1 + 1))+ => Proxy n1+ -> Proxy n2+ -> Proxy n+ -> Proxy ((n - 1) + 1)+ -> Proxy n+proxyInEqImplication2 _ _ _ x = x++type family F (n :: Nat) :: Nat+type instance F 3 = 8++proxyInEqImplication3 :: (KnownNat (F n))+ => Proxy (n :: Nat)+ -> Proxy (n :: Nat)+proxyInEqImplication3 = proxyInEqImplication3'++proxyInEqImplication3' :: (F n <= (3 * (F n)))+ => Proxy (n :: Nat)+ -> Proxy (n :: Nat)+proxyInEqImplication3' = id++type family G (n :: Nat) :: Nat+type instance G 2 = 3++proxyInEqImplication4 :: (1 <= (G n))+ => Proxy (n :: Nat)+ -> Proxy (n :: Nat)+proxyInEqImplication4 = proxyInEqImplication4'++proxyInEqImplication4' :: (F n <= ((G n) * (F n)))+ => Proxy (n :: Nat)+ -> Proxy (n :: Nat)+proxyInEqImplication4' = id++data AtMost n = forall a. (KnownNat a, a <= n) => AtMost (Proxy a)++instance Show (AtMost n) where+ show (AtMost (x :: Proxy a)) = "AtMost " P.++ show (natVal x)++succAtMost :: AtMost n -> AtMost (n + 1)+succAtMost (AtMost (Proxy :: Proxy a)) = AtMost (Proxy :: Proxy a)++eqReduceForward+ :: Eq (Boo (n + 1))+ => Dict (Eq (Boo (n + 2 - 1)))+eqReduceForward = Dict++eqReduceForwardMinusPlus+ :: (Eq (Boo (0 + n + 1)), 1 <= n)+ => Dict (Eq (Boo (n - 1 + 2)))+eqReduceForwardMinusPlus = Dict++eqReduceBackward+ :: (Eq (Boo (m + 2 - 1)))+ => Dict (Eq (Boo (m + 1)))+eqReduceBackward = Dict++eqReduceBackward'+ :: (Eq (Boo (1 + m + 2)))+ => Dict (Eq (Boo (m + 3)))+eqReduceBackward' = Dict++proxyInEq8fun+ :: (1 <= (n + CLog 2 n))+ => Proxy n+ -> Proxy n+proxyInEq8fun = id++proxyInEq8+ :: (1 <= n, KnownNat (CLog 2 n))+ => Proxy n+ -> Proxy n+proxyInEq8 = proxyInEq8fun++data H2 = H2 { p :: Nat }++class Q (dom :: Symbol) where+ type G2 dom :: H2++type family P (c :: H2) :: Nat where+ P ('H2 p) = p++type F2 (dom :: Symbol) = P (G2 dom)++type Dom = "System"++instance Q Dom where+ type G2 Dom = 'H2 2++tyFamMonotonicityFun :: (1 <= F2 dom) => Proxy (dom :: Symbol) -> ()+tyFamMonotonicityFun _ = ()++tyFamMonotonicity :: (2 <= F2 dom) => Proxy (dom :: Symbol) -> ()+tyFamMonotonicity dom = tyFamMonotonicityFun dom++oneLtPowSubst :: forall a b. (b ~ (2^a)) => Proxy a -> Proxy a+oneLtPowSubst = go+ where+ go :: 1 <= b => Proxy a -> Proxy a+ go = id ++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "ghc-typelits-natnormalise"+ [ testGroup "Basic functionality"+ [ testCase "show (head (1:>2:>3:>Nil))" $+ show (head (1:>2:>3:>Nil)) @?=+ "1"+ , testCase "show (tail (1:>2:>3:>Nil))" $+ show (tail (1:>2:>3:>Nil)) @?=+ "<2,3>"+ , testCase "show (init (1:>2:>3:>Nil))" $+ show (init (1:>2:>3:>Nil)) @?=+ "<1,2>"+ , testCase "show ((1:>2:>3:>Nil) ++ (7:>8:>Nil))" $+ show ((1:>2:>3:>Nil) ++ (7:>8:>Nil)) @?=+ "<1,2,3,7,8>"+ , testCase "show (splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil))" $+ show (splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil)) @?=+ "(<1,2,3>,<7,8>)"+ , testCase "show (concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil))" $+ show (concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil)) @?=+ "<1,2,3,4,5,6,7,8,9,10,11,12>"+ , testCase "show (unconcat (snat :: SNat 4) (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil))" $+ show (unconcat (snat :: SNat 4) (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil)) @?=+ "<<1,2,3,4>,<5,6,7,8>,<9,10,11,12>>"+ , testCase "show (proxyFun3 (Proxy :: Proxy 9))" $+ show (proxyFun3 (Proxy :: Proxy 9)) @?=+ "()"+ , testCase "show (proxyFun4 (Proxy :: Proxy 8))" $+ show (proxyFun4 (Proxy :: Proxy 8)) @?=+ "()"+ , testCase "show (proxyFun7 (Proxy :: Proxy 8) :: Proxy 3)" $+ show (proxyFun7 (Proxy :: Proxy 8) :: Proxy 3) @?=+ "Proxy"+ ]+ , testGroup "Equality"+ [ testCase "((2 ^ x) * (2 ^ (x + x))) ~ (2 * (2 ^ ((x + (x + x)) - 1)))" $+ show (proxyEq1 @1 Proxy) @?=+ "Proxy"+ , testCase "(((2 ^ x) - 2) * (2 ^ (x + x))) ~ ((2 ^ ((x + (x + x)) - 1)) + ((2 ^ ((x + (x + x)) - 1)) - (2 ^ ((x + x) + 1))))" $+ show (proxyEq2 @2 Proxy) @?=+ "Proxy"+ ]+ , testGroup "Implications"+ [ testCase "(x + 1) ~ (2 * y)) implies (((2 * (y - 1)) + 1)) ~ x" $+ show (proxyEq3 (Proxy :: Proxy 3) (Proxy :: Proxy 2) Proxy) @?=+ "Proxy"+ , testCase "(n+1) ~ ((n1 + m) + 1), m ~ n1, n1 ~ ((n2 + m1) + 1) implies n1 ~ 1 + (n2 + m1)" $+ show (proxyEqSubst (Proxy :: Proxy 6) (Proxy :: Proxy 2) (Proxy :: Proxy 3)+ (Proxy :: Proxy 12) (Proxy :: Proxy 6) (Proxy :: Proxy 6)) @?=+ "Proxy"+ ]+ , testGroup "Inequality"+ [ testCase "a <= a+1" $+ show (proxyInEq1 (Proxy :: Proxy 2) (Proxy :: Proxy 3)) @?=+ "()"+ , testCase "(a+1 <=? a) ~ False" $+ show (proxyInEq2 (Proxy :: Proxy 3) (Proxy :: Proxy 2)) @?=+ "()"+ , testCase "a <= a+b" $+ show (proxyInEq3 (Proxy :: Proxy 2) (Proxy :: Proxy 2)) @?=+ "()"+ , testCase "2a <= 4a" $+ show (proxyInEq4 (Proxy :: Proxy 2) (Proxy :: Proxy 4)) @?=+ "()"+ , testCase "1 <= 2^a" $+ show (proxyInEq5 (Proxy :: Proxy 1) (Proxy :: Proxy 1)) @?=+ "()"+ , testCase "`(2 <= (2 ^ (n + d)))` implies `(2 <= (2 ^ (d + n)))`" $+ show (proxyInEqImplication (Proxy :: Proxy 3) (Proxy :: Proxy 4)) @?=+ "Proxy"+ , testCase "1 <= a+3" $+ show (proxyInEq6 (Proxy :: Proxy 1) (Proxy :: Proxy 8)) @?=+ "()"+ , testCase "`1 <= 2*x` implies `1 <= x`" $+ show (predBNat (B1 (B1 BT))) @?=+ "b2"+ , testCase "`x + 2 <= y` implies `x <= y` and `2 <= y`" $+ show (proxyInEqImplication2 (Proxy :: Proxy 3) (Proxy :: Proxy 2) (Proxy :: Proxy 2) Proxy) @?=+ "Proxy"+ , testCase "`a <= n` implies `a <= (n+1)`" $+ show (succAtMost (AtMost (Proxy :: Proxy 3) :: AtMost 5)) @?=+ "AtMost 3"+ , testCase "1 <= 2^(a+3)" $+ show (proxyInEq7 (Proxy :: Proxy 1) (Proxy :: Proxy 8)) @?=+ "()"+ , testCase "KnownNat (F a) implies F a <= 3 * F a" $+ show (proxyInEqImplication3 (Proxy :: Proxy 3)) @?=+ "Proxy"+ , testCase "1 <= G a implies F a <= G a * F a" $+ show (proxyInEqImplication4 (Proxy :: Proxy 2)) @?=+ "Proxy"+ , testCase "`(1 <= n)` only implies `(1 <= n + F n)` when `KnownNat (F n)`" $+ show (proxyInEq8 (Proxy :: Proxy 2)) @?=+ "Proxy"+ , testCase "2 <= P (G2 dom) implies 1 <= P (G2 dom)" $+ show (tyFamMonotonicity (Proxy :: Proxy Dom)) @?=+ "()"+ , testCase "b ~ (2^a) => 1 <= b" $+ show (oneLtPowSubst (Proxy :: Proxy 0)) @?=+ "Proxy"+ ]+ , testGroup "errors"+ [ testCase "x + 2 ~ 3 + x" $ testProxy1 `throws` testProxy1Errors+ , testCase "GCD 6 8 + x ~ x + GCD 9 6" $ testProxy2 `throws` testProxy2Errors+ , testCase "Unify \"x + x + x\" with \"8\"" $ testProxy3 `throws` testProxy3Errors+ , testCase "Unify \"(2*x)+4\" with \"2\"" $ testProxy4 `throws` testProxy4Errors+ , testCase "Unify \"(2*x)+4\" with \"7\"" $ testProxy5 `throws` testProxy5Errors+ , testCase "Unify \"2^k\" with \"7\"" $ testProxy6 `throws` testProxy6Errors+ , testCase "x ~ y + x" $ testProxy8 `throws` testProxy8Errors+ , testCase "(CLog 2 (2 ^ n) ~ n, (1 <=? n) ~ True) => n ~ (n+d)" $+ testProxy15 (Proxy :: Proxy 1) `throws` testProxy15Errors+ , testCase "(n - 1) + 1 ~ n implies (1 <= n)" $ test16 `throws` test16Errors+ , testGroup "Inequality"+ [ testCase "a+1 <= a" $ testProxy9 `throws` testProxy9Errors+ , testCase "(a <=? a+1) ~ False" $ testProxy10 `throws` testProxy10Errors+ , testCase "(a <=? a) ~ False" $ testProxy11 `throws` testProxy11Errors+ , testCase "() => (a+b <= a+c)" $ testProxy12 `throws` testProxy12Errors+ , testCase "4a <= 2a" $ testProxy13 `throws` testProxy13Errors+ , testCase "2a <=? 4a ~ False" $ testProxy14 `throws` testProxy14Errors+ , testCase "Show (Boo n) => Show (Boo (n - 1 + 1))" $+ testProxy17 `throws` test17Errors+ , testCase "1 <= m, m <= rp implies 1 <= rp - m" $ (testProxy19 (Proxy @1) (Proxy @1)) `throws` test19Errors+ , testCase "Vacuously: 1 <= m ^ 2 ~ True" $ testProxy20 `throws` testProxy20Errors+ ]+ ]+ ]++-- | Assert that evaluation of the first argument (to WHNF) will throw+-- an exception whose string representation contains the given+-- substrings.+throws :: a -> [String] -> Assertion+throws v xs = do+ result <- try (evaluate v)+ case result of+ Right _ -> assertFailure "No exception!"+ Left (TypeError msg) ->+ if all (`isInfixOf` msg) xs+ then return ()+ else assertFailure msg++showFin :: forall n. KnownNat n => Fin n -> String+showFin f = mconcat [+ show (finToInt f)+ , "/"+ , show (natVal (Proxy :: Proxy n))+ ]++finToInt :: Fin n -> Int+finToInt FZ = 0+finToInt (FS fn) = finToInt fn + 1++predFin :: Fin (n + 2) -> Fin (n + 1)+predFin (FS fn) = fn+predFin FZ = FZ++showSucPred :: KnownNat (n + 2) => Fin (n + 2) -> String+showSucPred = showFin . FS . predFin++class Up env (n :: Nat) where+ up :: env -> Fin n -> Fin (n + 1)++class Down env (n :: Nat) where+ down :: env -> Fin n -> Fin (n - 1)++class ShowWith env (n :: Nat) where+ showWith :: env -> Fin n -> String++showDownUp+ :: (Up env n, Down env (n + 1), ShowWith env n)+ => env -> Fin n -> String+showDownUp env fn = showWith env $ down env $ up env fn++showDownUp'+ :: (Up env n, Down env (n + 1), KnownNat n)+ => env -> Fin n -> String+showDownUp' env fn = showFin $ down env $ up env fn++data family FakeUVector (n :: Nat) :: Type+data family FakeMUVector (n :: Nat) :: Type+type family Mutable (v :: Nat -> Type) :: Nat -> Type+type instance Mutable FakeUVector = FakeMUVector++class (IsMVector FakeMUVector n, IsVector FakeUVector n)+ => FakeUnbox n+class IsMVector (v :: Nat -> Type) a where+ touchMVector :: v a -> v a+class IsMVector (Mutable v) a => IsVector v a where+ touchVector :: v a -> v a++newtype WrapFakeVector n = WFV { unWrap :: FakeUVector (1 + n) }+newtype WrapFakeMVector n = MWFV { unWrapM :: FakeMUVector (1 + n) }+type instance Mutable WrapFakeVector = WrapFakeMVector++-- The following two instances cannot be derived without simplification phase!+instance FakeUnbox (n + 1) => IsVector WrapFakeVector n where+ touchVector = WFV . touchVector . unWrap+instance FakeUnbox (n + 1) => IsMVector WrapFakeMVector n where+ touchMVector = MWFV . touchMVector . unWrapM