ghc-typelits-natnormalise 0.7.9 → 0.7.10
raw patch · 11 files changed
+4085/−4040 lines, 11 filesdep ~containersdep ~ghcdep ~template-haskellsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: containers, ghc, template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +185/−182
- LICENSE +27/−27
- README.md +39/−39
- Setup.hs +2/−2
- ghc-typelits-natnormalise.cabal +116/−115
- src-ghc-9.4/GHC/TypeLits/Normalise.hs +740/−736
- 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 +40/−3
- tests/Tests.hs +711/−711
CHANGELOG.md view
@@ -1,182 +1,185 @@-# Changelog for the [`ghc-typelits-natnormalise`](http://hackage.haskell.org/package/ghc-typelits-natnormalise) package--## 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.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,115 +1,116 @@-name: ghc-typelits-natnormalise-version: 0.7.9-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.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.7,- ghc >=8.0.1 && <9.10,- 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.10)- hs-source-dirs: src-ghc-9.4- 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.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
src-ghc-9.4/GHC/TypeLits/Normalise.hs view
@@ -1,736 +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 #-}--{-# 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 GHC.TcPluginM.Extra- (tracePlugin, lookupModule, lookupName, 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.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin)-import GHC.Tc.Plugin- (TcPluginM, tcLookupClass, tcPluginTrace, tcPluginIO, newEvVar)-import GHC.Tc.Plugin (tcLookupTyCon)-import GHC.Tc.Types (TcPlugin (..), TcPluginSolveResult(..))-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.Data.FastString (fsLit)-import GHC.Types.Name.Occurrence (mkTcOcc)-import GHC.Types.Unique.FM (emptyUFM)-import GHC.Unit.Module (mkModuleName)-import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text)---- 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)- md <- lookupModule ordModule basePackage- ordCond <- look md "OrdCond"- leqT <- look md "<="- md1 <- lookupModule typeErrModule basePackage- assertT <- look md1 "Assert"- return (ref, (leqT,assertT,ordCond))- where- look md s = tcLookupTyCon =<< lookupName md (mkTcOcc s)- ordModule = mkModuleName "Data.Type.Ord"- typeErrModule = mkModuleName "GHC.TypeError"- basePackage = fsLit "base"--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__ >= 906+#if __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"+ )+ ,$(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__ >= 906+ [$(do localeEncoding <- runIO (getLocaleEncoding)+ if textEncodingName localeEncoding == textEncodingName utf8 then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" )@@ -239,8 +256,11 @@ testProxy11Errors = [$(do localeEncoding <- runIO (getLocaleEncoding) if textEncodingName localeEncoding == textEncodingName utf8-#if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ >= 910 then litE $ stringL "Couldn't match type ‘True’ with ‘False’"+ else litE $ stringL "Couldn't match type `True' with `False'"+#elif __GLASGOW_HASKELL__ >= 906+ then litE $ stringL "Couldn't match type ‘True’ with ‘False’" else litE $ stringL "Couldn't match type True with False" #else then litE $ stringL "Couldn't match type ‘'True’ with ‘'False’"@@ -314,7 +334,24 @@ testProxy14 = proxyInEq' testProxy14Errors =-#if __GLASGOW_HASKELL__ >= 906+#if __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"+ )+ ,$(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__ >= 906 [$(do localeEncoding <- runIO (getLocaleEncoding) if textEncodingName localeEncoding == textEncodingName utf8 then litE $ stringL "Couldn't match type ‘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