├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .hlint.yaml ├── CHANGELOG.markdown ├── LICENSE ├── README.markdown ├── Setup.hs ├── cabal.haskell-ci ├── cabal.project ├── constraints.cabal ├── src └── Data │ ├── Constraint.hs │ └── Constraint │ ├── Char.hs │ ├── Deferrable.hs │ ├── Forall.hs │ ├── Lifting.hs │ ├── Nat.hs │ ├── Symbol.hs │ └── Unsafe.hs └── tests ├── GH117Spec.hs ├── GH55Spec.hs └── Spec.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'constraints.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20240514 12 | # 13 | # REGENDATA ("0.19.20240514",["github","constraints.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:focal 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.10.1 32 | compilerKind: ghc 33 | compilerVersion: 9.10.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.8.2 37 | compilerKind: ghc 38 | compilerVersion: 9.8.2 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.6.5 42 | compilerKind: ghc 43 | compilerVersion: 9.6.5 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.4.8 47 | compilerKind: ghc 48 | compilerVersion: 9.4.8 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.2.8 52 | compilerKind: ghc 53 | compilerVersion: 9.2.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.0.2 57 | compilerKind: ghc 58 | compilerVersion: 9.0.2 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-8.10.7 62 | compilerKind: ghc 63 | compilerVersion: 8.10.7 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.8.4 67 | compilerKind: ghc 68 | compilerVersion: 8.8.4 69 | setup-method: hvr-ppa 70 | allow-failure: false 71 | - compiler: ghc-8.6.5 72 | compilerKind: ghc 73 | compilerVersion: 8.6.5 74 | setup-method: hvr-ppa 75 | allow-failure: false 76 | fail-fast: false 77 | steps: 78 | - name: apt 79 | run: | 80 | apt-get update 81 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 82 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 83 | mkdir -p "$HOME/.ghcup/bin" 84 | curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" 85 | chmod a+x "$HOME/.ghcup/bin/ghcup" 86 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 87 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 88 | else 89 | apt-add-repository -y 'ppa:hvr/ghc' 90 | apt-get update 91 | apt-get install -y "$HCNAME" 92 | mkdir -p "$HOME/.ghcup/bin" 93 | curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" 94 | chmod a+x "$HOME/.ghcup/bin/ghcup" 95 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 96 | fi 97 | env: 98 | HCKIND: ${{ matrix.compilerKind }} 99 | HCNAME: ${{ matrix.compiler }} 100 | HCVER: ${{ matrix.compilerVersion }} 101 | - name: Set PATH and environment variables 102 | run: | 103 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 104 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 105 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 106 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 107 | HCDIR=/opt/$HCKIND/$HCVER 108 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 109 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 110 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 111 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 112 | echo "HC=$HC" >> "$GITHUB_ENV" 113 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 114 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 115 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 116 | else 117 | HC=$HCDIR/bin/$HCKIND 118 | echo "HC=$HC" >> "$GITHUB_ENV" 119 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 120 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 121 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 122 | fi 123 | 124 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 125 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 126 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 127 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 128 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 129 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 130 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 131 | env: 132 | HCKIND: ${{ matrix.compilerKind }} 133 | HCNAME: ${{ matrix.compiler }} 134 | HCVER: ${{ matrix.compilerVersion }} 135 | - name: env 136 | run: | 137 | env 138 | - name: write cabal config 139 | run: | 140 | mkdir -p $CABAL_DIR 141 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 174 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 175 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 176 | rm -f cabal-plan.xz 177 | chmod a+x $HOME/.cabal/bin/cabal-plan 178 | cabal-plan --version 179 | - name: checkout 180 | uses: actions/checkout@v4 181 | with: 182 | path: source 183 | - name: initial cabal.project for sdist 184 | run: | 185 | touch cabal.project 186 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 187 | cat cabal.project 188 | - name: sdist 189 | run: | 190 | mkdir -p sdist 191 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 192 | - name: unpack 193 | run: | 194 | mkdir -p unpacked 195 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 196 | - name: generate cabal.project 197 | run: | 198 | PKGDIR_constraints="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/constraints-[0-9.]*')" 199 | echo "PKGDIR_constraints=${PKGDIR_constraints}" >> "$GITHUB_ENV" 200 | rm -f cabal.project cabal.project.local 201 | touch cabal.project 202 | touch cabal.project.local 203 | echo "packages: ${PKGDIR_constraints}" >> cabal.project 204 | echo "package constraints" >> cabal.project 205 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 206 | cat >> cabal.project <> cabal.project.local 209 | cat cabal.project 210 | cat cabal.project.local 211 | - name: dump install plan 212 | run: | 213 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 214 | cabal-plan 215 | - name: restore cache 216 | uses: actions/cache/restore@v4 217 | with: 218 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 219 | path: ~/.cabal/store 220 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 221 | - name: install dependencies 222 | run: | 223 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 224 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 225 | - name: build 226 | run: | 227 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 228 | - name: tests 229 | run: | 230 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 231 | - name: cabal check 232 | run: | 233 | cd ${PKGDIR_constraints} || false 234 | ${CABAL} -vnormal check 235 | - name: haddock 236 | run: | 237 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 238 | - name: save cache 239 | uses: actions/cache/save@v4 240 | if: always() 241 | with: 242 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 243 | path: ~/.cabal/store 244 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .git 3 | *.hs~ 4 | *.swp 5 | *.cabal~ 6 | dist-* 7 | cabal-dev 8 | *.o 9 | *.hi 10 | *.chi 11 | *.chs.h 12 | *.dyn_o 13 | *.dyn_hi 14 | .hpc 15 | .hsenv 16 | .cabal-sandbox/ 17 | cabal.sandbox.config 18 | *.prof 19 | *.aux 20 | *.hp 21 | *.eventlog 22 | .stack-work/ 23 | cabal.project.local 24 | cabal.project.local~ 25 | .HTF/ 26 | .ghc.environment.* 27 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: { name: Eta reduce } 2 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | 0.14.2 [2024.05.12] 2 | ------------------- 3 | * Re-export `Log2` from `Data.Constraint.Nat`. 4 | * Add `log2Nat` and `log2Pow` to `Data.Constraint.Nat`. 5 | 6 | 0.14.1 [2024.04.29] 7 | ------------------- 8 | * Remove an unused dependency on the `type-equality` library. 9 | 10 | 0.14 [2023.10.11] 11 | ----------------- 12 | * Drop support for GHCs older than 8.6. 13 | * The `forall` function in `Data.Constraint.Forall` has been renamed to 14 | `forall_`, since a future version of GHC will make the use of `forall` as 15 | an identifier an error. 16 | * Implement `Data.Constraint.Forall` using `QuantifiedConstraints`. 17 | * Remove `Lifting` instances for `ErrorT` and `ListT`, which were removed 18 | in `transformers-0.6.*`. 19 | * Add a `c => Boring (Dict c)` instance. 20 | * Add the `Data.Constraint.Char` module, which contains utilities for working 21 | with `KnownChar` constraints. This module is only available on GHC 9.2 or 22 | later. 23 | * Add `unsafeAxiom` to `Data.Constraint.Unsafe`. 24 | * Add `unsafeSChar`, `unsafeSNat`, and `unsafeSSymbol` to 25 | `Data.Constraint.Unsafe` when building with `base-4.18` (GHC 9.6) or later. 26 | 27 | 0.13.4 [2022.05.19] 28 | ------------------- 29 | * Correct the CPP introduced in `constraints-0.13.3` such that it works when 30 | building with `mtl-2.3.*` or later combined with `transformers < 0.6`. 31 | 32 | 0.13.3 [2022.01.31] 33 | ------------------- 34 | * Allow building with `transformers-0.6.*` and `mtl-2.3.*`. 35 | 36 | 0.13.2 [2021.11.10] 37 | ------------------- 38 | * Allow building on GHC HEAD. 39 | 40 | 0.13.1 [2021.10.31] 41 | ------------------- 42 | * Allow building with GHC 9.2. 43 | 44 | 0.13 [2021.02.17] 45 | ----------------- 46 | * `Data.Constraint.Symbol` now reexports the `GHC.TypeLits.AppendSymbol` type 47 | family from recent versions of `base` (or, on old versions of `base`, it 48 | defines a backwards-compatibile version of `AppendSymbol`). The existing 49 | `(++)` type family for `Data.Constraint.Symbol` is now a synonym for 50 | `AppendSymbol`. 51 | 52 | This is technically a breaking change, as `(++)` was previously defined like 53 | so: 54 | 55 | ```hs 56 | type family (++) :: Symbol -> Symbol -> Symbol 57 | ``` 58 | 59 | This meant that `(++)` could be partially applied. However, for compatibility 60 | with the way that `AppendSymbol` is defined, `(++)` is now defined like so: 61 | 62 | ```hs 63 | type m ++ n = AppendSymbol m n 64 | ``` 65 | 66 | As a result, `(++)` can no longer be partially applied. 67 | * Make the `(++)` type family in `Data.Constraint.Symbol` be `infixr 5`. 68 | * Add `implied :: (a => b) -> (a :- b)` to `Data.Constraint`, which converts 69 | a quantified constraint into an entailment. This is only available when 70 | compiled with GHC 8.6 or later. 71 | 72 | 0.12 [2020.02.03] 73 | ----------------- 74 | * Relax the type signature for `divideTimes`: 75 | 76 | ```diff 77 | -dividesTimes :: (Divides a b, Divides a c) :- Divides a (b * c) 78 | +dividesTimes :: Divides a b :- Divides a (b * c) 79 | ``` 80 | 81 | * Simplify the type signature of `dividesDef`: 82 | 83 | ```diff 84 | -dividesDef :: forall a b. Divides a b :- ((a * Div b a) ~ b) 85 | +dividesDef :: forall a b. Divides a b :- (Mod b a ~ 0) 86 | ``` 87 | 88 | The original type of `diviesDef` can be (partially) recovered by defining 89 | it in terms of the new `dividesDef`: 90 | 91 | ```hs 92 | dividesDef' :: forall a b. (1 <= a, Divides a b) :- ((a * Div b a) ~ b) 93 | dividesDef' = Sub $ case (dividesDef @a @b, euclideanNat @a @b) of 94 | (Sub Dict, Sub Dict) -> Dict 95 | ``` 96 | 97 | 0.11.2 [2019.09.06] 98 | ------------------- 99 | * Depend on the `type-equality` compatibility library so that `(:~~:)` may be 100 | used when compiling this library with GHC 8.0. This avoids having to redefine 101 | `(:~~:)` directly in the internals of `constraints` itself. 102 | 103 | 0.11.1 [2019.08.27] 104 | ------------------- 105 | * Make `Data.Constraint.Deferrable.UnsatisfiedConstraint` a newtype. 106 | 107 | 0.11 [2019.05.10] 108 | ----------------- 109 | * Introduce a `HasDict` type class for types that witness evidence of 110 | constraints, such as `Dict`, `(:-)`, `Coercion`, `(:~:)`, `(:~~:)`, and 111 | `TypeRep`. 112 | * Generalize the types of `withDict` and `(\\)` to be polymorphic over 113 | any `HasDict` instance. 114 | * Add `type (⊢) = (:-)`. 115 | * Fix unsafe mistakes in the statements of `dividesDef` and `timesDiv` in 116 | `Data.Constraint.Nat`. 117 | * Make the implementations of `Min` and `Max` reduce on more inputs in 118 | `Data.Constraint.Nat`. 119 | * Add `minusNat` and `minusZero` functions to `Data.Constraint.Nat`. 120 | * Support `hashable-1.3.*` and `semigroups-0.19.*`. 121 | 122 | 0.10.1 [2018.07.02] 123 | ------------------- 124 | * Allow building with GHC 8.6. 125 | * Add three axioms about `(+)` and `(-)` to `Data.Constraint.Nat`. 126 | 127 | 0.10 128 | ---- 129 | * Adapt to the `Semigroup`–`Monoid` Proposal (introduced in `base-4.11`): 130 | * Add a `Semigroup` instance for `Dict` 131 | * Add the appropriate `(:=>)` instances involving `Semigroup`, and change the 132 | `Class () (Monoid a)` instance to `Class (Semigroup a) (Monoid a)` when 133 | `base` is recent enough 134 | * Add the appropriate `Lifting(2)` instances involving `Semigroup` 135 | * `Data.Constraint.Nat` now reexports the `Div` and `Mod` type families from 136 | `GHC.TypeLits` on `base-4.11` or later 137 | * Fix the type signature of `maxCommutes` 138 | * Export the `no` method of `Bottom` 139 | * Add `NFData` instances for `Dict` and `(:-)` 140 | 141 | 0.9.1 142 | ----- 143 | * Correct an improper use of `unsafeCoerce` in the internals of 144 | `Data.Constraint.Nat` and `Data.Constraint.Symbol` 145 | * Correctly identify the mismatched types when you defer an unsatisfiable 146 | equality constraint through `Data.Constraint.Deferrable` 147 | * Re-export the `(:~~:)` defined in `base` from `Data.Constraint.Deferred` with 148 | GHC 8.2 or later 149 | * Add several new `(:=>)` instances for `Bits`, `Identity`, `Const`, `Natural`, 150 | `IO`, and `Word`. 151 | * Modernize some existing `Class` and `(:=>)` instances to reflect the fact 152 | that `Applicative` is now a superclass of `Monad` on recent versions of 153 | `base`. 154 | 155 | 0.9 156 | --- 157 | * Changes to `Data.Constraint`: 158 | * Add `strengthen1` and `strengthen2` 159 | * Changes to `Data.Constraint.Deferrable`: 160 | * Add a `Deferrable ()` instance 161 | * The `Deferrable (a ~ b)` instance now shows the `TypeRep`s of `a` and `b` 162 | when a type mismatch error is thrown 163 | * Add `defer_` and `deferEither_`, counterparts to `defer` and `deferEither` 164 | which do not require proxy arguments 165 | * Enable `PolyKinds`. This allows the `Deferrable (a ~ b)` instance to be 166 | polykinded on all supported versions of GHC _except_ 7.10, where the kinds 167 | must be `*` due to an old GHC bug 168 | * Introduce a heterogeneous equality type `(:~~:)`, and use it to define a 169 | `Deferrable (a ~~ b)` instance on GHC 8.0 or later 170 | * Changes to `Data.Constraint.Forall`: 171 | * Implement `ForallF` and `ForallT` in terms of `Forall` 172 | * Add `ForallV` and `InstV` (supporting a variable number of parameters) 173 | * Add a `forall` combinator 174 | * Introduce `Data.Constraint.Nat` and `Data.Constraint.Symbol`, which contain 175 | utilities for working with `KnownNat` and `KnownSymbol` constraints, 176 | respectively. These modules are only available on GHC 8.0 or later. 177 | 178 | 0.8 179 | ----- 180 | * GHC 8 compatibility 181 | * `transformers` 0.5 compatibility 182 | * `binary` 0.8 compatibility 183 | * Dropped support for GHC 7.6 in favor of a nicer Bottom representation. 184 | 185 | 0.7 186 | --- 187 | * Found a nicer encoding of the initial object in the category of constraints using a [nullary constraint](https://ghc.haskell.org/trac/ghc/ticket/7642). 188 | 189 | 0.6.1 190 | ----- 191 | * Remove the need for closed type families from the new `Forall`. 192 | 193 | 0.6 194 | --- 195 | * Completely redesigned `Data.Constraint.Forall`. The old design is unsound and can be abused to define `unsafeCoerce`! 196 | The new design requires closed type families, so this module now requires GHC 7.8+ 197 | 198 | 0.5.1 199 | ----- 200 | * Added `Data.Constraint.Deferrable`. 201 | 202 | 0.5 203 | ----- 204 | * Added `Data.Constraint.Lifting`. 205 | 206 | 0.4.1.3 207 | ------- 208 | * Acknowledge we actually need at least base 4.5 209 | 210 | 0.4.1.2 211 | ------- 212 | * Restore support for building on older GHCs 213 | 214 | 0.4.1.1 215 | ------- 216 | * Minor documentation fixes. 217 | 218 | 0.4.1 219 | ----- 220 | * Added `mapDict` and `unmapDict`. 221 | * Added a lot of documentation. 222 | 223 | 0.4 224 | --- 225 | * `Typeable` and `Data`. The `Data` instance for `(:-)` is a conservative approximation that avoids having to turn (:-) into a cartesian closed category. 226 | If it becomes a pain point for users, I know how to do that, and have done so in other libraries -- see [hask](http://github.com/ekmett/hask), but I'm hesitant to bring such heavy machinery to bear and it isn't clear how to do it in a way that is compatible with those other libraries. 227 | 228 | 0.3.5 229 | ----- 230 | * Explicit role annotations 231 | 232 | 0.3.4.1 233 | ------- 234 | * Fixed build failures. 235 | * Fixed an unused import warning on older GHCs. 236 | 237 | 0.3.4 238 | ----- 239 | * Added `bottom` 240 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2011-2015 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | constraints 2 | =========== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/constraints.svg)](https://hackage.haskell.org/package/constraints) [![Build Status](https://github.com/ekmett/constraints/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/constraints/actions?query=workflow%3AHaskell-CI) 5 | 6 | This package provides data types and classes for manipulating the 'ConstraintKinds' exposed by GHC in 7.4. 7 | 8 | Contact Information 9 | ------------------- 10 | 11 | Contributions and bug reports are welcome! 12 | 13 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 14 | 15 | -Edward Kmett 16 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: focal 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | -- irc-channels: irc.freenode.org#haskell-lens 5 | irc-if-in-origin-repo: True 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /constraints.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: constraints 3 | category: Constraints 4 | version: 0.14.2 5 | license: BSD-2-Clause 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: experimental 10 | homepage: http://github.com/ekmett/constraints/ 11 | bug-reports: http://github.com/ekmett/constraints/issues 12 | copyright: Copyright (C) 2011-2021 Edward A. Kmett 13 | synopsis: Constraint manipulation 14 | description: 15 | GHC 7.4 gave us the ability to talk about @ConstraintKinds@. They stopped crashing the compiler in GHC 7.6. 16 | . 17 | This package provides a vocabulary for working with them. 18 | 19 | build-type: Simple 20 | 21 | tested-with: 22 | GHC == 9.10.1 23 | GHC == 9.8.2 24 | GHC == 9.6.5 25 | GHC == 9.4.8 26 | GHC == 9.2.8 27 | GHC == 9.0.2 28 | GHC == 8.10.7 29 | GHC == 8.8.4 30 | GHC == 8.6.5 31 | 32 | extra-source-files: README.markdown 33 | , CHANGELOG.markdown 34 | 35 | source-repository head 36 | type: git 37 | location: https://github.com/ekmett/constraints.git 38 | 39 | library 40 | hs-source-dirs: src 41 | 42 | default-language: Haskell2010 43 | other-extensions: 44 | FunctionalDependencies, 45 | ScopedTypeVariables, 46 | StandaloneDeriving, 47 | FlexibleInstances, 48 | FlexibleContexts, 49 | ConstraintKinds, 50 | KindSignatures, 51 | TypeOperators, 52 | Rank2Types, 53 | GADTs 54 | 55 | build-depends: 56 | , base >= 4.12 && < 5 57 | , binary >= 0.7.1 && < 0.9 58 | , boring >= 0.2 && < 0.3 59 | , deepseq >= 1.3 && < 1.6 60 | , ghc-prim 61 | , hashable >= 1.2 && < 1.6 62 | , mtl >= 2.2 && < 2.4 63 | , transformers >= 0.5 && < 0.7 64 | if !impl(ghc >= 9.0) 65 | build-depends: 66 | integer-gmp 67 | 68 | exposed-modules: 69 | Data.Constraint 70 | Data.Constraint.Deferrable 71 | Data.Constraint.Forall 72 | Data.Constraint.Lifting 73 | Data.Constraint.Nat 74 | Data.Constraint.Symbol 75 | Data.Constraint.Unsafe 76 | 77 | if impl(ghc >= 9.2) 78 | exposed-modules: 79 | Data.Constraint.Char 80 | 81 | ghc-options: -Wall -Wno-star-is-type 82 | 83 | test-suite spec 84 | type: exitcode-stdio-1.0 85 | default-language: Haskell2010 86 | hs-source-dirs: tests 87 | main-is: Spec.hs 88 | other-modules: GH55Spec 89 | GH117Spec 90 | ghc-options: -Wall -threaded -rtsopts 91 | build-tool-depends: hspec-discover:hspec-discover >= 2 92 | build-depends: 93 | , base 94 | , constraints 95 | , hspec >= 2 96 | -------------------------------------------------------------------------------- /src/Data/Constraint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE QuantifiedConstraints #-} 12 | {-# LANGUAGE Rank2Types #-} 13 | {-# LANGUAGE RoleAnnotations #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE StandaloneDeriving #-} 16 | {-# LANGUAGE Trustworthy #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | {-# LANGUAGE TypeOperators #-} 19 | {-# LANGUAGE UndecidableInstances #-} 20 | {-# LANGUAGE UndecidableSuperClasses #-} 21 | {-# LANGUAGE UnicodeSyntax #-} 22 | 23 | -- | 24 | -- Copyright : (C) 2011-2015 Edward Kmett, 25 | -- License : BSD-style (see the file LICENSE) 26 | -- Maintainer : Edward Kmett 27 | -- Stability : experimental 28 | -- Portability : non-portable 29 | -- 30 | -- @ConstraintKinds@ made type classes into types of a new kind, @Constraint@. 31 | -- 32 | -- @ 33 | -- 'Eq' :: * -> 'Constraint' 34 | -- 'Ord' :: * -> 'Constraint' 35 | -- 'Monad' :: (* -> *) -> 'Constraint' 36 | -- @ 37 | -- 38 | -- The need for this extension was first publicized in the paper 39 | -- 40 | -- 41 | -- 42 | -- by Ralf Lämmel and Simon Peyton Jones in 2005, which shoehorned all the 43 | -- things they needed into a custom 'Sat' typeclass. 44 | -- 45 | -- With @ConstraintKinds@ we can put into code a lot of tools for manipulating 46 | -- these new types without such awkward workarounds. 47 | 48 | module Data.Constraint 49 | ( 50 | -- * The Kind of Constraints 51 | Constraint 52 | -- * Dictionary 53 | , Dict(Dict) 54 | , HasDict(..) 55 | , withDict 56 | , (\\) 57 | -- * Entailment 58 | , (:-)(Sub) 59 | , type (⊢) 60 | , type (|-) 61 | , type (&) 62 | , weaken1, weaken2, contract 63 | , strengthen1, strengthen2 64 | , (&&&), (***) 65 | , trans, refl 66 | , implied 67 | , Bottom(no) 68 | , top, bottom 69 | -- * Dict is fully faithful 70 | , mapDict 71 | , unmapDict 72 | -- * Reflection 73 | , Class(..) 74 | , (:=>)(..) 75 | ) where 76 | import Control.Applicative 77 | import Control.Category 78 | import Control.DeepSeq 79 | import Control.Monad 80 | import Data.Complex 81 | import Data.Ratio 82 | import Data.Data hiding (TypeRep) 83 | import qualified GHC.Exts as Exts (Any) 84 | import GHC.Exts (Constraint) 85 | import Data.Bits (Bits) 86 | import Data.Functor.Identity (Identity) 87 | import Numeric.Natural (Natural) 88 | import Data.Coerce (Coercible) 89 | import Data.Type.Coercion(Coercion(..)) 90 | import Data.Type.Equality (type (~~)) 91 | import qualified Data.Type.Equality as Hetero 92 | import Type.Reflection (TypeRep, typeRepKind, withTypeable) 93 | import Data.Boring (Boring (..)) 94 | 95 | -- | Values of type @'Dict' p@ capture a dictionary for a constraint of type @p@. 96 | -- 97 | -- e.g. 98 | -- 99 | -- @ 100 | -- 'Dict' :: 'Dict' ('Eq' 'Int') 101 | -- @ 102 | -- 103 | -- captures a dictionary that proves we have an: 104 | -- 105 | -- @ 106 | -- instance 'Eq' 'Int' 107 | -- @ 108 | -- 109 | -- Pattern matching on the 'Dict' constructor will bring this instance into scope. 110 | -- 111 | data Dict :: Constraint -> * where 112 | Dict :: a => Dict a 113 | 114 | deriving stock instance (Typeable p, p) => Data (Dict p) 115 | deriving stock instance Eq (Dict a) 116 | deriving stock instance Ord (Dict a) 117 | deriving stock instance Show (Dict a) 118 | 119 | instance c => Boring (Dict c) where 120 | boring = Dict 121 | 122 | {- 123 | instance (Typeable p, p) => Data (Dict p) where 124 | gfoldl _ z Dict = z Dict 125 | toConstr _ = dictConstr 126 | gunfold _ z c = case constrIndex c of 127 | 1 -> z Dict 128 | _ -> error "gunfold" 129 | dataTypeOf _ = dictDataType 130 | 131 | dictConstr :: Constr 132 | dictConstr = mkConstr dictDataType "Dict" [] Prefix 133 | 134 | dictDataType :: DataType 135 | dictDataType = mkDataType "Data.Constraint.Dict" [dictConstr] 136 | -} 137 | 138 | 139 | instance NFData (Dict c) where 140 | rnf Dict = () 141 | 142 | -- | Witnesses that a value of type @e@ contains evidence of the constraint @c@. 143 | -- 144 | -- Mainly intended to allow ('\\') to be overloaded, since it's a useful operator. 145 | class HasDict c e | e -> c where 146 | evidence :: e -> Dict c 147 | 148 | instance HasDict a (Dict a) where 149 | evidence = Prelude.id 150 | 151 | instance a => HasDict b (a :- b) where 152 | evidence (Sub x) = x 153 | 154 | instance HasDict (Coercible a b) (Coercion a b) where 155 | evidence Coercion = Dict 156 | 157 | instance HasDict (a ~ b) (a :~: b) where 158 | evidence Refl = Dict 159 | 160 | instance HasDict (a ~~ b) (a Hetero.:~~: b) where 161 | evidence Hetero.HRefl = Dict 162 | 163 | instance HasDict (Typeable k, Typeable a) (TypeRep (a :: k)) where 164 | evidence tr = withTypeable tr $ withTypeable (typeRepKind tr) Dict 165 | 166 | -- | From a 'Dict', takes a value in an environment where the instance 167 | -- witnessed by the 'Dict' is in scope, and evaluates it. 168 | -- 169 | -- Essentially a deconstruction of a 'Dict' into its continuation-style 170 | -- form. 171 | -- 172 | -- Can also be used to deconstruct an entailment, @a ':-' b@, using a context @a@. 173 | -- 174 | -- @ 175 | -- withDict :: 'Dict' c -> (c => r) -> r 176 | -- withDict :: a => (a ':-' c) -> (c => r) -> r 177 | -- @ 178 | withDict :: HasDict c e => e -> (c => r) -> r 179 | withDict d r = case evidence d of 180 | Dict -> r 181 | 182 | infixl 1 \\ -- required comment 183 | 184 | -- | Operator version of 'withDict', with the arguments flipped 185 | (\\) :: HasDict c e => (c => r) -> e -> r 186 | r \\ d = withDict d r 187 | 188 | infixr 9 :- 189 | infixr 9 ⊢ 190 | 191 | -- | Type entailment, as written with a single character. 192 | type (⊢) = (:-) 193 | 194 | -- | This is the type of entailment. 195 | -- 196 | -- @a ':-' b@ is read as @a@ \"entails\" @b@. 197 | -- 198 | -- With this we can actually build a category for 'Constraint' resolution. 199 | -- 200 | -- e.g. 201 | -- 202 | -- Because @'Eq' a@ is a superclass of @'Ord' a@, we can show that @'Ord' a@ 203 | -- entails @'Eq' a@. 204 | -- 205 | -- Because @instance 'Ord' a => 'Ord' [a]@ exists, we can show that @'Ord' a@ 206 | -- entails @'Ord' [a]@ as well. 207 | -- 208 | -- This relationship is captured in the ':-' entailment type here. 209 | -- 210 | -- Since @p ':-' p@ and entailment composes, ':-' forms the arrows of a 211 | -- 'Category' of constraints. However, 'Category' only became sufficiently 212 | -- general to support this instance in GHC 7.8, so prior to 7.8 this instance 213 | -- is unavailable. 214 | -- 215 | -- But due to the coherence of instance resolution in Haskell, this 'Category' 216 | -- has some very interesting properties. Notably, in the absence of 217 | -- @IncoherentInstances@, this category is \"thin\", which is to say that 218 | -- between any two objects (constraints) there is at most one distinguishable 219 | -- arrow. 220 | -- 221 | -- This means that for instance, even though there are two ways to derive 222 | -- @'Ord' a ':-' 'Eq' [a]@, the answers from these two paths _must_ by 223 | -- construction be equal. This is a property that Haskell offers that is 224 | -- pretty much unique in the space of languages with things they call \"type 225 | -- classes\". 226 | -- 227 | -- What are the two ways? 228 | -- 229 | -- Well, we can go from @'Ord' a ':-' 'Eq' a@ via the 230 | -- superclass relationship, and then from @'Eq' a ':-' 'Eq' [a]@ via the 231 | -- instance, or we can go from @'Ord' a ':-' 'Ord' [a]@ via the instance 232 | -- then from @'Ord' [a] ':-' 'Eq' [a]@ through the superclass relationship 233 | -- and this diagram by definition must \"commute\". 234 | -- 235 | -- Diagrammatically, 236 | -- 237 | -- > Ord a 238 | -- > ins / \ cls 239 | -- > v v 240 | -- > Ord [a] Eq a 241 | -- > cls \ / ins 242 | -- > v v 243 | -- > Eq [a] 244 | -- 245 | -- This safety net ensures that pretty much anything you can write with this 246 | -- library is sensible and can't break any assumptions on the behalf of 247 | -- library authors. 248 | newtype a :- b = Sub (a => Dict b) 249 | 250 | type role (:-) nominal nominal 251 | 252 | instance (Typeable p, Typeable q, p => q) => Data (p :- q) where 253 | gfoldl _ z d = z d 254 | gunfold _ z c = case constrIndex c of 255 | 1 -> z (Sub Dict) 256 | _ -> error "Data.Data.Data: Data.Constraint.:- constructor out of bounds" 257 | toConstr _ = subCon 258 | dataTypeOf _ = subTy 259 | 260 | subCon :: Constr 261 | subCon = mkConstr subTy "Sub Dict" [] Prefix 262 | {-# noinline subCon #-} 263 | subTy :: DataType 264 | subTy = mkDataType "Data.Constraint.:-" [subCon] 265 | {-# noinline subTy #-} 266 | 267 | -- | Possible since GHC 7.8, when 'Category' was made polykinded. 268 | instance Category (:-) where 269 | id = refl 270 | (.) = trans 271 | 272 | -- | Assumes 'IncoherentInstances' doesn't exist. 273 | instance Eq (a :- b) where 274 | _ == _ = True 275 | 276 | -- | Assumes 'IncoherentInstances' doesn't exist. 277 | instance Ord (a :- b) where 278 | compare _ _ = EQ 279 | 280 | instance Show (a :- b) where 281 | showsPrec d _ = showParen (d > 10) $ showString "Sub Dict" 282 | 283 | instance a => NFData (a :- b) where 284 | rnf (Sub Dict) = () 285 | 286 | -------------------------------------------------------------------------------- 287 | -- Constraints form a Category 288 | -------------------------------------------------------------------------------- 289 | 290 | -- | Transitivity of entailment 291 | -- 292 | -- If we view @(':-')@ as a Constraint-indexed category, then this is @('.')@ 293 | trans :: (b :- c) -> (a :- b) -> a :- c 294 | trans f g = Sub $ Dict \\ f \\ g 295 | 296 | -- | Reflexivity of entailment 297 | -- 298 | -- If we view @(':-')@ as a Constraint-indexed category, then this is 'id' 299 | refl :: a :- a 300 | refl = Sub Dict 301 | 302 | -------------------------------------------------------------------------------- 303 | -- QuantifiedConstraints 304 | -------------------------------------------------------------------------------- 305 | 306 | -- | Convert a quantified constraint into an entailment. 307 | implied :: forall a b. (a => b) => a :- b 308 | implied = Sub (Dict :: Dict b) 309 | 310 | -- | The internal hom for the category of constraints. 311 | -- 312 | -- This version can be passed around inside Dict, whereas (a => b) is impredicative 313 | -- 314 | -- @ 315 | -- foo :: Dict (Ord a => Eq a) 316 | -- foo = Dict 317 | -- @ 318 | -- 319 | -- fails to typecheck due to the lack of impredicative polymorphism, but 320 | -- 321 | -- @ 322 | -- foo :: Dict (Ord a |- Eq a) 323 | -- foo = Dict 324 | -- @ 325 | -- 326 | -- typechecks just fine. 327 | 328 | class (p => q) => p |- q 329 | instance (p => q) => p |- q 330 | 331 | 332 | -------------------------------------------------------------------------------- 333 | -- (,) is a Bifunctor 334 | -------------------------------------------------------------------------------- 335 | 336 | -- | due to the hack for the kind of @(,)@ in the current version of GHC we can't actually 337 | -- make instances for @(,) :: Constraint -> Constraint -> Constraint@, but we can define 338 | -- an equivalent type, that converts back and forth to @(,)@, and lets you hang instances. 339 | class (p,q) => p & q 340 | instance (p,q) => p & q 341 | 342 | -- | due to the hack for the kind of @(,)@ in the current version of GHC we can't actually 343 | -- make instances for @(,) :: Constraint -> Constraint -> Constraint@, but @(,)@ is a 344 | -- bifunctor on the category of constraints. This lets us map over both sides. 345 | (***) :: (a :- b) -> (c :- d) -> (a, c) :- (b, d) 346 | f *** g = Sub $ Dict \\ f \\ g 347 | 348 | -------------------------------------------------------------------------------- 349 | -- Constraints are Cartesian 350 | -------------------------------------------------------------------------------- 351 | 352 | -- | Weakening a constraint product 353 | -- 354 | -- The category of constraints is Cartesian. We can forget information. 355 | weaken1 :: (a, b) :- a 356 | weaken1 = Sub Dict 357 | 358 | -- | Weakening a constraint product 359 | -- 360 | -- The category of constraints is Cartesian. We can forget information. 361 | weaken2 :: (a, b) :- b 362 | weaken2 = Sub Dict 363 | 364 | strengthen1 :: Dict b -> a :- c -> a :- (b,c) 365 | strengthen1 d e = unmapDict (const d) &&& e 366 | 367 | strengthen2 :: Dict b -> a :- c -> a :- (c,b) 368 | strengthen2 d e = e &&& unmapDict (const d) 369 | 370 | -- | Contracting a constraint / diagonal morphism 371 | -- 372 | -- The category of constraints is Cartesian. We can reuse information. 373 | contract :: a :- (a, a) 374 | contract = Sub Dict 375 | 376 | -- | Constraint product 377 | -- 378 | -- > trans weaken1 (f &&& g) = f 379 | -- > trans weaken2 (f &&& g) = g 380 | (&&&) :: (a :- b) -> (a :- c) -> a :- (b, c) 381 | f &&& g = Sub $ Dict \\ f \\ g 382 | 383 | -------------------------------------------------------------------------------- 384 | -- Initial and terminal morphisms 385 | -------------------------------------------------------------------------------- 386 | 387 | -- | Every constraint implies truth 388 | -- 389 | -- These are the terminal arrows of the category, and @()@ is the terminal object. 390 | -- 391 | -- Given any constraint there is a unique entailment of the @()@ constraint from that constraint. 392 | top :: a :- () 393 | top = Sub Dict 394 | 395 | -- | 'Any' inhabits every kind, including 'Constraint' but is uninhabited, making it impossible to define an instance. 396 | class Exts.Any => Bottom where 397 | no :: a 398 | 399 | -- | 400 | -- This demonstrates the law of classical logic 401 | bottom :: Bottom :- a 402 | bottom = Sub no 403 | 404 | -------------------------------------------------------------------------------- 405 | -- Dict is fully faithful 406 | -------------------------------------------------------------------------------- 407 | 408 | -- | Apply an entailment to a dictionary. 409 | -- 410 | -- From a category theoretic perspective 'Dict' is a functor that maps from the category 411 | -- of constraints (with arrows in ':-') to the category Hask of Haskell data types. 412 | mapDict :: (a :- b) -> Dict a -> Dict b 413 | mapDict p Dict = case p of Sub q -> q 414 | 415 | -- | 416 | -- This functor is fully faithful, which is to say that given any function you can write 417 | -- @Dict a -> Dict b@ there also exists an entailment @a :- b@ in the category of constraints 418 | -- that you can build. 419 | unmapDict :: (Dict a -> Dict b) -> a :- b 420 | unmapDict f = Sub (f Dict) 421 | 422 | type role Dict nominal 423 | 424 | -------------------------------------------------------------------------------- 425 | -- Reflection 426 | -------------------------------------------------------------------------------- 427 | 428 | -- | Reify the relationship between a class and its superclass constraints as a class 429 | -- 430 | -- Given a definition such as 431 | -- 432 | -- @ 433 | -- class Foo a => Bar a 434 | -- @ 435 | -- 436 | -- you can capture the relationship between 'Bar a' and its superclass 'Foo a' with 437 | -- 438 | -- @ 439 | -- instance 'Class' (Foo a) (Bar a) where 'cls' = 'Sub' 'Dict' 440 | -- @ 441 | -- 442 | -- Now the user can use 'cls :: Bar a :- Foo a' 443 | class Class b h | h -> b where 444 | cls :: h :- b 445 | 446 | infixr 9 :=> 447 | -- | Reify the relationship between an instance head and its body as a class 448 | -- 449 | -- Given a definition such as 450 | -- 451 | -- @ 452 | -- instance Foo a => Foo [a] 453 | -- @ 454 | -- 455 | -- you can capture the relationship between the instance head and its body with 456 | -- 457 | -- @ 458 | -- instance Foo a ':=>' Foo [a] where 'ins' = 'Sub' 'Dict' 459 | -- @ 460 | class b :=> h | h -> b where 461 | ins :: b :- h 462 | 463 | -- Bootstrapping 464 | 465 | instance Class () (Class b a) where cls = Sub Dict 466 | instance Class () (b :=> a) where cls = Sub Dict 467 | 468 | instance Class b a => () :=> Class b a where ins = Sub Dict 469 | instance (b :=> a) => () :=> (b :=> a) where ins = Sub Dict 470 | 471 | instance Class () () where cls = Sub Dict 472 | instance () :=> () where ins = Sub Dict 473 | 474 | -- Local, Prelude, Applicative, C.M.I and Data.Monoid instances 475 | 476 | -- Eq 477 | instance Class () (Eq a) where cls = Sub Dict 478 | instance () :=> Eq () where ins = Sub Dict 479 | instance () :=> Eq Int where ins = Sub Dict 480 | instance () :=> Eq Bool where ins = Sub Dict 481 | instance () :=> Eq Integer where ins = Sub Dict 482 | instance () :=> Eq Float where ins = Sub Dict 483 | instance () :=> Eq Double where ins = Sub Dict 484 | instance Eq a :=> Eq [a] where ins = Sub Dict 485 | instance Eq a :=> Eq (Maybe a) where ins = Sub Dict 486 | instance Eq a :=> Eq (Complex a) where ins = Sub Dict 487 | instance Eq a :=> Eq (Ratio a) where ins = Sub Dict 488 | instance (Eq a, Eq b) :=> Eq (a, b) where ins = Sub Dict 489 | instance (Eq a, Eq b) :=> Eq (Either a b) where ins = Sub Dict 490 | instance () :=> Eq (Dict a) where ins = Sub Dict 491 | instance () :=> Eq (a :- b) where ins = Sub Dict 492 | instance () :=> Eq Word where ins = Sub Dict 493 | instance Eq a :=> Eq (Identity a) where ins = Sub Dict 494 | instance Eq a :=> Eq (Const a b) where ins = Sub Dict 495 | instance () :=> Eq Natural where ins = Sub Dict 496 | 497 | -- Ord 498 | instance Class (Eq a) (Ord a) where cls = Sub Dict 499 | instance () :=> Ord () where ins = Sub Dict 500 | instance () :=> Ord Bool where ins = Sub Dict 501 | instance () :=> Ord Int where ins = Sub Dict 502 | instance ():=> Ord Integer where ins = Sub Dict 503 | instance () :=> Ord Float where ins = Sub Dict 504 | instance ():=> Ord Double where ins = Sub Dict 505 | instance () :=> Ord Char where ins = Sub Dict 506 | instance Ord a :=> Ord (Maybe a) where ins = Sub Dict 507 | instance Ord a :=> Ord [a] where ins = Sub Dict 508 | instance (Ord a, Ord b) :=> Ord (a, b) where ins = Sub Dict 509 | instance (Ord a, Ord b) :=> Ord (Either a b) where ins = Sub Dict 510 | instance Integral a :=> Ord (Ratio a) where ins = Sub Dict 511 | instance () :=> Ord (Dict a) where ins = Sub Dict 512 | instance () :=> Ord (a :- b) where ins = Sub Dict 513 | instance () :=> Ord Word where ins = Sub Dict 514 | instance Ord a :=> Ord (Identity a) where ins = Sub Dict 515 | instance Ord a :=> Ord (Const a b) where ins = Sub Dict 516 | instance () :=> Ord Natural where ins = Sub Dict 517 | 518 | -- Show 519 | instance Class () (Show a) where cls = Sub Dict 520 | instance () :=> Show () where ins = Sub Dict 521 | instance () :=> Show Bool where ins = Sub Dict 522 | instance () :=> Show Ordering where ins = Sub Dict 523 | instance () :=> Show Char where ins = Sub Dict 524 | instance () :=> Show Int where ins = Sub Dict 525 | instance Show a :=> Show (Complex a) where ins = Sub Dict 526 | instance Show a :=> Show [a] where ins = Sub Dict 527 | instance Show a :=> Show (Maybe a) where ins = Sub Dict 528 | instance (Show a, Show b) :=> Show (a, b) where ins = Sub Dict 529 | instance (Show a, Show b) :=> Show (Either a b) where ins = Sub Dict 530 | instance (Integral a, Show a) :=> Show (Ratio a) where ins = Sub Dict 531 | instance () :=> Show (Dict a) where ins = Sub Dict 532 | instance () :=> Show (a :- b) where ins = Sub Dict 533 | instance () :=> Show Word where ins = Sub Dict 534 | instance Show a :=> Show (Identity a) where ins = Sub Dict 535 | instance Show a :=> Show (Const a b) where ins = Sub Dict 536 | instance () :=> Show Natural where ins = Sub Dict 537 | 538 | -- Read 539 | instance Class () (Read a) where cls = Sub Dict 540 | instance () :=> Read () where ins = Sub Dict 541 | instance () :=> Read Bool where ins = Sub Dict 542 | instance () :=> Read Ordering where ins = Sub Dict 543 | instance () :=> Read Char where ins = Sub Dict 544 | instance () :=> Read Int where ins = Sub Dict 545 | instance Read a :=> Read (Complex a) where ins = Sub Dict 546 | instance Read a :=> Read [a] where ins = Sub Dict 547 | instance Read a :=> Read (Maybe a) where ins = Sub Dict 548 | instance (Read a, Read b) :=> Read (a, b) where ins = Sub Dict 549 | instance (Read a, Read b) :=> Read (Either a b) where ins = Sub Dict 550 | instance (Integral a, Read a) :=> Read (Ratio a) where ins = Sub Dict 551 | instance () :=> Read Word where ins = Sub Dict 552 | instance Read a :=> Read (Identity a) where ins = Sub Dict 553 | instance Read a :=> Read (Const a b) where ins = Sub Dict 554 | instance () :=> Read Natural where ins = Sub Dict 555 | 556 | -- Enum 557 | instance Class () (Enum a) where cls = Sub Dict 558 | instance () :=> Enum () where ins = Sub Dict 559 | instance () :=> Enum Bool where ins = Sub Dict 560 | instance () :=> Enum Ordering where ins = Sub Dict 561 | instance () :=> Enum Char where ins = Sub Dict 562 | instance () :=> Enum Int where ins = Sub Dict 563 | instance () :=> Enum Integer where ins = Sub Dict 564 | instance () :=> Enum Float where ins = Sub Dict 565 | instance () :=> Enum Double where ins = Sub Dict 566 | instance Integral a :=> Enum (Ratio a) where ins = Sub Dict 567 | instance () :=> Enum Word where ins = Sub Dict 568 | instance Enum a :=> Enum (Identity a) where ins = Sub Dict 569 | instance Enum a :=> Enum (Const a b) where ins = Sub Dict 570 | instance () :=> Enum Natural where ins = Sub Dict 571 | 572 | -- Bounded 573 | instance Class () (Bounded a) where cls = Sub Dict 574 | instance () :=> Bounded () where ins = Sub Dict 575 | instance () :=> Bounded Ordering where ins = Sub Dict 576 | instance () :=> Bounded Bool where ins = Sub Dict 577 | instance () :=> Bounded Int where ins = Sub Dict 578 | instance () :=> Bounded Char where ins = Sub Dict 579 | instance (Bounded a, Bounded b) :=> Bounded (a,b) where ins = Sub Dict 580 | instance () :=> Bounded Word where ins = Sub Dict 581 | instance Bounded a :=> Bounded (Identity a) where ins = Sub Dict 582 | instance Bounded a :=> Bounded (Const a b) where ins = Sub Dict 583 | 584 | -- Num 585 | instance Class () (Num a) where cls = Sub Dict 586 | instance () :=> Num Int where ins = Sub Dict 587 | instance () :=> Num Integer where ins = Sub Dict 588 | instance () :=> Num Float where ins = Sub Dict 589 | instance () :=> Num Double where ins = Sub Dict 590 | instance RealFloat a :=> Num (Complex a) where ins = Sub Dict 591 | instance Integral a :=> Num (Ratio a) where ins = Sub Dict 592 | instance () :=> Num Word where ins = Sub Dict 593 | instance Num a :=> Num (Identity a) where ins = Sub Dict 594 | instance Num a :=> Num (Const a b) where ins = Sub Dict 595 | instance () :=> Num Natural where ins = Sub Dict 596 | 597 | -- Real 598 | instance Class (Num a, Ord a) (Real a) where cls = Sub Dict 599 | instance () :=> Real Int where ins = Sub Dict 600 | instance () :=> Real Integer where ins = Sub Dict 601 | instance () :=> Real Float where ins = Sub Dict 602 | instance () :=> Real Double where ins = Sub Dict 603 | instance Integral a :=> Real (Ratio a) where ins = Sub Dict 604 | instance () :=> Real Word where ins = Sub Dict 605 | instance Real a :=> Real (Identity a) where ins = Sub Dict 606 | instance Real a :=> Real (Const a b) where ins = Sub Dict 607 | instance () :=> Real Natural where ins = Sub Dict 608 | 609 | -- Integral 610 | instance Class (Real a, Enum a) (Integral a) where cls = Sub Dict 611 | instance () :=> Integral Int where ins = Sub Dict 612 | instance () :=> Integral Integer where ins = Sub Dict 613 | instance () :=> Integral Word where ins = Sub Dict 614 | instance Integral a :=> Integral (Identity a) where ins = Sub Dict 615 | instance Integral a :=> Integral (Const a b) where ins = Sub Dict 616 | instance () :=> Integral Natural where ins = Sub Dict 617 | 618 | -- Bits 619 | instance Class (Eq a) (Bits a) where cls = Sub Dict 620 | instance () :=> Bits Bool where ins = Sub Dict 621 | instance () :=> Bits Int where ins = Sub Dict 622 | instance () :=> Bits Integer where ins = Sub Dict 623 | instance () :=> Bits Word where ins = Sub Dict 624 | instance Bits a :=> Bits (Identity a) where ins = Sub Dict 625 | instance Bits a :=> Bits (Const a b) where ins = Sub Dict 626 | instance () :=> Bits Natural where ins = Sub Dict 627 | 628 | -- Fractional 629 | instance Class (Num a) (Fractional a) where cls = Sub Dict 630 | instance () :=> Fractional Float where ins = Sub Dict 631 | instance () :=> Fractional Double where ins = Sub Dict 632 | instance RealFloat a :=> Fractional (Complex a) where ins = Sub Dict 633 | instance Integral a :=> Fractional (Ratio a) where ins = Sub Dict 634 | instance Fractional a :=> Fractional (Identity a) where ins = Sub Dict 635 | instance Fractional a :=> Fractional (Const a b) where ins = Sub Dict 636 | 637 | -- Floating 638 | instance Class (Fractional a) (Floating a) where cls = Sub Dict 639 | instance () :=> Floating Float where ins = Sub Dict 640 | instance () :=> Floating Double where ins = Sub Dict 641 | instance RealFloat a :=> Floating (Complex a) where ins = Sub Dict 642 | instance Floating a :=> Floating (Identity a) where ins = Sub Dict 643 | instance Floating a :=> Floating (Const a b) where ins = Sub Dict 644 | 645 | -- RealFrac 646 | instance Class (Real a, Fractional a) (RealFrac a) where cls = Sub Dict 647 | instance () :=> RealFrac Float where ins = Sub Dict 648 | instance () :=> RealFrac Double where ins = Sub Dict 649 | instance Integral a :=> RealFrac (Ratio a) where ins = Sub Dict 650 | instance RealFrac a :=> RealFrac (Identity a) where ins = Sub Dict 651 | instance RealFrac a :=> RealFrac (Const a b) where ins = Sub Dict 652 | 653 | -- RealFloat 654 | instance Class (RealFrac a, Floating a) (RealFloat a) where cls = Sub Dict 655 | instance () :=> RealFloat Float where ins = Sub Dict 656 | instance () :=> RealFloat Double where ins = Sub Dict 657 | instance RealFloat a :=> RealFloat (Identity a) where ins = Sub Dict 658 | instance RealFloat a :=> RealFloat (Const a b) where ins = Sub Dict 659 | 660 | -- Semigroup 661 | instance Class () (Semigroup a) where cls = Sub Dict 662 | instance () :=> Semigroup () where ins = Sub Dict 663 | instance () :=> Semigroup Ordering where ins = Sub Dict 664 | instance () :=> Semigroup [a] where ins = Sub Dict 665 | instance Semigroup a :=> Semigroup (Maybe a) where ins = Sub Dict 666 | instance (Semigroup a, Semigroup b) :=> Semigroup (a, b) where ins = Sub Dict 667 | instance Semigroup a :=> Semigroup (Const a b) where ins = Sub Dict 668 | instance Semigroup a :=> Semigroup (Identity a) where ins = Sub Dict 669 | instance Semigroup a :=> Semigroup (IO a) where ins = Sub Dict 670 | 671 | -- Monoid 672 | instance Class (Semigroup a) (Monoid a) where cls = Sub Dict 673 | instance () :=> Monoid () where ins = Sub Dict 674 | instance () :=> Monoid Ordering where ins = Sub Dict 675 | instance () :=> Monoid [a] where ins = Sub Dict 676 | instance Monoid a :=> Monoid (Maybe a) where ins = Sub Dict 677 | instance (Monoid a, Monoid b) :=> Monoid (a, b) where ins = Sub Dict 678 | instance Monoid a :=> Monoid (Const a b) where ins = Sub Dict 679 | instance Monoid a :=> Monoid (Identity a) where ins = Sub Dict 680 | instance Monoid a :=> Monoid (IO a) where ins = Sub Dict 681 | 682 | -- Functor 683 | instance Class () (Functor f) where cls = Sub Dict 684 | instance () :=> Functor [] where ins = Sub Dict 685 | instance () :=> Functor Maybe where ins = Sub Dict 686 | instance () :=> Functor (Either a) where ins = Sub Dict 687 | instance () :=> Functor ((->) a) where ins = Sub Dict 688 | instance () :=> Functor ((,) a) where ins = Sub Dict 689 | instance () :=> Functor IO where ins = Sub Dict 690 | instance Monad m :=> Functor (WrappedMonad m) where ins = Sub Dict 691 | instance () :=> Functor Identity where ins = Sub Dict 692 | instance () :=> Functor (Const a) where ins = Sub Dict 693 | 694 | -- Applicative 695 | instance Class (Functor f) (Applicative f) where cls = Sub Dict 696 | instance () :=> Applicative [] where ins = Sub Dict 697 | instance () :=> Applicative Maybe where ins = Sub Dict 698 | instance () :=> Applicative (Either a) where ins = Sub Dict 699 | instance () :=> Applicative ((->)a) where ins = Sub Dict 700 | instance () :=> Applicative IO where ins = Sub Dict 701 | instance Monoid a :=> Applicative ((,)a) where ins = Sub Dict 702 | instance Monoid a :=> Applicative (Const a) where ins = Sub Dict 703 | instance Monad m :=> Applicative (WrappedMonad m) where ins = Sub Dict 704 | 705 | -- Alternative 706 | instance Class (Applicative f) (Alternative f) where cls = Sub Dict 707 | instance () :=> Alternative [] where ins = Sub Dict 708 | instance () :=> Alternative Maybe where ins = Sub Dict 709 | instance MonadPlus m :=> Alternative (WrappedMonad m) where ins = Sub Dict 710 | 711 | -- Monad 712 | instance Class (Applicative f) (Monad f) where cls = Sub Dict 713 | instance () :=> Monad [] where ins = Sub Dict 714 | instance () :=> Monad ((->) a) where ins = Sub Dict 715 | instance () :=> Monad (Either a) where ins = Sub Dict 716 | instance () :=> Monad IO where ins = Sub Dict 717 | instance () :=> Monad Identity where ins = Sub Dict 718 | 719 | -- MonadPlus 720 | instance Class (Monad f, Alternative f) (MonadPlus f) where cls = Sub Dict 721 | instance () :=> MonadPlus [] where ins = Sub Dict 722 | instance () :=> MonadPlus Maybe where ins = Sub Dict 723 | 724 | -------------------------------------------------------------------------------- 725 | -- UndecidableInstances 726 | -------------------------------------------------------------------------------- 727 | 728 | instance a :=> Enum (Dict a) where ins = Sub Dict 729 | instance a => Enum (Dict a) where 730 | toEnum _ = Dict 731 | fromEnum Dict = 0 732 | 733 | instance a :=> Bounded (Dict a) where ins = Sub Dict 734 | instance a => Bounded (Dict a) where 735 | minBound = Dict 736 | maxBound = Dict 737 | 738 | instance a :=> Read (Dict a) where ins = Sub Dict 739 | deriving instance a => Read (Dict a) 740 | 741 | instance () :=> Semigroup (Dict a) where ins = Sub Dict 742 | instance Semigroup (Dict a) where 743 | Dict <> Dict = Dict 744 | 745 | instance a :=> Monoid (Dict a) where ins = Sub Dict 746 | instance a => Monoid (Dict a) where 747 | mempty = Dict 748 | -------------------------------------------------------------------------------- /src/Data/Constraint/Char.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE AllowAmbiguousTypes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE CPP #-} 11 | -- | Utilities for working with 'KnownChar' constraints. 12 | -- 13 | -- This module is only available on GHC 9.2 or later. 14 | module Data.Constraint.Char 15 | ( CharToNat 16 | , NatToChar 17 | , charToNat 18 | , natToChar 19 | ) where 20 | 21 | import Data.Char 22 | import Data.Constraint 23 | import Data.Proxy 24 | import GHC.TypeLits 25 | #if MIN_VERSION_base(4,18,0) 26 | import Data.Constraint.Unsafe 27 | import qualified GHC.TypeNats as TN 28 | #else 29 | import Unsafe.Coerce 30 | #endif 31 | 32 | -- implementation details 33 | 34 | #if !MIN_VERSION_base(4,18,0) 35 | newtype Magic c = Magic (KnownChar c => Dict (KnownChar c)) 36 | #endif 37 | 38 | magicCN :: forall c n. (Char -> Int) -> KnownChar c :- KnownNat n 39 | #if MIN_VERSION_base(4,18,0) 40 | magicCN f = Sub $ TN.withKnownNat (unsafeSNat @n (fromIntegral (f (charVal (Proxy @c))))) Dict 41 | #else 42 | magicCN f = Sub $ unsafeCoerce (Magic Dict) (fromIntegral @Int @Natural (f (charVal (Proxy @c)))) 43 | #endif 44 | 45 | magicNC :: forall n c. (Int -> Char) -> KnownNat n :- KnownChar c 46 | #if MIN_VERSION_base(4,18,0) 47 | magicNC f = Sub $ withKnownChar (unsafeSChar @c (f (fromIntegral (natVal (Proxy @n))))) Dict 48 | #else 49 | magicNC f = Sub $ unsafeCoerce (Magic Dict) (f (fromIntegral (natVal (Proxy @n)))) 50 | #endif 51 | 52 | -- operations 53 | 54 | charToNat :: forall c. KnownChar c :- KnownNat (CharToNat c) 55 | charToNat = magicCN ord 56 | 57 | -- NB: 0x10FFFF the maximum value for a Unicode code point. Calling `chr` on 58 | -- anything greater will throw an exception. 59 | natToChar :: forall n. (n <= 0x10FFFF, KnownNat n) :- KnownChar (NatToChar n) 60 | natToChar = Sub $ case magicNC @n @(NatToChar n) chr of Sub r -> r 61 | -------------------------------------------------------------------------------- /src/Data/Constraint/Deferrable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | -- | 11 | -- Copyright : (C) 2015-2021 Edward Kmett 12 | -- License : BSD-style (see the file LICENSE) 13 | -- Maintainer : Edward Kmett 14 | -- Stability : experimental 15 | -- Portability : non-portable 16 | -- 17 | -- The idea for this trick comes from Dimitrios Vytiniotis. 18 | 19 | module Data.Constraint.Deferrable 20 | ( UnsatisfiedConstraint(..) 21 | , Deferrable(..) 22 | , defer 23 | , deferred 24 | , (:~~:)(HRefl) 25 | , (:~:)(Refl) 26 | ) where 27 | 28 | import Control.Exception 29 | import Control.Monad 30 | import Data.Constraint 31 | import Data.Proxy 32 | import Data.Typeable (Typeable, cast, typeRep) 33 | import Data.Type.Equality ((:~:)(Refl)) 34 | 35 | import GHC.Types (type (~~)) 36 | import Data.Type.Equality ((:~~:)(HRefl)) 37 | 38 | newtype UnsatisfiedConstraint = UnsatisfiedConstraint String 39 | deriving Show 40 | 41 | instance Exception UnsatisfiedConstraint 42 | 43 | -- | Allow an attempt at resolution of a constraint at a later time 44 | class Deferrable p where 45 | -- | Resolve a 'Deferrable' constraint with observable failure. 46 | deferEither :: (p => r) -> Either String r 47 | 48 | deferred :: forall p. Deferrable p :- p 49 | deferred = Sub $ defer @p Dict 50 | 51 | defer :: forall p r. Deferrable p => (p => r) -> r 52 | defer r = either (throw . UnsatisfiedConstraint) id $ deferEither @p r 53 | 54 | showTypeRep :: forall t. Typeable t => String 55 | showTypeRep = show $ typeRep (Proxy @t) 56 | 57 | instance Deferrable () where 58 | deferEither r = Right r 59 | 60 | -- | Deferrable homogeneous equality constraints. 61 | -- 62 | -- Note that due to a GHC bug (https://ghc.haskell.org/trac/ghc/ticket/10343), 63 | -- using this instance on GHC 7.10 will only work with @*@-kinded types. 64 | instance (Typeable k, Typeable (a :: k), Typeable b) => Deferrable (a ~ b) where 65 | deferEither r = case cast (Refl :: a :~: a) :: Maybe (a :~: b) of 66 | Just Refl -> Right r 67 | Nothing -> Left $ 68 | "deferred type equality: type mismatch between `" ++ showTypeRep @a ++ "’ and `" ++ showTypeRep @b ++ "'" 69 | 70 | -- | Deferrable heterogenous equality constraints. 71 | -- 72 | -- Only available on GHC 8.0 or later. 73 | instance (Typeable i, Typeable j, Typeable (a :: i), Typeable (b :: j)) => Deferrable (a ~~ b) where 74 | deferEither r = case cast (HRefl :: a :~~: a) :: Maybe (a :~~: b) of 75 | Just HRefl -> Right r 76 | Nothing -> Left $ 77 | "deferred type equality: type mismatch between `" ++ showTypeRep @a ++ "’ and `" ++ showTypeRep @b ++ "'" 78 | 79 | instance (Deferrable a, Deferrable b) => Deferrable (a, b) where 80 | deferEither r = join $ deferEither @a $ deferEither @b r 81 | 82 | instance (Deferrable a, Deferrable b, Deferrable c) => Deferrable (a, b, c) where 83 | deferEither r = join $ deferEither @a $ join $ deferEither @b $ deferEither @c r 84 | -------------------------------------------------------------------------------- /src/Data/Constraint/Forall.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE ConstraintKinds #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE UndecidableSuperClasses #-} 12 | {-# LANGUAGE Trustworthy #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | {-# LANGUAGE QuantifiedConstraints #-} 15 | {-# LANGUAGE GADTs #-} 16 | 17 | -- | 18 | -- Copyright : (C) 2011-2021 Edward Kmett, 19 | -- (C) 2015 Ørjan Johansen, 20 | -- (C) 2016 David Feuer 21 | -- License : BSD-style (see the file LICENSE) 22 | -- 23 | -- Maintainer : Edward Kmett 24 | -- Stability : experimental 25 | -- Portability : non-portable 26 | -- 27 | -- This module uses a trick to provide quantification over constraints. 28 | 29 | module Data.Constraint.Forall 30 | ( Forall, inst 31 | , ForallF, instF 32 | , Forall1, inst1 33 | , ForallT, instT 34 | , ForallV, InstV (instV) 35 | , forall_ 36 | ) where 37 | 38 | import Data.Constraint 39 | import Unsafe.Coerce (unsafeCoerce) 40 | 41 | class (forall a. p a) => Forall (p :: k -> Constraint) 42 | instance (forall a. p a) => Forall (p :: k -> Constraint) 43 | 44 | -- | Instantiate a quantified @'Forall' p@ constraint at type @a@. 45 | inst :: forall p a. Forall p :- p a 46 | inst = Sub Dict 47 | 48 | data Dict1 p where 49 | Dict1 :: (forall a. p a) => Dict1 p 50 | 51 | forallish :: forall p. Dict1 p -> Dict (Forall p) 52 | forallish Dict1 = Dict 53 | 54 | forall_ :: forall p. (forall a. Dict (p a)) -> Dict (Forall p) 55 | forall_ d = forallish (unsafeCoerce d) 56 | 57 | -- | Composition for constraints. 58 | class p (f a) => ComposeC (p :: k2 -> Constraint) (f :: k1 -> k2) (a :: k1) 59 | instance p (f a) => ComposeC p f a 60 | 61 | -- | A representation of the quantified constraint @forall a. p (f a)@. 62 | class Forall (ComposeC p f) => ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) 63 | instance Forall (ComposeC p f) => ForallF p f 64 | 65 | -- | Instantiate a quantified @'ForallF' p f@ constraint at type @a@. 66 | instF :: forall p f a . ForallF p f :- p (f a) 67 | instF = Sub $ 68 | case inst :: Forall (ComposeC p f) :- ComposeC p f a of 69 | Sub Dict -> Dict 70 | 71 | -- Classes building up to ForallT 72 | class p (t a b) => R (p :: k3 -> Constraint) (t :: k1 -> k2 -> k3) (a :: k1) (b :: k2) 73 | instance p (t a b) => R p t a b 74 | class Forall (R p t a) => Q (p :: k3 -> Constraint) (t :: k1 -> k2 -> k3) (a :: k1) 75 | instance Forall (R p t a) => Q p t a 76 | 77 | -- | A representation of the quantified constraint @forall f a. p (t f a)@. 78 | class Forall (Q p t) => ForallT (p :: k4 -> Constraint) (t :: (k1 -> k2) -> k3 -> k4) 79 | instance Forall (Q p t) => ForallT p t 80 | 81 | -- | Instantiate a quantified @'ForallT' p t@ constraint at types @f@ and @a@. 82 | instT :: forall k1 k2 k3 k4 (p :: k4 -> Constraint) (t :: (k1 -> k2) -> k3 -> k4) (f :: k1 -> k2) (a :: k3). ForallT p t :- p (t f a) 83 | instT = Sub $ 84 | case inst :: Forall (Q p t) :- Q p t f of { Sub Dict -> 85 | case inst :: Forall (R p t f) :- R p t f a of 86 | Sub Dict -> Dict } 87 | 88 | type Forall1 p = Forall p 89 | -- | Instantiate a quantified constraint on kind @* -> *@. 90 | -- This is now redundant since @'inst'@ became polykinded. 91 | inst1 :: forall (p :: (* -> *) -> Constraint) (f :: * -> *). Forall p :- p f 92 | inst1 = inst 93 | 94 | -- | A representation of the quantified constraint 95 | -- @forall a1 a2 ... an . p a1 a2 ... an@, supporting a variable number of 96 | -- parameters. 97 | type family ForallV :: k -> Constraint 98 | type instance ForallV = ForallV_ 99 | 100 | class ForallV' p => ForallV_ (p :: k) 101 | instance ForallV' p => ForallV_ p 102 | 103 | -- | Instantiate a quantified @'ForallV' p@ constraint as @c@, where 104 | -- @c ~ p a1 a2 ... an@. 105 | class InstV (p :: k) c | k c -> p where 106 | type ForallV' (p :: k) :: Constraint 107 | instV :: ForallV p :- c 108 | 109 | instance p ~ c => InstV (p :: Constraint) c where 110 | type ForallV' (p :: Constraint) = p 111 | instV = Sub Dict 112 | 113 | -- Treating 1 argument specially rather than recursing as a bit of (premature?) 114 | -- optimization 115 | instance p a ~ c => InstV (p :: k -> Constraint) c where 116 | type ForallV' (p :: k -> Constraint) = Forall p 117 | instV = Sub $ case inst :: Forall p :- c of 118 | Sub Dict -> Dict 119 | 120 | instance InstV (p a) c => InstV (p :: k1 -> k2 -> k3) c where 121 | type ForallV' (p :: k1 -> k2 -> k3) = ForallF ForallV p 122 | instV = Sub $ case instF :: ForallF ForallV p :- ForallV (p a) of 123 | Sub Dict -> case instV :: ForallV (p a) :- c of 124 | Sub Dict -> Dict 125 | 126 | -------------------------------------------------------------------------------- /src/Data/Constraint/Lifting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | 11 | module Data.Constraint.Lifting 12 | ( Lifting(..) 13 | , Lifting2(..) 14 | ) where 15 | 16 | import Control.Applicative 17 | import Control.Applicative.Backwards 18 | import Control.Applicative.Lift 19 | import Control.DeepSeq 20 | import Control.Monad 21 | import Control.Monad.Cont.Class 22 | import Control.Monad.Error.Class 23 | import Control.Monad.Fix 24 | import Control.Monad.IO.Class 25 | import Control.Monad.RWS.Class 26 | import Control.Monad.Trans.Cont 27 | import Control.Monad.Trans.Except 28 | import Control.Monad.Trans.Identity 29 | import Control.Monad.Trans.Maybe 30 | import Control.Monad.Trans.Reader 31 | import Control.Monad.Trans.RWS.Lazy as Lazy 32 | import Control.Monad.Trans.RWS.Strict as Strict 33 | import Control.Monad.Trans.State.Lazy as Lazy 34 | import Control.Monad.Trans.State.Strict as Strict 35 | import Control.Monad.Trans.Writer.Lazy as Lazy 36 | import Control.Monad.Trans.Writer.Strict as Strict 37 | import Data.Binary 38 | import Data.Complex 39 | import Data.Constraint 40 | import Data.Functor.Classes 41 | import Data.Functor.Compose as Functor 42 | import Data.Functor.Identity 43 | import Data.Functor.Product as Functor 44 | import Data.Functor.Reverse as Functor 45 | import Data.Functor.Sum as Functor 46 | import Data.Hashable 47 | import Data.Ratio 48 | import GHC.Arr 49 | 50 | class Lifting p f where 51 | lifting :: p a :- p (f a) 52 | 53 | instance Lifting Eq [] where lifting = Sub Dict 54 | instance Lifting Ord [] where lifting = Sub Dict 55 | instance Lifting Show [] where lifting = Sub Dict 56 | instance Lifting Read [] where lifting = Sub Dict 57 | instance Lifting Hashable [] where lifting = Sub Dict 58 | instance Lifting Binary [] where lifting = Sub Dict 59 | instance Lifting NFData [] where lifting = Sub Dict 60 | 61 | instance Lifting Eq Maybe where lifting = Sub Dict 62 | instance Lifting Ord Maybe where lifting = Sub Dict 63 | instance Lifting Show Maybe where lifting = Sub Dict 64 | instance Lifting Read Maybe where lifting = Sub Dict 65 | instance Lifting Hashable Maybe where lifting = Sub Dict 66 | instance Lifting Binary Maybe where lifting = Sub Dict 67 | instance Lifting NFData Maybe where lifting = Sub Dict 68 | instance Lifting Semigroup Maybe where lifting = Sub Dict 69 | instance Lifting Monoid Maybe where lifting = Sub Dict 70 | 71 | instance Lifting Eq Ratio where lifting = Sub Dict 72 | -- instance Lifting Show Ratio where lifting = Sub Dict -- requires 7.10 73 | 74 | instance Lifting Eq Complex where lifting = Sub Dict 75 | instance Lifting Read Complex where lifting = Sub Dict 76 | instance Lifting Show Complex where lifting = Sub Dict 77 | instance Lifting Semigroup ((->) a) where lifting = Sub Dict 78 | instance Lifting Monoid ((->) a) where lifting = Sub Dict 79 | 80 | instance Eq a => Lifting Eq (Either a) where lifting = Sub Dict 81 | instance Ord a => Lifting Ord (Either a) where lifting = Sub Dict 82 | instance Show a => Lifting Show (Either a) where lifting = Sub Dict 83 | instance Read a => Lifting Read (Either a) where lifting = Sub Dict 84 | instance Hashable a => Lifting Hashable (Either a) where lifting = Sub Dict 85 | instance Binary a => Lifting Binary (Either a) where lifting = Sub Dict 86 | instance NFData a => Lifting NFData (Either a) where lifting = Sub Dict 87 | 88 | instance Eq a => Lifting Eq ((,) a) where lifting = Sub Dict 89 | instance Ord a => Lifting Ord ((,) a) where lifting = Sub Dict 90 | instance Show a => Lifting Show ((,) a) where lifting = Sub Dict 91 | instance Read a => Lifting Read ((,) a) where lifting = Sub Dict 92 | instance Hashable a => Lifting Hashable ((,) a) where lifting = Sub Dict 93 | instance Binary a => Lifting Binary ((,) a) where lifting = Sub Dict 94 | instance NFData a => Lifting NFData ((,) a) where lifting = Sub Dict 95 | instance Semigroup a => Lifting Semigroup ((,) a) where lifting = Sub Dict 96 | instance Monoid a => Lifting Monoid ((,) a) where lifting = Sub Dict 97 | instance Bounded a => Lifting Bounded ((,) a) where lifting = Sub Dict 98 | instance Ix a => Lifting Ix ((,) a) where lifting = Sub Dict 99 | 100 | instance Functor f => Lifting Functor (Compose f) where lifting = Sub Dict 101 | instance Foldable f => Lifting Foldable (Compose f) where lifting = Sub Dict 102 | instance Traversable f => Lifting Traversable (Compose f) where lifting = Sub Dict 103 | instance Applicative f => Lifting Applicative (Compose f) where lifting = Sub Dict 104 | instance Alternative f => Lifting Alternative (Compose f) where lifting = Sub Dict -- overconstrained 105 | 106 | instance Show1 f => Lifting Show1 (Compose f) where lifting = Sub Dict 107 | instance Eq1 f => Lifting Eq1 (Compose f) where lifting = Sub Dict 108 | instance Ord1 f => Lifting Ord1 (Compose f) where lifting = Sub Dict 109 | instance Read1 f => Lifting Read1 (Compose f) where lifting = Sub Dict 110 | instance (Eq1 f, Eq1 g) => Lifting Eq (Compose f g) where lifting = Sub Dict 111 | instance (Ord1 f, Ord1 g) => Lifting Ord (Compose f g) where lifting = Sub Dict 112 | instance (Read1 f, Read1 g) => Lifting Read (Compose f g) where lifting = Sub Dict 113 | instance (Show1 f, Show1 g) => Lifting Show (Compose f g) where lifting = Sub Dict 114 | 115 | instance Functor f => Lifting Functor (Functor.Product f) where lifting = Sub Dict 116 | instance Foldable f => Lifting Foldable (Functor.Product f) where lifting = Sub Dict 117 | instance Traversable f => Lifting Traversable (Functor.Product f) where lifting = Sub Dict 118 | instance Applicative f => Lifting Applicative (Functor.Product f) where lifting = Sub Dict 119 | instance Alternative f => Lifting Alternative (Functor.Product f) where lifting = Sub Dict 120 | instance Monad f => Lifting Monad (Functor.Product f) where lifting = Sub Dict 121 | instance MonadFix f => Lifting MonadFix (Functor.Product f) where lifting = Sub Dict 122 | instance MonadPlus f => Lifting MonadPlus (Functor.Product f) where lifting = Sub Dict 123 | instance Show1 f => Lifting Show1 (Functor.Product f) where lifting = Sub Dict 124 | instance Eq1 f => Lifting Eq1 (Functor.Product f) where lifting = Sub Dict 125 | instance Ord1 f => Lifting Ord1 (Functor.Product f) where lifting = Sub Dict 126 | instance Read1 f => Lifting Read1 (Functor.Product f) where lifting = Sub Dict 127 | instance (Eq1 f, Eq1 g) => Lifting Eq (Functor.Product f g) where lifting = Sub Dict 128 | instance (Ord1 f, Ord1 g) => Lifting Ord (Functor.Product f g) where lifting = Sub Dict 129 | instance (Read1 f, Read1 g) => Lifting Read (Functor.Product f g) where lifting = Sub Dict 130 | instance (Show1 f, Show1 g) => Lifting Show (Functor.Product f g) where lifting = Sub Dict 131 | 132 | instance Functor f => Lifting Functor (Functor.Sum f) where lifting = Sub Dict 133 | instance Foldable f => Lifting Foldable (Functor.Sum f) where lifting = Sub Dict 134 | instance Traversable f => Lifting Traversable (Functor.Sum f) where lifting = Sub Dict 135 | instance Show1 f => Lifting Show1 (Functor.Sum f) where lifting = Sub Dict 136 | instance Eq1 f => Lifting Eq1 (Functor.Sum f) where lifting = Sub Dict 137 | instance Ord1 f => Lifting Ord1 (Functor.Sum f) where lifting = Sub Dict 138 | instance Read1 f => Lifting Read1 (Functor.Sum f) where lifting = Sub Dict 139 | instance (Eq1 f, Eq1 g) => Lifting Eq (Functor.Sum f g) where lifting = Sub Dict 140 | instance (Ord1 f, Ord1 g) => Lifting Ord (Functor.Sum f g) where lifting = Sub Dict 141 | instance (Read1 f, Read1 g) => Lifting Read (Functor.Sum f g) where lifting = Sub Dict 142 | instance (Show1 f, Show1 g) => Lifting Show (Functor.Sum f g) where lifting = Sub Dict 143 | 144 | instance Lifting Functor (Strict.StateT s) where lifting = Sub Dict 145 | instance Lifting Monad (Strict.StateT s) where lifting = Sub Dict 146 | instance Lifting MonadFix (Strict.StateT s) where lifting = Sub Dict 147 | instance Lifting MonadIO (Strict.StateT s) where lifting = Sub Dict 148 | instance Lifting MonadPlus (Strict.StateT s) where lifting = Sub Dict 149 | 150 | instance Lifting Functor (Lazy.StateT s) where lifting = Sub Dict 151 | instance Lifting Monad (Lazy.StateT s) where lifting = Sub Dict 152 | instance Lifting MonadFix (Lazy.StateT s) where lifting = Sub Dict 153 | instance Lifting MonadIO (Lazy.StateT s) where lifting = Sub Dict 154 | instance Lifting MonadPlus (Lazy.StateT s) where lifting = Sub Dict 155 | 156 | instance Lifting Functor (Lazy.RWST r w s) where lifting = Sub Dict 157 | instance Monoid w => Lifting Monad (Lazy.RWST r w s) where lifting = Sub Dict 158 | instance Monoid w => Lifting MonadFix (Lazy.RWST r w s) where lifting = Sub Dict 159 | instance Monoid w => Lifting MonadPlus (Lazy.RWST r w s) where lifting = Sub Dict 160 | instance Monoid w => Lifting MonadIO (Lazy.RWST r w s) where lifting = Sub Dict 161 | 162 | instance Lifting Functor (Strict.RWST r w s) where lifting = Sub Dict 163 | instance Monoid w => Lifting Monad (Strict.RWST r w s) where lifting = Sub Dict 164 | instance Monoid w => Lifting MonadFix (Strict.RWST r w s) where lifting = Sub Dict 165 | instance Monoid w => Lifting MonadPlus (Strict.RWST r w s) where lifting = Sub Dict 166 | instance Monoid w => Lifting MonadIO (Strict.RWST r w s) where lifting = Sub Dict 167 | 168 | instance Lifting Functor (ReaderT e) where lifting = Sub Dict 169 | instance Lifting Applicative (ReaderT e) where lifting = Sub Dict 170 | instance Lifting Alternative (ReaderT e) where lifting = Sub Dict 171 | instance Lifting Monad (ReaderT e) where lifting = Sub Dict 172 | instance Lifting MonadPlus (ReaderT e) where lifting = Sub Dict 173 | instance Lifting MonadFix (ReaderT e) where lifting = Sub Dict 174 | instance Lifting MonadIO (ReaderT e) where lifting = Sub Dict 175 | 176 | instance Lifting Functor (ExceptT e) where lifting = Sub Dict 177 | instance Lifting Foldable (ExceptT e) where lifting = Sub Dict 178 | instance Lifting Traversable (ExceptT e) where lifting = Sub Dict 179 | instance Lifting Monad (ExceptT e) where lifting = Sub Dict 180 | instance Lifting MonadFix (ExceptT e) where lifting = Sub Dict 181 | instance Monoid e => Lifting MonadPlus (ExceptT e) where lifting = Sub Dict -- overconstrained! 182 | instance Lifting MonadIO (ExceptT e) where lifting = Sub Dict 183 | instance Show e => Lifting Show1 (ExceptT e) where lifting = Sub Dict 184 | instance Eq e => Lifting Eq1 (ExceptT e) where lifting = Sub Dict 185 | instance Ord e => Lifting Ord1 (ExceptT e) where lifting = Sub Dict 186 | instance Read e => Lifting Read1 (ExceptT e) where lifting = Sub Dict 187 | instance (Show e, Show1 m) => Lifting Show (ExceptT e m) where lifting = Sub Dict 188 | instance (Eq e, Eq1 m) => Lifting Eq (ExceptT e m) where lifting = Sub Dict 189 | instance (Ord e, Ord1 m) => Lifting Ord (ExceptT e m) where lifting = Sub Dict 190 | instance (Read e, Read1 m) => Lifting Read (ExceptT e m) where lifting = Sub Dict 191 | 192 | instance Lifting Functor (Strict.WriterT w) where lifting = Sub Dict 193 | instance Monoid w => Lifting Applicative (Strict.WriterT w) where lifting = Sub Dict 194 | instance Monoid w => Lifting Alternative (Strict.WriterT w) where lifting = Sub Dict 195 | instance Monoid w => Lifting Monad (Strict.WriterT w) where lifting = Sub Dict 196 | instance Monoid w => Lifting MonadFix (Strict.WriterT w) where lifting = Sub Dict 197 | instance Monoid w => Lifting MonadPlus (Strict.WriterT w) where lifting = Sub Dict 198 | instance Lifting Foldable (Strict.WriterT w) where lifting = Sub Dict 199 | instance Lifting Traversable (Strict.WriterT w) where lifting = Sub Dict 200 | instance Monoid w => Lifting MonadIO (Strict.WriterT w) where lifting = Sub Dict 201 | instance Show w => Lifting Show1 (Strict.WriterT w) where lifting = Sub Dict 202 | instance Eq w => Lifting Eq1 (Strict.WriterT w) where lifting = Sub Dict 203 | instance Ord w => Lifting Ord1 (Strict.WriterT w) where lifting = Sub Dict 204 | instance Read w => Lifting Read1 (Strict.WriterT w) where lifting = Sub Dict 205 | instance (Show w, Show1 m) => Lifting Show (Strict.WriterT w m) where lifting = Sub Dict 206 | instance (Eq w, Eq1 m) => Lifting Eq (Strict.WriterT w m) where lifting = Sub Dict 207 | instance (Ord w, Ord1 m) => Lifting Ord (Strict.WriterT w m) where lifting = Sub Dict 208 | instance (Read w, Read1 m) => Lifting Read (Strict.WriterT w m) where lifting = Sub Dict 209 | 210 | instance Lifting Functor (Lazy.WriterT w) where lifting = Sub Dict 211 | instance Monoid w => Lifting Applicative (Lazy.WriterT w) where lifting = Sub Dict 212 | instance Monoid w => Lifting Alternative (Lazy.WriterT w) where lifting = Sub Dict 213 | instance Monoid w => Lifting Monad (Lazy.WriterT w) where lifting = Sub Dict 214 | instance Monoid w => Lifting MonadFix (Lazy.WriterT w) where lifting = Sub Dict 215 | instance Monoid w => Lifting MonadPlus (Lazy.WriterT w) where lifting = Sub Dict 216 | instance Lifting Foldable (Lazy.WriterT w) where lifting = Sub Dict 217 | instance Lifting Traversable (Lazy.WriterT w) where lifting = Sub Dict 218 | instance Monoid w => Lifting MonadIO (Lazy.WriterT w) where lifting = Sub Dict 219 | instance Show w => Lifting Show1 (Lazy.WriterT w) where lifting = Sub Dict 220 | instance Eq w => Lifting Eq1 (Lazy.WriterT w) where lifting = Sub Dict 221 | instance Ord w => Lifting Ord1 (Lazy.WriterT w) where lifting = Sub Dict 222 | instance Read w => Lifting Read1 (Lazy.WriterT w) where lifting = Sub Dict 223 | instance (Show w, Show1 m) => Lifting Show (Lazy.WriterT w m) where lifting = Sub Dict 224 | instance (Eq w, Eq1 m) => Lifting Eq (Lazy.WriterT w m) where lifting = Sub Dict 225 | instance (Ord w, Ord1 m) => Lifting Ord (Lazy.WriterT w m) where lifting = Sub Dict 226 | instance (Read w, Read1 m) => Lifting Read (Lazy.WriterT w m) where lifting = Sub Dict 227 | 228 | instance Lifting Functor (ContT r) where lifting = Sub Dict -- overconstrained 229 | instance Lifting Applicative (ContT r) where lifting = Sub Dict -- overconstrained 230 | instance Lifting Monad (ContT r) where lifting = Sub Dict -- overconstrained 231 | instance Lifting MonadIO (ContT r) where lifting = Sub Dict 232 | 233 | instance Lifting Functor IdentityT where lifting = Sub Dict 234 | instance Lifting Applicative IdentityT where lifting = Sub Dict 235 | instance Lifting Alternative IdentityT where lifting = Sub Dict 236 | instance Lifting Monad IdentityT where lifting = Sub Dict 237 | instance Lifting MonadPlus IdentityT where lifting = Sub Dict 238 | instance Lifting MonadFix IdentityT where lifting = Sub Dict 239 | instance Lifting Foldable IdentityT where lifting = Sub Dict 240 | instance Lifting Traversable IdentityT where lifting = Sub Dict 241 | instance Lifting MonadIO IdentityT where lifting = Sub Dict 242 | instance Lifting Show1 IdentityT where lifting = Sub Dict 243 | instance Lifting Read1 IdentityT where lifting = Sub Dict 244 | instance Lifting Ord1 IdentityT where lifting = Sub Dict 245 | instance Lifting Eq1 IdentityT where lifting = Sub Dict 246 | instance Show1 m => Lifting Show (IdentityT m) where lifting = Sub Dict 247 | instance Read1 m => Lifting Read (IdentityT m) where lifting = Sub Dict 248 | instance Ord1 m => Lifting Ord (IdentityT m) where lifting = Sub Dict 249 | instance Eq1 m => Lifting Eq (IdentityT m) where lifting = Sub Dict 250 | 251 | instance Lifting Functor MaybeT where lifting = Sub Dict 252 | instance Lifting Monad MaybeT where lifting = Sub Dict 253 | -- instance Lifting MonadFix MaybeT where lifting = Sub Dict 254 | instance Lifting MonadPlus MaybeT where lifting = Sub Dict -- overconstrained 255 | instance Lifting Foldable MaybeT where lifting = Sub Dict 256 | instance Lifting Traversable MaybeT where lifting = Sub Dict 257 | instance Lifting MonadIO MaybeT where lifting = Sub Dict 258 | instance Lifting Show1 MaybeT where lifting = Sub Dict 259 | instance Lifting Read1 MaybeT where lifting = Sub Dict 260 | instance Lifting Ord1 MaybeT where lifting = Sub Dict 261 | instance Lifting Eq1 MaybeT where lifting = Sub Dict 262 | instance Show1 m => Lifting Show (MaybeT m) where lifting = Sub Dict 263 | instance Read1 m => Lifting Read (MaybeT m) where lifting = Sub Dict 264 | instance Ord1 m => Lifting Ord (MaybeT m) where lifting = Sub Dict 265 | instance Eq1 m => Lifting Eq (MaybeT m) where lifting = Sub Dict 266 | 267 | instance Lifting Functor Reverse where lifting = Sub Dict 268 | instance Lifting Applicative Reverse where lifting = Sub Dict 269 | instance Lifting Alternative Reverse where lifting = Sub Dict 270 | instance Lifting Foldable Reverse where lifting = Sub Dict 271 | instance Lifting Traversable Reverse where lifting = Sub Dict 272 | instance Lifting Show1 Reverse where lifting = Sub Dict 273 | instance Lifting Read1 Reverse where lifting = Sub Dict 274 | instance Lifting Ord1 Reverse where lifting = Sub Dict 275 | instance Lifting Eq1 Reverse where lifting = Sub Dict 276 | instance Show1 f => Lifting Show (Reverse f) where lifting = Sub Dict 277 | instance Read1 f => Lifting Read (Reverse f) where lifting = Sub Dict 278 | instance Ord1 f => Lifting Ord (Reverse f) where lifting = Sub Dict 279 | instance Eq1 f => Lifting Eq (Reverse f) where lifting = Sub Dict 280 | 281 | instance Lifting Functor Backwards where lifting = Sub Dict 282 | instance Lifting Foldable Backwards where lifting = Sub Dict 283 | instance Lifting Traversable Backwards where lifting = Sub Dict 284 | instance Lifting Applicative Backwards where lifting = Sub Dict 285 | instance Lifting Alternative Backwards where lifting = Sub Dict 286 | instance Lifting Show1 Backwards where lifting = Sub Dict 287 | instance Lifting Read1 Backwards where lifting = Sub Dict 288 | instance Lifting Ord1 Backwards where lifting = Sub Dict 289 | instance Lifting Eq1 Backwards where lifting = Sub Dict 290 | instance Show1 f => Lifting Show (Backwards f) where lifting = Sub Dict 291 | instance Read1 f => Lifting Read (Backwards f) where lifting = Sub Dict 292 | instance Ord1 f => Lifting Ord (Backwards f) where lifting = Sub Dict 293 | instance Eq1 f => Lifting Eq (Backwards f) where lifting = Sub Dict 294 | 295 | instance Lifting Functor Lift where lifting = Sub Dict 296 | instance Lifting Foldable Lift where lifting = Sub Dict 297 | instance Lifting Traversable Lift where lifting = Sub Dict 298 | instance Lifting Applicative Lift where lifting = Sub Dict 299 | instance Lifting Alternative Lift where lifting = Sub Dict 300 | instance Lifting Show1 Lift where lifting = Sub Dict 301 | instance Lifting Read1 Lift where lifting = Sub Dict 302 | instance Lifting Ord1 Lift where lifting = Sub Dict 303 | instance Lifting Eq1 Lift where lifting = Sub Dict 304 | instance Show1 f => Lifting Show (Lift f) where lifting = Sub Dict 305 | instance Read1 f => Lifting Read (Lift f) where lifting = Sub Dict 306 | instance Ord1 f => Lifting Ord (Lift f) where lifting = Sub Dict 307 | instance Eq1 f => Lifting Eq (Lift f) where lifting = Sub Dict 308 | 309 | instance Lifting Eq Identity where lifting = Sub Dict 310 | instance Lifting Ord Identity where lifting = Sub Dict 311 | instance Lifting Show Identity where lifting = Sub Dict 312 | instance Lifting Read Identity where lifting = Sub Dict 313 | 314 | instance Lifting MonadCont MaybeT where lifting = Sub Dict 315 | instance Lifting MonadCont IdentityT where lifting = Sub Dict 316 | instance Monoid w => Lifting MonadCont (Strict.WriterT w) where lifting = Sub Dict 317 | instance Monoid w => Lifting MonadCont (Lazy.WriterT w) where lifting = Sub Dict 318 | instance Lifting MonadCont (ExceptT w) where lifting = Sub Dict 319 | instance Lifting MonadCont (Strict.StateT s) where lifting = Sub Dict 320 | instance Lifting MonadCont (Lazy.StateT s) where lifting = Sub Dict 321 | instance Lifting MonadCont (ReaderT e) where lifting = Sub Dict 322 | instance Monoid w => Lifting MonadCont (Strict.RWST r w s) where lifting = Sub Dict 323 | instance Monoid w => Lifting MonadCont (Lazy.RWST r w s) where lifting = Sub Dict 324 | 325 | instance Lifting (MonadError e) MaybeT where lifting = Sub Dict 326 | instance Lifting (MonadError e) IdentityT where lifting = Sub Dict 327 | instance Monoid w => Lifting (MonadError e) (Strict.WriterT w) where lifting = Sub Dict 328 | instance Monoid w => Lifting (MonadError e) (Lazy.WriterT w) where lifting = Sub Dict 329 | instance Lifting (MonadError e) (Strict.StateT s) where lifting = Sub Dict 330 | instance Lifting (MonadError e) (Lazy.StateT s) where lifting = Sub Dict 331 | instance Lifting (MonadError e) (ReaderT r) where lifting = Sub Dict 332 | instance Monoid w => Lifting (MonadError e) (Strict.RWST r w s) where lifting = Sub Dict 333 | instance Monoid w => Lifting (MonadError e) (Lazy.RWST r w s) where lifting = Sub Dict 334 | 335 | instance Lifting (MonadRWS r w s) MaybeT where lifting = Sub Dict 336 | instance Lifting (MonadRWS r w s) IdentityT where lifting = Sub Dict 337 | instance Lifting (MonadRWS r w s) (ExceptT e) where lifting = Sub Dict 338 | 339 | instance Lifting (MonadReader r) MaybeT where lifting = Sub Dict 340 | instance Lifting (MonadReader r) IdentityT where lifting = Sub Dict 341 | instance Monoid w => Lifting (MonadReader r) (Strict.WriterT w) where lifting = Sub Dict 342 | instance Monoid w => Lifting (MonadReader r) (Lazy.WriterT w) where lifting = Sub Dict 343 | instance Lifting (MonadReader r) (Strict.StateT s) where lifting = Sub Dict 344 | instance Lifting (MonadReader r) (Lazy.StateT s) where lifting = Sub Dict 345 | instance Lifting (MonadReader r) (ExceptT e) where lifting = Sub Dict 346 | instance Lifting (MonadReader r) (ContT r') where lifting = Sub Dict 347 | 348 | instance Lifting (MonadState s) MaybeT where lifting = Sub Dict 349 | instance Lifting (MonadState s) IdentityT where lifting = Sub Dict 350 | instance Monoid w => Lifting (MonadState s) (Strict.WriterT w) where lifting = Sub Dict 351 | instance Monoid w => Lifting (MonadState s) (Lazy.WriterT w) where lifting = Sub Dict 352 | instance Lifting (MonadState s) (ReaderT r) where lifting = Sub Dict 353 | instance Lifting (MonadState s) (ExceptT e) where lifting = Sub Dict 354 | instance Lifting (MonadState s) (ContT r') where lifting = Sub Dict 355 | 356 | class Lifting2 p f where 357 | lifting2 :: p a :- Lifting p (f a) -- (p a, p b) :- p (f a b) 358 | 359 | instance Lifting2 Eq Either where lifting2 = Sub Dict 360 | instance Lifting2 Ord Either where lifting2 = Sub Dict 361 | instance Lifting2 Show Either where lifting2 = Sub Dict 362 | instance Lifting2 Read Either where lifting2 = Sub Dict 363 | instance Lifting2 Hashable Either where lifting2 = Sub Dict 364 | instance Lifting2 Binary Either where lifting2 = Sub Dict 365 | instance Lifting2 NFData Either where lifting2 = Sub Dict 366 | 367 | instance Lifting2 Eq (,) where lifting2 = Sub Dict 368 | instance Lifting2 Ord (,) where lifting2 = Sub Dict 369 | instance Lifting2 Show (,) where lifting2 = Sub Dict 370 | instance Lifting2 Read (,) where lifting2 = Sub Dict 371 | instance Lifting2 Hashable (,) where lifting2 = Sub Dict 372 | instance Lifting2 Binary (,) where lifting2 = Sub Dict 373 | instance Lifting2 NFData (,) where lifting2 = Sub Dict 374 | instance Lifting2 Semigroup (,) where lifting2 = Sub Dict 375 | instance Lifting2 Monoid (,) where lifting2 = Sub Dict 376 | instance Lifting2 Bounded (,) where lifting2 = Sub Dict 377 | instance Lifting2 Ix (,) where lifting2 = Sub Dict 378 | 379 | instance Lifting2 Functor Compose where lifting2 = Sub Dict 380 | instance Lifting2 Foldable Compose where lifting2 = Sub Dict 381 | instance Lifting2 Traversable Compose where lifting2 = Sub Dict 382 | instance Lifting2 Applicative Compose where lifting2 = Sub Dict 383 | instance Lifting2 Alternative Compose where lifting2 = Sub Dict -- overconstrained 384 | 385 | instance Lifting2 Functor Functor.Product where lifting2 = Sub Dict 386 | instance Lifting2 Foldable Functor.Product where lifting2 = Sub Dict 387 | instance Lifting2 Traversable Functor.Product where lifting2 = Sub Dict 388 | instance Lifting2 Applicative Functor.Product where lifting2 = Sub Dict 389 | instance Lifting2 Alternative Functor.Product where lifting2 = Sub Dict 390 | instance Lifting2 Monad Functor.Product where lifting2 = Sub Dict 391 | instance Lifting2 MonadPlus Functor.Product where lifting2 = Sub Dict 392 | instance Lifting2 MonadFix Functor.Product where lifting2 = Sub Dict 393 | instance Lifting2 Show1 Functor.Product where lifting2 = Sub Dict 394 | instance Lifting2 Eq1 Functor.Product where lifting2 = Sub Dict 395 | instance Lifting2 Ord1 Functor.Product where lifting2 = Sub Dict 396 | instance Lifting2 Read1 Functor.Product where lifting2 = Sub Dict 397 | 398 | instance Lifting2 Functor Functor.Sum where lifting2 = Sub Dict 399 | instance Lifting2 Foldable Functor.Sum where lifting2 = Sub Dict 400 | instance Lifting2 Traversable Functor.Sum where lifting2 = Sub Dict 401 | instance Lifting2 Show1 Functor.Sum where lifting2 = Sub Dict 402 | instance Lifting2 Eq1 Functor.Sum where lifting2 = Sub Dict 403 | instance Lifting2 Ord1 Functor.Sum where lifting2 = Sub Dict 404 | instance Lifting2 Read1 Functor.Sum where lifting2 = Sub Dict 405 | -------------------------------------------------------------------------------- /src/Data/Constraint/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE AllowAmbiguousTypes #-} 12 | {-# LANGUAGE Trustworthy #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | {-# LANGUAGE NoStarIsType #-} 15 | -- | Utilities for working with 'KnownNat' constraints. 16 | -- 17 | -- This module is only available on GHC 8.0 or later. 18 | module Data.Constraint.Nat 19 | ( Min, Max, Lcm, Gcd, Divides, Div, Mod, Log2 20 | , plusNat, minusNat, timesNat, powNat, minNat, maxNat, gcdNat, lcmNat, divNat, modNat, log2Nat 21 | , plusZero, minusZero, timesZero, timesOne, powZero, powOne, maxZero, minZero, gcdZero, gcdOne, lcmZero, lcmOne 22 | , plusAssociates, timesAssociates, minAssociates, maxAssociates, gcdAssociates, lcmAssociates 23 | , plusCommutes, timesCommutes, minCommutes, maxCommutes, gcdCommutes, lcmCommutes 24 | , plusDistributesOverTimes, timesDistributesOverPow, timesDistributesOverGcd, timesDistributesOverLcm 25 | , minDistributesOverPlus, minDistributesOverTimes, minDistributesOverPow1, minDistributesOverPow2, minDistributesOverMax 26 | , maxDistributesOverPlus, maxDistributesOverTimes, maxDistributesOverPow1, maxDistributesOverPow2, maxDistributesOverMin 27 | , gcdDistributesOverLcm, lcmDistributesOverGcd 28 | , minIsIdempotent, maxIsIdempotent, lcmIsIdempotent, gcdIsIdempotent 29 | , plusIsCancellative, timesIsCancellative 30 | , dividesPlus, dividesTimes, dividesMin, dividesMax, dividesPow, dividesGcd, dividesLcm 31 | , plusMonotone1, plusMonotone2 32 | , timesMonotone1, timesMonotone2 33 | , powMonotone1, powMonotone2 34 | , minMonotone1, minMonotone2 35 | , maxMonotone1, maxMonotone2 36 | , divMonotone1, divMonotone2 37 | , euclideanNat 38 | , plusMod, timesMod 39 | , modBound 40 | , log2Pow 41 | , dividesDef 42 | , timesDiv 43 | , eqLe, leEq, leId, leTrans 44 | , leZero, zeroLe 45 | , plusMinusInverse1, plusMinusInverse2, plusMinusInverse3 46 | ) where 47 | 48 | import Data.Constraint 49 | import Data.Constraint.Unsafe 50 | import Data.Proxy 51 | import Data.Type.Bool 52 | import GHC.TypeNats 53 | import qualified Numeric.Natural as Nat 54 | 55 | #if MIN_VERSION_base(4,15,0) 56 | import GHC.Num.Natural (naturalLog2) 57 | #else 58 | import GHC.Exts (Int(..)) 59 | import GHC.Integer.Logarithms (integerLog2#) 60 | #endif 61 | 62 | #if !MIN_VERSION_base(4,18,0) 63 | import Unsafe.Coerce 64 | #endif 65 | 66 | type family Min (m::Nat) (n::Nat) :: Nat where 67 | Min m n = If (n <=? m) n m 68 | type family Max (m::Nat) (n::Nat) :: Nat where 69 | Max m n = If (n <=? m) m n 70 | type family Gcd (m::Nat) (n::Nat) :: Nat where 71 | Gcd m m = m 72 | type family Lcm (m::Nat) (n::Nat) :: Nat where 73 | Lcm m m = m 74 | 75 | type Divides n m = n ~ Gcd n m 76 | 77 | #if !MIN_VERSION_base(4,18,0) 78 | newtype Magic n = Magic (KnownNat n => Dict (KnownNat n)) 79 | #endif 80 | 81 | magicNNN :: forall n m o. (Nat.Natural -> Nat.Natural -> Nat.Natural) -> (KnownNat n, KnownNat m) :- KnownNat o 82 | #if MIN_VERSION_base(4,18,0) 83 | magicNNN f = Sub $ withKnownNat @o (unsafeSNat (natVal (Proxy @n) `f` natVal (Proxy @m))) Dict 84 | #else 85 | magicNNN f = Sub $ unsafeCoerce (Magic Dict) (natVal (Proxy @n) `f` natVal (Proxy @m)) 86 | #endif 87 | 88 | magicNN :: forall n m. (Nat.Natural -> Nat.Natural) -> KnownNat n :- KnownNat m 89 | #if MIN_VERSION_base(4,18,0) 90 | magicNN f = Sub $ withKnownNat @m (unsafeSNat (f (natVal (Proxy @n)))) Dict 91 | #else 92 | magicNN f = Sub $ unsafeCoerce (Magic Dict) (f (natVal (Proxy :: Proxy n))) 93 | #endif 94 | 95 | axiomLe :: forall (a :: Nat) (b :: Nat). Dict (a <= b) 96 | axiomLe = unsafeAxiom 97 | 98 | eqLe :: forall (a :: Nat) (b :: Nat). (a ~ b) :- (a <= b) 99 | eqLe = Sub Dict 100 | 101 | dividesGcd :: forall a b c. (Divides a b, Divides a c) :- Divides a (Gcd b c) 102 | dividesGcd = Sub unsafeAxiom 103 | 104 | dividesLcm :: forall a b c. (Divides a c, Divides b c) :- Divides (Lcm a b) c 105 | dividesLcm = Sub unsafeAxiom 106 | 107 | gcdCommutes :: forall a b. Dict (Gcd a b ~ Gcd b a) 108 | gcdCommutes = unsafeAxiom 109 | 110 | lcmCommutes :: forall a b. Dict (Lcm a b ~ Lcm b a) 111 | lcmCommutes = unsafeAxiom 112 | 113 | gcdZero :: forall a. Dict (Gcd 0 a ~ a) 114 | gcdZero = unsafeAxiom 115 | 116 | gcdOne :: forall a. Dict (Gcd 1 a ~ 1) 117 | gcdOne = unsafeAxiom 118 | 119 | lcmZero :: forall a. Dict (Lcm 0 a ~ 0) 120 | lcmZero = unsafeAxiom 121 | 122 | lcmOne :: forall a. Dict (Lcm 1 a ~ a) 123 | lcmOne = unsafeAxiom 124 | 125 | gcdNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Gcd n m) 126 | gcdNat = magicNNN gcd 127 | 128 | lcmNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Lcm n m) 129 | lcmNat = magicNNN lcm 130 | 131 | plusNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (n + m) 132 | plusNat = magicNNN (+) 133 | 134 | minusNat :: forall n m. (KnownNat n, KnownNat m, m <= n) :- KnownNat (n - m) 135 | minusNat = Sub $ case magicNNN @n @m (-) of Sub r -> r 136 | 137 | minNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Min n m) 138 | minNat = magicNNN min 139 | 140 | maxNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Max n m) 141 | maxNat = magicNNN max 142 | 143 | timesNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (n * m) 144 | timesNat = magicNNN (*) 145 | 146 | powNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (n ^ m) 147 | powNat = magicNNN (^) 148 | 149 | divNat :: forall n m. (KnownNat n, KnownNat m, 1 <= m) :- KnownNat (Div n m) 150 | divNat = Sub $ case magicNNN @n @m div of Sub r -> r 151 | 152 | modNat :: forall n m. (KnownNat n, KnownNat m, 1 <= m) :- KnownNat (Mod n m) 153 | modNat = Sub $ case magicNNN @n @m mod of Sub r -> r 154 | 155 | log2Nat :: forall n. (KnownNat n, 1 <= n) :- KnownNat (Log2 n) 156 | log2Nat = Sub $ case magicNN @n log2 of Sub r -> r 157 | where 158 | log2 :: Nat.Natural -> Nat.Natural 159 | #if MIN_VERSION_base(4,15,0) 160 | log2 n = fromIntegral (naturalLog2 n) 161 | #else 162 | log2 n = fromIntegral (I# (integerLog2# (toInteger n))) 163 | #endif 164 | 165 | plusZero :: forall n. Dict ((n + 0) ~ n) 166 | plusZero = Dict 167 | 168 | minusZero :: forall n. Dict ((n - 0) ~ n) 169 | minusZero = Dict 170 | 171 | timesZero :: forall n. Dict ((n * 0) ~ 0) 172 | timesZero = Dict 173 | 174 | timesOne :: forall n. Dict ((n * 1) ~ n) 175 | timesOne = Dict 176 | 177 | minZero :: forall n. Dict (Min n 0 ~ 0) 178 | #if MIN_VERSION_base(4,16,0) 179 | minZero = unsafeAxiom 180 | #else 181 | minZero = Dict 182 | #endif 183 | 184 | maxZero :: forall n. Dict (Max n 0 ~ n) 185 | #if MIN_VERSION_base(4,16,0) 186 | maxZero = unsafeAxiom 187 | #else 188 | maxZero = Dict 189 | #endif 190 | 191 | powZero :: forall n. Dict ((n ^ 0) ~ 1) 192 | powZero = Dict 193 | 194 | leZero :: forall a. (a <= 0) :- (a ~ 0) 195 | leZero = Sub unsafeAxiom 196 | 197 | zeroLe :: forall (a :: Nat). Dict (0 <= a) 198 | #if MIN_VERSION_base(4,16,0) 199 | zeroLe = unsafeAxiom 200 | #else 201 | zeroLe = Dict 202 | #endif 203 | 204 | plusMinusInverse1 :: forall n m. Dict (((m + n) - n) ~ m) 205 | plusMinusInverse1 = unsafeAxiom 206 | 207 | plusMinusInverse2 :: forall n m. (m <= n) :- (((m + n) - m) ~ n) 208 | plusMinusInverse2 = Sub unsafeAxiom 209 | 210 | plusMinusInverse3 :: forall n m. (n <= m) :- (((m - n) + n) ~ m) 211 | plusMinusInverse3 = Sub unsafeAxiom 212 | 213 | plusMonotone1 :: forall a b c. (a <= b) :- (a + c <= b + c) 214 | plusMonotone1 = Sub unsafeAxiom 215 | 216 | plusMonotone2 :: forall a b c. (b <= c) :- (a + b <= a + c) 217 | plusMonotone2 = Sub unsafeAxiom 218 | 219 | powMonotone1 :: forall a b c. (a <= b) :- ((a^c) <= (b^c)) 220 | powMonotone1 = Sub unsafeAxiom 221 | 222 | powMonotone2 :: forall a b c. (b <= c) :- ((a^b) <= (a^c)) 223 | powMonotone2 = Sub unsafeAxiom 224 | 225 | divMonotone1 :: forall a b c. (a <= b) :- (Div a c <= Div b c) 226 | divMonotone1 = Sub unsafeAxiom 227 | 228 | divMonotone2 :: forall a b c. (b <= c) :- (Div a c <= Div a b) 229 | divMonotone2 = Sub unsafeAxiom 230 | 231 | timesMonotone1 :: forall a b c. (a <= b) :- (a * c <= b * c) 232 | timesMonotone1 = Sub unsafeAxiom 233 | 234 | timesMonotone2 :: forall a b c. (b <= c) :- (a * b <= a * c) 235 | timesMonotone2 = Sub unsafeAxiom 236 | 237 | minMonotone1 :: forall a b c. (a <= b) :- (Min a c <= Min b c) 238 | minMonotone1 = Sub unsafeAxiom 239 | 240 | minMonotone2 :: forall a b c. (b <= c) :- (Min a b <= Min a c) 241 | minMonotone2 = Sub unsafeAxiom 242 | 243 | maxMonotone1 :: forall a b c. (a <= b) :- (Max a c <= Max b c) 244 | maxMonotone1 = Sub unsafeAxiom 245 | 246 | maxMonotone2 :: forall a b c. (b <= c) :- (Max a b <= Max a c) 247 | maxMonotone2 = Sub unsafeAxiom 248 | 249 | powOne :: forall n. Dict ((n ^ 1) ~ n) 250 | powOne = unsafeAxiom 251 | 252 | plusMod :: forall a b c. (1 <= c) :- (Mod (a + b) c ~ Mod (Mod a c + Mod b c) c) 253 | plusMod = Sub unsafeAxiom 254 | 255 | timesMod :: forall a b c. (1 <= c) :- (Mod (a * b) c ~ Mod (Mod a c * Mod b c) c) 256 | timesMod = Sub unsafeAxiom 257 | 258 | modBound :: forall m n. (1 <= n) :- (Mod m n <= n) 259 | modBound = Sub unsafeAxiom 260 | 261 | log2Pow :: forall n. Dict (Log2 (2 ^ n) ~ n) 262 | log2Pow = unsafeAxiom 263 | 264 | euclideanNat :: (1 <= c) :- (a ~ (c * Div a c + Mod a c)) 265 | euclideanNat = Sub unsafeAxiom 266 | 267 | plusCommutes :: forall n m. Dict ((m + n) ~ (n + m)) 268 | plusCommutes = unsafeAxiom 269 | 270 | timesCommutes :: forall n m. Dict ((m * n) ~ (n * m)) 271 | timesCommutes = unsafeAxiom 272 | 273 | minCommutes :: forall n m. Dict (Min m n ~ Min n m) 274 | minCommutes = unsafeAxiom 275 | 276 | maxCommutes :: forall n m. Dict (Max m n ~ Max n m) 277 | maxCommutes = unsafeAxiom 278 | 279 | plusAssociates :: forall m n o. Dict (((m + n) + o) ~ (m + (n + o))) 280 | plusAssociates = unsafeAxiom 281 | 282 | timesAssociates :: forall m n o. Dict (((m * n) * o) ~ (m * (n * o))) 283 | timesAssociates = unsafeAxiom 284 | 285 | minAssociates :: forall m n o. Dict (Min (Min m n) o ~ Min m (Min n o)) 286 | minAssociates = unsafeAxiom 287 | 288 | maxAssociates :: forall m n o. Dict (Max (Max m n) o ~ Max m (Max n o)) 289 | maxAssociates = unsafeAxiom 290 | 291 | gcdAssociates :: forall a b c. Dict (Gcd (Gcd a b) c ~ Gcd a (Gcd b c)) 292 | gcdAssociates = unsafeAxiom 293 | 294 | lcmAssociates :: forall a b c. Dict (Lcm (Lcm a b) c ~ Lcm a (Lcm b c)) 295 | lcmAssociates = unsafeAxiom 296 | 297 | minIsIdempotent :: forall n. Dict (Min n n ~ n) 298 | minIsIdempotent = Dict 299 | 300 | maxIsIdempotent :: forall n. Dict (Max n n ~ n) 301 | maxIsIdempotent = Dict 302 | 303 | gcdIsIdempotent :: forall n. Dict (Gcd n n ~ n) 304 | gcdIsIdempotent = Dict 305 | 306 | lcmIsIdempotent :: forall n. Dict (Lcm n n ~ n) 307 | lcmIsIdempotent = Dict 308 | 309 | minDistributesOverPlus :: forall n m o. Dict ((n + Min m o) ~ Min (n + m) (n + o)) 310 | minDistributesOverPlus = unsafeAxiom 311 | 312 | minDistributesOverTimes :: forall n m o. Dict ((n * Min m o) ~ Min (n * m) (n * o)) 313 | minDistributesOverTimes = unsafeAxiom 314 | 315 | minDistributesOverPow1 :: forall n m o. Dict ((Min n m ^ o) ~ Min (n ^ o) (m ^ o)) 316 | minDistributesOverPow1 = unsafeAxiom 317 | 318 | minDistributesOverPow2 :: forall n m o. Dict ((n ^ Min m o) ~ Min (n ^ m) (n ^ o)) 319 | minDistributesOverPow2 = unsafeAxiom 320 | 321 | minDistributesOverMax :: forall n m o. Dict (Max n (Min m o) ~ Min (Max n m) (Max n o)) 322 | minDistributesOverMax = unsafeAxiom 323 | 324 | maxDistributesOverPlus :: forall n m o. Dict ((n + Max m o) ~ Max (n + m) (n + o)) 325 | maxDistributesOverPlus = unsafeAxiom 326 | 327 | maxDistributesOverTimes :: forall n m o. Dict ((n * Max m o) ~ Max (n * m) (n * o)) 328 | maxDistributesOverTimes = unsafeAxiom 329 | 330 | maxDistributesOverPow1 :: forall n m o. Dict ((Max n m ^ o) ~ Max (n ^ o) (m ^ o)) 331 | maxDistributesOverPow1 = unsafeAxiom 332 | 333 | maxDistributesOverPow2 :: forall n m o. Dict ((n ^ Max m o) ~ Max (n ^ m) (n ^ o)) 334 | maxDistributesOverPow2 = unsafeAxiom 335 | 336 | maxDistributesOverMin :: forall n m o. Dict (Min n (Max m o) ~ Max (Min n m) (Min n o)) 337 | maxDistributesOverMin = unsafeAxiom 338 | 339 | plusDistributesOverTimes :: forall n m o. Dict ((n * (m + o)) ~ (n * m + n * o)) 340 | plusDistributesOverTimes = unsafeAxiom 341 | 342 | timesDistributesOverPow :: forall n m o. Dict ((n ^ (m + o)) ~ (n ^ m * n ^ o)) 343 | timesDistributesOverPow = unsafeAxiom 344 | 345 | timesDistributesOverGcd :: forall n m o. Dict ((n * Gcd m o) ~ Gcd (n * m) (n * o)) 346 | timesDistributesOverGcd = unsafeAxiom 347 | 348 | timesDistributesOverLcm :: forall n m o. Dict ((n * Lcm m o) ~ Lcm (n * m) (n * o)) 349 | timesDistributesOverLcm = unsafeAxiom 350 | 351 | plusIsCancellative :: forall n m o. ((n + m) ~ (n + o)) :- (m ~ o) 352 | plusIsCancellative = Sub unsafeAxiom 353 | 354 | timesIsCancellative :: forall n m o. (1 <= n, (n * m) ~ (n * o)) :- (m ~ o) 355 | timesIsCancellative = Sub unsafeAxiom 356 | 357 | gcdDistributesOverLcm :: forall a b c. Dict (Gcd (Lcm a b) c ~ Lcm (Gcd a c) (Gcd b c)) 358 | gcdDistributesOverLcm = unsafeAxiom 359 | 360 | lcmDistributesOverGcd :: forall a b c. Dict (Lcm (Gcd a b) c ~ Gcd (Lcm a c) (Lcm b c)) 361 | lcmDistributesOverGcd = unsafeAxiom 362 | 363 | dividesPlus :: (Divides a b, Divides a c) :- Divides a (b + c) 364 | dividesPlus = Sub unsafeAxiom 365 | 366 | dividesTimes :: Divides a b :- Divides a (b * c) 367 | dividesTimes = Sub unsafeAxiom 368 | 369 | dividesMin :: (Divides a b, Divides a c) :- Divides a (Min b c) 370 | dividesMin = Sub unsafeAxiom 371 | 372 | dividesMax :: (Divides a b, Divides a c) :- Divides a (Max b c) 373 | dividesMax = Sub unsafeAxiom 374 | 375 | -- This `dividesDef` is simpler and more convenient than Divides a b :- ((a * Div b a) ~ b) 376 | -- because the latter can be easily derived via 'euclideanNat', but not vice versa. 377 | 378 | dividesDef :: forall a b. Divides a b :- (Mod b a ~ 0) 379 | dividesDef = Sub unsafeAxiom 380 | 381 | dividesPow :: (1 <= n, Divides a b) :- Divides a (b^n) 382 | dividesPow = Sub unsafeAxiom 383 | 384 | timesDiv :: forall a b. Dict ((a * Div b a) <= b) 385 | timesDiv = unsafeAxiom 386 | 387 | -- (<=) is an internal category in the category of constraints. 388 | 389 | leId :: forall (a :: Nat). Dict (a <= a) 390 | leId = Dict 391 | 392 | leEq :: forall (a :: Nat) (b :: Nat). (a <= b, b <= a) :- (a ~ b) 393 | leEq = Sub unsafeAxiom 394 | 395 | leTrans :: forall (a :: Nat) (b :: Nat) (c :: Nat). (b <= c, a <= b) :- (a <= c) 396 | leTrans = Sub (axiomLe @a @c) 397 | -------------------------------------------------------------------------------- /src/Data/Constraint/Symbol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE AllowAmbiguousTypes #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE CPP #-} 11 | -- | Utilities for working with 'KnownSymbol' constraints. 12 | module Data.Constraint.Symbol 13 | ( type AppendSymbol 14 | , type (++) 15 | , type Take 16 | , type Drop 17 | , type Length 18 | , appendSymbol 19 | , appendUnit1 20 | , appendUnit2 21 | , appendAssociates 22 | , takeSymbol 23 | , dropSymbol 24 | , takeAppendDrop 25 | , lengthSymbol 26 | , takeLength 27 | , take0 28 | , takeEmpty 29 | , dropLength 30 | , drop0 31 | , dropEmpty 32 | , lengthTake 33 | , lengthDrop 34 | , dropDrop 35 | , takeTake 36 | ) where 37 | 38 | import Data.Constraint 39 | import Data.Constraint.Nat 40 | import Data.Constraint.Unsafe 41 | import Data.Proxy 42 | import GHC.TypeLits 43 | #if MIN_VERSION_base(4,18,0) 44 | import qualified GHC.TypeNats as TN 45 | #else 46 | import Unsafe.Coerce 47 | #endif 48 | 49 | -- | An infix synonym for 'AppendSymbol'. 50 | type (m :: Symbol) ++ (n :: Symbol) = AppendSymbol m n 51 | infixr 5 ++ 52 | 53 | type family Take :: Nat -> Symbol -> Symbol where 54 | type family Drop :: Nat -> Symbol -> Symbol where 55 | type family Length :: Symbol -> Nat where 56 | 57 | -- implementation details 58 | 59 | #if !MIN_VERSION_base(4,18,0) 60 | newtype Magic n = Magic (KnownSymbol n => Dict (KnownSymbol n)) 61 | #endif 62 | 63 | magicNSS :: forall n m o. (Int -> String -> String) -> (KnownNat n, KnownSymbol m) :- KnownSymbol o 64 | #if MIN_VERSION_base(4,18,0) 65 | magicNSS f = Sub $ withKnownSymbol (unsafeSSymbol @o (fromIntegral (natVal (Proxy @n)) `f` symbolVal (Proxy @m))) Dict 66 | #else 67 | magicNSS f = Sub $ unsafeCoerce (Magic Dict) (fromIntegral (natVal (Proxy @n)) `f` symbolVal (Proxy @m)) 68 | #endif 69 | 70 | magicSSS :: forall n m o. (String -> String -> String) -> (KnownSymbol n, KnownSymbol m) :- KnownSymbol o 71 | #if MIN_VERSION_base(4,18,0) 72 | magicSSS f = Sub $ withKnownSymbol (unsafeSSymbol @o (symbolVal (Proxy @n) `f` symbolVal (Proxy @m))) Dict 73 | #else 74 | magicSSS f = Sub $ unsafeCoerce (Magic Dict) (symbolVal (Proxy @n) `f` symbolVal (Proxy @m)) 75 | #endif 76 | 77 | magicSN :: forall a n. (String -> Int) -> KnownSymbol a :- KnownNat n 78 | #if MIN_VERSION_base(4,18,0) 79 | magicSN f = Sub $ TN.withKnownNat (unsafeSNat @n (fromIntegral (f (symbolVal (Proxy :: Proxy a))))) Dict 80 | #else 81 | magicSN f = Sub $ unsafeCoerce (Magic Dict) (toInteger (f (symbolVal (Proxy @a)))) 82 | #endif 83 | 84 | -- operations 85 | 86 | appendSymbol :: (KnownSymbol a, KnownSymbol b) :- KnownSymbol (AppendSymbol a b) 87 | appendSymbol = magicSSS (++) 88 | 89 | appendUnit1 :: forall a. Dict (AppendSymbol "" a ~ a) 90 | appendUnit1 = Dict 91 | 92 | appendUnit2 :: forall a. Dict (AppendSymbol a "" ~ a) 93 | appendUnit2 = Dict 94 | 95 | appendAssociates :: forall a b c. Dict (AppendSymbol (AppendSymbol a b) c ~ AppendSymbol a (AppendSymbol b c)) 96 | appendAssociates = unsafeAxiom 97 | 98 | takeSymbol :: forall n a. (KnownNat n, KnownSymbol a) :- KnownSymbol (Take n a) 99 | takeSymbol = magicNSS take 100 | 101 | dropSymbol :: forall n a. (KnownNat n, KnownSymbol a) :- KnownSymbol (Drop n a) 102 | dropSymbol = magicNSS drop 103 | 104 | takeAppendDrop :: forall n a. Dict (AppendSymbol (Take n a) (Drop n a) ~ a) 105 | takeAppendDrop = unsafeAxiom 106 | 107 | lengthSymbol :: forall a. KnownSymbol a :- KnownNat (Length a) 108 | lengthSymbol = magicSN length 109 | 110 | takeLength :: forall n a. (Length a <= n) :- (Take n a ~ a) 111 | takeLength = Sub unsafeAxiom 112 | 113 | take0 :: forall a. Dict (Take 0 a ~ "") 114 | take0 = unsafeAxiom 115 | 116 | takeEmpty :: forall n. Dict (Take n "" ~ "") 117 | takeEmpty = unsafeAxiom 118 | 119 | dropLength :: forall n a. (Length a <= n) :- (Drop n a ~ "") 120 | dropLength = Sub unsafeAxiom 121 | 122 | drop0 :: forall a. Dict (Drop 0 a ~ a) 123 | drop0 = unsafeAxiom 124 | 125 | dropEmpty :: forall n. Dict (Drop n "" ~ "") 126 | dropEmpty = unsafeAxiom 127 | 128 | lengthTake :: forall n a. Dict (Length (Take n a) <= n) 129 | lengthTake = unsafeAxiom 130 | 131 | lengthDrop :: forall n a. Dict (Length a <= (Length (Drop n a) + n)) 132 | lengthDrop = unsafeAxiom 133 | 134 | dropDrop :: forall n m a. Dict (Drop n (Drop m a) ~ Drop (n + m) a) 135 | dropDrop = unsafeAxiom 136 | 137 | takeTake :: forall n m a. Dict (Take n (Take m a) ~ Take (Min n m) a) 138 | takeTake = unsafeAxiom 139 | -------------------------------------------------------------------------------- /src/Data/Constraint/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE Unsafe #-} 8 | {-# LANGUAGE CPP #-} 9 | {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 10 | 11 | -- | 12 | -- Copyright : (C) 2011-2021 Edward Kmett 13 | -- License : BSD-style (see the file LICENSE) 14 | -- Maintainer : Edward Kmett 15 | -- Stability : experimental 16 | -- Portability : non-portable 17 | -- 18 | -- Unsafe utilities used throughout @constraints@. As the names suggest, these 19 | -- functions are unsafe in general and can cause your program to segfault if 20 | -- used improperly. Handle with care. 21 | 22 | module Data.Constraint.Unsafe 23 | ( Coercible 24 | , unsafeAxiom 25 | , unsafeCoerceConstraint 26 | , unsafeDerive 27 | , unsafeUnderive 28 | 29 | #if MIN_VERSION_base(4,18,0) 30 | -- * Unsafely creating @GHC.TypeLits@ singleton values 31 | , unsafeSChar 32 | , unsafeSNat 33 | , unsafeSSymbol 34 | #endif 35 | ) where 36 | 37 | import Data.Coerce 38 | import Data.Constraint 39 | import Unsafe.Coerce 40 | 41 | #if MIN_VERSION_base(4,18,0) 42 | import GHC.TypeLits (SChar, SNat, SSymbol) 43 | import Numeric.Natural (Natural) 44 | #endif 45 | 46 | -- | Unsafely create a dictionary for any constraint. 47 | unsafeAxiom :: Dict c 48 | unsafeAxiom = unsafeCoerce (Dict :: Dict ()) 49 | 50 | -- | Coerce a dictionary unsafely from one type to another 51 | unsafeCoerceConstraint :: a :- b 52 | unsafeCoerceConstraint = unsafeCoerce refl 53 | 54 | -- | Coerce a dictionary unsafely from one type to a newtype of that type 55 | unsafeDerive :: Coercible n o => (o -> n) -> t o :- t n 56 | unsafeDerive _ = unsafeCoerceConstraint 57 | 58 | -- | Coerce a dictionary unsafely from a newtype of a type to the base type 59 | unsafeUnderive :: Coercible n o => (o -> n) -> t n :- t o 60 | unsafeUnderive _ = unsafeCoerceConstraint 61 | 62 | #if MIN_VERSION_base(4,18,0) 63 | -- NB: if https://gitlab.haskell.org/ghc/ghc/-/issues/23478 were implemented, 64 | -- then we could avoid using 'unsafeCoerce' in the definitions below. 65 | 66 | -- | Unsafely create an 'SChar' value directly from a 'Char'. Use this function 67 | -- with care: 68 | -- 69 | -- * The 'Char' value must match the 'Char' @c@ encoded in the return type 70 | -- @'SChar' c@. 71 | -- 72 | -- * Be wary of using this function to create multiple values of type 73 | -- @'SChar' T@, where @T@ is a type family that does not reduce (e.g., 74 | -- @Any@ from "GHC.Exts"). If you do, GHC is liable to optimize away one of 75 | -- the values and replace it with the other during a common subexpression 76 | -- elimination pass. If the two values have different underlying 'Char' 77 | -- values, this could be disastrous. 78 | unsafeSChar :: Char -> SChar c 79 | unsafeSChar = unsafeCoerce 80 | 81 | -- | Unsafely create an 'SNat' value directly from a 'Natural'. Use this 82 | -- function with care: 83 | -- 84 | -- * The 'Natural' value must match the 'Nat' @n@ encoded in the return type 85 | -- @'SNat' n@. 86 | -- 87 | -- * Be wary of using this function to create multiple values of type 88 | -- @'SNat' T@, where @T@ is a type family that does not reduce (e.g., 89 | -- @Any@ from "GHC.Exts"). If you do, GHC is liable to optimize away one of 90 | -- the values and replace it with the other during a common subexpression 91 | -- elimination pass. If the two values have different underlying 'Natural' 92 | -- values, this could be disastrous. 93 | unsafeSNat :: Natural -> SNat n 94 | unsafeSNat = unsafeCoerce 95 | 96 | -- | Unsafely create an 'SSymbol' value directly from a 'String'. Use this 97 | -- function with care: 98 | -- 99 | -- * The 'String' value must match the 'Symbol' @s@ encoded in the return type 100 | -- @'SSymbol' s@. 101 | -- 102 | -- * Be wary of using this function to create multiple values of type 103 | -- @'SSymbol' T@, where @T@ is a type family that does not reduce (e.g., 104 | -- @Any@ from "GHC.Exts"). If you do, GHC is liable to optimize away one of 105 | -- the values and replace it with the other during a common subexpression 106 | -- elimination pass. If the two values have different underlying 'String' 107 | -- values, this could be disastrous. 108 | unsafeSSymbol :: String -> SSymbol s 109 | unsafeSSymbol = unsafeCoerce 110 | #endif 111 | -------------------------------------------------------------------------------- /tests/GH117Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module GH117Spec (main, spec) where 8 | 9 | import Test.Hspec 10 | 11 | #if __GLASGOW_HASKELL__ >= 902 12 | import Data.Constraint 13 | import Data.Constraint.Char 14 | import Data.Proxy 15 | import GHC.TypeLits 16 | 17 | spec :: Spec 18 | spec = 19 | describe "GH #117" $ do 20 | it "should evaluate `charToNat @'a'` to 97" $ 21 | case charToNat @'a' of 22 | Sub (Dict :: Dict (KnownNat n)) -> 23 | natVal (Proxy @n) `shouldBe` 97 24 | it "should evaluate `natToChar @97` to 'a'" $ 25 | case natToChar @97 of 26 | Sub (Dict :: Dict (KnownChar c)) -> 27 | charVal (Proxy @c) `shouldBe` 'a' 28 | #else 29 | spec :: Spec 30 | spec = return () 31 | #endif 32 | 33 | main :: IO () 34 | main = hspec spec 35 | -------------------------------------------------------------------------------- /tests/GH55Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module GH55Spec (main, spec) where 9 | 10 | import Data.Constraint 11 | import Data.Constraint.Nat 12 | import GHC.TypeLits 13 | import Test.Hspec 14 | 15 | newtype GF (n :: Nat) = GF Integer deriving (Eq, Show) 16 | 17 | instance KnownNat n => Num (GF n) where 18 | xf@(GF a) + GF b = GF $ (a+b) `mod` (natVal xf) 19 | xf@(GF a) - GF b = GF $ (a-b) `mod` (natVal xf) 20 | xf@(GF a) * GF b = GF $ (a*b) `mod` (natVal xf) 21 | abs = id 22 | signum xf@(GF a) | a==0 = xf 23 | | otherwise = GF 1 24 | fromInteger = GF 25 | 26 | x :: GF 5 27 | x = GF 3 28 | 29 | y :: GF 5 30 | y = GF 4 31 | 32 | foo :: (KnownNat m, KnownNat n) => GF m -> GF n -> GF (Lcm m n) 33 | foo m@(GF a) n@(GF b) = GF $ (a*b) `mod` (lcm (natVal m) (natVal n)) 34 | 35 | bar :: (KnownNat m) => GF m -> GF m -> GF m 36 | bar (a :: GF m) b = foo a b - foo b a \\ Sub @() (lcmIsIdempotent @m) \\ lcmNat @m @m 37 | 38 | z :: GF 5 39 | z = bar x y 40 | 41 | spec :: Spec 42 | spec = describe "GH #53" $ 43 | it "should normalize Lcm m m" $ 44 | z `shouldBe` (GF 0 :: GF (Lcm 5 5)) 45 | 46 | main :: IO () 47 | main = hspec spec 48 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------