├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .gitmodules ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.haskell-ci ├── cabal.project ├── eliminators.cabal ├── src └── Data │ ├── Eliminator.hs │ └── Eliminator │ ├── Functor.hs │ ├── Monoid.hs │ ├── Semigroup.hs │ ├── TH.hs │ ├── TypeLits.hs │ └── TypeNats.hs └── tests ├── DecideSpec.hs ├── DecideTypes.hs ├── EqualitySpec.hs ├── EqualityTypes.hs ├── GADTSpec.hs ├── Internal.hs ├── ListSpec.hs ├── ListTypes.hs ├── MatchabilizeSpec.hs ├── MatchabilizeTypes.hs ├── PolyRecTypes.hs ├── Spec.hs ├── VecSpec.hs └── VecTypes.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 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.20241222 12 | # 13 | # REGENDATA ("0.19.20241222",["github","cabal.project"]) 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:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.1 32 | compilerKind: ghc 33 | compilerVersion: 9.12.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | fail-fast: false 37 | steps: 38 | - name: apt-get install 39 | run: | 40 | apt-get update 41 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 42 | - name: Install GHCup 43 | run: | 44 | mkdir -p "$HOME/.ghcup/bin" 45 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 46 | chmod a+x "$HOME/.ghcup/bin/ghcup" 47 | - name: Install cabal-install (prerelease) 48 | run: | 49 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 50 | "$HOME/.ghcup/bin/ghcup" install cabal 3.15.0.0.2024.10.3 || (cat "$HOME"/.ghcup/logs/*.* && false) 51 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.15.0.0.2024.10.3 -vnormal+nowrap" >> "$GITHUB_ENV" 52 | - name: Install GHC (GHCup) 53 | if: matrix.setup-method == 'ghcup' 54 | run: | 55 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 56 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 57 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 58 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 59 | echo "HC=$HC" >> "$GITHUB_ENV" 60 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 61 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 62 | env: 63 | HCKIND: ${{ matrix.compilerKind }} 64 | HCNAME: ${{ matrix.compiler }} 65 | HCVER: ${{ matrix.compilerVersion }} 66 | - name: Set PATH and environment variables 67 | run: | 68 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 69 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 70 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 71 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 72 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 73 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 74 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 75 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 76 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 77 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 78 | env: 79 | HCKIND: ${{ matrix.compilerKind }} 80 | HCNAME: ${{ matrix.compiler }} 81 | HCVER: ${{ matrix.compilerVersion }} 82 | - name: env 83 | run: | 84 | env 85 | - name: write cabal config 86 | run: | 87 | mkdir -p $CABAL_DIR 88 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 121 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 122 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 123 | rm -f cabal-plan.xz 124 | chmod a+x $HOME/.cabal/bin/cabal-plan 125 | cabal-plan --version 126 | - name: checkout 127 | uses: actions/checkout@v4 128 | with: 129 | path: source 130 | - name: initial cabal.project for sdist 131 | run: | 132 | touch cabal.project 133 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 134 | cat cabal.project 135 | - name: sdist 136 | run: | 137 | mkdir -p sdist 138 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 139 | - name: unpack 140 | run: | 141 | mkdir -p unpacked 142 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 143 | - name: generate cabal.project 144 | run: | 145 | PKGDIR_eliminators="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/eliminators-[0-9.]*')" 146 | echo "PKGDIR_eliminators=${PKGDIR_eliminators}" >> "$GITHUB_ENV" 147 | rm -f cabal.project cabal.project.local 148 | touch cabal.project 149 | touch cabal.project.local 150 | echo "packages: ${PKGDIR_eliminators}" >> cabal.project 151 | echo "package eliminators" >> cabal.project 152 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 153 | cat >> cabal.project <> cabal.project.local 158 | cat cabal.project 159 | cat cabal.project.local 160 | - name: dump install plan 161 | run: | 162 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 163 | cabal-plan 164 | - name: restore cache 165 | uses: actions/cache/restore@v4 166 | with: 167 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 168 | path: ~/.cabal/store 169 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 170 | - name: install dependencies 171 | run: | 172 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 173 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 174 | - name: build 175 | run: | 176 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 177 | - name: tests 178 | run: | 179 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 180 | - name: cabal check 181 | run: | 182 | cd ${PKGDIR_eliminators} || false 183 | ${CABAL} -vnormal check 184 | - name: haddock 185 | run: | 186 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 187 | - name: save cache 188 | if: always() 189 | uses: actions/cache/save@v4 190 | with: 191 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 192 | path: ~/.cabal/store 193 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/RyanGlScott/eliminators/c9654f256f85ddcd75eb0df4df58633cf14d3706/.gitmodules -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ### 0.9.6 [2024.12.30] 2 | * Require `singletons-base-3.5` and GHC 9.12. 3 | 4 | ### 0.9.5 [2024.05.12] 5 | * Require `singletons-base-3.4` and GHC 9.10. 6 | 7 | ### 0.9.4 [2023.10.13] 8 | * Require `singletons-base-3.3` and GHC 9.8. 9 | 10 | ### 0.9.3 [2023.03.12] 11 | * Require `singletons-base-3.2` and GHC 9.6. 12 | 13 | ### 0.9.2 [2023.02.27] 14 | * Support building with `th-abstraction-0.5.*`. 15 | 16 | ### 0.9.1 [2022.08.23] 17 | * Require GHC 9.4. 18 | * Add `Data.Eliminator.TypeLits`, which re-exports 19 | `Data.Eliminator.TypeNats.elimNat` and adds a new `elimSymbol` eliminator 20 | for `GHC.TypeLits.Symbol`. 21 | 22 | ## 0.9 [2021.10.31] 23 | * Require `singletons-base-3.1` and GHC 9.2. 24 | * Add `{e,E}limProxy` to `Data.Eliminator`. 25 | * `Data.Eliminator` no longer exports `{e,E}limFirst` and `{e,E}limLast` 26 | eliminators. If you wish to use eliminators that work over `First`/`Last` 27 | from `Data.Monoid`, you must import them `Data.Eliminator.Monoid`. If you 28 | wish to use eliminators that over `First`/`Last` from `Data.Semigroup`, you 29 | must import them from the new `Data.Eliminator.Semigroup` module. 30 | * `Data.Eliminator` no longer exports `{e,E}limProduct` and `{e,E}limSum` 31 | eliminators. If you wish to use eliminators that work over `Product`/`Sum` 32 | from `Data.Monoid` or `Data.Semigroup`, you must import them 33 | `Data.Eliminator.Monoid` or `Data.Eliminator.Semigroup`. If you wish to use 34 | eliminators that over `Product`/`Sum` from 35 | `Data.Functor.Product`/`Data.Functor.Sum`, you must import them from the new 36 | `Data.Eliminator.Functor` module. 37 | 38 | ## 0.8 [2021.03.12] 39 | * Require `singletons-base-3.0` and GHC 9.0. 40 | * Remove eliminators for `Data.Semigroup.Option`, which is deprecated as of 41 | `base-4.15.0.0`. 42 | 43 | ## 0.7 [2020.03.25] 44 | * Require `singletons-2.7` and GHC 8.10. 45 | * Add experimental support for generating type-level eliminators through the 46 | `deriveTypeElim` and `deriveTypeElimNamed` functions. 47 | * Add eliminators for `All`, `Any`, `Arg`, `Const`, `Down`, `Dual`, `First`, 48 | `Identity`, `Last`, `Max`, `Min`, `Option`, `Product`, `Sum`, 49 | and `WrappedMonoid`. 50 | 51 | ## 0.6 [2019.08.27] 52 | * Require `singletons-2.6` and GHC 8.8. 53 | 54 | ### 0.5.1 [2019.04.26] 55 | * Support `th-abstraction-0.3.0.0` or later. 56 | 57 | ## 0.5 [2018.09.18] 58 | * Require `singletons-2.5` and GHC 8.6. 59 | 60 | ### 0.4.1 [2018.02.13] 61 | * Add `elimVoid` to `Data.Eliminator`. 62 | 63 | ## 0.4 [2018.01.09] 64 | * Require `singletons-2.4` and GHC 8.4. 65 | 66 | ## 0.3 [2017-11-07] 67 | * Migrate the old `elimNat` from `Data.Eliminator` (which worked over the `Nat` 68 | from `GHC.TypeNats`) to `Data.Eliminator.TypeNats`. There `elimNat` that now 69 | lives in `Data.Eliminator` is for an unrelated `Nat` data type from the 70 | `singleton-nats` package (which is a proper, inductively defined, Peano 71 | natural number type). 72 | 73 | ## 0.2 [2017-07-22] 74 | * Introduce the `Data.Eliminator.TH` module, which provides functionality for 75 | generating eliminator functions using Template Haskell. Currently, only 76 | simple algebraic data types that do not use polymorphic recursion are 77 | supported. 78 | * All eliminators now use predicates with `(~>)`. 79 | 80 | ## 0.1 [2017-07-02] 81 | * Initial release. 82 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Ryan Scott 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 are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ryan Scott nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `eliminators` 2 | [![Hackage](https://img.shields.io/hackage/v/eliminators.svg)][Hackage: eliminators] 3 | [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/eliminators.svg)](http://packdeps.haskellers.com/reverse/eliminators) 4 | [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] 5 | [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] 6 | [![Build Status](https://github.com/RyanGlScott/eliminators/workflows/Haskell-CI/badge.svg)](https://github.com/RyanGlScott/eliminators/actions?query=workflow%3AHaskell-CI) 7 | 8 | [Hackage: eliminators]: 9 | http://hackage.haskell.org/package/eliminators 10 | "eliminators package on Hackage" 11 | [Haskell.org]: 12 | http://www.haskell.org 13 | "The Haskell Programming Language" 14 | [tl;dr Legal: BSD3]: 15 | https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 16 | "BSD 3-Clause License (Revised)" 17 | 18 | This library provides eliminators for inductive data types, leveraging the power of the `singletons` library to allow dependently typed elimination. 19 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: jammy 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | local-ghc-options: -Werror 5 | -- Needed to avoid https://github.com/haskell/cabal/issues/9917 6 | installed: +all -Cabal -Cabal-syntax 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /eliminators.cabal: -------------------------------------------------------------------------------- 1 | name: eliminators 2 | version: 0.9.6 3 | synopsis: Dependently typed elimination functions using singletons 4 | description: This library provides eliminators for inductive data types, 5 | leveraging the power of the @singletons@ library to allow 6 | dependently typed elimination. 7 | homepage: https://github.com/RyanGlScott/eliminators 8 | bug-reports: https://github.com/RyanGlScott/eliminators/issues 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Ryan Scott 12 | maintainer: Ryan Scott 13 | stability: Experimental 14 | copyright: (C) 2017 Ryan Scott 15 | category: Dependent Types 16 | build-type: Simple 17 | extra-source-files: CHANGELOG.md, README.md 18 | cabal-version: >=1.10 19 | tested-with: GHC == 9.12.1 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/RyanGlScott/eliminators 24 | 25 | library 26 | exposed-modules: Data.Eliminator 27 | Data.Eliminator.Functor 28 | Data.Eliminator.Monoid 29 | Data.Eliminator.Semigroup 30 | Data.Eliminator.TH 31 | Data.Eliminator.TypeLits 32 | Data.Eliminator.TypeNats 33 | build-depends: base >= 4.21 && < 4.22 34 | , extra >= 1.4.2 && < 1.9 35 | , singletons-base >= 3.5 && < 3.6 36 | , singleton-nats >= 0.4.2 && < 0.5 37 | , template-haskell >= 2.23 && < 2.24 38 | , text >= 2.0.1 && < 2.2 39 | , th-abstraction >= 0.4 && < 0.8 40 | , th-desugar >= 1.18 && < 1.19 41 | hs-source-dirs: src 42 | default-language: GHC2021 43 | ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors -fenable-th-splice-warnings 44 | 45 | test-suite spec 46 | type: exitcode-stdio-1.0 47 | main-is: Spec.hs 48 | other-modules: DecideSpec 49 | DecideTypes 50 | EqualitySpec 51 | EqualityTypes 52 | GADTSpec 53 | Internal 54 | MatchabilizeSpec 55 | MatchabilizeTypes 56 | ListSpec 57 | ListTypes 58 | PolyRecTypes 59 | VecTypes 60 | VecSpec 61 | build-depends: base >= 4.21 && < 4.22 62 | , eliminators 63 | , hspec >= 2 && < 3 64 | , singletons-base >= 3.5 && < 3.6 65 | , singleton-nats >= 0.4.2 && < 0.5 66 | build-tool-depends: hspec-discover:hspec-discover 67 | hs-source-dirs: tests 68 | default-language: GHC2021 69 | ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors -fenable-th-splice-warnings -threaded -rtsopts 70 | -------------------------------------------------------------------------------- /src/Data/Eliminator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-| 8 | Module: Data.Eliminator 9 | Copyright: (C) 2017 Ryan Scott 10 | License: BSD-style (see the file LICENSE) 11 | Maintainer: Ryan Scott 12 | Stability: Experimental 13 | Portability: GHC 14 | 15 | Dependently typed elimination functions using @singletons@. 16 | 17 | This module exports a combination of eliminators whose names are known not to 18 | clash with each other. Potential name conflicts have been resolved by putting 19 | the conflicting names in separate modules: 20 | 21 | * "Data.Eliminator" defines 'elimNat', which works over the 'Nat' data type 22 | from "Data.Nat". For an eliminator that works over 'Nat' from "GHC.TypeNats", 23 | see "Data.Eliminator.TypeNats". 24 | 25 | * "Data.Eliminator" avoids exporting eliminators for @First@ and @Last@ data 26 | types, as there are multiple data types with these names. If you want 27 | eliminators for the 'First' and 'Last' data types from "Data.Monoid", import 28 | them from "Data.Eliminator.Monoid". If you want eliminators for the 'First' 29 | and 'Last' data types from "Data.Semigroup", import them from 30 | "Data.Eliminator.Semigroup". 31 | 32 | * "Data.Eliminator" avoids exporting eliminators for @Product@ and @Sum@ data 33 | types, as there are multiple data types with these names. If you want 34 | eliminators for the 'Product' and 'Sum' data types from "Data.Monoid" or 35 | "Data.Semigroup", import them from "Data.Eliminator.Monoid" or 36 | "Data.Eliminator.Semigroup". If you want eliminators for the 'Product' and 37 | 'Sum' data types from "Data.Functor.Product" and "Data.Functor.Sum", 38 | respectively, import them from "Data.Eliminator.Functor". 39 | -} 40 | module Data.Eliminator ( 41 | -- * Eliminator functions 42 | -- $eliminators 43 | elimAll 44 | , ElimAll 45 | , elimAny 46 | , ElimAny 47 | , elimArg 48 | , ElimArg 49 | , elimBool 50 | , ElimBool 51 | , elimConst 52 | , ElimConst 53 | , elimDown 54 | , ElimDown 55 | , elimDual 56 | , ElimDual 57 | , elimEither 58 | , ElimEither 59 | , elimIdentity 60 | , ElimIdentity 61 | , elimList 62 | , ElimList 63 | , elimMax 64 | , ElimMax 65 | , elimMaybe 66 | , ElimMaybe 67 | , elimMin 68 | , ElimMin 69 | , elimNat 70 | , ElimNat 71 | , elimNonEmpty 72 | , ElimNonEmpty 73 | , elimOrdering 74 | , ElimOrdering 75 | , elimProxy 76 | , ElimProxy 77 | , elimTuple0 78 | , ElimTuple0 79 | , elimTuple2 80 | , ElimTuple2 81 | , elimTuple3 82 | , ElimTuple3 83 | , elimTuple4 84 | , ElimTuple4 85 | , elimTuple5 86 | , ElimTuple5 87 | , elimTuple6 88 | , ElimTuple6 89 | , elimTuple7 90 | , ElimTuple7 91 | , elimVoid 92 | , ElimVoid 93 | , elimWrappedMonoid 94 | , ElimWrappedMonoid 95 | ) where 96 | 97 | import Control.Monad.Extra 98 | 99 | import Data.Eliminator.Functor 100 | import Data.Eliminator.Monoid 101 | import Data.Eliminator.Semigroup 102 | import Data.Eliminator.TH 103 | import Data.List.NonEmpty (NonEmpty(..)) 104 | import Data.List.NonEmpty.Singletons (SNonEmpty(..)) 105 | import Data.Nat 106 | import Data.Ord (Down(..)) 107 | import Data.Ord.Singletons (SDown(..)) 108 | import Data.Proxy.Singletons (SProxy(..)) 109 | import Data.Void (Void) 110 | 111 | import Language.Haskell.TH (nameBase) 112 | import Language.Haskell.TH.Desugar (tupleNameDegree_maybe) 113 | 114 | import Prelude.Singletons 115 | 116 | {- $eliminators 117 | 118 | These eliminators are defined with propositions of kind @\ ~> 'Type'@ 119 | (that is, using the @('~>')@ kind). These eliminators are designed for 120 | defunctionalized (i.e., \"partially applied\") types as predicates, 121 | and as a result, the predicates must be applied manually with 'Apply'. 122 | 123 | The naming conventions are: 124 | 125 | * If the datatype has an alphanumeric name, its eliminator will have that name 126 | with @elim@ prepended. 127 | 128 | * If the datatype has a symbolic name, its eliminator will have that name 129 | with @~>@ prepended. 130 | -} 131 | 132 | $(concatMapM (\n -> (++) <$> deriveElim n <*> deriveTypeElim n) 133 | [ ''Bool 134 | , ''Down 135 | , ''Either 136 | , ''Maybe 137 | , ''Nat 138 | , ''NonEmpty 139 | , ''Ordering 140 | , ''Proxy 141 | , ''Void 142 | ]) 143 | $(deriveElimNamed "elimList" ''[]) 144 | $(deriveTypeElimNamed "ElimList" ''[]) 145 | $(concatMapM (\n -> do deg <- fromMaybeM (fail $ "Internal error: " 146 | ++ nameBase n 147 | ++ " is not the name of a tuple") 148 | (pure $ tupleNameDegree_maybe n) 149 | terms <- deriveElimNamed ("elimTuple" ++ show deg) n 150 | types <- deriveTypeElimNamed ("ElimTuple" ++ show deg) n 151 | pure $ terms ++ types) 152 | [''(), ''(,), ''(,,), ''(,,,), ''(,,,,), ''(,,,,,), ''(,,,,,,)]) 153 | -------------------------------------------------------------------------------- /src/Data/Eliminator/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-| 7 | Module: Data.Eliminator.Functor 8 | Copyright: (C) 2021 Ryan Scott 9 | License: BSD-style (see the file LICENSE) 10 | Maintainer: Ryan Scott 11 | Stability: Experimental 12 | Portability: GHC 13 | 14 | Eliminator functions for data types in the @Data.Functor.*@ module namespace. 15 | All of these are re-exported from "Data.Eliminator" with the exceptions of 16 | 'Sum' and 'Product', as these clash with eliminators of the same names in 17 | "Data.Eliminator.Semigroup" and "Data.Eliminator.Monoid". 18 | -} 19 | module Data.Eliminator.Functor ( 20 | elimConst 21 | , ElimConst 22 | , elimIdentity 23 | , ElimIdentity 24 | , elimProduct 25 | , ElimProduct 26 | , elimSum 27 | , ElimSum 28 | ) where 29 | 30 | import Control.Monad.Extra 31 | 32 | import Data.Eliminator.TH 33 | import Data.Functor.Const (Const(..)) 34 | import Data.Functor.Const.Singletons (SConst(..)) 35 | import Data.Functor.Identity (Identity(..)) 36 | import Data.Functor.Identity.Singletons (SIdentity(..)) 37 | import Data.Functor.Product (Product(..)) 38 | import Data.Functor.Product.Singletons (SProduct(..)) 39 | import Data.Functor.Sum (Sum(..)) 40 | import Data.Functor.Sum.Singletons (SSum(..)) 41 | 42 | $(concatMapM (\n -> (++) <$> deriveElim n <*> deriveTypeElim n) 43 | [ ''Const 44 | , ''Identity 45 | , ''Product 46 | , ''Sum 47 | ]) 48 | -------------------------------------------------------------------------------- /src/Data/Eliminator/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-| 7 | Module: Data.Eliminator.Monoid 8 | Copyright: (C) 2021 Ryan Scott 9 | License: BSD-style (see the file LICENSE) 10 | Maintainer: Ryan Scott 11 | Stability: Experimental 12 | Portability: GHC 13 | 14 | Eliminator functions for data types in "Data.Monoid". All of these are 15 | re-exported from "Data.Eliminator" with the following exceptions: 16 | 17 | * 'First' and 'Last' are not re-exported from "Data.Eliminator", as they clash 18 | with eliminators of the same names in "Data.Eliminator.Functor" and 19 | "Data.Eliminator.Semigroup". 20 | 21 | * 'Sum' and 'Product' are not re-exported from "Data.Eliminator", as they clash 22 | with eliminators of the same names in "Data.Eliminator.Functor". 23 | -} 24 | module Data.Eliminator.Monoid ( 25 | elimAll 26 | , ElimAll 27 | , elimAny 28 | , ElimAny 29 | , elimDual 30 | , ElimDual 31 | , elimFirst 32 | , ElimFirst 33 | , elimLast 34 | , ElimLast 35 | , elimProduct 36 | , ElimProduct 37 | , elimSum 38 | , ElimSum 39 | ) where 40 | 41 | import Control.Monad.Extra 42 | 43 | import Data.Eliminator.TH 44 | import Data.Monoid 45 | import Data.Monoid.Singletons 46 | 47 | $(concatMapM (\n -> (++) <$> deriveElim n <*> deriveTypeElim n) 48 | [ ''All 49 | , ''Any 50 | , ''Dual 51 | , ''First 52 | , ''Last 53 | , ''Product 54 | , ''Sum 55 | ]) 56 | -------------------------------------------------------------------------------- /src/Data/Eliminator/Semigroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-| 7 | Module: Data.Eliminator.Semigroup 8 | Copyright: (C) 2021 Ryan Scott 9 | License: BSD-style (see the file LICENSE) 10 | Maintainer: Ryan Scott 11 | Stability: Experimental 12 | Portability: GHC 13 | 14 | Eliminator functions for data types in "Data.Semigroup". All of these are 15 | re-exported from "Data.Eliminator" with the following exceptions: 16 | 17 | * 'First' and 'Last' are not re-exported from "Data.Eliminator", as they clash 18 | with eliminators of the same names in "Data.Eliminator.Functor" and 19 | "Data.Eliminator.Monoid". 20 | 21 | * 'Sum' and 'Product' are not re-exported from "Data.Eliminator", as they clash 22 | with eliminators of the same names in "Data.Eliminator.Functor". 23 | -} 24 | module Data.Eliminator.Semigroup ( 25 | elimAll 26 | , ElimAll 27 | , elimAny 28 | , ElimAny 29 | , elimArg 30 | , ElimArg 31 | , elimDual 32 | , ElimDual 33 | , elimFirst 34 | , ElimFirst 35 | , elimLast 36 | , ElimLast 37 | , elimMax 38 | , ElimMax 39 | , elimMin 40 | , ElimMin 41 | , elimProduct 42 | , ElimProduct 43 | , elimSum 44 | , ElimSum 45 | , elimWrappedMonoid 46 | , ElimWrappedMonoid 47 | ) where 48 | 49 | import Control.Monad.Extra 50 | 51 | import Data.Eliminator.Monoid hiding (elimFirst, ElimFirst, elimLast, ElimLast) 52 | import Data.Eliminator.TH 53 | import Data.Semigroup 54 | import Data.Semigroup.Singletons 55 | 56 | $(concatMapM (\n -> (++) <$> deriveElim n <*> deriveTypeElim n) 57 | [ ''Arg 58 | , ''First 59 | , ''Last 60 | , ''Max 61 | , ''Min 62 | , ''WrappedMonoid 63 | ]) 64 | -------------------------------------------------------------------------------- /src/Data/Eliminator/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskellQuotes #-} 4 | {-# LANGUAGE Unsafe #-} 5 | {-| 6 | Module: Data.Eliminator.TH 7 | Copyright: (C) 2017 Ryan Scott 8 | License: BSD-style (see the file LICENSE) 9 | Maintainer: Ryan Scott 10 | Stability: Experimental 11 | Portability: GHC 12 | 13 | Generate dependently typed elimination functions using Template Haskell. 14 | -} 15 | module Data.Eliminator.TH ( 16 | -- * Eliminator generation 17 | -- ** Term-level eliminators 18 | -- $term-conventions 19 | deriveElim 20 | , deriveElimNamed 21 | -- ** Type-level eliminators 22 | -- $type-conventions 23 | , deriveTypeElim 24 | , deriveTypeElimNamed 25 | ) where 26 | 27 | import Control.Monad 28 | 29 | import Data.Char (isLetter, isUpper, toUpper) 30 | import Data.Foldable 31 | import qualified Data.Kind as Kind (Type) 32 | import Data.Maybe 33 | import Data.Proxy 34 | import Data.Singletons.TH.Options 35 | 36 | import Language.Haskell.TH 37 | import Language.Haskell.TH.Datatype as Datatype 38 | import Language.Haskell.TH.Datatype.TyVarBndr 39 | import Language.Haskell.TH.Desugar hiding (DataFlavor(..)) 40 | 41 | import Prelude.Singletons 42 | 43 | {- $term-conventions 44 | 'deriveElim' and 'deriveElimNamed' provide a way to automate the creation of 45 | eliminator functions, which are mostly boilerplate. Here is a complete example 46 | showing how one might use 'deriveElim': 47 | 48 | @ 49 | $('singletons' [d| data MyList a = MyNil | MyCons a (MyList a) |]) 50 | $('deriveElim' ''MyList) 51 | @ 52 | 53 | This will produce an eliminator function that looks roughly like the following: 54 | 55 | @ 56 | elimMyList :: forall (a :: 'Type') (p :: MyList a '~>' 'Type') (l :: MyList a). 57 | 'Sing' l 58 | -> 'Apply' p MyNil 59 | -> (forall (x :: a). 'Sing' x 60 | -> forall (xs :: MyList a). 'Sing' xs -> 'Apply' p xs 61 | -> 'Apply' p (MyCons x xs)) 62 | -> 'Apply' p l 63 | elimMyList SMyNil pMyNil _ = pMyNil 64 | elimMyList (SMyCons (x' :: 'Sing' x) (xs' :: 'Sing' xs)) pMyNil pMyCons 65 | = pMyCons x' xs' (elimMyList \@a \@p \@xs pMyNil pMyCons) 66 | @ 67 | 68 | There are some important things to note here: 69 | 70 | * Because these eliminators use 'Sing' under the hood, in order for 71 | 'deriveElim' to work, the 'Sing' instance for the data type given as an 72 | argument must be in scope. Moreover, 'deriveElim' assumes the naming 73 | conventions for singled constructors used by the @singletons@ library. 74 | (This is why the 'singletons' function is used in the example above). 75 | 76 | * There is a convention for the order in which the arguments appear. 77 | The quantified type variables appear in this order: 78 | 79 | 1. First, the type variables of the data type itself (@a@, in the above example). 80 | 81 | 2. Second, a predicate type variable of kind @\ '~>' 'Type'@ 82 | (@p@, in the above example). 83 | 84 | 3. Finally, a type variable of kind @\@ (@l@, in the above example). 85 | 86 | The function arguments appear in this order: 87 | 88 | 1. First, a 'Sing' argument (@'Sing' l@, in the above example). 89 | 90 | 2. Next, there are arguments that correspond to each constructor. More on this 91 | in a second. 92 | 93 | The return type is the predicate type variable applied to the data type 94 | (@'Apply' p (MyCons x xs)@, the above example). 95 | 96 | The type of each constructor argument also follows certain conventions: 97 | 98 | 1. For each field, there will be a rank-2 type variable whose kind matches 99 | the type of the field, followed by a matching 'Sing' type. For instance, 100 | in the above example, @forall (x :: a). 'Sing' x@ corresponds to the 101 | first field of @MyCons@. 102 | 103 | 2. In addition, if the field is a recursive occurrence of the data type, 104 | an additional argument will follow the 'Sing' type. This is best 105 | explained using the above example. In the @MyCons@ constructor, the second 106 | field (of type @MyCons a@) is a recursive occurrence of @MyCons@, so 107 | that corresponds to the type 108 | @forall (xs :: MyList a). 'Sing' xs -> 'Apply' p xs@, where @'Apply' p xs@ 109 | is only present due to the recursion. 110 | 111 | 3. Finally, the return type will be the predicate type variable applied 112 | to a saturated occurrence of the data constructor 113 | (@'Apply' p (MyCons x xs)@, in the above example). 114 | 115 | * You'll need to enable lots of GHC extensions in order for the code generated 116 | by 'deriveElim' to typecheck. You'll need at least the following: 117 | 118 | * @AllowAmbiguousTypes@ 119 | 120 | * @DataKinds@ 121 | 122 | * @GADTs@ 123 | 124 | * @PolyKinds@ 125 | 126 | * @RankNTypes@ 127 | 128 | * @ScopedTypeVariables@ 129 | 130 | * @TemplateHaskell@ 131 | 132 | * @TypeApplications@ 133 | 134 | * 'deriveElim' doesn't support every possible data type at the moment. 135 | It is known not to work for the following: 136 | 137 | * Data types defined using @GADTs@ or @ExistentialQuantification@ 138 | 139 | * Data family instances 140 | 141 | * Data types which use polymorphic recursion 142 | (e.g., @data Foo a = Foo (Foo a)@) 143 | -} 144 | 145 | -- | @'deriveElim' dataName@ generates a top-level elimination function for the 146 | -- datatype @dataName@. The eliminator will follow these naming conventions: 147 | -- 148 | -- * If the datatype has an alphanumeric name, its eliminator will have that name 149 | -- with @elim@ prepended. 150 | -- 151 | -- * If the datatype has a symbolic name, its eliminator will have that name 152 | -- with @~>@ prepended. 153 | deriveElim :: Name -> Q [Dec] 154 | deriveElim dataName = deriveElimNamed (eliminatorName dataName) dataName 155 | 156 | -- | @'deriveElimNamed' funName dataName@ generates a top-level elimination 157 | -- function named @funName@ for the datatype @dataName@. 158 | deriveElimNamed :: String -> Name -> Q [Dec] 159 | deriveElimNamed = deriveElimNamed' (Proxy @IsTerm) 160 | 161 | {- $type-conventions 162 | 'deriveTypeElim' and 'deriveTypeElimNamed' are like 'deriveElim' and 163 | 'deriveElimNamed' except that they create /type/-level eliminators instead of 164 | term-level ones. Here is an example showing how one might use 165 | 'deriveTypeElim': 166 | 167 | @ 168 | data MyList a = MyNil | MyCons a (MyList a) 169 | $('deriveTypeElim' ''MyList) 170 | @ 171 | 172 | This will produce an eliminator function that looks roughly like the following: 173 | 174 | @ 175 | type ElimMyList :: forall (a :: 'Type'). 176 | forall (p :: MyList a '~>' 'Type') (l :: MyList a) 177 | -> 'Apply' p MyNil 178 | -> (forall (x :: a) (xs :: MyList a) 179 | -> 'Apply' p xs '~>' 'Apply' p (MyCons x xs)) 180 | -> 'Apply' p l 181 | type family ElimMyList p l pMyNil pMyCons where 182 | forall (a :: 'Type') 183 | (p :: MyList a ~> 'Type') 184 | (pMyNil :: 'Apply' p MyNil) 185 | (pMyCons :: forall (x :: a) (xs :: MyList a) 186 | -> 'Apply' p xs '~>' 'Apply' p (MyCons x xs)). 187 | ElimMyList @a p MyNil pMyNil pMyCons = 188 | pMyNil 189 | forall (a :: 'Type') 190 | (p :: MyList a ~> 'Type') 191 | (_pMyNil :: 'Apply' p MyNil) 192 | (pMyCons :: forall (x :: a) (xs :: MyList a) 193 | -> 'Apply' p xs '~>' 'Apply' p (MyCons x xs)) 194 | x' xs'. 195 | ElimMyList @a p (MyCons x' xs') pMyNil pMyCons = 196 | 'Apply' (pMyCons x' xs') (ElimMyList @a p xs' pMyNil pMyCons) 197 | @ 198 | 199 | Note the following differences from a term-level eliminator that 'deriveElim' 200 | would generate: 201 | 202 | * Type-level eliminators do not use 'Sing'. Instead, they use visible dependent 203 | quantification. That is, instead of generating 204 | @forall (x :: a). Sing x -> ...@ (as a term-level eliminator would do), a 205 | type-level eliminator would use @forall (x :: a) -> ...@. 206 | 207 | * Term-level eliminators quantify @p@ with an invisible @forall@, whereas 208 | type-level eliminators quantify @p@ with a visible @forall@. (Really, @p@ 209 | ought to be quantified visibly in both forms of eliminator, but GHC does not 210 | yet support visible dependent quantification at the term level.) 211 | 212 | * Type-level eliminators use ('~>') in certain places where (@->@) would appear 213 | in term-level eliminators. For instance, note the use of 214 | @'Apply' p xs '~>' 'Apply' p (MyCons x xs)@ in @ElimMyList@ above. This is 215 | done to make it easier to use type-level eliminators with defunctionalization 216 | symbols (which aren't necessary for term-level eliminators). 217 | 218 | This comes with a notable drawback: type-level eliminators cannot support 219 | data constructors where recursive occurrences of the data type appear in a 220 | position other than the last field of a constructor. In other words, 221 | 'deriveTypeElim' works on the @MyList@ example above, but not this variant: 222 | 223 | @ 224 | data SnocList a = SnocNil | SnocCons (SnocList a) a 225 | @ 226 | 227 | This is because @$('deriveTypeElim' ''SnocList)@ would generate an eliminator 228 | with the following kind: 229 | 230 | @ 231 | type ElimSnocList :: forall (a :: 'Type'). 232 | forall (p :: SnocList a '~>' 'Type') (l :: SnocList a) 233 | -> 'Apply' p SnocNil 234 | -> (forall (xs :: SnocList a) -> 'Apply' p xs 235 | '~>' (forall (x :: a) -> 'Apply' p (SnocCons x xs))) 236 | -> 'Apply' p l 237 | @ 238 | 239 | Unfortunately, the kind 240 | @'Apply' p xs '~>' (forall (x :: a) -> 'Apply' p (SnocCons x xs))@ is 241 | impredicative. 242 | 243 | * In addition to the language extensions that 'deriveElim' requires, you'll need 244 | to enable these extensions in order to use 'deriveTypeElim': 245 | 246 | * @StandaloneKindSignatures@ 247 | 248 | * @UndecidableInstances@ 249 | -} 250 | 251 | -- | @'deriveTypeElim' dataName@ generates a type-level eliminator for the 252 | -- datatype @dataName@. The eliminator will follow these naming conventions: 253 | -- 254 | -- * If the datatype has an alphanumeric name, its eliminator will have that name 255 | -- with @Elim@ prepended. 256 | -- 257 | -- * If the datatype has a symbolic name, its eliminator will have that name 258 | -- with @~>@ prepended. 259 | deriveTypeElim :: Name -> Q [Dec] 260 | deriveTypeElim dataName = deriveTypeElimNamed (upcase (eliminatorName dataName)) dataName 261 | 262 | -- | @'deriveTypeElimNamed' funName dataName@ generates a type-level eliminator 263 | -- named @funName@ for the datatype @dataName@. 264 | deriveTypeElimNamed :: String -> Name -> Q [Dec] 265 | deriveTypeElimNamed = deriveElimNamed' (Proxy @IsType) 266 | 267 | -- The workhorse for deriveElim(Named). This generates either a term- or 268 | -- type-level eliminator, depending on which Eliminator instance is used. 269 | deriveElimNamed' :: 270 | Eliminator t 271 | => proxy t 272 | -> String -- The name of the eliminator function 273 | -> Name -- The name of the data type 274 | -> Q [Dec] -- The eliminator's type signature and body 275 | deriveElimNamed' prox funName dataName = do 276 | info@(DatatypeInfo { datatypeVars = dataVarBndrs 277 | , datatypeInstTypes = instTys 278 | , datatypeVariant = variant 279 | , datatypeCons = cons 280 | }) <- reifyDatatype dataName 281 | let noDataFamilies = 282 | fail "Eliminators for data family instances are currently not supported" 283 | case variant of 284 | DataInstance -> noDataFamilies 285 | NewtypeInstance -> noDataFamilies 286 | Datatype -> pure () 287 | Newtype -> pure () 288 | #if MIN_VERSION_th_abstraction(0,5,0) 289 | Datatype.TypeData -> pure () 290 | #endif 291 | predVar <- newName "p" 292 | singVar <- newName "s" 293 | let elimName = mkName funName 294 | promDataKind = datatypeType info 295 | predVarBndr = kindedTV predVar (InfixT promDataKind ''(~>) (ConT ''Kind.Type)) 296 | singVarBndr = kindedTV singVar promDataKind 297 | caseTypes <- traverse (caseType prox dataName predVar) cons 298 | unless (length (findParams info) == length instTys) $ 299 | fail "Eliminators for polymorphically recursive data types are currently not supported" 300 | let returnType = predType predVar (VarT singVar) 301 | elimType = elimTypeSig prox dataVarBndrs predVarBndr singVarBndr 302 | caseTypes returnType 303 | elimEqns <- qElimEqns prox (mkName funName) dataName 304 | dataVarBndrs predVarBndr singVarBndr 305 | caseTypes cons 306 | pure [elimSigD prox elimName elimType, elimEqns] 307 | 308 | -- Generate the type for a "case alternative" in an eliminator function's type 309 | -- signature, which is done on a constructor-by-constructor basis. 310 | caseType :: 311 | Eliminator t 312 | => proxy t 313 | -> Name -- The name of the data type 314 | -> Name -- The predicate type variable 315 | -> ConstructorInfo -- The data constructor 316 | -> Q Type -- The full case type 317 | caseType prox dataName predVar 318 | (ConstructorInfo { constructorName = conName 319 | , constructorVars = conVars 320 | , constructorContext = conContext 321 | , constructorFields = fieldTypes }) 322 | = do unless (null conVars && null conContext) $ 323 | fail $ unlines 324 | [ "Eliminators for GADTs or datatypes with existentially quantified" 325 | , "data constructors currently not supported" 326 | ] 327 | vars <- newNameList "f" $ length fieldTypes 328 | let returnType = predType predVar 329 | (foldl' AppT (ConT conName) (map VarT vars)) 330 | pure $ foldr' (\(var, varType) t -> 331 | prependElimCaseTypeVar prox dataName predVar var varType t) 332 | returnType 333 | (zip vars fieldTypes) 334 | 335 | -- Generate a single clause for a term-level eliminator's @go@ function. 336 | goCaseClause :: 337 | Name -- The name of the @go@ function 338 | -> Name -- The name of the data type 339 | -> Name -- The name of the "case alternative" to apply on the right-hand side 340 | -> ConstructorInfo -- The data constructor 341 | -> Q Clause -- The generated function clause 342 | goCaseClause goName dataName usedCaseVar 343 | (ConstructorInfo { constructorName = conName 344 | , constructorFields = fieldTypes }) 345 | = do let numFields = length fieldTypes 346 | singVars <- newNameList "s" numFields 347 | singVarSigs <- newNameList "sTy" numFields 348 | let singConName = singledDataConName defaultOptions conName 349 | mkSingVarPat var varSig = SigP (VarP var) (singType varSig) 350 | singVarPats = zipWith mkSingVarPat singVars singVarSigs 351 | 352 | mbInductiveArg singVar singVarSig varType = 353 | let inductiveArg = VarE goName `AppTypeE` VarT singVarSig 354 | `AppE` VarE singVar 355 | in mbInductiveCase dataName varType $ const inductiveArg 356 | mkArg f (singVar, singVarSig, varType) = 357 | foldAppE f $ VarE singVar 358 | : maybeToList (mbInductiveArg singVar singVarSig varType) 359 | rhs = foldl' mkArg (VarE usedCaseVar) $ 360 | zip3 singVars singVarSigs fieldTypes 361 | pure $ Clause [ConP singConName [] singVarPats] 362 | (NormalB rhs) 363 | [] 364 | 365 | -- Generate a single equation for a type-level eliminator. 366 | -- 367 | -- This code is fairly similar in structure to caseClause, but different 368 | -- enough in subtle ways that I did not attempt to de-duplicate this code as 369 | -- a method of the Eliminator class. 370 | caseTySynEqn :: 371 | Name -- The name of the eliminator function 372 | -> Name -- The name of the data type 373 | -> [TyVarBndrUnit] -- The type variables bound by the data type 374 | -> TyVarBndrUnit -- The predicate type variable 375 | -> Int -- The index of this constructor (0-indexed) 376 | -> [Type] -- The types of each "case alternative" in the eliminator 377 | -- function's type signature 378 | -> ConstructorInfo -- The data constructor 379 | -> Q TySynEqn -- The generated type family equation 380 | caseTySynEqn elimName dataName dataVarBndrs predVarBndr conIndex caseTypes 381 | (ConstructorInfo { constructorName = conName 382 | , constructorFields = fieldTypes }) 383 | = do let dataVarNames = map tvName dataVarBndrs 384 | predVarName = tvName predVarBndr 385 | numFields = length fieldTypes 386 | singVars <- newNameList "s" numFields 387 | usedCaseVar <- newName "useThis" 388 | caseVarBndrs <- flip itraverse caseTypes $ \i caseTy -> 389 | let mkVarName 390 | | i == conIndex = pure usedCaseVar 391 | | otherwise = newName ("_p" ++ show i) 392 | in liftA2 kindedTV mkVarName (pure caseTy) 393 | let caseVarNames = map tvName caseVarBndrs 394 | prefix = foldAppKindT (ConT elimName) $ map VarT dataVarNames 395 | mbInductiveArg singVar varType = 396 | let inductiveArg = foldAppT prefix $ VarT predVarName 397 | : VarT singVar 398 | : map VarT caseVarNames 399 | in mbInductiveCase dataName varType $ const inductiveArg 400 | mkArg f (singVar, varType) = 401 | foldAppDefunT (f `AppT` VarT singVar) 402 | $ maybeToList (mbInductiveArg singVar varType) 403 | bndrs = dataVarBndrs ++ predVarBndr : caseVarBndrs ++ map plainTV singVars 404 | lhs = foldAppT prefix $ VarT predVarName 405 | : foldAppT (ConT conName) (map VarT singVars) 406 | : map VarT caseVarNames 407 | rhs = foldl' mkArg (VarT usedCaseVar) $ zip singVars fieldTypes 408 | pure $ TySynEqn (Just bndrs) lhs rhs 409 | 410 | -- Are we dealing with a term or a type? 411 | data TermOrType 412 | = IsTerm 413 | | IsType 414 | 415 | -- A class that abstracts out certain common operations that one must perform 416 | -- for both term- and type-level eliminators. 417 | class Eliminator (t :: TermOrType) where 418 | -- Create the Dec for an eliminator function's type signature. 419 | elimSigD :: 420 | proxy t 421 | -> Name -- The name of the eliminator function 422 | -> Type -- The type of the eliminator function 423 | -> Dec -- The type signature Dec (SigD or KiSigD) 424 | 425 | -- Create an eliminator function's type. 426 | elimTypeSig :: 427 | proxy t 428 | -> [TyVarBndrUnit] -- The type variables bound by the data type 429 | -> TyVarBndrUnit -- The predicate type variable 430 | -> TyVarBndrUnit -- The type variable whose kind is that of the data type itself 431 | -> [Type] -- The types of each "case alternative" in the eliminator 432 | -- function's type signature 433 | -> Type -- The eliminator function's return type 434 | -> Type -- The full type 435 | 436 | -- Take a data constructor's field type and prepend it to a "case 437 | -- alternative" in an eliminator function's type signature. 438 | prependElimCaseTypeVar :: 439 | proxy t 440 | -> Name -- The name of the data type 441 | -> Name -- The predicate type variable 442 | -> Name -- A fresh type variable name 443 | -> Kind -- The field type 444 | -> Type -- The rest of the "case alternative" type 445 | -> Type -- The "case alternative" type after prepending 446 | 447 | -- Generate the clauses/equations for the body of the eliminator function. 448 | qElimEqns :: 449 | proxy t 450 | -> Name -- The name of the eliminator function 451 | -> Name -- The name of the data type 452 | -> [TyVarBndrUnit] -- The type variables bound by the data type 453 | -> TyVarBndrUnit -- The predicate type variable 454 | -> TyVarBndrUnit -- The type variable whose kind is that of the data type itself 455 | -> [Type] -- The types of each "case alternative" in the eliminator 456 | -- function's type signature 457 | -> [ConstructorInfo] -- The data constructors 458 | -> Q Dec -- The Dec containing the clauses/equations 459 | 460 | instance Eliminator IsTerm where 461 | elimSigD _ = SigD 462 | 463 | elimTypeSig _ dataVarBndrs predVarBndr singVarBndr caseTypes returnType = 464 | ForallT (changeTVFlags SpecifiedSpec $ 465 | dataVarBndrs ++ [predVarBndr, singVarBndr]) [] $ 466 | ravel (singType (tvName singVarBndr):caseTypes) returnType 467 | 468 | prependElimCaseTypeVar _ dataName predVar var varType t = 469 | ForallT [kindedTVSpecified var varType] [] $ 470 | ravel (singType var:maybeToList (mbInductiveType dataName predVar var varType)) t 471 | 472 | -- A unique characteristic of term-level eliminators is that we manually 473 | -- apply the static argument transformation, e.g., 474 | -- 475 | -- elimT :: forall a (p :: T a ~> Type) (t :: T a). 476 | -- Sing t 477 | -- -> (forall (x :: a) (xs :: T a). 478 | -- Sing x -> Sing xs -> Apply p xs -> Apply p (MkT x xs)) 479 | -- -> Apply p t 480 | -- elimT st k = go @s k 481 | -- where 482 | -- go :: forall (t' :: T a). 483 | -- Sing t' -> Apply p t' 484 | -- go (SMkT (sx :: Sing x) (sxs :: Sing xs)) = 485 | -- k sx sxs (go @xs sxs) 486 | -- 487 | -- This reduces the likelihood of recursive calls falling afoul of GHC's 488 | -- ambiguity check. 489 | qElimEqns _ elimName dataName _dataVarBndrs predVarBndr singVarBndr _caseTypes cons = do 490 | singTermVar <- newName "s" 491 | caseVars <- newNameList "p" $ length cons 492 | goName <- newName "go" 493 | let singTypeVar = tvName singVarBndr 494 | goSingTypeVar <- newName $ nameBase singTypeVar 495 | let elimRHS = VarE goName `AppTypeE` VarT singTypeVar `AppE` VarE singTermVar 496 | goSingVarBndr = mapTVName (const goSingTypeVar) singVarBndr 497 | goReturnType = predType (tvName predVarBndr) (VarT goSingTypeVar) 498 | goType = ForallT (changeTVFlags SpecifiedSpec [goSingVarBndr]) [] $ 499 | ArrowT `AppT` singType goSingTypeVar `AppT` goReturnType 500 | goClauses 501 | <- if null cons 502 | then pure [Clause [VarP singTermVar] (NormalB (CaseE (VarE singTermVar) [])) []] 503 | else zipWithM (goCaseClause goName dataName) caseVars cons 504 | pure $ FunD elimName [ Clause (map VarP (singTermVar:caseVars)) (NormalB elimRHS) 505 | [SigD goName goType, FunD goName goClauses] ] 506 | 507 | instance Eliminator IsType where 508 | elimSigD _ = KiSigD 509 | 510 | elimTypeSig _ dataVarBndrs predVarBndr singVarBndr caseTypes returnType = 511 | ForallT (changeTVFlags SpecifiedSpec dataVarBndrs) [] $ 512 | ForallVisT [predVarBndr, singVarBndr] $ 513 | ravel caseTypes returnType 514 | 515 | prependElimCaseTypeVar _ dataName predVar var varType t = 516 | ForallVisT [kindedTV var varType] $ 517 | ravelDefun (maybeToList (mbInductiveType dataName predVar var varType)) t 518 | 519 | qElimEqns _ elimName dataName dataVarBndrs predVarBndr singVarBndr caseTypes cons = do 520 | caseVarBndrs <- replicateM (length caseTypes) (plainTV <$> newName "p") 521 | let predVar = tvName predVarBndr 522 | singVar = tvName singVarBndr 523 | tyFamHead = TypeFamilyHead elimName 524 | (plainTV predVar:plainTV singVar:caseVarBndrs) 525 | NoSig Nothing 526 | caseEqns <- itraverse (\i -> caseTySynEqn elimName dataName 527 | dataVarBndrs predVarBndr i caseTypes) cons 528 | pure $ ClosedTypeFamilyD tyFamHead caseEqns 529 | 530 | mbInductiveType :: Name -> Name -> Name -> Kind -> Maybe Type 531 | mbInductiveType dataName predVar var varType = 532 | mbInductiveCase dataName varType $ const $ predType predVar $ VarT var 533 | 534 | mbInductiveCase :: Name -> Type -> ([TypeArg] -> a) -> Maybe a 535 | mbInductiveCase dataName varType inductiveArg 536 | = case unfoldType varType of 537 | (headTy, argTys) 538 | -- Annoying special case for lists 539 | | ListT <- headTy 540 | , dataName == ''[] 541 | -> Just $ inductiveArg argTys 542 | 543 | | ConT n <- headTy 544 | , dataName == n 545 | -> Just $ inductiveArg argTys 546 | 547 | | otherwise 548 | -> Nothing 549 | 550 | -- | Construct a type of the form @'Sing' x@ given @x@. 551 | singType :: Name -> Type 552 | singType x = ConT ''Sing `AppT` VarT x 553 | 554 | -- | Construct a type of the form @'Apply' p ty@ given @p@ and @ty@. 555 | predType :: Name -> Type -> Type 556 | predType p ty = ConT ''Apply `AppT` VarT p `AppT` ty 557 | 558 | -- | Generate a list of fresh names with a common prefix, and numbered suffixes. 559 | newNameList :: String -> Int -> Q [Name] 560 | newNameList prefix n = ireplicateA n $ newName . (prefix ++) . show 561 | 562 | -- Compute an eliminator function's name from the data type name. 563 | eliminatorName :: Name -> String 564 | eliminatorName n 565 | | first:_ <- nStr 566 | , isUpper first 567 | = "elim" ++ nStr 568 | 569 | | otherwise 570 | = "~>" ++ nStr 571 | where 572 | nStr = nameBase n 573 | 574 | -- Construct a function type, separating the arguments with -> 575 | ravel :: [Type] -> Type -> Type 576 | ravel args res = go args 577 | where 578 | go [] = res 579 | go (h:t) = AppT (AppT ArrowT h) (go t) 580 | 581 | -- Construct a function type, separating the arguments with ~> 582 | ravelDefun :: [Type] -> Type -> Type 583 | ravelDefun args res = go args 584 | where 585 | go [] = res 586 | go (h:t) = AppT (AppT (ConT ''(~>)) h) (go t) 587 | 588 | -- Apply an expression to a list of expressions using ordinary function applications. 589 | foldAppE :: Exp -> [Exp] -> Exp 590 | foldAppE = foldl' AppE 591 | 592 | -- Apply a type to a list of types using ordinary function applications. 593 | foldAppT :: Type -> [Type] -> Type 594 | foldAppT = foldl' AppT 595 | 596 | -- Apply a type to a list of types using defunctionalized applications 597 | -- (i.e., using Apply from singletons). 598 | foldAppDefunT :: Type -> [Type] -> Type 599 | foldAppDefunT = foldl' (\x y -> ConT ''Apply `AppT` x `AppT` y) 600 | 601 | -- Apply a type to a list of types using visible kind applications. 602 | foldAppKindT :: Type -> [Type] -> Type 603 | foldAppKindT = foldl' AppKindT 604 | 605 | itraverse :: Applicative f => (Int -> a -> f b) -> [a] -> f [b] 606 | itraverse f xs0 = go xs0 0 where 607 | go [] _ = pure [] 608 | go (x:xs) n = (:) <$> f n x <*> (go xs $! (n + 1)) 609 | 610 | ireplicateA :: Applicative f => Int -> (Int -> f a) -> f [a] 611 | ireplicateA cnt0 f = 612 | loop cnt0 0 613 | where 614 | loop cnt n 615 | | cnt <= 0 = pure [] 616 | | otherwise = liftA2 (:) (f n) (loop (cnt - 1) $! (n + 1)) 617 | 618 | -- | Find the data type constructor arguments that are parameters. 619 | -- 620 | -- Parameters are names which are unchanged across the structure. 621 | -- They appear at least once in every constructor type, always appear 622 | -- in the same argument position(s), and nothing else ever appears in those 623 | -- argument positions. 624 | -- 625 | -- This was adapted from a similar algorithm used in Idris 626 | -- (https://github.com/idris-lang/Idris-dev/blob/a13caeb4e50d0c096d34506f2ebf6b9d140a07aa/src/Idris/Elab/Utils.hs#L401-L468), 627 | -- licensed under the BSD-3-Clause license. 628 | findParams :: DatatypeInfo -> [Int] 629 | findParams (DatatypeInfo { datatypeName = dataName 630 | , datatypeInstTypes = instTys 631 | , datatypeCons = cons 632 | }) = 633 | let allapps = map getDataApp cons 634 | -- do each constructor separately, then merge the results (names 635 | -- may change between constructors) 636 | conParams = map paramPos allapps 637 | in inAll conParams 638 | where 639 | inAll :: Eq pos => [[pos]] -> [pos] 640 | inAll [] = [] 641 | inAll (x : xs) = filter (\p -> all (\ps -> p `elem` ps) xs) x 642 | 643 | paramPos :: Eq name => [[Maybe name]] -> [Int] 644 | paramPos [] = [] 645 | paramPos (args : rest) 646 | = dropNothing $ keepSame (zip [0..] args) rest 647 | 648 | dropNothing :: [(pos, Maybe name)] -> [pos] 649 | dropNothing [] = [] 650 | dropNothing ((_, Nothing) : ts) = dropNothing ts 651 | dropNothing ((x, _) : ts) = x : dropNothing ts 652 | 653 | keepSame :: Eq name => 654 | [(pos, Maybe name)] -> [[Maybe name]] -> 655 | [(pos, Maybe name)] 656 | keepSame as [] = as 657 | keepSame as (args : rest) = keepSame (update as args) rest 658 | 659 | update :: Eq name => [(pos, Maybe name)] -> [Maybe name] -> [(pos, Maybe name)] 660 | update [] _ = [] 661 | update _ [] = [] 662 | update ((n, Just x) : as) (Just x' : args) 663 | | x == x' = (n, Just x) : update as args 664 | update ((n, _) : as) (_ : args) = (n, Nothing) : update as args 665 | 666 | getDataApp :: ConstructorInfo -> [[Maybe Name]] 667 | getDataApp (ConstructorInfo { constructorFields = fields }) = 668 | concatMap getThem $ 669 | fields ++ [ applyType (ConT dataName) $ map TANormal 670 | $ map unSigType instTys 671 | ] 672 | where 673 | getThem :: Type -> [[Maybe Name]] 674 | getThem ty = maybeToList $ mbInductiveCase dataName ty inductiveArg 675 | 676 | inductiveArg :: [TypeArg] -> [Maybe Name] 677 | inductiveArg argTys = 678 | let visArgTys = filterTANormals argTys 679 | in mParam visArgTys visArgTys 680 | 681 | -- keep the arguments which are single names, which appear 682 | -- in the return type, counting only the first time they appear in 683 | -- the return type as the parameter position 684 | mParam :: [Type] -> [Type] -> [Maybe Name] 685 | mParam _ [] = [] 686 | mParam args (VarT n:rest) 687 | | paramIn False n args 688 | = Just n : mParam (filter (noN n) args) rest 689 | mParam args (_:rest) = Nothing : mParam args rest 690 | 691 | paramIn :: Bool -> Name -> [Type] -> Bool 692 | paramIn ok _ [] = ok 693 | paramIn ok n (VarT t:ts) = paramIn (ok || n == t) n ts 694 | paramIn ok n (t:ts) 695 | | n `elem` freeVariables t = False -- not a single name 696 | | otherwise = paramIn ok n ts 697 | 698 | -- If the name appears again later, don't count that appearance 699 | -- as a parameter position 700 | noN :: Name -> Type -> Bool 701 | noN n (VarT t) = n /= t 702 | noN _ _ = False 703 | 704 | ----- 705 | -- Taken directly from th-desugar 706 | ----- 707 | 708 | -- | Remove all of the explicit kind signatures from a 'Type'. 709 | unSigType :: Type -> Type 710 | unSigType (SigT t _) = t 711 | unSigType (AppT f x) = AppT (unSigType f) (unSigType x) 712 | unSigType (ForallT tvbs ctxt t) = ForallT tvbs (map unSigType ctxt) (unSigType t) 713 | unSigType (InfixT t1 n t2) = InfixT (unSigType t1) n (unSigType t2) 714 | unSigType (UInfixT t1 n t2) = UInfixT (unSigType t1) n (unSigType t2) 715 | unSigType (ParensT t) = ParensT (unSigType t) 716 | unSigType (AppKindT t k) = AppKindT (unSigType t) (unSigType k) 717 | unSigType (ImplicitParamT n t) = ImplicitParamT n (unSigType t) 718 | unSigType t = t 719 | 720 | ----- 721 | -- Taken directly from singletons 722 | ----- 723 | 724 | -- Make an identifier uppercase. If the identifier is infix, this acts as the 725 | -- identity function. 726 | upcase :: String -> String 727 | upcase str 728 | | isHsLetter first 729 | = toUpper first : tailNameStr str 730 | 731 | | otherwise 732 | = str 733 | where 734 | first = headNameStr str 735 | 736 | -- is it a letter or underscore? 737 | isHsLetter :: Char -> Bool 738 | isHsLetter c = isLetter c || c == '_' 739 | 740 | -- Return the first character in a Name's string (i.e., nameBase). 741 | -- Precondition: the string is non-empty. 742 | headNameStr :: String -> Char 743 | headNameStr str = 744 | case str of 745 | (c:_) -> c 746 | [] -> error "headNameStr: Expected non-empty string" 747 | 748 | -- Drop the first character in a Name's string (i.e., nameBase). 749 | -- Precondition: the string is non-empty. 750 | tailNameStr :: String -> String 751 | tailNameStr str = 752 | case str of 753 | (_:cs) -> cs 754 | [] -> error "tailNameStr: Expected non-empty string" 755 | -------------------------------------------------------------------------------- /src/Data/Eliminator/TypeLits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-| 5 | Module: Data.Eliminator.TypeLits 6 | Copyright: (C) 2022 Ryan Scott 7 | License: BSD-style (see the file LICENSE) 8 | Maintainer: Ryan Scott 9 | Stability: Experimental 10 | Portability: GHC 11 | 12 | Crude imitations of eliminator functions for 'GHC.TypeLits.Nat' and 13 | 'GHC.TypeLits.Symbol'. 14 | -} 15 | module Data.Eliminator.TypeLits 16 | ( elimNat 17 | , elimSymbol 18 | ) where 19 | 20 | import Data.Eliminator.TypeNats 21 | import Data.Kind (Type) 22 | import Data.Singletons 23 | import qualified Data.Text as T 24 | 25 | import GHC.TypeLits.Singletons () 26 | import GHC.TypeLits 27 | 28 | import Unsafe.Coerce (unsafeCoerce) 29 | 30 | -- | Although 'Nat' is not actually an inductive data type in GHC, we can 31 | -- (crudely) pretend that it is using this eliminator. 32 | elimSymbol :: forall (p :: Symbol ~> Type) (s :: Symbol). 33 | Sing s 34 | -> Apply p "" 35 | -> (forall (c :: Char) (ss :: Symbol). 36 | Sing c -> Sing ss -> Apply p ss -> 37 | Apply p (ConsSymbol c ss)) 38 | -> Apply p s 39 | elimSymbol ssym pNil pCons = go @s ssym 40 | where 41 | go :: forall (s' :: Symbol). Sing s' -> Apply p s' 42 | go ssym' = 43 | case T.uncons (fromSing ssym') of 44 | Nothing -> unsafeCoerce pNil 45 | Just (c, ss) -> withSomeSing c $ \(sc :: Sing c) -> 46 | withSomeSing ss $ \(sss :: Sing ss) -> 47 | unsafeCoerce (pCons sc sss (go @ss sss)) 48 | -------------------------------------------------------------------------------- /src/Data/Eliminator/TypeNats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-| 5 | Module: Data.Eliminator.TypeNats 6 | Copyright: (C) 2017 Ryan Scott 7 | License: BSD-style (see the file LICENSE) 8 | Maintainer: Ryan Scott 9 | Stability: Experimental 10 | Portability: GHC 11 | 12 | A crude imitation of an eliminator function for 'GHC.TypeNats.Nat'. 13 | -} 14 | module Data.Eliminator.TypeNats (elimNat) where 15 | 16 | import Data.Kind (Type) 17 | import Data.Singletons 18 | 19 | import GHC.TypeLits.Singletons () 20 | import GHC.TypeNats 21 | 22 | import Unsafe.Coerce (unsafeCoerce) 23 | 24 | -- | Although 'Nat' is not actually an inductive data type in GHC, we can 25 | -- (crudely) pretend that it is using this eliminator. 26 | elimNat :: forall (p :: Nat ~> Type) (n :: Nat). 27 | Sing n 28 | -> Apply p 0 29 | -> (forall (k :: Nat). Sing k -> Apply p k -> Apply p (k + 1)) 30 | -> Apply p n 31 | elimNat snat pZ pS = go @n snat 32 | where 33 | go :: forall (n' :: Nat). Sing n' -> Apply p n' 34 | go snat' = 35 | case fromSing snat' of 36 | 0 -> unsafeCoerce pZ 37 | nPlusOne -> withSomeSing (pred nPlusOne) $ \(sk :: Sing k) -> 38 | unsafeCoerce (pS sk (go @k sk)) 39 | -------------------------------------------------------------------------------- /tests/DecideSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | module DecideSpec where 3 | 4 | import Data.Eliminator 5 | import Data.Nat 6 | import Data.Singletons.TH hiding (Decision(..)) 7 | import Data.Type.Equality 8 | 9 | import EqualitySpec (cong, replace) 10 | import DecideTypes 11 | 12 | import Prelude.Singletons 13 | 14 | import Test.Hspec 15 | 16 | main :: IO () 17 | main = hspec spec 18 | 19 | spec :: Spec 20 | spec = parallel $ do 21 | let proved = "Proved Refl" 22 | disproved = "Disproved " 23 | describe "decEqNat" $ do 24 | it "returns evidence that two Nats are equal" $ do 25 | show (decEqNat (sLit @0) (sLit @0)) `shouldBe` proved 26 | show (decEqNat (sLit @1) (sLit @0)) `shouldBe` disproved 27 | show (decEqNat (sLit @0) (sLit @1)) `shouldBe` disproved 28 | show (decEqNat (sLit @1) (sLit @1)) `shouldBe` proved 29 | describe "decEqList" $ do 30 | it "returns evidence that two lists are equal" $ do 31 | let decEqNatList = decEqList decEqNat 32 | show (decEqNatList SNil SNil) `shouldBe` proved 33 | show (decEqNatList (SCons (sLit @0) SNil) SNil) `shouldBe` disproved 34 | show (decEqNatList SNil (SCons (sLit @0) SNil)) `shouldBe` disproved 35 | show (decEqNatList (SCons (sLit @0) SNil) (SCons (sLit @0) SNil)) `shouldBe` proved 36 | show (decEqNatList (SCons (sLit @1) SNil) (SCons (sLit @0) SNil)) `shouldBe` disproved 37 | 38 | ----- 39 | 40 | peanoEqConsequencesSame :: forall (n :: Nat). Sing n -> NatEqConsequences n n 41 | peanoEqConsequencesSame sn = elimNat @WhyNatEqConsequencesSameSym0 @n sn base step 42 | where 43 | base :: WhyNatEqConsequencesSame Z 44 | base = () 45 | 46 | step :: forall (k :: Nat). 47 | Sing k 48 | -> WhyNatEqConsequencesSame k 49 | -> WhyNatEqConsequencesSame (S k) 50 | step _ _ = Refl 51 | 52 | useNatEq :: forall n j. Sing n -> n :~: j -> NatEqConsequences n j 53 | useNatEq sn nEqJ = replace @Nat @n @j @(NatEqConsequencesSym1 n) 54 | (peanoEqConsequencesSame @n sn) nEqJ 55 | 56 | zNotS :: forall n. Z :~: S n -> Void 57 | zNotS = useNatEq @Z @(S n) SZ 58 | 59 | sNotZ :: forall n. S n :~: Z -> Void 60 | sNotZ eq = zNotS @n (sym eq) 61 | 62 | sInjective :: forall n j. Sing n -> S n :~: S j -> n :~: j 63 | sInjective sn = useNatEq @(S n) @(S j) (SS sn) 64 | 65 | decEqZ :: forall (j :: Nat). Sing j -> Decision (Z :~: j) 66 | decEqZ sj = elimNat @WhyDecEqZSym0 @j sj base step 67 | where 68 | base :: Decision (Z :~: Z) 69 | base = Proved Refl 70 | 71 | step :: forall (k :: Nat). 72 | Sing k -> Decision (Z :~: k) -> Decision (Z :~: S k) 73 | step _ _ = Disproved (zNotS @k) 74 | 75 | decCongS :: forall n j. Sing n -> Decision (n :~: j) -> Decision (S n :~: S j) 76 | decCongS sn dNJ = withSomeSing dNJ $ \(sDNJ :: Sing d) -> 77 | elimDecision @_ @(ConstSym1 (Decision (S n :~: S j))) @d 78 | sDNJ left right 79 | where 80 | left :: forall (x :: n :~: j). 81 | Sing x -> Decision (S n :~: S j) 82 | left yes = Proved $ cong @Nat @Nat @(TyCon S) @n @j (fromSing yes) 83 | 84 | right :: forall (r :: (n :~: j) ~> Void). 85 | Sing r -> Decision (S n :~: S j) 86 | right no = Disproved $ fromSing no . sInjective @n @j sn 87 | 88 | decEqNat :: forall (n :: Nat) (j :: Nat). Sing n -> Sing j -> Decision (n :~: j) 89 | decEqNat sn = runWhyDecEqNat $ elimNat @(TyCon WhyDecEqNat) @n sn base step 90 | where 91 | base :: WhyDecEqNat Z 92 | base = WhyDecEqNat decEqZ 93 | 94 | step :: forall (k :: Nat). 95 | Sing k 96 | -> WhyDecEqNat k 97 | -> WhyDecEqNat (S k) 98 | step sk swhyK = WhyDecEqNat $ \(sl :: Sing l) -> 99 | elimNat @(WhyDecEqSSym1 k) @l sl baseStep stepStep 100 | where 101 | baseStep :: Decision (S k :~: Z) 102 | baseStep = Disproved $ sNotZ @k 103 | 104 | stepStep :: forall (m :: Nat). 105 | Sing m 106 | -> Decision (S k :~: m) 107 | -> Decision (S k :~: S m) 108 | stepStep sm _ = decCongS sk (runWhyDecEqNat swhyK sm) 109 | 110 | listEqConsequencesSame :: forall e (es :: [e]). Sing es -> ListEqConsequences es es 111 | listEqConsequencesSame sl = elimList @e @WhyListEqConsequencesSameSym0 @es sl base step 112 | where 113 | base :: ListEqConsequences '[] '[] 114 | base = () 115 | 116 | step :: forall (x :: e). Sing x 117 | -> forall (xs :: [e]). Sing xs 118 | -> ListEqConsequences xs xs 119 | -> ListEqConsequences (x:xs) (x:xs) 120 | step _ _ _ = (Refl, Refl) 121 | 122 | useListEq :: forall e (xs :: [e]) (ys :: [e]). 123 | Sing xs -> xs :~: ys -> ListEqConsequences xs ys 124 | useListEq sxs xsEqYs = replace @[e] @xs @ys @(ListEqConsequencesSym1 xs) 125 | (listEqConsequencesSame @e @xs sxs) xsEqYs 126 | 127 | nilNotCons :: forall e (x :: e) (xs :: [e]). '[] :~: (x:xs) -> Void 128 | nilNotCons = useListEq @e @'[] @(x:xs) SNil 129 | 130 | consNotNil :: forall e (x :: e) (xs :: [e]). (x:xs) :~: '[] -> Void 131 | consNotNil eq = nilNotCons @e @x @xs (sym eq) 132 | 133 | consInjective :: forall e (x :: e) (xs :: [e]) (y :: e) (ys :: [e]). 134 | Sing x -> Sing xs 135 | -> (x:xs) :~: (y:ys) 136 | -> (x :~: y, xs :~: ys) 137 | consInjective sx sxs = useListEq @e @(x:xs) @(y:ys) (SCons sx sxs) 138 | 139 | decEqNil :: forall e (es :: [e]). Sing es -> Decision ('[] :~: es) 140 | decEqNil ses = elimList @e @WhyDecEqNilSym0 @es ses base step 141 | where 142 | base :: Decision ('[] :~: '[]) 143 | base = Proved Refl 144 | 145 | step :: forall (x :: e). Sing x 146 | -> forall (xs :: [e]). Sing xs 147 | -> Decision ('[] :~: xs) 148 | -> Decision ('[] :~: (x:xs)) 149 | step _ (_ :: Sing xs) _ = Disproved (nilNotCons @e @x @xs) 150 | 151 | intermixListEqs :: forall e (x :: e) (xs :: [e]) (y :: e) (ys :: [e]). 152 | x :~: y -> xs :~: ys 153 | -> (x:xs) :~: (y:ys) 154 | intermixListEqs xEqY xsEqYs = 155 | replace @e @x @y @(WhyIntermixListEqs1Sym3 x xs ys) 156 | (replace @[e] @xs @ys @(WhyIntermixListEqs2Sym2 x xs) Refl xsEqYs) 157 | xEqY 158 | 159 | decCongCons :: forall e (x :: e) (xs :: [e]) (y :: e) (ys :: [e]). 160 | Sing x -> Sing xs 161 | -> Decision (x :~: y) -> Decision (xs :~: ys) 162 | -> Decision ((x:xs) :~: (y:ys)) 163 | decCongCons sx sxs dXY dXsYs = 164 | withSomeSing dXY $ \(sDXY :: Sing dXY) -> 165 | elimDecision @_ @(ConstSym1 (Decision ((x:xs) :~: (y:ys)))) @dXY 166 | sDXY left right 167 | where 168 | left :: forall (z :: x :~: y). 169 | Sing z -> Decision ((x:xs) :~: (y:ys)) 170 | left xEqY = withSomeSing dXsYs $ \(sDXsYs :: Sing dXsYs) -> 171 | elimDecision @_ @(ConstSym1 (Decision ((x:xs) :~: (y:ys)))) @dXsYs 172 | sDXsYs leftLeft leftRight 173 | where 174 | leftLeft :: forall (zz :: xs :~: ys). 175 | Sing zz -> Decision ((x:xs) :~: (y:ys)) 176 | leftLeft xsEqYs = Proved $ intermixListEqs (fromSing xEqY) (fromSing xsEqYs) 177 | 178 | leftRight :: forall (r :: (xs :~: ys) ~> Void). 179 | Sing r -> Decision ((x:xs) :~: (y:ys)) 180 | leftRight no = Disproved $ fromSing no . snd . injective 181 | 182 | right :: forall (r :: (x :~: y) ~> Void). 183 | Sing r -> Decision ((x:xs) :~: (y:ys)) 184 | right no = Disproved $ fromSing no . fst . injective 185 | 186 | injective :: (x:xs) :~: (y:ys) -> (x :~: y, xs :~: ys) 187 | injective = consInjective @e @x @xs @y @ys sx sxs 188 | 189 | decEqList :: forall e (es1 :: [e]) (es2 :: [e]). 190 | (forall (e1 :: e) (e2 :: e). 191 | Sing e1 -> Sing e2 -> Decision (e1 :~: e2)) 192 | -> Sing es1 -> Sing es2 -> Decision (es1 :~: es2) 193 | decEqList f ses1 = runWhyDecEqList $ elimList @e @(TyCon1 WhyDecEqList) @es1 ses1 base step 194 | where 195 | base :: WhyDecEqList '[] 196 | base = WhyDecEqList decEqNil 197 | 198 | step :: forall (x :: e). Sing x 199 | -> forall (xs :: [e]). Sing xs 200 | -> WhyDecEqList xs 201 | -> WhyDecEqList (x:xs) 202 | step sx (sxs :: Sing xs) swhyXs = 203 | WhyDecEqList $ \(sl :: Sing l) -> 204 | elimList @e @(WhyDecEqConsSym2 x xs) @l sl 205 | stepBase stepStep 206 | where 207 | stepBase :: Decision ((x:xs) :~: '[]) 208 | stepBase = Disproved $ consNotNil @e @x @xs 209 | 210 | stepStep :: forall (y :: e). Sing y 211 | -> forall (ys :: [e]). Sing ys 212 | -> Decision ((x:xs) :~: ys) 213 | -> Decision ((x:xs) :~: (y:ys)) 214 | stepStep sy sys _ = decCongCons sx sxs 215 | (f sx sy) 216 | (runWhyDecEqList swhyXs sys) 217 | -------------------------------------------------------------------------------- /tests/DecideTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeAbstractions #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -Wno-unused-foralls #-} 8 | module DecideTypes where 9 | 10 | import Data.Eliminator 11 | import Data.Kind 12 | import Data.Nat 13 | import Data.Singletons.TH hiding (Decision(..)) 14 | 15 | import Prelude.Singletons (ConstSym1) 16 | 17 | -- Due to https://github.com/goldfirere/singletons/issues/82, promoting the 18 | -- Decision data type from Data.Singletons.Decide is a tad awkward. To work 19 | -- around these, we define a more general Decision' data type here. 20 | type Decision' :: (Type ~> Type ~> Type) -> Type -> Type 21 | data Decision' p a 22 | = Proved a 23 | | Disproved (p @@ a @@ Void) 24 | 25 | elimDecision :: forall a (p :: PDecision a ~> Type) (d :: PDecision a). 26 | Sing d 27 | -> (forall (yes :: a). Sing yes -> p @@ Proved yes) 28 | -> (forall (no :: a ~> Void). Sing no -> p @@ Disproved no) 29 | -> p @@ d 30 | elimDecision sd pProved pDisproved = go @d sd 31 | where 32 | go :: forall (d' :: PDecision a). Sing d' -> p @@ d' 33 | go (SProved yes) = pProved yes 34 | go (SDisproved no) = pDisproved no 35 | 36 | type ElimDecision :: forall a. 37 | forall (p :: PDecision a ~> Type) 38 | (d :: PDecision a) -> 39 | (forall (yes :: a) -> p @@ Proved yes) 40 | -> (forall (no :: a ~> Void) -> p @@ Disproved no) 41 | -> p @@ d 42 | type family ElimDecision p d pProved pDisproved where 43 | forall a (p :: PDecision a ~> Type) 44 | (pProved :: forall (yes :: a) -> p @@ Proved yes) 45 | (pDisproved :: forall (no :: a ~> Void) -> p @@ Disproved no) yes. 46 | ElimDecision p (Proved yes) pProved pDisproved = pProved yes 47 | forall a (p :: PDecision a ~> Type) 48 | (pProved :: forall (yes :: a) -> p @@ Proved yes) 49 | (pDisproved :: forall (no :: a ~> Void) -> p @@ Disproved no) no. 50 | ElimDecision p (Disproved no) pProved pDisproved = pDisproved no 51 | 52 | instance Show a => Show (Decision' p a) where 53 | showsPrec p (Proved a) = 54 | showParen (p > 10) $ showString "Proved " . showsPrec 11 a 55 | showsPrec p (Disproved _) = 56 | showParen (p > 10) $ showString "Disproved " 57 | 58 | type Decision :: Type -> Type 59 | type Decision = Decision' (TyCon (->)) 60 | 61 | type PDecision :: Type -> Type 62 | type PDecision = Decision' (~>@#@$) 63 | 64 | type SDecision :: PDecision a -> Type 65 | data SDecision d where 66 | SProved :: forall a (x :: a). Sing x -> SDecision (Proved x) 67 | SDisproved :: forall a (r :: a ~> Void). Sing r -> SDecision (Disproved r) 68 | type instance Sing = SDecision 69 | 70 | instance SingKind a => SingKind (PDecision a) where 71 | type Demote (PDecision a) = Decision (Demote a) 72 | fromSing (SProved a) = Proved (fromSing a) 73 | fromSing (SDisproved r) = Disproved (fromSing r) 74 | toSing (Proved x) = withSomeSing x $ SomeSing . SProved 75 | toSing (Disproved r) = withSomeSing r $ SomeSing . SDisproved 76 | 77 | ----- 78 | 79 | -- These newtype wrappers are needed to work around 80 | -- https://gitlab.haskell.org/ghc/ghc/issues/9269 81 | type WhyDecEqNat :: Nat -> Type 82 | newtype WhyDecEqNat k = WhyDecEqNat 83 | { runWhyDecEqNat :: forall (j :: Nat). Sing j -> Decision (k :~: j) } 84 | 85 | type WhyDecEqList :: [e] -> Type 86 | newtype WhyDecEqList (l1 :: [e]) = WhyDecEqList 87 | { runWhyDecEqList :: forall (l2 :: [e]). Sing l2 -> Decision (l1 :~: l2) } 88 | 89 | type ConstVoidNat :: Nat -> Type -> Type 90 | type ConstVoidNat m r = Void 91 | 92 | -- ElimNat requires an argument of kind (forall (m :: Nat) -> ...), which is 93 | -- not the same thing as (Nat -> ...). Unfortunately, it's not easy to convince 94 | -- singletons-th to generate defunctionalization symbols for ConstVoidNat that 95 | -- have a dependent kind like this. As a result, we have to define 96 | -- defunctionalization symbols by hand with the appropriate kind. 97 | type ConstVoidNatSym :: forall (m :: Nat) -> (Type ~> Type) 98 | data ConstVoidNatSym m z 99 | type instance Apply (ConstVoidNatSym m) r = ConstVoidNat m r 100 | 101 | type EqSameNat :: Nat -> Nat -> Type -> Type 102 | type EqSameNat n m r = n :~: m 103 | 104 | type EqSameNatSym :: Nat -> forall (m :: Nat) -> (Type ~> Type) 105 | data EqSameNatSym n m z 106 | type instance Apply (EqSameNatSym n m) r = EqSameNat n m r 107 | 108 | type ConstVoidList :: e -> [e] -> Type -> Type 109 | type ConstVoidList y ys r = Void 110 | 111 | type ConstVoidListSym :: forall e. forall (y :: e) (ys :: [e]) 112 | -> (Type ~> Type) 113 | data ConstVoidListSym y ys z 114 | type instance Apply (ConstVoidListSym y ys) r = ConstVoidList y ys r 115 | 116 | type EqSameList :: e -> [e] -> e -> [e] -> Type -> Type 117 | type EqSameList x xs y ys r = (x :~: y, xs :~: ys) 118 | 119 | type EqSameListSym :: forall e. e -> [e] -> forall (y :: e) (ys :: [e]) 120 | -> (Type ~> Type) 121 | data EqSameListSym x xs y ys z 122 | type instance Apply (EqSameListSym x xs y ys) r = EqSameList x xs y ys r 123 | 124 | $(singletons [d| 125 | type NatEqConsequencesBase :: Nat -> Type 126 | type NatEqConsequencesBase m = ElimNat (ConstSym1 Type) m () ConstVoidNatSym 127 | 128 | type NatEqConsequencesStep :: Nat -> (Nat ~> Type) -> Nat -> Type 129 | type NatEqConsequencesStep m r n = ElimNat (ConstSym1 Type) n Void (EqSameNatSym m) 130 | 131 | type ListEqConsequencesBase :: [e] -> Type 132 | type ListEqConsequencesBase ys = ElimList (ConstSym1 Type) ys () ConstVoidListSym 133 | 134 | type ListEqConsequencesStep :: e -> [e] -> ([e] ~> Type) -> [e] -> Type 135 | type ListEqConsequencesStep x xs r ys = ElimList (ConstSym1 Type) ys Void (EqSameListSym x xs) 136 | |]) 137 | 138 | type NatEqConsequencesStepSym :: forall (m :: Nat) 139 | -> (Nat ~> Type) ~> (Nat ~> Type) 140 | data NatEqConsequencesStepSym m z 141 | type instance Apply (NatEqConsequencesStepSym m) r = NatEqConsequencesStepSym2 m r 142 | 143 | type ListEqConsequencesStepSym :: forall e. forall (x :: e) (xs :: [e]) 144 | -> ([e] ~> Type) ~> ([e] ~> Type) 145 | data ListEqConsequencesStepSym x xs z 146 | type instance Apply (ListEqConsequencesStepSym x xs) r = ListEqConsequencesStepSym3 x xs r 147 | 148 | $(singletons [d| 149 | type NatEqConsequences :: Nat -> Nat -> Type 150 | type NatEqConsequences n m = 151 | ElimNat (ConstSym1 (Nat ~> Type)) n 152 | NatEqConsequencesBaseSym0 153 | NatEqConsequencesStepSym @@ m 154 | 155 | type WhyNatEqConsequencesSame :: Nat -> Type 156 | type WhyNatEqConsequencesSame a = NatEqConsequences a a 157 | 158 | type WhyDecEqZ :: Nat -> Type 159 | type WhyDecEqZ k = Decision (Z :~: k) 160 | 161 | type WhyDecEqS :: Nat -> Nat -> Type 162 | type WhyDecEqS n k = Decision (S n :~: k) 163 | 164 | type ListEqConsequences :: [e] -> [e] -> Type 165 | type ListEqConsequences (xs :: [e]) (ys :: [e]) = 166 | ElimList (ConstSym1 ([e] ~> Type)) xs 167 | ListEqConsequencesBaseSym0 168 | ListEqConsequencesStepSym @@ ys 169 | 170 | type WhyListEqConsequencesSame :: [e] -> Type 171 | type WhyListEqConsequencesSame es = ListEqConsequences es es 172 | 173 | type WhyDecEqNil :: [e] -> Type 174 | type WhyDecEqNil es = Decision ('[] :~: es) 175 | 176 | type WhyDecEqCons :: e -> [e] -> [e] -> Type 177 | type WhyDecEqCons x xs es = Decision ((x:xs) :~: es) 178 | 179 | type WhyIntermixListEqs1 :: e -> [e] -> [e] -> e -> Type 180 | type WhyIntermixListEqs1 x xs ys k = (x:xs) :~: (k:ys) 181 | 182 | type WhyIntermixListEqs2 :: e -> [e] -> [e] -> Type 183 | type WhyIntermixListEqs2 x xs k = (x:xs) :~: (x:k) 184 | |]) 185 | -------------------------------------------------------------------------------- /tests/EqualitySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GADTs #-} 4 | module EqualitySpec where 5 | 6 | import Data.Kind 7 | import Data.Singletons 8 | import qualified Data.Type.Equality as DTE 9 | import Data.Type.Equality ((:~:)(..), (:~~:)(..)) 10 | 11 | import EqualityTypes 12 | import Internal 13 | 14 | import Test.Hspec 15 | 16 | main :: IO () 17 | main = hspec spec 18 | 19 | spec :: Spec 20 | spec = parallel $ do 21 | describe "sym" $ do 22 | let boolEq :: Bool :~: Bool 23 | boolEq = Refl 24 | it "behaves like the one from Data.Type.Equality" $ do 25 | sym boolEq `shouldBe` DTE.sym boolEq 26 | sym (sym boolEq) `shouldBe` DTE.sym (DTE.sym boolEq) 27 | it "behaves like the one from Data.Type.Equality" $ do 28 | trans boolEq boolEq `shouldBe` DTE.trans boolEq boolEq 29 | trans boolEq (sym boolEq) `shouldBe` Refl 30 | 31 | ----- 32 | 33 | j :: forall k (p :: forall (x :: k) (y :: k). x :~: y ~> Type) 34 | (a :: k) (b :: k) 35 | (r :: a :~: b). 36 | Sing r 37 | -> (forall (x :: k). p @@ (Refl @x)) 38 | -> p @@ r 39 | j SRefl pRefl = pRefl @a 40 | 41 | jProp :: forall k (p :: k ~> k ~> Prop) 42 | (a :: k) (b :: k). 43 | a :~: b 44 | -> (forall (x :: k). p @@ x @@ x) 45 | -> p @@ a @@ b 46 | jProp Refl pRefl = pRefl @a 47 | 48 | hj :: forall (p :: forall y z (w :: y) (x :: z). w :~~: x ~> Type) 49 | j k (a :: j) (b :: k) 50 | (r :: a :~~: b). 51 | Sing r 52 | -> (forall y (w :: y). p @@ (HRefl @w)) 53 | -> p @@ r 54 | hj SHRefl pHRefl = pHRefl @j @a 55 | 56 | hjProp :: forall (p :: forall y z. y ~> z ~> Prop) 57 | j k (a :: j) (b :: k). 58 | a :~~: b 59 | -> (forall y (w :: y). p @@ w @@ w) 60 | -> p @@ a @@ b 61 | hjProp HRefl pHRefl = pHRefl @j @a 62 | 63 | k :: forall k (a :: k) 64 | (p :: a :~: a ~> Type) 65 | (r :: a :~: a). 66 | Sing r 67 | -> p @@ Refl 68 | -> p @@ r 69 | k SRefl pRefl = pRefl 70 | 71 | hk :: forall k (a :: k) 72 | (p :: a :~~: a ~> Type) 73 | (r :: a :~~: a). 74 | Sing r 75 | -> p @@ HRefl 76 | -> p @@ r 77 | hk SHRefl pHRefl = pHRefl 78 | 79 | sym :: forall t (a :: t) (b :: t). 80 | a :~: b -> b :~: a 81 | sym eq = withSomeSing eq $ \(singEq :: Sing r) -> 82 | (~>:~:) @t @a @WhySymSym0 @b @r singEq Refl 83 | 84 | sSym :: forall t (a :: t) (b :: t) (e :: a :~: b). 85 | Sing e -> Sing (Symmetry e) 86 | sSym se = (~>:~:) @t @a @WhySSymSym0 @b @e se SRefl 87 | 88 | hsym :: forall j k (a :: j) (b :: k). 89 | a :~~: b -> b :~~: a 90 | hsym eq = withSomeSing eq $ \(singEq :: Sing r) -> 91 | (~>:~~:) @j @a @WhyHSymSym0 @k @b @r singEq HRefl 92 | 93 | sHSym :: forall j k (a :: j) (b :: k) (e :: a :~~: b). 94 | Sing e -> Sing (HSymmetry e) 95 | sHSym se = (~>:~~:) @j @a @WhySHSymSym0 @k @b @e se SHRefl 96 | 97 | symIdempotent :: forall t (a :: t) (b :: t) 98 | (e :: a :~: b). 99 | Sing e -> Symmetry (Symmetry e) :~: e 100 | symIdempotent se = (~>:~:) @t @a @WhySymIdempotentSym0 @b @e se Refl 101 | 102 | hsymIdempotent :: forall j k (a :: j) (b :: k) 103 | (e :: a :~~: b). 104 | Sing e -> HSymmetry (HSymmetry e) :~: e 105 | hsymIdempotent se = (~>:~~:) @j @a @WhyHSymIdempotentSym0 @k @b @e se Refl 106 | 107 | trans :: forall t (a :: t) (b :: t) (c :: t). 108 | a :~: b -> b :~: c -> a :~: c 109 | trans eq1 eq2 = withSomeSing eq1 $ \(singEq1 :: Sing r) -> 110 | unwrapTrans ((~>:~:) @t @a @WrappedTransSym0 @b @r 111 | singEq1 (WrapTrans id)) eq2 112 | 113 | htrans :: forall j k l (a :: j) (b :: k) (c :: l). 114 | a :~~: b -> b :~~: c -> a :~~: c 115 | htrans eq1 eq2 = withSomeSing eq1 $ \(singEq1 :: Sing r) -> 116 | unwrapHTrans ((~>:~~:) @j @a @WrappedHTransSym0 @k @b @r 117 | singEq1 (WrapHTrans id)) eq2 118 | 119 | replace :: forall t (from :: t) (to :: t) (p :: t ~> Type). 120 | p @@ from 121 | -> from :~: to 122 | -> p @@ to 123 | replace from eq = 124 | withSomeSing eq $ \(singEq :: Sing r) -> 125 | (~>:~:) @t @from @(WhyReplaceSym2 from p) @to @r singEq from 126 | 127 | hreplace :: forall j k (from :: j) (to :: k) 128 | (p :: forall z. z ~> Type). 129 | p @@ from 130 | -> from :~~: to 131 | -> p @@ to 132 | hreplace from heq = 133 | withSomeSing heq $ \(singEq :: Sing r) -> 134 | (~>:~~:) @j @from @(WhyHReplaceSym2 from (WrapPred p)) @k @to @r singEq from 135 | 136 | leibniz :: forall t (f :: t ~> Type) (a :: t) (b :: t). 137 | a :~: b 138 | -> f @@ a 139 | -> f @@ b 140 | leibniz = replace @t @a @b @(WhyLeibnizSym2 f a) id 141 | 142 | hleibniz :: forall (f :: forall t. t ~> Type) j k (a :: j) (b :: k). 143 | a :~~: b 144 | -> f @@ a 145 | -> f @@ b 146 | hleibniz = hreplace @j @k @a @b @(WhyHLeibnizSym2 (WrapPred f) a) id 147 | 148 | cong :: forall x y (f :: x ~> y) 149 | (a :: x) (b :: x). 150 | a :~: b 151 | -> f @@ a :~: f @@ b 152 | cong eq = 153 | withSomeSing eq $ \(singEq :: Sing r) -> 154 | (~>:~:) @x @a @(WhyCongSym1 f) @b @r singEq Refl 155 | 156 | eqIsRefl :: forall k (a :: k) (b :: k) (e :: a :~: b). 157 | Sing e -> e :~~: (Refl :: a :~: a) 158 | eqIsRefl eq = (~>:~:) @k @a @WhyEqIsReflSym0 @b @e eq HRefl 159 | 160 | heqIsHRefl :: forall j k (a :: j) (b :: k) (e :: a :~~: b). 161 | Sing e -> e :~~: (HRefl :: a :~~: a) 162 | heqIsHRefl heq = (~>:~~:) @j @a @WhyHEqIsHReflSym0 @k @b @e heq HRefl 163 | 164 | transLeft :: forall j (a :: j) (b :: j) (e :: a :~: b). 165 | Sing e -> Trans e Refl :~: e 166 | transLeft se = leibniz @(a :~: b) @WhyTransLeftSym0 167 | @(Symmetry (Symmetry e)) @e 168 | (symIdempotent se) transLeftHelper 169 | where 170 | transLeftHelper :: Trans (Symmetry (Symmetry e)) Refl 171 | :~: Symmetry (Symmetry e) 172 | transLeftHelper = (~>:~:) @j @b @WhyTransLeftHelperSym0 @a @(Symmetry e) 173 | (sSym se) Refl 174 | 175 | htransLeft :: forall j k (a :: j) (b :: k) (e :: a :~~: b). 176 | Sing e -> HTrans e HRefl :~: e 177 | htransLeft se = leibniz @(a :~~: b) @WhyHTransLeftSym0 178 | @(HSymmetry (HSymmetry e)) @e 179 | (hsymIdempotent se) htransLeftHelper 180 | where 181 | htransLeftHelper :: HTrans (HSymmetry (HSymmetry e)) HRefl 182 | :~: HSymmetry (HSymmetry e) 183 | htransLeftHelper = (~>:~~:) @k @b @WhyHTransLeftHelperSym0 @j @a @(HSymmetry e) 184 | (sHSym se) Refl 185 | 186 | transRight :: forall j (a :: j) (b :: j) (e :: a :~: b). 187 | Sing e -> Trans Refl e :~: e 188 | transRight se = (~>:~:) @j @a @WhyTransRightSym0 @b @e se Refl 189 | 190 | htransRight :: forall j k (a :: j) (b :: k) (e :: a :~~: b). 191 | Sing e -> HTrans HRefl e :~: e 192 | htransRight se = (~>:~~:) @j @a @WhyHTransRightSym0 @k @b @e se Refl 193 | 194 | -- Commented out for now, since these take ages to compile :( 195 | -- Perhaps https://gitlab.haskell.org/ghc/ghc/merge_requests/611 will make 196 | -- things tolerable. 197 | {- 198 | sTrans :: forall t (a :: t) (b :: t) (c :: t) 199 | (e1 :: a :~: b) (e2 :: b :~: c). 200 | Sing e1 -> Sing e2 -> Sing (Trans e1 e2) 201 | sTrans se1 = unwrapSTrans $ (~>:~:) @t @a @WhySTransSym0 @b @e1 202 | se1 (WrapSTrans sTransHelper) 203 | where 204 | sTransHelper :: forall (z :: t) (e' :: a :~: z). 205 | Sing e' -> Sing (Trans Refl e') 206 | sTransHelper se' = leibniz @(a :~: z) @(TyCon1 Sing) @e' @(Trans Refl e') 207 | (sym (transRight se')) se' 208 | 209 | sHTrans :: forall j k l (a :: j) (b :: k) (c :: l) 210 | (e1 :: a :~~: b) (e2 :: b :~~: c). 211 | Sing e1 -> Sing e2 -> Sing (HTrans e1 e2) 212 | sHTrans se1 = unwrapSHTrans $ (~>:~~:) @j @a @WhySHTransSym0 @k @b @e1 213 | se1 (WrapSHTrans sHTransHelper) 214 | where 215 | sHTransHelper :: forall m (z :: m) (e' :: a :~~: z). 216 | Sing e' -> Sing (HTrans HRefl e') 217 | sHTransHelper se' = leibniz @(a :~~: z) @(TyCon1 Sing) @e' @(HTrans HRefl e') 218 | (sym (htransRight se')) se' 219 | 220 | rebalance :: forall j (x1 :: j) (x2 :: j) (x3 :: j) (x4 :: j) 221 | (a :: x1 :~: x2) (b :: x2 :~: x3) (c :: x3 :~: x4). 222 | Sing a -> Sing b -> Sing c 223 | -> Trans a (Trans b c) :~: Trans (Trans a b) c 224 | rebalance sa sb sc = leibniz @(x1 :~: x2) @(WhyRebalanceSym2 b c) 225 | @(Symmetry (Symmetry a)) @a 226 | (symIdempotent sa) rebalanceHelper 227 | where 228 | rebalanceHelper :: Trans (Symmetry (Symmetry a)) (Trans b c) 229 | :~: Trans (Trans (Symmetry (Symmetry a)) b) c 230 | rebalanceHelper = (~>:~:) @j @x2 @(WhyRebalanceHelperSym2 b c) @x1 @(Symmetry a) 231 | (sSym sa) rebalanceBC 232 | 233 | rebalanceBC :: Trans Refl (Trans b c) :~: Trans (Trans Refl b) c 234 | rebalanceBC = trans (transRight (sTrans sb sc)) transRightBC 235 | 236 | transRightBC :: Trans b c :~: Trans (Trans Refl b) c 237 | transRightBC = cong @(x2 :~: x3) @(x2 :~: x4) @(FlipSym2 TransSym0 c) 238 | @b @(Trans Refl b) 239 | (sym (transRight sb)) 240 | 241 | hrebalance :: forall k1 k2 k3 k4 (x1 :: k1) (x2 :: k2) (x3 :: k3) (x4 :: k4) 242 | (a :: x1 :~~: x2) (b :: x2 :~~: x3) (c :: x3 :~~: x4). 243 | Sing a -> Sing b -> Sing c 244 | -> HTrans a (HTrans b c) :~: HTrans (HTrans a b) c 245 | hrebalance sa sb sc = leibniz @(x1 :~~: x2) @(WhyHRebalanceSym2 b c) 246 | @(HSymmetry (HSymmetry a)) @a 247 | (hsymIdempotent sa) hrebalanceHelper 248 | where 249 | hrebalanceHelper :: HTrans (HSymmetry (HSymmetry a)) (HTrans b c) 250 | :~: HTrans (HTrans (HSymmetry (HSymmetry a)) b) c 251 | hrebalanceHelper = (~>:~~:) @k2 @x2 @(WhyHRebalanceHelperSym2 b c) 252 | @k1 @x1 @(HSymmetry a) 253 | (sHSym sa) hrebalanceBC 254 | 255 | hrebalanceBC :: HTrans HRefl (HTrans b c) :~: HTrans (HTrans HRefl b) c 256 | hrebalanceBC = trans (htransRight (sHTrans sb sc)) htransRightBC 257 | 258 | htransRightBC :: HTrans b c :~: HTrans (HTrans HRefl b) c 259 | htransRightBC = cong @(x2 :~~: x3) @(x2 :~~: x4) @(FlipSym2 HTransSym0 c) 260 | @b @(HTrans HRefl b) 261 | (sym (htransRight sb)) 262 | -} 263 | -------------------------------------------------------------------------------- /tests/EqualityTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeAbstractions #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -Wno-orphans #-} 8 | module EqualityTypes where 9 | 10 | import Data.Kind 11 | import Data.Singletons.TH 12 | import Data.Singletons.TH.Options 13 | import Data.Type.Equality ((:~~:)(..)) 14 | 15 | import Internal 16 | 17 | $(withOptions defaultOptions{genSingKindInsts = False} $ 18 | genSingletons [''(:~:), ''(:~~:)]) 19 | 20 | instance SingKind (a :~: b) where 21 | type Demote (a :~: b) = a :~: b 22 | fromSing SRefl = Refl 23 | toSing Refl = SomeSing SRefl 24 | 25 | instance SingKind (a :~~: b) where 26 | type Demote (a :~~: b) = a :~~: b 27 | fromSing SHRefl = HRefl 28 | toSing HRefl = SomeSing SHRefl 29 | 30 | -- | Christine Paulin-Mohring's version of the J rule. 31 | (~>:~:) :: forall k (a :: k) 32 | (p :: forall (y :: k). a :~: y ~> Type) 33 | (b :: k) (r :: a :~: b). 34 | Sing r 35 | -> p @@ Refl 36 | -> p @@ r 37 | (~>:~:) SRefl pRefl = pRefl 38 | 39 | type (~>:~:) :: forall k (a :: k). 40 | forall (p :: forall (y :: k). a :~: y ~> Type) 41 | -> forall (b :: k). 42 | forall (r :: a :~: b) 43 | -> p @@ Refl 44 | -> p @@ r 45 | type family (~>:~:) p r pRefl where 46 | forall k (a :: k) 47 | (p :: forall (y :: k). a :~: y ~> Type) 48 | (pRefl :: p @@ Refl). 49 | (~>:~:) p Refl pRefl = pRefl 50 | 51 | (~>!:~:) :: forall k (a :: k) 52 | (p :: k ~> Prop) 53 | (b :: k). 54 | a :~: b 55 | -> p @@ a 56 | -> p @@ b 57 | (~>!:~:) Refl pRefl = pRefl 58 | 59 | type (~>!:~:) :: forall k (a :: k). 60 | forall (p :: k ~> Prop) 61 | -> forall (b :: k). 62 | a :~: b 63 | -> p @@ a 64 | -> p @@ b 65 | type family (~>!:~:) p r pRefl where 66 | (~>!:~:) _ Refl pRefl = pRefl 67 | 68 | -- | Christine Paulin-Mohring's version of the J rule, but heterogeneously kinded. 69 | (~>:~~:) :: forall j (a :: j) 70 | (p :: forall z (y :: z). a :~~: y ~> Type) 71 | k (b :: k) (r :: a :~~: b). 72 | Sing r 73 | -> p @@ HRefl 74 | -> p @@ r 75 | (~>:~~:) SHRefl pHRefl = pHRefl 76 | 77 | type (~>:~~:) :: forall j (a :: j). 78 | forall (p :: forall z (y :: z). a :~~: y ~> Type) 79 | -> forall k (b :: k). 80 | forall (r :: a :~~: b) 81 | -> p @@ HRefl 82 | -> p @@ r 83 | type family (~>:~~:) p r pHRefl where 84 | forall j (a :: j) 85 | (p :: forall z (y :: z). a :~~: y ~> Type) 86 | (pHRefl :: p @@ HRefl). 87 | (~>:~~:) p HRefl pHRefl = pHRefl 88 | 89 | (~>!:~~:) :: forall j (a :: j) 90 | (p :: forall z. z ~> Prop) 91 | k (b :: k). 92 | a :~~: b 93 | -> p @@ a 94 | -> p @@ b 95 | (~>!:~~:) HRefl pHRefl = pHRefl 96 | 97 | type (~>!:~~:) :: forall j (a :: j). 98 | forall (p :: forall z. z ~> Prop) 99 | -> forall k (b :: k). 100 | a :~~: b 101 | -> p @@ a 102 | -> p @@ b 103 | type family (~>!:~~:) p r pHRefl where 104 | forall j (a :: j) 105 | (p :: forall z. z ~> Prop) 106 | (pHRefl :: p @@ a). 107 | (~>!:~~:) p (HRefl :: a :~~: a) pHRefl = pHRefl 108 | 109 | ----- 110 | 111 | -- These newtype wrappers are needed to work around 112 | -- https://gitlab.haskell.org/ghc/ghc/issues/9269 113 | type WrappedTrans' :: 114 | (Type ~> Type ~> Type) -> forall k (x :: k) (y :: k). x :~: y -> Type 115 | newtype WrappedTrans' p (e :: (x :: k) :~: y) = 116 | WrapTrans (forall (z :: k). p @@ (y :~: z) @@ (x :~: z)) 117 | 118 | type WrappedHTrans' :: 119 | (Type ~> Type ~> Type) -> forall j (x :: j) k (y :: k). x :~~: y -> Type 120 | newtype WrappedHTrans' p (e :: x :~~: y) = 121 | WrapHTrans (forall l (z :: l). p @@ (y :~~: z) @@ (x :~~: z)) 122 | 123 | $(singletons [d| 124 | type WrappedTrans :: forall k (x :: k) (y :: k). x :~: y -> Type 125 | type WrappedTrans = WrappedTrans' (TyCon2 (->)) 126 | 127 | type PWrappedTrans :: forall k (x :: k) (y :: k). x :~: y -> Type 128 | type PWrappedTrans = WrappedTrans' (~>@#@$) 129 | 130 | type WrappedHTrans :: forall j (x :: j) k (y :: k). x :~~: y -> Type 131 | type WrappedHTrans = WrappedHTrans' (TyCon2 (->)) 132 | 133 | type PWrappedHTrans :: forall j (x :: j) k (y :: k). x :~~: y -> Type 134 | type PWrappedHTrans = WrappedHTrans' (~>@#@$) 135 | |]) 136 | 137 | unwrapTrans :: WrappedTrans (e :: (x :: k) :~: y) 138 | -> forall (z :: k). y :~: z -> x :~: z 139 | unwrapTrans (WrapTrans f) = f 140 | 141 | type UnwrapTrans :: 142 | forall k (x :: k) (y :: k) (e :: x :~: y). 143 | PWrappedTrans e -> forall (z :: k). y :~: z ~> x :~: z 144 | type family UnwrapTrans wt :: forall z. y :~: z ~> x :~: z where 145 | forall k (x :: k) (y :: k) (uwt :: forall (z :: k). y :~: z ~> x :~: z). 146 | UnwrapTrans (WrapTrans uwt) = uwt 147 | 148 | unwrapHTrans :: WrappedHTrans (e :: x :~~: y) 149 | -> forall l (z :: l). y :~~: z -> x :~~: z 150 | unwrapHTrans (WrapHTrans f) = f 151 | 152 | type UnwrapHTrans :: 153 | forall j (x :: j) k (y :: k) (e :: x :~~: y). 154 | PWrappedHTrans e -> forall l (z :: l). y :~~: z ~> x :~~: z 155 | type family UnwrapHTrans wht :: forall l (z :: l). y :~~: z ~> x :~~: z where 156 | forall j (x :: j) k (y :: k) (uwht :: forall l (z :: l). y :~~: z ~> x :~~: z). 157 | UnwrapHTrans (WrapHTrans uwht) = uwht 158 | 159 | -- This is all needed to avoid impredicativity in the defunctionalization 160 | -- symbols for WhyHReplace and WhyHLeibniz. 161 | type WrappedPred :: Type 162 | newtype WrappedPred = WrapPred { unwrapPred :: forall z. z ~> Type } 163 | 164 | type UnwrapPred :: WrappedPred -> forall z. z ~> Type 165 | type family UnwrapPred wp :: forall z. z ~> Type where 166 | forall (uwp :: forall z. z ~> Type). UnwrapPred (WrapPred uwp) = uwp 167 | 168 | $(singletons [d| 169 | type WhySym :: forall t (a :: t) (y :: t). a :~: y -> Type 170 | type WhySym (e :: a :~: y) = y :~: a 171 | 172 | type WhyHSym :: forall j (a :: j) t (y :: t). a :~~: y -> Type 173 | type WhyHSym (e :: a :~~: y) = y :~~: a 174 | 175 | type TransStep :: forall k (x :: k) (z :: k). x :~: z -> x :~: z 176 | type TransStep e = e 177 | 178 | type HTransStep :: forall j (x :: j) k (z :: k). x :~~: z -> x :~~: z 179 | type HTransStep e = e 180 | |]) 181 | 182 | $(singletons [d| 183 | -- These use eliminators, but th-desugar takes a while to expand them. 184 | -- TODO RGS: Investigate why. 185 | {- 186 | type Trans :: a :~: b -> b :~: c -> a :~: c 187 | type Trans x y = 188 | UnwrapTrans ((~>:~:) PWrappedTransSym0 x (WrapTrans TransStepSym0)) @@ y 189 | 190 | type HTrans :: a :~~: b -> b :~~: c -> a :~~: c 191 | type HTrans x y = 192 | UnwrapHTrans ((~>:~~:) PWrappedHTransSym0 x (WrapHTrans HTransStepSym0)) @@ y 193 | -} 194 | 195 | type Trans :: a :~: b -> b :~: c -> a :~: c 196 | type family Trans x y where 197 | Trans Refl Refl = Refl 198 | 199 | type HTrans :: a :~~: b -> b :~~: c -> a :~~: c 200 | type family HTrans x y where 201 | HTrans HRefl HRefl = HRefl 202 | |]) 203 | 204 | type WhyReplace :: forall t. forall (from :: t) 205 | -> (t ~> Type) 206 | -> forall (y :: t). from :~: y 207 | -> Type 208 | type WhyReplace from p (e :: from :~: y) = p @@ y 209 | data WhyReplaceSym2 :: forall t. forall (from :: t) 210 | -> (t ~> Type) 211 | -> forall (y :: t). from :~: y 212 | ~> Type 213 | type instance Apply (WhyReplaceSym2 x y) z = WhyReplace x y z 214 | 215 | type WhyHReplace :: forall j. forall (from :: j) 216 | -> WrappedPred 217 | -> forall k (y :: k). from :~~: y 218 | -> Type 219 | type WhyHReplace from p (e :: from :~~: y) = UnwrapPred p @@ y 220 | data WhyHReplaceSym2 :: forall j. forall (from :: j) 221 | -> WrappedPred 222 | -> forall k (y :: k). from :~~: y ~> Type 223 | type instance Apply (WhyHReplaceSym2 x y) z = WhyHReplace x y z 224 | 225 | $(singletons [d| 226 | type WhyLeibniz (f :: t ~> Type) (a :: t) (z :: t) = 227 | f @@ a -> f @@ z :: Type 228 | |]) 229 | 230 | type WhyHLeibniz :: WrappedPred 231 | -> forall j. j 232 | -> forall k. k 233 | -> Type 234 | type WhyHLeibniz f a b = UnwrapPred f @@ a -> UnwrapPred f @@ b 235 | data WhyHLeibnizSym2 :: WrappedPred 236 | -> forall j. j 237 | -> forall k. k 238 | ~> Type 239 | type instance Apply (WhyHLeibnizSym2 x y) z = WhyHLeibniz x y z 240 | 241 | type WhyCong :: (x ~> y) -> forall (a :: x) (z :: x). a :~: z -> Type 242 | type WhyCong f (e :: a :~: z) = f @@ a :~: f @@ z 243 | data WhyCongSym1 :: (x ~> y) -> forall (a :: x) (z :: x). a :~: z ~> Type 244 | type instance Apply (WhyCongSym1 x) y = WhyCong x y 245 | 246 | $(singletons [d| 247 | type WhyEqIsRefl :: forall k (a :: k) (z :: k). a :~: z -> Type 248 | type WhyEqIsRefl (e :: a :~: z) = e :~~: (Refl :: a :~: a) 249 | 250 | type WhyHEqIsHRefl :: forall j (a :: j) k (z :: k). a :~~: z -> Type 251 | type WhyHEqIsHRefl (e :: a :~~: z) = e :~~: (HRefl :: a :~~: a) 252 | 253 | type WhyTransLeft :: forall k (a :: k) (z :: k). a :~: z -> Type 254 | type WhyTransLeft e = Trans e Refl :~: e 255 | 256 | type WhyHTransLeft :: forall j (a :: j) k (z :: k). a :~~: z -> Type 257 | type WhyHTransLeft e = HTrans e HRefl :~: e 258 | 259 | type WhyTransRight :: forall k (a :: k) (z :: k). a :~: z -> Type 260 | type WhyTransRight e = Trans Refl e :~: e 261 | 262 | type WhyHTransRight :: forall j (a :: j) k (z :: k). a :~~: z -> Type 263 | type WhyHTransRight e = HTrans HRefl e :~: e 264 | 265 | type WhyRebalance :: x2 :~: x3 -> x3 :~: x4 -> x1 :~: x2 -> Type 266 | type WhyRebalance b c a = Trans a (Trans b c) :~: Trans (Trans a b) c 267 | 268 | type WhyHRebalance :: x2 :~~: x3 -> x3 :~~: x4 -> x1 :~~: x2 -> Type 269 | type WhyHRebalance b c a = HTrans a (HTrans b c) :~: HTrans (HTrans a b) c 270 | |]) 271 | 272 | type Symmetry :: a :~: b -> b :~: a 273 | type Symmetry (r :: a :~: b) = (~>:~:) WhySymSym0 r Refl 274 | 275 | type HSymmetry :: a :~~: b -> b :~~: a 276 | type HSymmetry (r :: a :~~: b) = (~>:~~:) WhyHSymSym0 r HRefl 277 | 278 | -- These newtype wrappers are needed to work around 279 | -- https://gitlab.haskell.org/ghc/ghc/issues/9269 280 | type WrappedSTrans :: forall k (x :: k) (y :: k). x :~: y -> Type 281 | newtype WrappedSTrans (e1 :: (x :: k) :~: y) = 282 | WrapSTrans { unwrapSTrans :: forall (z :: k) (e2 :: y :~: z). 283 | Sing e2 -> Sing (Trans e1 e2) } 284 | 285 | type WrappedSHTrans :: forall j (x :: j) k (y :: k). x :~~: y -> Type 286 | newtype WrappedSHTrans (e1 :: x :~~: y) = 287 | WrapSHTrans { unwrapSHTrans :: forall l (z :: l) (e2 :: y :~~: z). 288 | Sing e2 -> Sing (HTrans e1 e2) } 289 | 290 | $(singletons [d| 291 | type WhySSym :: forall t (a :: t) (y :: t). a :~: y -> Type 292 | type WhySSym e = Sing (Symmetry e) 293 | 294 | type WhySymIdempotent :: forall t (a :: t) (z :: t). a :~: z -> Type 295 | type WhySymIdempotent r = Symmetry (Symmetry r) :~: r 296 | 297 | type WhySHSym :: forall j (a :: j) z (y :: z). a :~~: y -> Type 298 | type WhySHSym e = Sing (HSymmetry e) 299 | 300 | type WhyHSymIdempotent :: forall j (a :: j) z (y :: z). a :~~: y -> Type 301 | type WhyHSymIdempotent r = HSymmetry (HSymmetry r) :~: r 302 | 303 | type WhyTransLeftHelper :: forall k (b :: k) (z :: k). b :~: z -> Type 304 | type WhyTransLeftHelper e = Trans (Symmetry e) Refl :~: Symmetry e 305 | 306 | type WhyHTransLeftHelper :: forall k. forall (b :: k) j (z :: j). b :~~: z -> Type 307 | type WhyHTransLeftHelper e = HTrans (HSymmetry e) HRefl :~: HSymmetry e 308 | 309 | type WhySTrans :: forall k (x :: k) (y :: k). x :~: y -> Type 310 | type WhySTrans e = WrappedSTrans e 311 | 312 | type WhySHTrans :: forall j (x :: j) k (y :: k). x :~~: y -> Type 313 | type WhySHTrans e = WrappedSHTrans e 314 | |]) 315 | 316 | type WhyRebalanceHelper :: x2 :~: x3 -> x3 :~: x4 -> forall x1. x2 :~: x1 -> Type 317 | type WhyRebalanceHelper b c a = 318 | Trans (Symmetry a) (Trans b c) :~: Trans (Trans (Symmetry a) b) c 319 | data WhyRebalanceHelperSym2 :: x2 :~: x3 -> x3 :~: x4 -> forall x1. x2 :~: x1 ~> Type 320 | type instance Apply (WhyRebalanceHelperSym2 x y) z = WhyRebalanceHelper x y z 321 | 322 | type WhyHRebalanceHelper :: x2 :~~: x3 -> x3 :~~: x4 -> forall k1 (x1 :: k1). x2 :~~: x1 -> Type 323 | type WhyHRebalanceHelper b c a = 324 | HTrans (HSymmetry a) (HTrans b c) :~: HTrans (HTrans (HSymmetry a) b) c 325 | data WhyHRebalanceHelperSym2 :: x2 :~~: x3 -> x3 :~~: x4 -> forall k1 (x1 :: k1). x2 :~~: x1 ~> Type 326 | type instance Apply (WhyHRebalanceHelperSym2 x y) z = WhyHRebalanceHelper x y z 327 | -------------------------------------------------------------------------------- /tests/GADTSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeAbstractions #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module GADTSpec where 8 | 9 | import Data.Kind 10 | import Data.Singletons.TH 11 | import Data.Singletons.TH.Options 12 | 13 | import Internal 14 | 15 | import Test.Hspec 16 | 17 | main :: IO () 18 | main = hspec spec 19 | 20 | spec :: Spec 21 | spec = pure () 22 | 23 | ----- 24 | 25 | $(withOptions defaultOptions{genSingKindInsts = False} $ 26 | singletons [d| 27 | type So :: Bool -> Type 28 | data So b where 29 | Oh :: So True 30 | |]) 31 | 32 | elimSo :: forall (p :: forall (long_sucker :: Bool). So long_sucker ~> Type) 33 | (what :: Bool) (s :: So what). 34 | Sing s 35 | -> p @@ Oh 36 | -> p @@ s 37 | elimSo SOh pOh = pOh 38 | 39 | type ElimSo :: forall (p :: forall (long_sucker :: Bool). So long_sucker ~> Type) 40 | -> forall (what :: Bool). 41 | forall (s :: So what) 42 | -> p @@ Oh 43 | -> p @@ s 44 | type family ElimSo p s pOh where 45 | forall (p :: forall (long_sucker :: Bool). So long_sucker ~> Type) 46 | (pOh :: p @@ Oh). 47 | ElimSo p Oh pOh = pOh 48 | 49 | elimPropSo :: forall (p :: Bool ~> Prop) (what :: Bool). 50 | So what 51 | -> p @@ True 52 | -> p @@ what 53 | elimPropSo Oh pOh = pOh 54 | 55 | type ElimPropSo :: forall (p :: Bool ~> Prop) 56 | -> forall (what :: Bool). 57 | So what 58 | -> p @@ True 59 | -> p @@ what 60 | type family ElimPropSo p s pOh where 61 | forall (p :: Bool ~> Prop) (pOh :: p @@ True). 62 | ElimPropSo p Oh pOh = pOh 63 | 64 | $(withOptions defaultOptions{genSingKindInsts = False} $ 65 | singletons [d| 66 | type Flarble :: Type -> Type -> Type 67 | data Flarble a b where 68 | MkFlarble1 :: a -> Flarble a b 69 | -- MkFlarble2 :: a ~ Bool => Flarble a (Maybe b) 70 | MkFlarble2 :: Flarble Bool (Maybe b) 71 | |]) 72 | 73 | elimFlarble :: forall (p :: forall x y. Flarble x y ~> Type) 74 | a b (f :: Flarble a b). 75 | Sing f 76 | -> (forall a' b' (x :: a'). Sing x -> p @@ (MkFlarble1 x :: Flarble a' b')) 77 | -> (forall b'. p @@ (MkFlarble2 :: Flarble Bool (Maybe b'))) 78 | -> p @@ f 79 | elimFlarble sf pMkFlarble1 pMkFlarble2 = go @a @b @f sf 80 | where 81 | go :: forall a' b' (f' :: Flarble a' b'). 82 | Sing f' -> p @@ f' 83 | go s@(SMkFlarble1 sx) = 84 | case s of 85 | (_ :: Sing (MkFlarble1 x :: Flarble a'' b'')) -> pMkFlarble1 @a'' @b'' @x sx 86 | go s@SMkFlarble2 = 87 | case s of 88 | (_ :: Sing (MkFlarble2 :: Flarble Bool (Maybe b''))) -> pMkFlarble2 @b'' 89 | 90 | type ElimFlarble :: 91 | forall (p :: forall x y. Flarble x y ~> Type) 92 | -> forall a b. 93 | forall (f :: Flarble a b) 94 | -> (forall a' b'. forall (x :: a') -> p @@ (MkFlarble1 x :: Flarble a' b')) 95 | -> (forall b'. p @@ (MkFlarble2 :: Flarble Bool (Maybe b'))) 96 | -> p @@ f 97 | type family ElimFlarble p f pMkFlarble1 pMkFlarble2 where 98 | forall (p :: forall x y. Flarble x y ~> Type) a b 99 | (pMkFlarble1 :: forall a' b'. forall (x :: a') -> p @@ (MkFlarble1 x :: Flarble a' b')) 100 | (pMkFlarble2 :: forall b'. p @@ (MkFlarble2 :: Flarble Bool (Maybe b'))) x. 101 | ElimFlarble p (MkFlarble1 x :: Flarble a b) pMkFlarble1 pMkFlarble2 = 102 | pMkFlarble1 @a @b x 103 | forall (p :: forall x y. Flarble x y ~> Type) 104 | (pMkFlarble1 :: forall a' b'. forall (x :: a') -> p @@ (MkFlarble1 x :: Flarble a' b')) 105 | (pMkFlarble2 :: forall b'. p @@ (MkFlarble2 :: Flarble Bool (Maybe b'))) b'. 106 | ElimFlarble p (MkFlarble2 :: Flarble Bool (Maybe b')) pMkFlarble1 pMkFlarble2 = 107 | pMkFlarble2 @b' 108 | 109 | elimPropFlarble :: forall (p :: Type ~> Type ~> Prop) a b. 110 | Flarble a b 111 | -> (forall a' b'. a' -> p @@ a' @@ b') 112 | -> (forall b'. p @@ Bool @@ Maybe b') 113 | -> p @@ a @@ b 114 | elimPropFlarble fl pMkFlarble1 pMkFlarble2 = go @a @b fl 115 | where 116 | go :: forall a' b'. Flarble a' b' -> p @@ a' @@ b' 117 | go f@(MkFlarble1 x) = 118 | case f of 119 | (_ :: Flarble a'' b'') -> pMkFlarble1 @a'' @b'' x 120 | go f@MkFlarble2 = 121 | case f of 122 | (_ :: Flarble Bool (Maybe b'')) -> pMkFlarble2 @b'' 123 | 124 | type ElimPropFlarble :: 125 | forall (p :: Type ~> Type ~> Prop) 126 | -> forall a b. 127 | Flarble a b 128 | -> (forall a' b'. a' ~> p @@ a' @@ b') 129 | -> (forall b'. p @@ Bool @@ Maybe b') 130 | -> p @@ a @@ b 131 | type family ElimPropFlarble p f pMkFlarble1 pMkFlarble2 where 132 | forall (p :: Type ~> Type ~> Prop) a b 133 | (pMkFlarble1 :: forall a' b'. a' ~> p @@ a' @@ b') 134 | (pMkFlarble2 :: forall b'. p @@ Bool @@ Maybe b') x. 135 | ElimPropFlarble p (MkFlarble1 x :: Flarble a b) pMkFlarble1 pMkFlarble2 = 136 | pMkFlarble1 @a @b @@ x 137 | forall (p :: Type ~> Type ~> Prop) 138 | (pMkFlarble1 :: forall a' b'. a' ~> p @@ a' @@ b') 139 | (pMkFlarble2 :: forall b'. p @@ Bool @@ Maybe b') b'. 140 | ElimPropFlarble p (MkFlarble2 :: Flarble Bool (Maybe b')) pMkFlarble1 pMkFlarble2 = 141 | pMkFlarble2 @b' 142 | 143 | $(withOptions defaultOptions{genSingKindInsts = False} $ 144 | singletons [d| 145 | type Obj :: Type 146 | data Obj where 147 | MkObj :: o -> Obj 148 | |]) 149 | 150 | elimObj :: forall (p :: Obj ~> Type) (o :: Obj). 151 | Sing o 152 | -> (forall obj (x :: obj). Sing x -> p @@ MkObj x) 153 | -> p @@ o 154 | elimObj (SMkObj (sx :: Sing (x :: obj))) pMkObj = pMkObj @obj @x sx 155 | 156 | type ElimObj :: forall (p :: Obj ~> Type) 157 | (o :: Obj) 158 | -> (forall obj. forall (x :: obj) -> p @@ MkObj x) 159 | -> p @@ o 160 | type family ElimObj p o pMkObj where 161 | forall (p :: Obj ~> Type) 162 | (pMkObj :: forall obj. forall (x :: obj) -> p @@ MkObj x) 163 | obj (x :: obj). 164 | ElimObj p (MkObj (x :: obj)) pMkObj = pMkObj @obj x 165 | 166 | elimPropObj :: forall (p :: Prop). 167 | Obj 168 | -> (forall obj. obj -> p) 169 | -> p 170 | elimPropObj (MkObj o) pMkObj = pMkObj o 171 | 172 | type ElimPropObj :: forall (p :: Prop) -> Obj -> (forall obj. obj ~> p) -> p 173 | type family ElimPropObj p o pMkObj where 174 | forall (p :: Prop) (pMkObj :: forall obj. obj ~> p) o. 175 | ElimPropObj p (MkObj o) pMkObj = pMkObj @@ o 176 | -------------------------------------------------------------------------------- /tests/Internal.hs: -------------------------------------------------------------------------------- 1 | module Internal where 2 | 3 | import Data.Kind 4 | 5 | type Prop :: Type 6 | type Prop = Type 7 | -------------------------------------------------------------------------------- /tests/ListSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | module ListSpec where 4 | 5 | import Data.Eliminator 6 | import Data.List.Singletons 7 | import Data.Type.Equality 8 | 9 | import EqualitySpec (cong) 10 | import ListTypes 11 | 12 | import Prelude.Singletons 13 | 14 | import Test.Hspec 15 | 16 | main :: IO () 17 | main = hspec spec 18 | 19 | spec :: Spec 20 | spec = pure () 21 | 22 | ----- 23 | 24 | mapPreservesLength :: forall x y (f :: x ~> y) (l :: [x]). 25 | SingI l 26 | => Length l :~: Length (Map f l) 27 | mapPreservesLength 28 | = elimList @x @(WhyMapPreservesLengthSym1 f) @l (sing @l) base step 29 | where 30 | base :: WhyMapPreservesLength f '[] 31 | base = Refl 32 | 33 | step :: forall (s :: x). Sing s 34 | -> forall (ss :: [x]). Sing ss 35 | -> WhyMapPreservesLength f ss 36 | -> WhyMapPreservesLength f (s:ss) 37 | step _ _ = cong @_ @_ @((+@#@$$) 1) 38 | 39 | mapFusion :: forall x y z 40 | (f :: y ~> z) (g :: x ~> y) (l :: [x]). 41 | SingI l 42 | => Map f (Map g l) :~: Map (f .@#@$$$ g) l 43 | mapFusion 44 | = elimList @x @(WhyMapFusionSym2 f g) @l (sing @l) base step 45 | where 46 | base :: WhyMapFusion f g '[] 47 | base = Refl 48 | 49 | step :: forall (s :: x). Sing s 50 | -> forall (ss :: [x]). Sing ss 51 | -> WhyMapFusion f g ss 52 | -> WhyMapFusion f g (s:ss) 53 | step _ _ = cong @_ @_ @((:@#@$$) (f @@ (g @@ s))) 54 | -------------------------------------------------------------------------------- /tests/ListTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeAbstractions #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | module ListTypes where 7 | 8 | import Data.Kind 9 | import Data.List.Singletons 10 | import Data.Singletons.TH 11 | import Prelude.Singletons 12 | 13 | $(singletons [d| 14 | type WhyMapPreservesLength :: (x ~> y) -> [x] -> Type 15 | type WhyMapPreservesLength f l = Length l :~: Length (Map f l) 16 | 17 | type WhyMapFusion :: (y ~> z) -> (x ~> y) -> [x] -> Type 18 | type WhyMapFusion f g l = Map f (Map g l) :~: Map (f .@#@$$$ g) l 19 | |]) 20 | -------------------------------------------------------------------------------- /tests/MatchabilizeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | module MatchabilizeSpec where 3 | 4 | import Data.Eliminator 5 | import Data.Type.Equality 6 | 7 | import MatchabilizeTypes 8 | 9 | import Prelude.Singletons 10 | 11 | import Test.Hspec 12 | 13 | main :: IO () 14 | main = hspec spec 15 | 16 | spec :: Spec 17 | spec = pure () 18 | 19 | ----- 20 | 21 | type ElimMaybeSimple :: b -> (a ~> b) -> Maybe a -> b 22 | type ElimMaybeSimple (n :: b) j m = 23 | UnMatchabilize (ElimMaybe (ConstSym1 b) m n (Matchabilize j)) 24 | 25 | test1 :: ElimMaybeSimple "a" IdSym0 Nothing :~: "a" 26 | test1 = Refl 27 | 28 | test2 :: ElimMaybeSimple "a" IdSym0 (Just "b") :~: "b" 29 | test2 = Refl 30 | -------------------------------------------------------------------------------- /tests/MatchabilizeTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# OPTIONS_GHC -Wno-unused-foralls #-} 4 | module MatchabilizeTypes where 5 | 6 | import Data.Singletons 7 | 8 | type Matchabilize :: (a ~> b) -> forall (x :: a) -> b 9 | data family Matchabilize 10 | 11 | type UnMatchabilize :: k -> k 12 | type family UnMatchabilize a where 13 | UnMatchabilize (Matchabilize f a) = f @@ a 14 | UnMatchabilize x = x 15 | -------------------------------------------------------------------------------- /tests/PolyRecTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeAbstractions #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module PolyRecTypes where 8 | 9 | import Data.Kind 10 | import Data.Singletons.Base.TH 11 | 12 | import Internal 13 | 14 | $(singletons [d| 15 | type WeirdList :: Type -> Type 16 | data WeirdList a = WeirdNil | WeirdCons a (WeirdList (WeirdList a)) 17 | |]) 18 | 19 | elimWeirdList :: forall (p :: forall t. WeirdList t ~> Type) 20 | a (wl :: WeirdList a). 21 | Sing wl 22 | -> (forall t. p @t @@ WeirdNil) 23 | -> (forall t (x :: t) (xs :: WeirdList (WeirdList t)). 24 | Sing x -> Sing xs -> p @(WeirdList t) @@ xs -> p @t @@ (WeirdCons x xs)) 25 | -> p @a @@ wl 26 | elimWeirdList swl pWeirdNil pWeirdCons = go @a @wl swl 27 | where 28 | go :: forall t (wlt :: WeirdList t). Sing wlt -> p @t @@ wlt 29 | go SWeirdNil = pWeirdNil @t 30 | go (SWeirdCons (sx :: Sing x) (sxs :: Sing xs)) = 31 | pWeirdCons @t @x @xs sx sxs (go @(WeirdList t) @xs sxs) 32 | 33 | type ElimWeirdList :: forall (p :: forall t. WeirdList t ~> Type) 34 | -> forall a. 35 | forall (wl :: WeirdList a) 36 | -> (forall t. p @t @@ WeirdNil) 37 | -> (forall t. 38 | forall (x :: t) (xs :: WeirdList (WeirdList t)) -> 39 | p @(WeirdList t) @@ xs ~> p @t @@ (WeirdCons x xs)) 40 | -> p @a @@ wl 41 | type family ElimWeirdList p wl pWeirdNil pWeirdCons where 42 | forall (p :: forall t. WeirdList t ~> Type) 43 | (pWeirdNil :: forall t. p @t @@ WeirdNil) 44 | (pWeirdCons :: forall t. forall (x :: t) (xs :: WeirdList (WeirdList t)) -> 45 | p @(WeirdList t) @@ xs ~> p @t @@ (WeirdCons x xs)) 46 | a. 47 | ElimWeirdList p (WeirdNil @a) pWeirdNil pWeirdCons = pWeirdNil @a 48 | forall (p :: forall t. WeirdList t ~> Type) 49 | (pWeirdNil :: forall t. p @t @@ WeirdNil) 50 | (pWeirdCons :: forall t. forall (x :: t) (xs :: WeirdList (WeirdList t)) -> 51 | p @(WeirdList t) @@ xs ~> p @t @@ (WeirdCons x xs)) 52 | a (x :: a) (xs :: WeirdList (WeirdList a)). 53 | ElimWeirdList p (WeirdCons @a x xs) pWeirdNil pWeirdCons = 54 | pWeirdCons @a x xs @@ ElimWeirdList p @(WeirdList a) xs pWeirdNil pWeirdCons 55 | 56 | elimPropWeirdList :: forall (p :: Prop ~> Prop) 57 | (a :: Prop). 58 | WeirdList a 59 | -> (forall (t :: Prop). p @@ t) 60 | -> (forall (t :: Prop). 61 | t -> WeirdList (WeirdList t) -> p @@ WeirdList t -> p @@ t) 62 | -> p @@ a 63 | elimPropWeirdList wl pWeirdNil pWeirdCons = go @a wl 64 | where 65 | go :: forall (t :: Prop). WeirdList t -> p @@ t 66 | go WeirdNil = pWeirdNil @t 67 | go (WeirdCons x xs) = pWeirdCons @t x xs (go @(WeirdList t) xs) 68 | 69 | type ElimPropWeirdList :: forall (p :: Prop ~> Prop) 70 | -> forall (a :: Prop). 71 | WeirdList a 72 | -> (forall (t :: Prop). p @@ t) 73 | -> (forall (t :: Prop). 74 | t ~> WeirdList (WeirdList t) ~> p @@ WeirdList t ~> p @@ t) 75 | -> p @@ a 76 | type family ElimPropWeirdList p wl pWeirdNil pWeirdCons where 77 | forall (p :: Prop ~> Prop) 78 | (pWeirdNil :: forall (t :: Prop). p @@ t) 79 | (pWeirdCons :: forall (t :: Prop). t ~> WeirdList (WeirdList t) ~> p @@ WeirdList t ~> p @@ t) 80 | a. 81 | ElimPropWeirdList p (WeirdNil @a) pWeirdNil pWeirdCons = pWeirdNil @a 82 | forall (p :: Prop ~> Prop) 83 | (pWeirdNil :: forall (t :: Prop). p @@ t) 84 | (pWeirdCons :: forall (t :: Prop). t ~> WeirdList (WeirdList t) ~> p @@ WeirdList t ~> p @@ t) 85 | a (x :: a) (xs :: WeirdList (WeirdList a)). 86 | ElimPropWeirdList p (WeirdCons x xs) pWeirdNil pWeirdCons = 87 | pWeirdCons @a @@ x @@ xs @@ ElimPropWeirdList p @(WeirdList a) xs pWeirdNil pWeirdCons 88 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /tests/VecSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE NoStarIsType #-} 4 | module VecSpec where 5 | 6 | import Data.Eliminator 7 | import Data.Nat 8 | 9 | import Prelude.Singletons 10 | 11 | import VecTypes 12 | 13 | import Test.Hspec 14 | 15 | main :: IO () 16 | main = hspec spec 17 | 18 | spec :: Spec 19 | spec = parallel $ do 20 | describe "replicateVec" $ do 21 | it "works with empty lists" $ 22 | replicateVec (sLit @0) () `shouldBe` VNil 23 | it "works with non-empty lists" $ do 24 | replicateVec (sLit @1) () `shouldBe` () :# VNil 25 | replicateVec (sLit @2) () `shouldBe` () :# () :# VNil 26 | describe "mapVec" $ do 27 | it "maps over a Vec" $ do 28 | mapVec reverse ("hello" :# "world" :# VNil) 29 | `shouldBe` ("olleh" :# "dlrow" :# VNil) 30 | describe "zipWithVec" $ do 31 | it "zips two Vecs" $ do 32 | zipWithVec (,) ((2 :: Int) :# 22 :# VNil) 33 | ("chicken-of-the-woods" :# "hen-of-woods" :# VNil) 34 | `shouldBe` ((2, "chicken-of-the-woods") :# (22, "hen-of-woods") 35 | :# VNil) 36 | describe "appendVec" $ do 37 | it "appends two Vecs" $ do 38 | appendVec ("portabello" :# "bay-bolete" 39 | :# "funnel-chantrelle" 40 | :# VNil) 41 | ("sheathed-woodtuft" :# "puffball" :# VNil) 42 | `shouldBe` ("portabello" :# "bay-bolete" 43 | :# "funnel-chantrelle" 44 | :# "sheathed-woodtuft" 45 | :# "puffball" 46 | :# VNil) 47 | describe "transposeVec" $ do 48 | it "transposes a Vec" $ do 49 | transposeVec (('a' :# 'b' :# 'c' :# VNil) 50 | :# ('d' :# 'e' :# 'f' :# VNil) 51 | :# VNil) 52 | `shouldBe` 53 | (('a' :# 'd' :# VNil) 54 | :# ('b' :# 'e' :# VNil) 55 | :# ('c' :# 'f' :# VNil) 56 | :# VNil) 57 | describe "concatVec" $ do 58 | it "concats a Vec of Vecs" $ do 59 | concatVec ((False :# True :# False :# VNil) 60 | :# (True :# False :# True :# VNil) 61 | :# VNil) 62 | `shouldBe` (False :# True :# False :# True 63 | :# False :# True :# VNil) 64 | 65 | ----- 66 | 67 | replicateVec :: forall e (howMany :: Nat). 68 | Sing howMany -> e -> Vec e howMany 69 | replicateVec s e = elimNat @(TyCon (Vec e)) @howMany s VNil step 70 | where 71 | step :: forall (k :: Nat). Sing k -> Vec e k -> Vec e (S k) 72 | step _ = (e :#) 73 | 74 | mapVec :: forall a b (n :: Nat). 75 | SingI n 76 | => (a -> b) -> Vec a n -> Vec b n 77 | mapVec f = elimNat @(WhyMapVecSym2 a b) @n (sing @n) base step 78 | where 79 | base :: WhyMapVec a b Z 80 | base _ = VNil 81 | 82 | step :: forall (k :: Nat). Sing k -> WhyMapVec a b k -> WhyMapVec a b (S k) 83 | step _ mapK vK = f (vhead vK) :# mapK (vtail vK) 84 | 85 | zipWithVec :: forall a b c (n :: Nat). 86 | SingI n 87 | => (a -> b -> c) -> Vec a n -> Vec b n -> Vec c n 88 | zipWithVec f = elimNat @(WhyZipWithVecSym3 a b c) @n (sing @n) base step 89 | where 90 | base :: WhyZipWithVec a b c Z 91 | base _ _ = VNil 92 | 93 | step :: forall (k :: Nat). 94 | Sing k 95 | -> WhyZipWithVec a b c k 96 | -> WhyZipWithVec a b c (S k) 97 | step _ zwK vaK vbK = f (vhead vaK) (vhead vbK) 98 | :# zwK (vtail vaK) (vtail vbK) 99 | 100 | appendVec :: forall e (n :: Nat) (m :: Nat). 101 | SingI n 102 | => Vec e n -> Vec e m -> Vec e (n + m) 103 | appendVec = elimNat @(WhyAppendVecSym2 e m) @n (sing @n) base step 104 | where 105 | base :: WhyAppendVec e m Z 106 | base _ = id 107 | 108 | step :: forall (k :: Nat). 109 | Sing k 110 | -> WhyAppendVec e m k 111 | -> WhyAppendVec e m (S k) 112 | step _ avK vK1 vK2 = vhead vK1 :# avK (vtail vK1) vK2 113 | 114 | transposeVec :: forall e (n :: Nat) (m :: Nat). 115 | (SingI n, SingI m) 116 | => Vec (Vec e m) n -> Vec (Vec e n) m 117 | transposeVec = elimNat @(WhyTransposeVecSym2 e m) @n (sing @n) base step 118 | where 119 | base :: WhyTransposeVec e m Z 120 | base _ = replicateVec (sing @m) VNil 121 | 122 | step :: forall (k :: Nat). 123 | Sing k 124 | -> WhyTransposeVec e m k 125 | -> WhyTransposeVec e m (S k) 126 | step _ transK vK = zipWithVec (:#) (vhead vK) (transK (vtail vK)) 127 | 128 | concatVec :: forall e (n :: Nat) (j :: Nat). 129 | (SingKind e, SingI j, e ~ Demote e) 130 | => Vec (Vec e j) n -> Vec e (n * j) 131 | concatVec l = withSomeSing l $ \(singL :: Sing l) -> 132 | elimVec @(Vec e j) @WhyConcatVecSym0 @n @l singL base step 133 | where 134 | base :: WhyConcatVec VNil 135 | base = VNil 136 | 137 | step :: forall (k :: Nat) (x :: Vec e j) (xs :: Vec (Vec e j) k). 138 | Sing x -> Sing xs 139 | -> WhyConcatVec xs 140 | -> WhyConcatVec (x :# xs) 141 | step h _ vKJ = appendVec (fromSing h) vKJ 142 | -------------------------------------------------------------------------------- /tests/VecTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE NoStarIsType #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeAbstractions #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | module VecTypes where 9 | 10 | import Data.Kind (Type) 11 | import Data.Nat 12 | import Data.Singletons.Base.TH 13 | import Data.Singletons.TH.Options 14 | 15 | import Internal 16 | 17 | import Prelude.Singletons 18 | 19 | $(withOptions defaultOptions{genSingKindInsts = False} $ 20 | singletons [d| 21 | type Vec :: Type -> Nat -> Type 22 | data Vec a n where 23 | VNil :: Vec a Z 24 | (:#) :: { vhead :: a, vtail :: Vec a n } -> Vec a (S n) 25 | infixr 5 :# 26 | |]) 27 | deriving instance Eq a => Eq (Vec a n) 28 | deriving instance Ord a => Ord (Vec a n) 29 | deriving instance Show a => Show (Vec a n) 30 | 31 | instance SingKind a => SingKind (Vec a n) where 32 | type Demote (Vec a n) = Vec (Demote a) n 33 | fromSing SVNil = VNil 34 | fromSing (x :%# xs) = fromSing x :# fromSing xs 35 | toSing VNil = SomeSing SVNil 36 | toSing (x :# xs) = 37 | withSomeSing x $ \sx -> 38 | withSomeSing xs $ \sxs -> 39 | SomeSing $ sx :%# sxs 40 | 41 | elimVec :: forall a (p :: forall (k :: Nat). Vec a k ~> Type) 42 | (n :: Nat) (v :: Vec a n). 43 | Sing v 44 | -> p @@ VNil 45 | -> (forall (k :: Nat) (x :: a) (xs :: Vec a k). 46 | Sing x -> Sing xs -> p @@ xs -> p @@ (x :# xs)) 47 | -> p @@ v 48 | elimVec sv pVNil pVCons = go @n @v sv 49 | where 50 | go :: forall (n' :: Nat) (v' :: Vec a n'). 51 | Sing v' -> p @@ v' 52 | go SVNil = pVNil 53 | go (sx :%# (sxs :: Sing (xs :: Vec a k))) = 54 | pVCons sx sxs (go @k @xs sxs) 55 | 56 | type ElimVec :: forall a. 57 | forall (p :: forall (k :: Nat). Vec a k ~> Type) 58 | -> forall (n :: Nat). 59 | forall (v :: Vec a n) 60 | -> p @@ VNil 61 | -> (forall (k :: Nat). 62 | forall (x :: a) (xs :: Vec a k) -> 63 | p @@ xs ~> p @@ (x :# xs)) 64 | -> p @@ v 65 | type family ElimVec p v pVNil pVCons where 66 | forall a (p :: forall (k :: Nat). Vec a k ~> Type) 67 | (pVNil :: p @@ VNil) 68 | (pVCons :: forall (k :: Nat). 69 | forall (x :: a) (xs :: Vec a k) -> 70 | p @@ xs ~> p @@ (x :# xs)). 71 | ElimVec p VNil pVNil pVCons = pVNil 72 | forall a (p :: forall (k :: Nat). Vec a k ~> Type) 73 | (pVNil :: p @@ VNil) 74 | (pVCons :: forall (k :: Nat). 75 | forall (x :: a) (xs :: Vec a k) -> 76 | p @@ xs ~> p @@ (x :# xs)) k x xs. 77 | ElimVec p (x :# (xs :: Vec a k)) pVNil pVCons = 78 | pVCons x xs @@ ElimVec @a p @k xs pVNil pVCons 79 | 80 | elimPropVec :: forall a (p :: Nat ~> Prop) (n :: Nat). 81 | Vec a n 82 | -> p @@ Z 83 | -> (forall (k :: Nat). a -> Vec a k -> p @@ k -> p @@ S k) 84 | -> p @@ n 85 | elimPropVec v pZ pS = go @n v 86 | where 87 | go :: forall (n' :: Nat). Vec a n' -> p @@ n' 88 | go VNil = pZ 89 | go (x :# (xs :: Vec a k)) = pS x xs (go @k xs) 90 | 91 | type ElimPropVec :: forall a. 92 | forall (p :: Nat ~> Prop) 93 | -> forall (n :: Nat). 94 | Vec a n 95 | -> p @@ Z 96 | -> (forall (k :: Nat). a ~> Vec a k ~> p @@ k ~> p @@ S k) 97 | -> p @@ n 98 | type family ElimPropVec p v pZ pS where 99 | forall a (p :: Nat ~> Prop) 100 | (pZ :: p @@ Z) 101 | (pS :: forall (k :: Nat). a ~> Vec a k ~> p @@ k ~> p @@ S k). 102 | ElimPropVec p VNil pZ pS = pZ 103 | forall a (p :: Nat ~> Prop) 104 | (pZ :: p @@ Z) 105 | (pS :: forall (k :: Nat). a ~> Vec a k ~> p @@ k ~> p @@ S k) k x xs. 106 | ElimPropVec p (x :# (xs :: Vec a k)) pZ pS = 107 | pS @@ x @@ xs @@ ElimPropVec @a p @k xs pZ pS 108 | 109 | $(singletons [d| 110 | type WhyMapVec :: Type -> Type -> Nat -> Type 111 | type WhyMapVec a b n = Vec a n -> Vec b n 112 | 113 | type WhyZipWithVec :: Type -> Type -> Type -> Nat -> Type 114 | type WhyZipWithVec a b c n = Vec a n -> Vec b n -> Vec c n 115 | 116 | type WhyAppendVec :: Type -> Nat -> Nat -> Type 117 | type WhyAppendVec e m n = Vec e n -> Vec e m -> Vec e (n + m) 118 | 119 | type WhyTransposeVec :: Type -> Nat -> Nat -> Type 120 | type WhyTransposeVec e m n = Vec (Vec e m) n -> Vec (Vec e n) m 121 | 122 | type WhyConcatVec :: Vec (Vec e j) n -> Type 123 | type WhyConcatVec (l :: Vec (Vec e j) n) = Vec e (n * j) 124 | |]) 125 | --------------------------------------------------------------------------------