├── .envrc ├── .github └── workflows │ └── flake-ci.yml ├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── decidable.cabal ├── flake.lock ├── flake.nix ├── fourmolu.yaml └── src └── Data └── Type ├── Predicate.hs ├── Predicate ├── Auto.hs ├── Logic.hs ├── Param.hs └── Quantification.hs ├── Universe.hs └── Universe └── Subset.hs /.envrc: -------------------------------------------------------------------------------- 1 | watch_file *.cabal 2 | use flake 3 | -------------------------------------------------------------------------------- /.github/workflows/flake-ci.yml: -------------------------------------------------------------------------------- 1 | name: "Flake CI" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | checks: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - name: Free Disk Space 10 | uses: insightsengineering/free-disk-space@v1.1.0 11 | - uses: actions/checkout@v3 12 | - uses: webfactory/ssh-agent@v0.9.0 13 | with: 14 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 15 | - uses: cachix/install-nix-action@v22 16 | with: 17 | nix_path: nixpkgs=channel:nixos-unstable 18 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 19 | extra_nix_config: | 20 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 21 | allow-import-from-derivation = true 22 | auto-optimise-store = true 23 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 24 | - uses: cachix/cachix-action@v13 25 | with: 26 | name: mstksg 27 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 28 | - run: nix flake check --show-trace 29 | 30 | cache: 31 | runs-on: ubuntu-latest 32 | steps: 33 | - name: Free Disk Space 34 | uses: insightsengineering/free-disk-space@v1.1.0 35 | - uses: actions/checkout@v4.1.1 36 | - uses: webfactory/ssh-agent@v0.9.0 37 | with: 38 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 39 | - uses: cachix/install-nix-action@v22 40 | with: 41 | nix_path: nixpkgs=channel:nixos-unstable 42 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 43 | extra_nix_config: | 44 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 45 | allow-import-from-derivation = true 46 | auto-optimise-store = true 47 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 48 | - uses: cachix/cachix-action@v13 49 | with: 50 | name: mstksg 51 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 52 | - run: nix build --show-trace 53 | - run: nix develop --show-trace 54 | 55 | every-compiler: 56 | runs-on: ubuntu-latest 57 | steps: 58 | - name: Free Disk Space 59 | uses: insightsengineering/free-disk-space@v1.1.0 60 | - uses: actions/checkout@v3 61 | - uses: webfactory/ssh-agent@v0.9.0 62 | with: 63 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 64 | - uses: cachix/install-nix-action@v22 65 | with: 66 | nix_path: nixpkgs=channel:nixos-unstable 67 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 68 | extra_nix_config: | 69 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 70 | allow-import-from-derivation = true 71 | auto-optimise-store = true 72 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 73 | - uses: cachix/cachix-action@v13 74 | with: 75 | name: mstksg 76 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 77 | - run: nix build .#everyCompiler 78 | 79 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | .ghc.environment* 4 | dist-newstyle/ 5 | /result 6 | /.direnv 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | script: 2 | - | 3 | set -ex 4 | case "$BUILD" in 5 | stack) 6 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 7 | ;; 8 | cabal) 9 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 10 | 11 | ORIGDIR=$(pwd) 12 | for dir in $PACKAGES 13 | do 14 | cd $dir 15 | cabal check || [ "$CABALVER" == "1.16" ] 16 | cabal sdist 17 | PKGVER=$(cabal info . | awk '{print $2;exit}') 18 | SRC_TGZ=$PKGVER.tar.gz 19 | cd dist 20 | tar zxfv "$SRC_TGZ" 21 | cd "$PKGVER" 22 | cabal configure --enable-tests --ghc-options -O0 23 | cabal build 24 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 25 | cabal test 26 | else 27 | cabal test --show-details=streaming --log=/dev/stdout 28 | fi 29 | cd $ORIGDIR 30 | done 31 | ;; 32 | esac 33 | set +ex 34 | matrix: 35 | include: 36 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 37 | addons: 38 | apt: 39 | sources: 40 | - hvr-ghc 41 | packages: 42 | - cabal-install-head 43 | - ghc-head 44 | - happy-1.19.5 45 | - alex-3.1.7 46 | compiler: ': #GHC HEAD' 47 | - env: BUILD=stack ARGS="" 48 | addons: 49 | apt: 50 | packages: 51 | - libgmp-dev 52 | compiler: ': #stack default' 53 | - env: BUILD=stack ARGS="--resolver nightly" 54 | addons: 55 | apt: 56 | packages: 57 | - libgmp-dev 58 | compiler: ': #stack nightly' 59 | - env: BUILD=stack ARGS="" 60 | os: osx 61 | compiler: ': #stack default osx' 62 | - env: BUILD=stack ARGS="--resolver nightly" 63 | os: osx 64 | compiler: ': #stack nightly osx' 65 | allow_failures: 66 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 67 | - env: BUILD=stack ARGS="--resolver nightly" 68 | install: 69 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo 70 | '?')]" 71 | - if [ -f configure.ac ]; then autoreconf -i; fi 72 | - | 73 | set -ex 74 | case "$BUILD" in 75 | stack) 76 | # Add in extra-deps for older snapshots, as necessary 77 | # 78 | # This is disabled by default, as relying on the solver like this can 79 | # make builds unreliable. Instead, if you have this situation, it's 80 | # recommended that you maintain multiple stack-lts-X.yaml files. 81 | 82 | #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 83 | # stack --no-terminal $ARGS build cabal-install && \ 84 | # stack --no-terminal $ARGS solver --update-config) 85 | 86 | # Build the dependencies 87 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 88 | ;; 89 | cabal) 90 | cabal --version 91 | travis_retry cabal update 92 | 93 | # Get the list of packages from the stack.yaml file. Note that 94 | # this will also implicitly run hpack as necessary to generate 95 | # the .cabal files needed by cabal-install. 96 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 97 | 98 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 99 | ;; 100 | esac 101 | set +ex 102 | cache: 103 | directories: 104 | - $HOME/.ghc 105 | - $HOME/.cabal 106 | - $HOME/.stack 107 | - $TRAVIS_BUILD_DIR/.stack-work 108 | before_install: 109 | - unset CC 110 | - CABALARGS="" 111 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 112 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 113 | - mkdir -p ~/.local/bin 114 | - | 115 | if [ `uname` = "Darwin" ] 116 | then 117 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 118 | else 119 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 120 | fi 121 | 122 | # Use the more reliable S3 mirror of Hackage 123 | mkdir -p $HOME/.cabal 124 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 125 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 126 | language: generic 127 | sudo: false 128 | 129 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changelog 2 | ========= 3 | 4 | Version 0.3.1.1 5 | --------------- 6 | 7 | *February 27, 2024* 8 | 9 | 10 | 11 | * Remove upper bounds and deprecated pragmas 12 | 13 | Version 0.3.1.0 14 | --------------- 15 | 16 | *July 4, 2023* 17 | 18 | 19 | 20 | * Now requires singletons-3.0 and above, and GHC 9.2 and above 21 | 22 | Version 0.3.0.0 23 | --------------- 24 | 25 | *Feburary 2, 2020* 26 | 27 | 28 | 29 | * Update to work with *singletons-2.6*, the type family update 30 | * Change `Evident` to now be a defunctionalization symbol for `Sing`, instead 31 | of a type synonym with `TyPred`, to match with *singletons-2.6*. Most code 32 | in practice should be the same. 33 | * Fix instances for `FProd`s: now can prove and decide any `FProd f (Wit p)`, 34 | and can prove and decide and auto any `FProd f WrappedSing`. 35 | 36 | Version 0.2.1.0 37 | --------------- 38 | 39 | *August 24, 2019* 40 | 41 | 42 | 43 | * Add `autoTC` for convenient usage of `auto` with type constructors. 44 | 45 | Version 0.2.0.0 46 | --------------- 47 | 48 | *August 12, 2019* 49 | 50 | 51 | 52 | * Full restructuring of the Universe system, pulling it all out into a new 53 | package, *functor-products*. 54 | 55 | Version 0.1.5.0 56 | --------------- 57 | 58 | *March 6, 2018* 59 | 60 | 61 | 62 | * Add `allToAny` to *Data.Type.Predicate.Quantification*. 63 | * Add `PPMapV`, `EqBy`, and `IsTC` to *Data.Type.Predicate.Param*. 64 | * Kind-indexed singletons for indices in *Data.Type.Universe*. 65 | 66 | Version 0.1.4.0 67 | --------------- 68 | 69 | *October 29, 2018* 70 | 71 | 72 | 73 | * Added `tripleNegation` and `negateTwice` to *Data.Type.Predicate.Logic*, 74 | for more constructivist principles. 75 | * Renamed `excludedMiddle` to `complementation`. 76 | * Add `TyPP`, `SearchableTC`, `searchTC`, `SelectableTC`, `selectTC` to 77 | *Data.Type.Predicate.Param*, to mirror `TyPred` and the 78 | `DecidableTC`/`ProvableTC` interface from *Data.Type.Predicate* 79 | 80 | Version 0.1.3.1 81 | --------------- 82 | 83 | *October 26, 2018* 84 | 85 | 86 | 87 | * *BUGFIX* Remove overlapping `Auto` instances for `IsNothing` and `IsLeft`. 88 | 89 | Version 0.1.3.0 90 | --------------- 91 | 92 | *October 24, 2018* 93 | 94 | 95 | 96 | * Added a type and `Universe` for universe disjunction or summing, `:+:`, 97 | with appropriate `Elem` and `Auto` instances. 98 | * Added `Universe` instances (and appropriate `Elem` and `Auto` instances) 99 | for `Proxy` (the null universe) and `Identity`. 100 | * `Auto` instances for `IsNothing` and `IsLeft`. 101 | 102 | 103 | Version 0.1.2.0 104 | --------------- 105 | 106 | *October 14, 2018* 107 | 108 | 109 | 110 | * New `:.:` for universe composition, with `Elem` and `Universe` instances, 111 | and associated functions for working with them alongside `Any`, `All`. 112 | * Many of the `Elem` instances and indices in *Data.Type.Universe* have had 113 | their name changed to be more consistent with their role as indices. 114 | `IsJust` is now `IJust`, `IsRight` is `IRight`, `Snd` is `ISnd`. 115 | * Convenience predicates for alternate universes, such as `IsJust`, `IsLeft`, 116 | `IsNothing`, etc. 117 | * `NotAll` quantifier added alongside `None`. 118 | * Many new implications added to *Data.Type.Predicate.Quantification*, 119 | converting not-any and all-not, etc. 120 | * `NotFound p` added as a convenience predicate synonym for `Not (Found p)`. 121 | * Some implications showing the equivalence between `Found (InP f)` and 122 | `NotNull f` added to *Data.Type.Predicate.Param*. 123 | * Many new deduction rules added to *Data.Type.Predicate.Auto*. Please see 124 | module documentation for a detailed list of new rules and classes in this 125 | version. 126 | * Convenient combinators for dealing with `Refuted` and `Decision` added to 127 | *Data.Type.Predicate*: `elimDisproof` and `mapRefuted`. 128 | 129 | 130 | Version 0.1.1.0 131 | --------------- 132 | 133 | *October 12, 2018* 134 | 135 | 136 | 137 | * `flipDecision`, `forgetDisproof`, `forgetProof`, `isProved`, and 138 | `isDisproved` added to *Data.Type.Predicate* module. 139 | * `ProvableTC`, `DeccidableTC`, `proveTC`, and `decideTC` helper functions 140 | and constraints 141 | * *Data.Type.Predicate.Auto* module, for generating witnesses at 142 | compile-time. 143 | * Instances for injection and projection out of `&&&` and `|||`, with some 144 | tricks to prevent overlapping instance issues. 145 | 146 | Version 0.1.0.0 147 | --------------- 148 | 149 | *October 10, 2018* 150 | 151 | 152 | 153 | * Initial release. 154 | 155 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Justin Le (c) 2018 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 Justin Le 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 | [decidable][] 2 | ============= 3 | 4 | [![decidable on Hackage](https://img.shields.io/hackage/v/decidable.svg?maxAge=86400)](https://hackage.haskell.org/package/decidable) 5 | [![Build Status](https://travis-ci.org/mstksg/decidable.svg?branch=master)](https://travis-ci.org/mstksg/decidable) 6 | 7 | This library provides combinators and typeclasses for working and manipulating 8 | type-level predicates in Haskell, which are represented as matchable type-level 9 | functions `k ~> Type` from the *singletons* library. See *Data.Type.Predicate* 10 | for a good starting point, and the documentation for `Predicate` on how to 11 | define predicates. 12 | 13 | [decidable]: http://hackage.haskell.org/package/decidable 14 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /decidable.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: decidable 8 | version: 0.3.1.1 9 | synopsis: Combinators for manipulating dependently-typed predicates. 10 | description: 11 | This library provides combinators and typeclasses for working and manipulating 12 | type-level predicates in Haskell, which are represented as matchable type-level 13 | functions @k ~> Type@ from the @singletons@ library. See "Data.Type.Predicate" 14 | for a good starting point, and the documentation for 'Predicate' on how to 15 | define predicates. 16 | 17 | category: Dependent Types 18 | homepage: https://github.com/mstksg/decidable#readme 19 | bug-reports: https://github.com/mstksg/decidable/issues 20 | author: Justin Le 21 | maintainer: justin@jle.im 22 | copyright: (c) Justin Le 2018 23 | license: BSD3 24 | license-file: LICENSE 25 | build-type: Simple 26 | tested-with: GHC >=9.2 27 | extra-source-files: 28 | CHANGELOG.md 29 | README.md 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/mstksg/decidable 34 | 35 | library 36 | exposed-modules: 37 | Data.Type.Predicate 38 | Data.Type.Predicate.Auto 39 | Data.Type.Predicate.Logic 40 | Data.Type.Predicate.Param 41 | Data.Type.Predicate.Quantification 42 | Data.Type.Universe 43 | Data.Type.Universe.Subset 44 | 45 | other-modules: Paths_decidable 46 | hs-source-dirs: src 47 | ghc-options: 48 | -Wall -Wredundant-constraints -Wcompat -Werror=incomplete-patterns 49 | 50 | build-depends: 51 | base >=4.16 && <5 52 | , functor-products >=0.1.2 53 | , microlens 54 | , singletons >=3.0 55 | , singletons-base 56 | , vinyl 57 | 58 | default-language: Haskell2010 59 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "HTTP": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1451647621, 7 | "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", 8 | "owner": "phadej", 9 | "repo": "HTTP", 10 | "rev": "9bc0996d412fef1787449d841277ef663ad9a915", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "phadej", 15 | "repo": "HTTP", 16 | "type": "github" 17 | } 18 | }, 19 | "cabal-32": { 20 | "flake": false, 21 | "locked": { 22 | "lastModified": 1603716527, 23 | "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", 24 | "owner": "haskell", 25 | "repo": "cabal", 26 | "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", 27 | "type": "github" 28 | }, 29 | "original": { 30 | "owner": "haskell", 31 | "ref": "3.2", 32 | "repo": "cabal", 33 | "type": "github" 34 | } 35 | }, 36 | "cabal-34": { 37 | "flake": false, 38 | "locked": { 39 | "lastModified": 1645834128, 40 | "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", 41 | "owner": "haskell", 42 | "repo": "cabal", 43 | "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "haskell", 48 | "ref": "3.4", 49 | "repo": "cabal", 50 | "type": "github" 51 | } 52 | }, 53 | "cabal-36": { 54 | "flake": false, 55 | "locked": { 56 | "lastModified": 1669081697, 57 | "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", 58 | "owner": "haskell", 59 | "repo": "cabal", 60 | "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "owner": "haskell", 65 | "ref": "3.6", 66 | "repo": "cabal", 67 | "type": "github" 68 | } 69 | }, 70 | "cardano-shell": { 71 | "flake": false, 72 | "locked": { 73 | "lastModified": 1608537748, 74 | "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", 75 | "owner": "input-output-hk", 76 | "repo": "cardano-shell", 77 | "rev": "9392c75087cb9a3d453998f4230930dea3a95725", 78 | "type": "github" 79 | }, 80 | "original": { 81 | "owner": "input-output-hk", 82 | "repo": "cardano-shell", 83 | "type": "github" 84 | } 85 | }, 86 | "flake-compat": { 87 | "flake": false, 88 | "locked": { 89 | "lastModified": 1672831974, 90 | "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", 91 | "owner": "input-output-hk", 92 | "repo": "flake-compat", 93 | "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", 94 | "type": "github" 95 | }, 96 | "original": { 97 | "owner": "input-output-hk", 98 | "ref": "hkm/gitlab-fix", 99 | "repo": "flake-compat", 100 | "type": "github" 101 | } 102 | }, 103 | "flake-utils": { 104 | "inputs": { 105 | "systems": "systems" 106 | }, 107 | "locked": { 108 | "lastModified": 1710146030, 109 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 110 | "owner": "numtide", 111 | "repo": "flake-utils", 112 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 113 | "type": "github" 114 | }, 115 | "original": { 116 | "id": "flake-utils", 117 | "type": "indirect" 118 | } 119 | }, 120 | "flake-utils_2": { 121 | "inputs": { 122 | "systems": "systems_2" 123 | }, 124 | "locked": { 125 | "lastModified": 1710146030, 126 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 127 | "owner": "numtide", 128 | "repo": "flake-utils", 129 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 130 | "type": "github" 131 | }, 132 | "original": { 133 | "owner": "numtide", 134 | "repo": "flake-utils", 135 | "type": "github" 136 | } 137 | }, 138 | "ghc-8.6.5-iohk": { 139 | "flake": false, 140 | "locked": { 141 | "lastModified": 1600920045, 142 | "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", 143 | "owner": "input-output-hk", 144 | "repo": "ghc", 145 | "rev": "95713a6ecce4551240da7c96b6176f980af75cae", 146 | "type": "github" 147 | }, 148 | "original": { 149 | "owner": "input-output-hk", 150 | "ref": "release/8.6.5-iohk", 151 | "repo": "ghc", 152 | "type": "github" 153 | } 154 | }, 155 | "hackage": { 156 | "flake": false, 157 | "locked": { 158 | "lastModified": 1719880711, 159 | "narHash": "sha256-l6O9JzsNm0hK7AKHeegzQZ7FvAlzM5qxHIWOXMebzCk=", 160 | "owner": "input-output-hk", 161 | "repo": "hackage.nix", 162 | "rev": "4b1044b947c482975b30a029a42e8e73a3bec073", 163 | "type": "github" 164 | }, 165 | "original": { 166 | "owner": "input-output-hk", 167 | "repo": "hackage.nix", 168 | "type": "github" 169 | } 170 | }, 171 | "haskellNix": { 172 | "inputs": { 173 | "HTTP": "HTTP", 174 | "cabal-32": "cabal-32", 175 | "cabal-34": "cabal-34", 176 | "cabal-36": "cabal-36", 177 | "cardano-shell": "cardano-shell", 178 | "flake-compat": "flake-compat", 179 | "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", 180 | "hackage": "hackage", 181 | "hls-1.10": "hls-1.10", 182 | "hls-2.0": "hls-2.0", 183 | "hls-2.2": "hls-2.2", 184 | "hls-2.3": "hls-2.3", 185 | "hls-2.4": "hls-2.4", 186 | "hls-2.5": "hls-2.5", 187 | "hls-2.6": "hls-2.6", 188 | "hls-2.7": "hls-2.7", 189 | "hls-2.8": "hls-2.8", 190 | "hpc-coveralls": "hpc-coveralls", 191 | "hydra": "hydra", 192 | "iserv-proxy": "iserv-proxy", 193 | "nixpkgs": [ 194 | "haskellProjectFlake", 195 | "haskellNix", 196 | "nixpkgs-unstable" 197 | ], 198 | "nixpkgs-2003": "nixpkgs-2003", 199 | "nixpkgs-2105": "nixpkgs-2105", 200 | "nixpkgs-2111": "nixpkgs-2111", 201 | "nixpkgs-2205": "nixpkgs-2205", 202 | "nixpkgs-2211": "nixpkgs-2211", 203 | "nixpkgs-2305": "nixpkgs-2305", 204 | "nixpkgs-2311": "nixpkgs-2311", 205 | "nixpkgs-unstable": "nixpkgs-unstable", 206 | "old-ghc-nix": "old-ghc-nix", 207 | "stackage": "stackage" 208 | }, 209 | "locked": { 210 | "lastModified": 1719881433, 211 | "narHash": "sha256-q995hk+Ez6itYO9no8zeF0hrmTm4RmtSPy38E1qdgyE=", 212 | "owner": "input-output-hk", 213 | "repo": "haskell.nix", 214 | "rev": "ba1756105ba7c77bbffbc1e39e6a72a33257e8d1", 215 | "type": "github" 216 | }, 217 | "original": { 218 | "owner": "input-output-hk", 219 | "repo": "haskell.nix", 220 | "type": "github" 221 | } 222 | }, 223 | "haskellProjectFlake": { 224 | "inputs": { 225 | "flake-utils": "flake-utils_2", 226 | "haskellNix": "haskellNix", 227 | "nixpkgs": [ 228 | "haskellProjectFlake", 229 | "haskellNix", 230 | "nixpkgs-unstable" 231 | ] 232 | }, 233 | "locked": { 234 | "lastModified": 1720157618, 235 | "narHash": "sha256-03NGKAogP+QTst+t3YkPo7vEcCNCyKtWPUTJqVX6oak=", 236 | "owner": "mstksg", 237 | "repo": "haskell-project-flake", 238 | "rev": "88da75788bad94ab1194424468c373ffac0de31e", 239 | "type": "github" 240 | }, 241 | "original": { 242 | "owner": "mstksg", 243 | "repo": "haskell-project-flake", 244 | "type": "github" 245 | } 246 | }, 247 | "hls-1.10": { 248 | "flake": false, 249 | "locked": { 250 | "lastModified": 1680000865, 251 | "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", 252 | "owner": "haskell", 253 | "repo": "haskell-language-server", 254 | "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", 255 | "type": "github" 256 | }, 257 | "original": { 258 | "owner": "haskell", 259 | "ref": "1.10.0.0", 260 | "repo": "haskell-language-server", 261 | "type": "github" 262 | } 263 | }, 264 | "hls-2.0": { 265 | "flake": false, 266 | "locked": { 267 | "lastModified": 1687698105, 268 | "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", 269 | "owner": "haskell", 270 | "repo": "haskell-language-server", 271 | "rev": "783905f211ac63edf982dd1889c671653327e441", 272 | "type": "github" 273 | }, 274 | "original": { 275 | "owner": "haskell", 276 | "ref": "2.0.0.1", 277 | "repo": "haskell-language-server", 278 | "type": "github" 279 | } 280 | }, 281 | "hls-2.2": { 282 | "flake": false, 283 | "locked": { 284 | "lastModified": 1693064058, 285 | "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", 286 | "owner": "haskell", 287 | "repo": "haskell-language-server", 288 | "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", 289 | "type": "github" 290 | }, 291 | "original": { 292 | "owner": "haskell", 293 | "ref": "2.2.0.0", 294 | "repo": "haskell-language-server", 295 | "type": "github" 296 | } 297 | }, 298 | "hls-2.3": { 299 | "flake": false, 300 | "locked": { 301 | "lastModified": 1695910642, 302 | "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", 303 | "owner": "haskell", 304 | "repo": "haskell-language-server", 305 | "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", 306 | "type": "github" 307 | }, 308 | "original": { 309 | "owner": "haskell", 310 | "ref": "2.3.0.0", 311 | "repo": "haskell-language-server", 312 | "type": "github" 313 | } 314 | }, 315 | "hls-2.4": { 316 | "flake": false, 317 | "locked": { 318 | "lastModified": 1699862708, 319 | "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", 320 | "owner": "haskell", 321 | "repo": "haskell-language-server", 322 | "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", 323 | "type": "github" 324 | }, 325 | "original": { 326 | "owner": "haskell", 327 | "ref": "2.4.0.1", 328 | "repo": "haskell-language-server", 329 | "type": "github" 330 | } 331 | }, 332 | "hls-2.5": { 333 | "flake": false, 334 | "locked": { 335 | "lastModified": 1701080174, 336 | "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", 337 | "owner": "haskell", 338 | "repo": "haskell-language-server", 339 | "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", 340 | "type": "github" 341 | }, 342 | "original": { 343 | "owner": "haskell", 344 | "ref": "2.5.0.0", 345 | "repo": "haskell-language-server", 346 | "type": "github" 347 | } 348 | }, 349 | "hls-2.6": { 350 | "flake": false, 351 | "locked": { 352 | "lastModified": 1705325287, 353 | "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", 354 | "owner": "haskell", 355 | "repo": "haskell-language-server", 356 | "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", 357 | "type": "github" 358 | }, 359 | "original": { 360 | "owner": "haskell", 361 | "ref": "2.6.0.0", 362 | "repo": "haskell-language-server", 363 | "type": "github" 364 | } 365 | }, 366 | "hls-2.7": { 367 | "flake": false, 368 | "locked": { 369 | "lastModified": 1708965829, 370 | "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", 371 | "owner": "haskell", 372 | "repo": "haskell-language-server", 373 | "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", 374 | "type": "github" 375 | }, 376 | "original": { 377 | "owner": "haskell", 378 | "ref": "2.7.0.0", 379 | "repo": "haskell-language-server", 380 | "type": "github" 381 | } 382 | }, 383 | "hls-2.8": { 384 | "flake": false, 385 | "locked": { 386 | "lastModified": 1715153580, 387 | "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", 388 | "owner": "haskell", 389 | "repo": "haskell-language-server", 390 | "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", 391 | "type": "github" 392 | }, 393 | "original": { 394 | "owner": "haskell", 395 | "ref": "2.8.0.0", 396 | "repo": "haskell-language-server", 397 | "type": "github" 398 | } 399 | }, 400 | "hpc-coveralls": { 401 | "flake": false, 402 | "locked": { 403 | "lastModified": 1607498076, 404 | "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", 405 | "owner": "sevanspowell", 406 | "repo": "hpc-coveralls", 407 | "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", 408 | "type": "github" 409 | }, 410 | "original": { 411 | "owner": "sevanspowell", 412 | "repo": "hpc-coveralls", 413 | "type": "github" 414 | } 415 | }, 416 | "hydra": { 417 | "inputs": { 418 | "nix": "nix", 419 | "nixpkgs": [ 420 | "haskellProjectFlake", 421 | "haskellNix", 422 | "hydra", 423 | "nix", 424 | "nixpkgs" 425 | ] 426 | }, 427 | "locked": { 428 | "lastModified": 1671755331, 429 | "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=", 430 | "owner": "NixOS", 431 | "repo": "hydra", 432 | "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8", 433 | "type": "github" 434 | }, 435 | "original": { 436 | "id": "hydra", 437 | "type": "indirect" 438 | } 439 | }, 440 | "iserv-proxy": { 441 | "flake": false, 442 | "locked": { 443 | "lastModified": 1717479972, 444 | "narHash": "sha256-7vE3RQycHI1YT9LHJ1/fUaeln2vIpYm6Mmn8FTpYeVo=", 445 | "owner": "stable-haskell", 446 | "repo": "iserv-proxy", 447 | "rev": "2ed34002247213fc435d0062350b91bab920626e", 448 | "type": "github" 449 | }, 450 | "original": { 451 | "owner": "stable-haskell", 452 | "ref": "iserv-syms", 453 | "repo": "iserv-proxy", 454 | "type": "github" 455 | } 456 | }, 457 | "lowdown-src": { 458 | "flake": false, 459 | "locked": { 460 | "lastModified": 1633514407, 461 | "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", 462 | "owner": "kristapsdz", 463 | "repo": "lowdown", 464 | "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", 465 | "type": "github" 466 | }, 467 | "original": { 468 | "owner": "kristapsdz", 469 | "repo": "lowdown", 470 | "type": "github" 471 | } 472 | }, 473 | "nix": { 474 | "inputs": { 475 | "lowdown-src": "lowdown-src", 476 | "nixpkgs": "nixpkgs", 477 | "nixpkgs-regression": "nixpkgs-regression" 478 | }, 479 | "locked": { 480 | "lastModified": 1661606874, 481 | "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=", 482 | "owner": "NixOS", 483 | "repo": "nix", 484 | "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f", 485 | "type": "github" 486 | }, 487 | "original": { 488 | "owner": "NixOS", 489 | "ref": "2.11.0", 490 | "repo": "nix", 491 | "type": "github" 492 | } 493 | }, 494 | "nixpkgs": { 495 | "locked": { 496 | "lastModified": 1657693803, 497 | "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=", 498 | "owner": "NixOS", 499 | "repo": "nixpkgs", 500 | "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2", 501 | "type": "github" 502 | }, 503 | "original": { 504 | "owner": "NixOS", 505 | "ref": "nixos-22.05-small", 506 | "repo": "nixpkgs", 507 | "type": "github" 508 | } 509 | }, 510 | "nixpkgs-2003": { 511 | "locked": { 512 | "lastModified": 1620055814, 513 | "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", 514 | "owner": "NixOS", 515 | "repo": "nixpkgs", 516 | "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", 517 | "type": "github" 518 | }, 519 | "original": { 520 | "owner": "NixOS", 521 | "ref": "nixpkgs-20.03-darwin", 522 | "repo": "nixpkgs", 523 | "type": "github" 524 | } 525 | }, 526 | "nixpkgs-2105": { 527 | "locked": { 528 | "lastModified": 1659914493, 529 | "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", 530 | "owner": "NixOS", 531 | "repo": "nixpkgs", 532 | "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", 533 | "type": "github" 534 | }, 535 | "original": { 536 | "owner": "NixOS", 537 | "ref": "nixpkgs-21.05-darwin", 538 | "repo": "nixpkgs", 539 | "type": "github" 540 | } 541 | }, 542 | "nixpkgs-2111": { 543 | "locked": { 544 | "lastModified": 1659446231, 545 | "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", 546 | "owner": "NixOS", 547 | "repo": "nixpkgs", 548 | "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", 549 | "type": "github" 550 | }, 551 | "original": { 552 | "owner": "NixOS", 553 | "ref": "nixpkgs-21.11-darwin", 554 | "repo": "nixpkgs", 555 | "type": "github" 556 | } 557 | }, 558 | "nixpkgs-2205": { 559 | "locked": { 560 | "lastModified": 1685573264, 561 | "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", 562 | "owner": "NixOS", 563 | "repo": "nixpkgs", 564 | "rev": "380be19fbd2d9079f677978361792cb25e8a3635", 565 | "type": "github" 566 | }, 567 | "original": { 568 | "owner": "NixOS", 569 | "ref": "nixpkgs-22.05-darwin", 570 | "repo": "nixpkgs", 571 | "type": "github" 572 | } 573 | }, 574 | "nixpkgs-2211": { 575 | "locked": { 576 | "lastModified": 1688392541, 577 | "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", 578 | "owner": "NixOS", 579 | "repo": "nixpkgs", 580 | "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", 581 | "type": "github" 582 | }, 583 | "original": { 584 | "owner": "NixOS", 585 | "ref": "nixpkgs-22.11-darwin", 586 | "repo": "nixpkgs", 587 | "type": "github" 588 | } 589 | }, 590 | "nixpkgs-2305": { 591 | "locked": { 592 | "lastModified": 1701362232, 593 | "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", 594 | "owner": "NixOS", 595 | "repo": "nixpkgs", 596 | "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", 597 | "type": "github" 598 | }, 599 | "original": { 600 | "owner": "NixOS", 601 | "ref": "nixpkgs-23.05-darwin", 602 | "repo": "nixpkgs", 603 | "type": "github" 604 | } 605 | }, 606 | "nixpkgs-2311": { 607 | "locked": { 608 | "lastModified": 1701386440, 609 | "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", 610 | "owner": "NixOS", 611 | "repo": "nixpkgs", 612 | "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", 613 | "type": "github" 614 | }, 615 | "original": { 616 | "owner": "NixOS", 617 | "ref": "nixpkgs-23.11-darwin", 618 | "repo": "nixpkgs", 619 | "type": "github" 620 | } 621 | }, 622 | "nixpkgs-regression": { 623 | "locked": { 624 | "lastModified": 1643052045, 625 | "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", 626 | "owner": "NixOS", 627 | "repo": "nixpkgs", 628 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 629 | "type": "github" 630 | }, 631 | "original": { 632 | "owner": "NixOS", 633 | "repo": "nixpkgs", 634 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 635 | "type": "github" 636 | } 637 | }, 638 | "nixpkgs-unstable": { 639 | "locked": { 640 | "lastModified": 1694822471, 641 | "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", 642 | "owner": "NixOS", 643 | "repo": "nixpkgs", 644 | "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", 645 | "type": "github" 646 | }, 647 | "original": { 648 | "owner": "NixOS", 649 | "repo": "nixpkgs", 650 | "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", 651 | "type": "github" 652 | } 653 | }, 654 | "old-ghc-nix": { 655 | "flake": false, 656 | "locked": { 657 | "lastModified": 1631092763, 658 | "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", 659 | "owner": "angerman", 660 | "repo": "old-ghc-nix", 661 | "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", 662 | "type": "github" 663 | }, 664 | "original": { 665 | "owner": "angerman", 666 | "ref": "master", 667 | "repo": "old-ghc-nix", 668 | "type": "github" 669 | } 670 | }, 671 | "root": { 672 | "inputs": { 673 | "flake-utils": "flake-utils", 674 | "haskellProjectFlake": "haskellProjectFlake", 675 | "nixpkgs": [ 676 | "haskellProjectFlake", 677 | "nixpkgs" 678 | ] 679 | } 680 | }, 681 | "stackage": { 682 | "flake": false, 683 | "locked": { 684 | "lastModified": 1719879847, 685 | "narHash": "sha256-6dqYwS1aUwn8bm+8Tan/tNGmEoWbjArBKO/jTh964f8=", 686 | "owner": "input-output-hk", 687 | "repo": "stackage.nix", 688 | "rev": "562135a1623b181e8a4fd8d76c63827d9f4417c6", 689 | "type": "github" 690 | }, 691 | "original": { 692 | "owner": "input-output-hk", 693 | "repo": "stackage.nix", 694 | "type": "github" 695 | } 696 | }, 697 | "systems": { 698 | "locked": { 699 | "lastModified": 1681028828, 700 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 701 | "owner": "nix-systems", 702 | "repo": "default", 703 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 704 | "type": "github" 705 | }, 706 | "original": { 707 | "owner": "nix-systems", 708 | "repo": "default", 709 | "type": "github" 710 | } 711 | }, 712 | "systems_2": { 713 | "locked": { 714 | "lastModified": 1681028828, 715 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 716 | "owner": "nix-systems", 717 | "repo": "default", 718 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 719 | "type": "github" 720 | }, 721 | "original": { 722 | "owner": "nix-systems", 723 | "repo": "default", 724 | "type": "github" 725 | } 726 | } 727 | }, 728 | "root": "root", 729 | "version": 7 730 | } 731 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Basic Haskell Project Flake"; 3 | inputs = { 4 | haskellProjectFlake.url = "github:mstksg/haskell-project-flake"; 5 | nixpkgs.follows = "haskellProjectFlake/nixpkgs"; 6 | }; 7 | outputs = 8 | { self 9 | , nixpkgs 10 | , flake-utils 11 | , haskellProjectFlake 12 | }: 13 | flake-utils.lib.eachDefaultSystem (system: 14 | let 15 | name = "decidable"; 16 | pkgs = import nixpkgs { 17 | inherit system; 18 | overlays = [ haskellProjectFlake.overlays."${system}".default ]; 19 | }; 20 | project-flake = pkgs.haskell-project-flake 21 | { 22 | inherit name; 23 | src = ./.; 24 | excludeCompilerMajors = [ "ghc810" "ghc90" ]; 25 | defaultCompiler = "ghc982"; 26 | }; 27 | in 28 | { 29 | packages = project-flake.packages; 30 | apps = project-flake.apps; 31 | checks = project-flake.checks; 32 | devShells = project-flake.devShells; 33 | legacyPackages."${name}" = project-flake; 34 | } 35 | ); 36 | } 37 | 38 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | column-limit: 100 2 | comma-style: leading 3 | fixities: [] 4 | function-arrows: trailing 5 | haddock-style: single-line 6 | haddock-style-module: null 7 | import-export-style: diff-friendly 8 | in-style: right-align 9 | indent-wheres: true 10 | indentation: 2 11 | let-style: inline 12 | newlines-between-decls: 1 13 | record-break-space: true 14 | reexports: [] 15 | respectful: true 16 | single-constraint-parens: never 17 | unicode: detect 18 | -------------------------------------------------------------------------------- /src/Data/Type/Predicate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE EmptyCase #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE InstanceSigs #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | 17 | -- | 18 | -- Module : Data.Type.Predicate 19 | -- Copyright : (c) Justin Le 2018 20 | -- License : BSD3 21 | -- 22 | -- Maintainer : justin@jle.im 23 | -- Stability : experimental 24 | -- Portability : non-portable 25 | -- 26 | -- Combinators for working with type-level predicates, along with 27 | -- typeclasses for canonical proofs and deciding functions. 28 | module Data.Type.Predicate ( 29 | -- * Predicates 30 | Predicate, 31 | Wit (..), 32 | 33 | -- ** Construct Predicates 34 | TyPred, 35 | Evident, 36 | EqualTo, 37 | BoolPred, 38 | Impossible, 39 | In, 40 | 41 | -- ** Manipulate predicates 42 | PMap, 43 | type Not, 44 | decideNot, 45 | 46 | -- * Provable Predicates 47 | Prove, 48 | type (-->), 49 | type (-->#), 50 | Provable (..), 51 | Disprovable, 52 | disprove, 53 | ProvableTC, 54 | proveTC, 55 | TFunctor (..), 56 | compImpl, 57 | 58 | -- * Decidable Predicates 59 | Decide, 60 | type (-?>), 61 | type (-?>#), 62 | Decidable (..), 63 | DecidableTC, 64 | decideTC, 65 | DFunctor (..), 66 | 67 | -- * Manipulate Decisions 68 | Decision (..), 69 | flipDecision, 70 | mapDecision, 71 | elimDisproof, 72 | forgetDisproof, 73 | forgetProof, 74 | isProved, 75 | isDisproved, 76 | mapRefuted, 77 | ) where 78 | 79 | import Data.Either.Singletons 80 | import Data.Function.Singletons 81 | import Data.Functor.Identity 82 | import Data.Functor.Identity.Singletons 83 | import Data.Kind 84 | import Data.List.NonEmpty (NonEmpty (..)) 85 | import qualified Data.List.NonEmpty.Singletons as NE 86 | import Data.List.Singletons hiding (ElemSym1) 87 | import Data.Maybe 88 | import Data.Maybe.Singletons 89 | import Data.Singletons 90 | import Data.Singletons.Decide 91 | import Data.Tuple.Singletons 92 | import Data.Type.Functor.Product 93 | import Data.Void 94 | 95 | -- | A type-level predicate in Haskell. We say that the predicate @P :: 96 | -- 'Predicate' k@ is true/satisfied by input @x :: k@ if there exists 97 | -- a value of type @P \@\@ x@, and that it false/disproved if such a value 98 | -- cannot exist. (Where '@@' is 'Apply', the singleton library's type-level 99 | -- function application for mathcable functions). In some contexts, this 100 | -- is also known as a dependently typed "view". 101 | -- 102 | -- See 'Provable' and 'Decidable' for more information on how to use, prove 103 | -- and decide these predicates. 104 | -- 105 | -- The kind @k ~> 'Type'@ is the kind of "matchable" type-level functions 106 | -- in Haskell. They are type-level functions that are encoded as dummy 107 | -- type constructors ("defunctionalization symbols") that can be decidedly 108 | -- "matched" on for things like typeclass instances. 109 | -- 110 | -- There are two ways to define your own predicates: 111 | -- 112 | -- 1. Using the predicate combinators and predicate transformers in 113 | -- this library and the /singletons/ library, which let you construct 114 | -- pre-made predicates and sometimes create predicates from other 115 | -- predicates. 116 | -- 117 | -- 2. Manually creating a data type that acts as a matchable predicate. 118 | -- 119 | -- For an example of the latter, we can create the "not p" predicate, which 120 | -- takes a predicate @p@ as input and returns the negation of the 121 | -- predicate: 122 | -- 123 | -- @ 124 | -- -- First, create the data type with the kind signature you want 125 | -- data Not :: Predicate k -> Predicate k 126 | -- 127 | -- -- Then, write the 'Apply' instance, to specify the type of the 128 | -- -- witnesses of that predicate 129 | -- instance 'Apply' (Not p) a = (p '@@' a) -> 'Void' 130 | -- @ 131 | -- 132 | -- See the source of "Data.Type.Predicate" and "Data.Type.Predicate.Logic" 133 | -- for simple examples of hand-made predicates. For example, we have the 134 | -- always-true predicate 'Evident': 135 | -- 136 | -- @ 137 | -- data Evident :: 'Predicate' k 138 | -- instance Apply Evident a = 'Sing' a 139 | -- @ 140 | -- 141 | -- And the "and" predicate combinator: 142 | -- 143 | -- @ 144 | -- data (&&&) :: Predicate k -> Predicate k -> Predicate k 145 | -- instance Apply (p &&& q) a = (p '@@' a, q '@@' a) 146 | -- @ 147 | -- 148 | -- Typically it is recommended to create predicates from the supplied 149 | -- predicate combinators ('TyPred' can be used for any type constructor to 150 | -- turn it into a predicate, for instance) whenever possible. 151 | type Predicate k = k ~> Type 152 | 153 | -- | Convert a normal '->' type constructor into a 'Predicate'. 154 | -- 155 | -- @ 156 | -- 'TyPred' :: (k -> 'Type') -> 'Predicate' k 157 | -- @ 158 | type TyPred = (TyCon1 :: (k -> Type) -> Predicate k) 159 | 160 | -- | The always-true predicate. 161 | -- 162 | -- @ 163 | -- 'Evident' :: 'Predicate' k 164 | -- @ 165 | data Evident :: Predicate k 166 | 167 | type instance Apply Evident a = Sing a 168 | 169 | -- | The always-false predicate 170 | -- 171 | -- Could also be defined as @'ConstSym1' Void@, but this defintion gives 172 | -- us a free 'Decidable' instance. 173 | -- 174 | -- @ 175 | -- 'Impossible' :: 'Predicate' k 176 | -- @ 177 | type Impossible = (Not Evident :: Predicate k) 178 | 179 | -- | @'EqualTo' a@ is a predicate that the input is equal to @a@. 180 | -- 181 | -- @ 182 | -- 'EqualTo' :: k -> 'Predicate' k 183 | -- @ 184 | type EqualTo (a :: k) = (TyPred ((:~:) a) :: Predicate k) 185 | 186 | -- | Convert a tradtional @k ~> 'Bool'@ predicate into a 'Predicate'. 187 | -- 188 | -- @ 189 | -- 'BoolPred' :: (k ~> Bool) -> Predicate k 190 | -- @ 191 | type BoolPred (p :: k ~> Bool) = (PMap p (EqualTo 'True) :: Predicate k) 192 | 193 | -- | Pre-compose a function to a predicate 194 | -- 195 | -- @ 196 | -- 'PMap' :: (k ~> j) -> 'Predicate' j -> Predicate k 197 | -- @ 198 | type PMap (f :: k ~> j) (p :: Predicate j) = (p .@#@$$$ f :: Predicate k) 199 | 200 | -- | A @'Wit' p a@ is a value of type @p \@\@ a@ --- that is, it is a proof 201 | -- or witness that @p@ is satisfied for @a@. 202 | -- 203 | -- It essentially turns a @k ~> 'Type'@ ("matchable" @'Predicate' k@) /back 204 | -- into/ a @k -> 'Type'@ predicate. 205 | newtype Wit p a = Wit {getWit :: p @@ a} 206 | 207 | -- | A decision function for predicate @p@. See 'Decidable' for more 208 | -- information. 209 | type Decide p = forall a. Sing a -> Decision (p @@ a) 210 | 211 | -- | Like implication '-->', but knowing @p \@\@ a@ can only let us decidably 212 | -- prove @q @@ a@ is true or false. 213 | type p -?> q = forall a. Sing a -> p @@ a -> Decision (q @@ a) 214 | 215 | -- | Like '-?>', but only in a specific context @h@. 216 | type (p -?># q) h = forall a. Sing a -> p @@ a -> h (Decision (q @@ a)) 217 | 218 | -- | A proving function for predicate @p@; in some contexts, also called 219 | -- a "view function". See 'Provable' for more information. 220 | type Prove p = forall a. Sing a -> p @@ a 221 | 222 | -- | We say that @p@ implies @q@ (@p '-->' q@) if, given @p @@ a@, we can 223 | -- always prove @q \@\@ a@. 224 | type p --> q = forall a. Sing a -> p @@ a -> q @@ a 225 | 226 | -- | This is implication '-->#', but only in a specific context @h@. 227 | type (p --># q) h = forall a. Sing a -> p @@ a -> h (q @@ a) 228 | 229 | infixr 1 -?> 230 | infixr 1 -?># 231 | infixr 1 --> 232 | infixr 1 --># 233 | 234 | -- | A typeclass for decidable predicates. 235 | -- 236 | -- A predicate is decidable if, given any input @a@, you can either prove 237 | -- or disprove @p \@\@ a@. A @'Decision' (p \@\@ a)@ is a data type 238 | -- that has a branch @p \@\@ a@ and @'Refuted' (p \@\@ a)@. 239 | -- 240 | -- This typeclass associates a canonical decision function for every 241 | -- decidable predicate. 242 | -- 243 | -- It confers two main advatnages: 244 | -- 245 | -- 1. The decision function for every predicate is available via the 246 | -- same name 247 | -- 248 | -- 2. We can write 'Decidable' instances for polymorphic predicate 249 | -- transformers (predicates parameterized on other predicates) easily, 250 | -- by refering to 'Decidable' instances of the transformed predicates. 251 | class Decidable p where 252 | -- | The canonical decision function for predicate @p@. 253 | -- 254 | -- Note that 'decide' is ambiguously typed, so you /always/ need to call by 255 | -- specifying the predicate you want to prove using TypeApplications 256 | -- syntax: 257 | -- 258 | -- @ 259 | -- 'decide' \@MyPredicate 260 | -- @ 261 | -- 262 | -- See 'decideTC' and 'DecidableTC' for a version that isn't ambiguously 263 | -- typed, but only works when @p@ is a type constructor. 264 | decide :: Decide p 265 | default decide :: Provable p => Decide p 266 | decide = Proved . prove @p 267 | 268 | -- | A typeclass for provable predicates (constructivist tautologies). In 269 | -- some context, these are also known as "views". 270 | -- 271 | -- A predicate is provable if, given any input @a@, you can generate 272 | -- a proof of @p \@\@ a@. Essentially, it means that a predicate is "always 273 | -- true". 274 | -- 275 | -- We can call a type a view if, for any input @a@, there is /some/ 276 | -- constructor of @p \@\@ a@ that can we can use to "categorize" @a@. 277 | -- 278 | -- This typeclass associates a canonical proof function for every provable 279 | -- predicate, or a canonical view function for any view. 280 | -- 281 | -- It confers two main advatnages: 282 | -- 283 | -- 1. The proof function/view for every predicate/view is available via 284 | -- the same name 285 | -- 286 | -- 2. We can write 'Provable' instances for polymorphic predicate 287 | -- transformers (predicates parameterized on other predicates) easily, 288 | -- by refering to 'Provable' instances of the transformed predicates. 289 | class Provable p where 290 | -- | The canonical proving function for predicate @p@ (or a canonical 291 | -- view function for view @p@). 292 | -- 293 | -- Note that 'prove' is ambiguously typed, so you /always/ need to call 294 | -- by specifying the predicate you want to prove using TypeApplications 295 | -- syntax: 296 | -- 297 | -- @ 298 | -- 'prove' \@MyPredicate 299 | -- @ 300 | -- 301 | -- See 'proveTC' and 'ProvableTC' for a version that isn't ambiguously 302 | -- typed, but only works when @p@ is a type constructor. 303 | prove :: Prove p 304 | 305 | -- | @'Disprovable' p@ is a constraint that @p@ can be disproven. 306 | type Disprovable p = Provable (Not p) 307 | 308 | -- | The deciding/disproving function for @'Disprovable' p@. 309 | -- 310 | -- Must be called by applying the 'Predicate' to disprove: 311 | -- 312 | -- @ 313 | -- 'disprove' \@p 314 | -- @ 315 | disprove :: forall p. Disprovable p => Prove (Not p) 316 | disprove = prove @(Not p) 317 | 318 | -- | If @T :: k -> 'Type'@ is a type constructor, then @'DecidableTC' T@ is 319 | -- a constraint that @T@ is "decidable", in that you have a canonical 320 | -- function: 321 | -- 322 | -- @ 323 | -- 'decideTC' :: 'Sing' a -> 'Decision' (T a) 324 | -- @ 325 | -- 326 | -- Is essentially 'Decidable', except with /type constructors/ @k -> 327 | -- 'Type'@ instead of matchable type-level functions (that are @k ~> 328 | -- 'Type'@). Useful because 'decideTC' doesn't require anything fancy like 329 | -- TypeApplications to use. 330 | -- 331 | -- Also is in this library for compatiblity with "traditional" predicates 332 | -- that are GADT type constructors. 333 | -- 334 | -- @since 0.1.1.0 335 | type DecidableTC p = Decidable (TyPred p) 336 | 337 | -- | The canonical deciding function for @'DecidableTC' t@. 338 | -- 339 | -- Note that because @t@ must be an injective type constructor, you can use 340 | -- this without explicit type applications; the instance of 'DecidableTC' 341 | -- can be inferred from the result type. 342 | -- 343 | -- @since 0.1.1.0 344 | decideTC :: forall t a. DecidableTC t => Sing a -> Decision (t a) 345 | decideTC = decide @(TyPred t) 346 | 347 | -- | If @T :: k -> 'Type'@ is a type constructor, then @'ProvableTC' T@ is 348 | -- a constraint that @T@ is "decidable", in that you have a canonical 349 | -- function: 350 | -- 351 | -- @ 352 | -- 'proveTC' :: 'Sing' a -> T a 353 | -- @ 354 | -- 355 | -- Is essentially 'Provable', except with /type constructors/ @k -> 'Type'@ 356 | -- instead of matchable type-level functions (that are @k ~> 'Type'@). 357 | -- Useful because 'proveTC' doesn't require anything fancy like 358 | -- TypeApplications to use. 359 | -- 360 | -- Also is in this library for compatiblity with "traditional" predicates 361 | -- that are GADT type constructors. 362 | -- 363 | -- @since 0.1.1.0 364 | type ProvableTC p = Provable (TyPred p) 365 | 366 | -- | The canonical proving function for @'DecidableTC' t@. 367 | -- 368 | -- Note that because @t@ must be an injective type constructor, you can use 369 | -- this without explicit type applications; the instance of 'ProvableTC' 370 | -- can be inferred from the result type. 371 | -- 372 | -- @since 0.1.1.0 373 | proveTC :: forall t a. ProvableTC t => Sing a -> t a 374 | proveTC = prove @(TyPred t) 375 | 376 | -- | Implicatons @p '-?>' q@ can be lifted "through" a 'DFunctor' into an 377 | -- @f p '-?>' f q@. 378 | class DFunctor f where 379 | dmap :: forall p q. (p -?> q) -> (f p -?> f q) 380 | 381 | -- | Implicatons @p '-->' q@ can be lifted "through" a 'TFunctor' into an 382 | -- @f p '-->' f q@. 383 | class TFunctor f where 384 | tmap :: forall p q. (p --> q) -> (f p --> f q) 385 | 386 | instance (SDecide k, SingI (a :: k)) => Decidable (EqualTo a) where 387 | decide = (sing %~) 388 | 389 | instance Decidable Evident 390 | instance Provable Evident where 391 | prove = id 392 | 393 | -- | @since 3.0.0 394 | instance Decidable (TyPred WrappedSing) 395 | 396 | -- | @since 3.0.0 397 | instance Provable (TyPred WrappedSing) where 398 | prove = WrapSing 399 | 400 | -- | @since 3.0.0 401 | instance Provable p => Provable (TyPred (Rec (Wit p))) where 402 | prove = mapProd (Wit . prove @p) . singProd 403 | 404 | -- | @since 3.0.0 405 | instance Decidable p => Decidable (TyPred (Rec (Wit p))) where 406 | decide = \case 407 | SNil -> Proved RNil 408 | x `SCons` xs -> case decide @p x of 409 | Proved p -> case decideTC xs of 410 | Proved ps -> Proved $ Wit p :& ps 411 | Disproved vs -> Disproved $ \case 412 | _ :& ps -> vs ps 413 | Disproved v -> Disproved $ \case 414 | Wit p :& _ -> v p 415 | 416 | -- | @since 3.0.0 417 | instance Provable (TyPred (Rec WrappedSing)) where 418 | prove = mapProd WrapSing . singProd 419 | 420 | -- | @since 3.0.0 421 | instance Decidable (TyPred (Rec WrappedSing)) 422 | 423 | -- | @since 3.0.0 424 | instance Provable p => Provable (TyPred (PMaybe (Wit p))) where 425 | prove = mapProd (Wit . prove @p) . singProd 426 | 427 | -- | @since 3.0.0 428 | instance Decidable p => Decidable (TyPred (PMaybe (Wit p))) where 429 | decide = \case 430 | SNothing -> Proved PNothing 431 | SJust x -> 432 | mapDecision (PJust . Wit) (\case PJust (Wit p) -> p) 433 | . decide @p 434 | $ x 435 | 436 | -- | @since 3.0.0 437 | instance Provable (TyPred (PMaybe WrappedSing)) where 438 | prove = mapProd WrapSing . singProd 439 | 440 | -- | @since 3.0.0 441 | instance Decidable (TyPred (PMaybe WrappedSing)) 442 | 443 | -- | @since 3.0.0 444 | instance Provable p => Provable (TyPred (NERec (Wit p))) where 445 | prove = mapProd (Wit . prove @p) . singProd 446 | 447 | -- | @since 3.0.0 448 | instance Decidable p => Decidable (TyPred (NERec (Wit p))) where 449 | decide = \case 450 | x NE.:%| xs -> case decide @p x of 451 | Proved p -> case decideTC xs of 452 | Proved ps -> Proved $ Wit p :&| ps 453 | Disproved vs -> Disproved $ \case 454 | _ :&| ps -> vs ps 455 | Disproved v -> Disproved $ \case 456 | Wit p :&| _ -> v p 457 | 458 | -- | @since 3.0.0 459 | instance Provable (TyPred (NERec WrappedSing)) where 460 | prove = mapProd WrapSing . singProd 461 | 462 | -- | @since 3.0.0 463 | instance Decidable (TyPred (NERec WrappedSing)) 464 | 465 | -- | @since 3.0.0 466 | instance Provable p => Provable (TyPred (PIdentity (Wit p))) where 467 | prove = mapProd (Wit . prove @p) . singProd 468 | 469 | -- | @since 3.0.0 470 | instance Decidable p => Decidable (TyPred (PIdentity (Wit p))) where 471 | decide = \case 472 | SIdentity x -> 473 | mapDecision (PIdentity . Wit) (\case PIdentity (Wit p) -> p) 474 | . decide @p 475 | $ x 476 | 477 | -- | @since 3.0.0 478 | instance Provable (TyPred (PIdentity WrappedSing)) where 479 | prove = mapProd WrapSing . singProd 480 | 481 | -- | @since 3.0.0 482 | instance Decidable (TyPred (PIdentity WrappedSing)) 483 | 484 | -- | @since 3.0.0 485 | instance Provable p => Provable (TyPred (PEither (Wit p))) where 486 | prove = mapProd (Wit . prove @p) . singProd 487 | 488 | -- | @since 3.0.0 489 | instance Decidable p => Decidable (TyPred (PEither (Wit p))) where 490 | decide = \case 491 | SLeft x -> Proved $ PLeft x 492 | SRight y -> 493 | mapDecision (PRight . Wit) (\case PRight (Wit p) -> p) 494 | . decide @p 495 | $ y 496 | 497 | -- | @since 3.0.0 498 | instance Provable (TyPred (PEither WrappedSing)) where 499 | prove = mapProd WrapSing . singProd 500 | 501 | -- | @since 3.0.0 502 | instance Decidable (TyPred (PEither WrappedSing)) 503 | 504 | -- | @since 3.0.0 505 | instance Provable p => Provable (TyPred (PTup (Wit p))) where 506 | prove = mapProd (Wit . prove @p) . singProd 507 | 508 | -- | @since 3.0.0 509 | instance Decidable p => Decidable (TyPred (PTup (Wit p))) where 510 | decide (STuple2 x y) = 511 | mapDecision (PTup x . Wit) (\case PTup _ (Wit p) -> p) 512 | . decide @p 513 | $ y 514 | 515 | -- | @since 3.0.0 516 | instance Provable (TyPred (PTup WrappedSing)) where 517 | prove = mapProd WrapSing . singProd 518 | 519 | -- | @since 3.0.0 520 | instance Decidable (TyPred (PTup WrappedSing)) 521 | 522 | instance (Decidable p, SingI f) => Decidable (PMap f p) where 523 | decide = decide @p . applySing (sing :: Sing f) 524 | 525 | instance (Provable p, SingI f) => Provable (PMap f p) where 526 | prove = prove @p . applySing (sing :: Sing f) 527 | 528 | -- | Compose two implications. 529 | compImpl :: 530 | forall p q r. 531 | () => 532 | p --> q -> 533 | q --> r -> 534 | p --> r 535 | compImpl f g s = g s . f s 536 | 537 | -- | @'Not' p@ is the predicate that @p@ is not true. 538 | data Not :: Predicate k -> Predicate k 539 | 540 | type instance Apply (Not p) a = Refuted (p @@ a) 541 | 542 | instance Decidable p => Decidable (Not p) where 543 | decide (x :: Sing a) = decideNot @p @a (decide @p x) 544 | 545 | instance Provable (Not Impossible) where 546 | prove x v = absurd $ v x 547 | 548 | -- | Decide @'Not' p@ based on decisions of @p@. 549 | decideNot :: 550 | forall p a. 551 | () => 552 | Decision (p @@ a) -> 553 | Decision (Not p @@ a) 554 | decideNot = flipDecision 555 | 556 | -- | Flip the contents of a decision. Turn a proof of @a@ into a disproof 557 | -- of not-@a@. 558 | -- 559 | -- Note that this is not reversible in general in constructivist logic See 560 | -- 'Data.Type.Predicate.Logic.doubleNegation' for a situation where it is. 561 | -- 562 | -- @since 0.1.1.0 563 | flipDecision :: 564 | Decision a -> 565 | Decision (Refuted a) 566 | flipDecision = \case 567 | Proved p -> Disproved ($ p) 568 | Disproved v -> Proved v 569 | 570 | -- | Map over the value inside a 'Decision'. 571 | mapDecision :: 572 | (a -> b) -> 573 | (b -> a) -> 574 | Decision a -> 575 | Decision b 576 | mapDecision f g = \case 577 | Proved p -> Proved $ f p 578 | Disproved v -> Disproved $ mapRefuted g v 579 | 580 | -- | Converts a 'Decision' to a 'Maybe'. Drop the witness of disproof of 581 | -- @a@, returning 'Just' if 'Proved' (with the proof) and 'Nothing' if 582 | -- 'Disproved'. 583 | -- 584 | -- @since 0.1.1.0 585 | forgetDisproof :: 586 | Decision a -> 587 | Maybe a 588 | forgetDisproof = \case 589 | Proved p -> Just p 590 | Disproved _ -> Nothing 591 | 592 | -- | Drop the witness of proof of @a@, returning 'Nothing' if 'Proved' and 593 | -- 'Just' if 'Disproved' (with the disproof). 594 | -- 595 | -- @since 0.1.1.0 596 | forgetProof :: 597 | Decision a -> 598 | Maybe (Refuted a) 599 | forgetProof = forgetDisproof . flipDecision 600 | 601 | -- | Boolean test if a 'Decision' is 'Proved'. 602 | -- 603 | -- @since 0.1.1.0 604 | isProved :: Decision a -> Bool 605 | isProved = isJust . forgetDisproof 606 | 607 | -- | Boolean test if a 'Decision' is 'Disproved'. 608 | -- 609 | -- @since 0.1.1.0 610 | isDisproved :: Decision a -> Bool 611 | isDisproved = isNothing . forgetDisproof 612 | 613 | -- | Helper function for a common pattern of eliminating the disproved 614 | -- branch of 'Decision' to certaintify the proof. 615 | -- 616 | -- @since 0.1.2.0 617 | elimDisproof :: 618 | Decision a -> 619 | Refuted (Refuted a) -> 620 | a 621 | elimDisproof = \case 622 | Proved p -> const p 623 | Disproved v -> absurd . ($ v) 624 | 625 | -- | Change the target of a 'Refuted' with a contravariant mapping 626 | -- function. 627 | -- 628 | -- @since 0.1.2.0 629 | mapRefuted :: 630 | (a -> b) -> 631 | Refuted b -> 632 | Refuted a 633 | mapRefuted = flip (.) 634 | 635 | -- | @'In' f as@ is a predicate that a given input @a@ is a member of 636 | -- collection @as@. 637 | type In (f :: Type -> Type) (as :: f k) = ElemSym1 f as 638 | 639 | instance (SDecide k, SingI (as :: [k])) => Decidable (In [] as) where 640 | decide :: forall a. Sing a -> Decision (Index as a) 641 | decide x = go (sing @as) 642 | where 643 | go :: Sing bs -> Decision (Index bs a) 644 | go = \case 645 | SNil -> Disproved $ \case {} 646 | y `SCons` ys -> case x %~ y of 647 | Proved Refl -> Proved IZ 648 | Disproved v -> case go ys of 649 | Proved i -> Proved (IS i) 650 | Disproved u -> Disproved $ \case 651 | IZ -> v Refl 652 | IS i -> u i 653 | 654 | instance (SDecide k, SingI (as :: Maybe k)) => Decidable (In Maybe as) where 655 | decide x = case sing @as of 656 | SNothing -> Disproved $ \case {} 657 | SJust y -> case x %~ y of 658 | Proved Refl -> Proved IJust 659 | Disproved v -> Disproved $ \case IJust -> v Refl 660 | 661 | instance (SDecide k, SingI (as :: Either j k)) => Decidable (In (Either j) as) where 662 | decide x = case sing @as of 663 | SLeft _ -> Disproved $ \case {} 664 | SRight y -> case x %~ y of 665 | Proved Refl -> Proved IRight 666 | Disproved v -> Disproved $ \case IRight -> v Refl 667 | 668 | instance (SDecide k, SingI (as :: NonEmpty k)) => Decidable (In NonEmpty as) where 669 | decide x = case sing @as of 670 | y NE.:%| (Sing :: Sing bs) -> case x %~ y of 671 | Proved Refl -> Proved NEHead 672 | Disproved v -> case decide @(In [] bs) x of 673 | Proved i -> Proved $ NETail i 674 | Disproved u -> Disproved $ \case 675 | NEHead -> v Refl 676 | NETail i -> u i 677 | 678 | instance (SDecide k, SingI (as :: (j, k))) => Decidable (In ((,) j) as) where 679 | decide x = case sing @as of 680 | STuple2 _ y -> case x %~ y of 681 | Proved Refl -> Proved ISnd 682 | Disproved v -> Disproved $ \case ISnd -> v Refl 683 | 684 | instance (SDecide k, SingI (as :: Identity k)) => Decidable (In Identity as) where 685 | decide x = case sing @as of 686 | SIdentity y -> case x %~ y of 687 | Proved Refl -> Proved IId 688 | Disproved v -> Disproved $ \case IId -> v Refl 689 | -------------------------------------------------------------------------------- /src/Data/Type/Predicate/Auto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE EmptyCase #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | -- | 17 | -- Module : Data.Type.Predicate.Auto 18 | -- Copyright : (c) Justin Le 2018 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : justin@jle.im 22 | -- Stability : experimental 23 | -- Portability : non-portable 24 | -- 25 | -- Useful utilities for situations where you know that a predicate @P@ is 26 | -- satisfied for a specific @a@ at compile-time. 27 | -- 28 | -- @since 0.1.1.0 29 | module Data.Type.Predicate.Auto ( 30 | -- * Automatically generate witnesses at compile-time 31 | Auto (..), 32 | autoTC, 33 | AutoNot, 34 | autoNot, 35 | autoAny, 36 | autoNotAll, 37 | AutoProvable, 38 | 39 | -- ** Helper classes 40 | AutoElem (..), 41 | AutoAll (..), 42 | ) where 43 | 44 | import Data.Functor.Identity 45 | import Data.List.NonEmpty (NonEmpty (..)) 46 | import Data.Singletons 47 | import Data.Singletons.Sigma 48 | import Data.Type.Equality 49 | import Data.Type.Functor.Product 50 | import Data.Type.Predicate 51 | import Data.Type.Predicate.Logic 52 | import Data.Type.Predicate.Param 53 | import Data.Type.Predicate.Quantification 54 | import Data.Type.Universe 55 | 56 | -- | Automatically generate a witness for predicate @p@ applied to input 57 | -- @a@. 58 | -- 59 | -- Mostly useful for situations where you know @a@ at compile-time, so you 60 | -- can just write 'auto' directly in your source code. The choice is 61 | -- intended to mirror the @auto@ keyword in languages like Idris. 62 | -- 63 | -- Very close in nature to the @Known@ typeclass in the /type-combinators/ 64 | -- library. 65 | -- 66 | -- Admittedly this interface is a bit clunky and ad-hoc; at this point you 67 | -- can just try writing 'auto' in your code and praying that it works. You 68 | -- always have the option, of course, to just manually write proofs. If 69 | -- you have any inference rules to suggest, feel free to submit a PR! 70 | -- 71 | -- An important limitation of 'Auto' is the Haskell type system prevents 72 | -- "either-or" constraints; this could potentially be implemented using 73 | -- compiler plugins. 74 | -- 75 | -- One consequence of this is that it is impossible to automatically derive 76 | -- @'Any' f p@ and @'Not' ('All' f p)@. 77 | -- 78 | -- For these, the compiler needs help; you can use 'autoAny' and 79 | -- 'autoNotAll' for these situations. 80 | class Auto (p :: Predicate k) (a :: k) where 81 | -- | Have the compiler generate a witness for @p \@\@ a@. 82 | -- 83 | -- Must be called using type application syntax: 84 | -- 85 | -- @ 86 | -- 'auto' @_ @p @a 87 | -- @ 88 | auto :: p @@ a 89 | 90 | -- | A version of 'auto' that "just works" with type inference, if the 91 | -- predicate is a type constructor. 92 | -- 93 | -- @since 0.2.1.0 94 | autoTC :: forall t a. Auto (TyPred t) a => t a 95 | autoTC = auto @_ @(TyPred t) @a 96 | 97 | instance SingI a => Auto Evident a where 98 | auto = sing 99 | 100 | -- | @since 0.1.2.0 101 | instance SingI a => Auto (Not Impossible) a where 102 | auto = ($ sing) 103 | 104 | instance Auto (EqualTo a) a where 105 | auto = Refl 106 | 107 | instance (Auto p a, Auto q a) => Auto (p &&& q) a where 108 | auto = (auto @_ @p @a, auto @_ @q @a) 109 | 110 | instance Auto q a => Auto (p ==> q) a where 111 | auto _ = auto @_ @q @a 112 | 113 | -- | Helper "predicate transformer" that gives you an instant 'auto' for 114 | -- any 'Provable' instance. 115 | -- 116 | -- For example, say you have predicate @P@ that you know is 'Provable', and 117 | -- you wish to generate a @P \@\@ x@, for some specific @x@ you know at 118 | -- compile-time. You can use: 119 | -- 120 | -- @ 121 | -- 'auto' \@_ \@('AutoProvable' P) \@x 122 | -- @ 123 | -- 124 | -- to obtain a @P \@\@ x@. 125 | -- 126 | -- 'AutoProvable' is essentially the identity function. 127 | data AutoProvable :: Predicate k -> Predicate k 128 | 129 | type instance Apply (AutoProvable p) a = p @@ a 130 | 131 | instance (Provable p, SingI a) => Auto (AutoProvable p) a where 132 | auto = prove @p @a sing 133 | 134 | -- | Typeclass representing 'Elem's pointing to an @a :: k@ that can be 135 | -- generated automatically from type-level collection @as :: f k@. 136 | -- 137 | -- If GHC knows both the type-level collection and the element you want to 138 | -- find at compile-time, this instance should allow it to find it. 139 | -- 140 | -- Used to help in the instance of 'Auto' for the 'In' predicate. 141 | -- 142 | -- Example usage: 143 | -- 144 | -- @ 145 | -- 'autoElem' :: 'Index' '[1,6,2,3] 2 146 | -- -- IS (IS IZ) -- third spot 147 | -- @ 148 | -- 149 | -- And when used with 'Auto': 150 | -- 151 | -- @ 152 | -- 'auto' \@_ \@('In' [] '[1,6,2,3]) \@2 153 | -- -- IS (IS IZ) 154 | -- @ 155 | class AutoElem f (as :: f k) (a :: k) where 156 | -- | Generate the 'Elem' pointing to the @a :: @ in a type-level 157 | -- collection @as :: f k@. 158 | autoElem :: Elem f as a 159 | 160 | instance {-# OVERLAPPING #-} AutoElem [] (a ': as) a where 161 | autoElem = IZ 162 | 163 | instance {-# OVERLAPPING #-} AutoElem [] as a => AutoElem [] (b ': as) a where 164 | autoElem = IS autoElem 165 | 166 | instance AutoElem Maybe ('Just a) a where 167 | autoElem = IJust 168 | 169 | instance AutoElem (Either j) ('Right a) a where 170 | autoElem = IRight 171 | 172 | instance AutoElem NonEmpty (a ':| as) a where 173 | autoElem = NEHead 174 | 175 | instance AutoElem [] as a => AutoElem NonEmpty (b ':| as) a where 176 | autoElem = NETail autoElem 177 | 178 | -- | @since 0.1.2.0 179 | instance AutoElem ((,) j) '(w, a) a where 180 | autoElem = ISnd 181 | 182 | instance AutoElem Identity ('Identity a) a where 183 | autoElem = IId 184 | 185 | instance AutoElem f as a => Auto (In f as) a where 186 | auto = autoElem @_ @f @as @a 187 | 188 | -- | Helper class for deriving 'Auto' instances for 'All' predicates; each 189 | -- 'Universe' instance is expected to implement these if possible, to get 190 | -- free 'Auto' instaces for their 'All' predicates. 191 | -- 192 | -- Also helps for 'Not' 'Any' predicates and 'Not' 'Found' 'AnyMatch' 193 | -- predicates. 194 | -- 195 | -- @since 0.1.2.0 196 | class AutoAll f (p :: Predicate k) (as :: f k) where 197 | -- | Generate an 'All' for a given predicate over all items in @as@. 198 | autoAll :: All f p @@ as 199 | 200 | instance AutoAll [] p '[] where 201 | autoAll = WitAll $ \case {} 202 | 203 | instance (Auto p a, AutoAll [] p as) => AutoAll [] p (a ': as) where 204 | autoAll = WitAll $ \case 205 | IZ -> auto @_ @p @a 206 | IS i -> runWitAll (autoAll @_ @[] @p @as) i 207 | 208 | instance AutoAll Maybe p 'Nothing where 209 | autoAll = WitAll $ \case {} 210 | 211 | instance Auto p a => AutoAll Maybe p ('Just a) where 212 | autoAll = WitAll $ \case IJust -> auto @_ @p @a 213 | 214 | instance AutoAll (Either j) p ('Left e) where 215 | autoAll = WitAll $ \case {} 216 | 217 | instance Auto p a => AutoAll (Either j) p ('Right a) where 218 | autoAll = WitAll $ \case IRight -> auto @_ @p @a 219 | 220 | instance (Auto p a, AutoAll [] p as) => AutoAll NonEmpty p (a ':| as) where 221 | autoAll = WitAll $ \case 222 | NEHead -> auto @_ @p @a 223 | NETail i -> runWitAll (autoAll @_ @[] @p @as) i 224 | 225 | instance Auto p a => AutoAll ((,) j) p '(w, a) where 226 | autoAll = WitAll $ \case ISnd -> auto @_ @p @a 227 | 228 | instance Auto p a => AutoAll Identity p ('Identity a) where 229 | autoAll = WitAll $ \case IId -> auto @_ @p @a 230 | 231 | -- | @since 0.1.2.0 232 | instance AutoAll f p as => Auto (All f p) as where 233 | auto = autoAll @_ @f @p @as 234 | 235 | -- | @since 0.1.2.0 236 | instance SingI a => Auto (NotNull []) (a ': as) where 237 | auto = WitAny IZ sing 238 | 239 | -- | @since 0.1.2.0 240 | instance SingI a => Auto IsJust ('Just a) where 241 | auto = WitAny IJust sing 242 | 243 | -- | @since 0.1.2.0 244 | instance SingI a => Auto IsRight ('Right a) where 245 | auto = WitAny IRight sing 246 | 247 | -- | @since 0.1.2.0 248 | instance SingI a => Auto (NotNull NonEmpty) (a ':| as) where 249 | auto = WitAny NEHead sing 250 | 251 | -- | @since 0.1.2.0 252 | instance SingI a => Auto (NotNull ((,) j)) '(w, a) where 253 | auto = WitAny ISnd sing 254 | 255 | instance SingI a => Auto (NotNull Identity) ('Identity a) where 256 | auto = WitAny IId sing 257 | 258 | -- | An @'AutoNot' p a@ constraint means that @p \@\@ a@ can be proven to 259 | -- not be true at compiletime. 260 | -- 261 | -- @since 0.1.2.0 262 | type AutoNot (p :: Predicate k) = Auto (Not p) 263 | 264 | -- | Disprove @p \@\@ a@ at compiletime. 265 | -- 266 | -- @ 267 | -- 'autoNot' \@_ \@p \@a :: 'Not' p '@@' a 268 | -- @ 269 | -- 270 | -- @since 0.1.2.0 271 | autoNot :: forall k (p :: Predicate k) (a :: k). AutoNot p a => Not p @@ a 272 | autoNot = auto @k @(Not p) @a 273 | 274 | -- | @since 0.1.2.0 275 | instance Auto (Found p) (f @@ a) => Auto (Found (PPMap f p)) a where 276 | auto = case auto @_ @(Found p) @(f @@ a) of 277 | i :&: p -> i :&: p 278 | 279 | -- | @since 0.1.2.0 280 | instance Auto (NotFound p) (f @@ a) => Auto (NotFound (PPMap f p)) a where 281 | auto = 282 | mapRefuted (\(i :&: p) -> i :&: p) $ 283 | autoNot @_ @(Found p) @(f @@ a) 284 | 285 | -- | @since 0.1.2.0 286 | instance Auto p (f @@ a) => Auto (PMap f p) a where 287 | auto = auto @_ @p @(f @@ a) 288 | 289 | -- | @since 0.1.2.0 290 | instance AutoNot p (f @@ a) => Auto (Not (PMap f p)) a where 291 | auto = autoNot @_ @p @(f @@ a) 292 | 293 | -- | Helper function to generate an @'Any' f p@ if you can pick out 294 | -- a specific @a@ in @as@ where the predicate is provable at compile-time. 295 | -- 296 | -- This is used to get around a fundamental limitation of 'Auto' as 297 | -- a Haskell typeclass. 298 | -- 299 | -- @since 0.1.2.0 300 | autoAny :: 301 | forall f p as a. 302 | Auto p a => 303 | Elem f as a -> 304 | Any f p @@ as 305 | autoAny i = WitAny i (auto @_ @p @a) 306 | 307 | -- | @since 0.1.2.0 308 | instance (SingI as, AutoAll f (Not p) as) => Auto (Not (Any f p)) as where 309 | auto = allNotNone sing $ autoAll @_ @f @(Not p) @as 310 | 311 | -- | Helper function to generate a @'Not' ('All' f p)@ if you can pick out 312 | -- a specific @a@ in @as@ where the predicate is disprovable at compile-time. 313 | -- 314 | -- This is used to get around a fundamental limitation of 'Auto' as 315 | -- a Haskell typeclass. 316 | -- 317 | -- @since 0.1.2.0 318 | autoNotAll :: 319 | forall p f as a. 320 | (AutoNot p a, SingI as) => 321 | Elem f as a -> 322 | Not (All f p) @@ as 323 | autoNotAll = anyNotNotAll sing . autoAny 324 | 325 | -- | @since 0.1.2.0 326 | instance (SingI as, AutoAll f (Not (Found p)) as) => Auto (Not (Found (AnyMatch f p))) as where 327 | auto = 328 | mapRefuted (\(s :&: WitAny i p) -> WitAny i (s :&: p)) $ 329 | auto @_ @(Not (Any f (Found p))) @as 330 | 331 | -- | @since 3.0.0 332 | instance SingI as => Auto (TyPred (Rec WrappedSing)) as where 333 | auto = proveTC sing 334 | 335 | -- | @since 3.0.0 336 | instance SingI as => Auto (TyPred (PMaybe WrappedSing)) as where 337 | auto = proveTC sing 338 | 339 | -- | @since 3.0.0 340 | instance SingI as => Auto (TyPred (NERec WrappedSing)) as where 341 | auto = proveTC sing 342 | 343 | -- | @since 3.0.0 344 | instance SingI as => Auto (TyPred (PEither WrappedSing)) as where 345 | auto = proveTC sing 346 | 347 | -- | @since 3.0.0 348 | instance SingI as => Auto (TyPred (PTup WrappedSing)) as where 349 | auto = proveTC sing 350 | 351 | -- | @since 3.0.0 352 | instance SingI as => Auto (TyPred (PIdentity WrappedSing)) as where 353 | auto = proveTC sing 354 | 355 | -- | @since 3.0.0 356 | instance (SingI as, Provable p) => Auto (TyPred (Rec (Wit p))) as where 357 | auto = proveTC sing 358 | 359 | -- | @since 3.0.0 360 | instance (SingI as, Provable p) => Auto (TyPred (PMaybe (Wit p))) as where 361 | auto = proveTC sing 362 | 363 | -- | @since 3.0.0 364 | instance (SingI as, Provable p) => Auto (TyPred (NERec (Wit p))) as where 365 | auto = proveTC sing 366 | 367 | -- | @since 3.0.0 368 | instance (SingI as, Provable p) => Auto (TyPred (PEither (Wit p))) as where 369 | auto = proveTC sing 370 | 371 | -- | @since 3.0.0 372 | instance (SingI as, Provable p) => Auto (TyPred (PTup (Wit p))) as where 373 | auto = proveTC sing 374 | 375 | -- | @since 3.0.0 376 | instance (SingI as, Provable p) => Auto (TyPred (PIdentity (Wit p))) as where 377 | auto = proveTC sing 378 | -------------------------------------------------------------------------------- /src/Data/Type/Predicate/Logic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TupleSections #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | 15 | -- | 16 | -- Module : Data.Type.Predicate.Logic 17 | -- Copyright : (c) Justin Le 2018 18 | -- License : BSD3 19 | -- 20 | -- Maintainer : justin@jle.im 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | -- 24 | -- Logical and algebraic connectives for predicates, as well as common 25 | -- logical combinators. 26 | module Data.Type.Predicate.Logic ( 27 | -- * Top and bottom 28 | Evident, 29 | Impossible, 30 | 31 | -- * Logical connectives 32 | type Not, 33 | decideNot, 34 | type (&&&), 35 | decideAnd, 36 | type (|||), 37 | decideOr, 38 | type (^||), 39 | type (||^), 40 | type (^^^), 41 | decideXor, 42 | type (==>), 43 | proveImplies, 44 | Implies, 45 | type (<==>), 46 | Equiv, 47 | 48 | -- * Logical deductions 49 | compImpl, 50 | explosion, 51 | atom, 52 | complementation, 53 | doubleNegation, 54 | tripleNegation, 55 | negateTwice, 56 | contrapositive, 57 | contrapositive', 58 | 59 | -- ** Lattice 60 | projAndFst, 61 | projAndSnd, 62 | injOrLeft, 63 | injOrRight, 64 | ) where 65 | 66 | import Data.Singletons 67 | import Data.Singletons.Decide 68 | import Data.Type.Predicate 69 | import Data.Void 70 | 71 | -- | @p '&&&' q@ is a predicate that both @p@ and @q@ are true. 72 | data (&&&) :: Predicate k -> Predicate k -> Predicate k 73 | 74 | type instance Apply (p &&& q) a = (p @@ a, q @@ a) 75 | infixr 3 &&& 76 | 77 | instance (Decidable p, Decidable q) => Decidable (p &&& q) where 78 | decide (x :: Sing a) = decideAnd @p @q @a (decide @p x) (decide @q x) 79 | 80 | instance (Provable p, Provable q) => Provable (p &&& q) where 81 | prove x = (prove @p x, prove @q x) 82 | 83 | -- | Decide @p '&&&' q@ based on decisions of @p@ and @q@. 84 | decideAnd :: 85 | forall p q a. 86 | () => 87 | Decision (p @@ a) -> 88 | Decision (q @@ a) -> 89 | Decision ((p &&& q) @@ a) 90 | decideAnd = \case 91 | Proved p -> mapDecision (p,) snd 92 | Disproved v -> \_ -> Disproved $ \(p, _) -> v p 93 | 94 | -- | @p '|||' q@ is a predicate that either @p@ and @q@ are true. 95 | data (|||) :: Predicate k -> Predicate k -> Predicate k 96 | 97 | type instance Apply (p ||| q) a = Either (p @@ a) (q @@ a) 98 | infixr 2 ||| 99 | 100 | -- | Prefers @p@ over @q@. 101 | instance (Decidable p, Decidable q) => Decidable (p ||| q) where 102 | decide (x :: Sing a) = decideOr @p @q @a (decide @p x) (decide @q x) 103 | 104 | -- | Decide @p '|||' q@ based on decisions of @p@ and @q@. 105 | -- 106 | -- Prefers @p@ over @q@. 107 | decideOr :: 108 | forall p q a. 109 | () => 110 | Decision (p @@ a) -> 111 | Decision (q @@ a) -> 112 | Decision ((p ||| q) @@ a) 113 | decideOr = \case 114 | Proved p -> \_ -> Proved $ Left p 115 | Disproved v -> mapDecision Right (either (absurd . v) id) 116 | 117 | -- | Left-biased "or". In proofs, prioritize a proof of the left side over 118 | -- a proof of the right side. 119 | -- 120 | -- @since 0.1.2.0 121 | type p ^|| q = p ||| Not p &&& q 122 | 123 | -- | Right-biased "or". In proofs, prioritize a proof of the right side over 124 | -- a proof of the left side. 125 | -- 126 | -- @since 0.1.2.0 127 | type p ||^ q = p &&& Not q ||| q 128 | 129 | -- | @p '^^^' q@ is a predicate that either @p@ and @q@ are true, but not 130 | -- both. 131 | type p ^^^ q = (p &&& Not q) ||| (Not p &&& q) 132 | 133 | -- | Decide @p '^^^' q@ based on decisions of @p@ and @q@. 134 | decideXor :: 135 | forall p q a. 136 | () => 137 | Decision (p @@ a) -> 138 | Decision (q @@ a) -> 139 | Decision ((p ^^^ q) @@ a) 140 | decideXor p q = 141 | decideOr @(p &&& Not q) @(Not p &&& q) @a 142 | (decideAnd @p @(Not q) @a p (decideNot @q @a q)) 143 | (decideAnd @(Not p) @q @a (decideNot @p @a p) q) 144 | 145 | -- | @p ==> q@ is true if @q@ is provably true under the condition that @p@ 146 | -- is true. 147 | data (==>) :: Predicate k -> Predicate k -> Predicate k 148 | 149 | type instance Apply (p ==> q) a = p @@ a -> q @@ a 150 | 151 | infixr 1 ==> 152 | 153 | instance Decidable (Impossible ==> p) 154 | instance Provable (Impossible ==> p) where 155 | prove = explosion @p 156 | 157 | instance (Decidable (p ==> q), Decidable q) => Decidable (Not q ==> Not p) where 158 | decide x = case decide @(p ==> q) x of 159 | Proved pq -> Proved $ \vq p -> vq (pq p) 160 | Disproved vpq -> case decide @q x of 161 | Proved q -> Disproved $ \_ -> vpq (const q) 162 | Disproved vq -> Disproved $ \vnpnq -> vpq (absurd . vnpnq vq) 163 | instance Provable (p ==> q) => Provable (Not q ==> Not p) where 164 | prove = contrapositive @p @q (prove @(p ==> q)) 165 | 166 | -- | @since 0.1.1.0 167 | instance {-# OVERLAPPING #-} Decidable (p &&& q ==> p) 168 | 169 | -- | @since 0.1.1.0 170 | instance {-# OVERLAPPING #-} Provable (p &&& q ==> p) where 171 | prove = projAndFst @p @q 172 | 173 | -- | @since 0.1.1.0 174 | instance {-# OVERLAPPING #-} Decidable (p &&& q ==> q) 175 | 176 | -- | @since 0.1.1.0 177 | instance {-# OVERLAPPING #-} Provable (p &&& q ==> q) where 178 | prove = projAndSnd @p @q 179 | 180 | -- | @since 0.1.1.0 181 | instance {-# OVERLAPPING #-} Decidable (p &&& p ==> p) 182 | 183 | -- | @since 0.1.1.0 184 | instance {-# OVERLAPPING #-} Provable (p &&& p ==> p) where 185 | prove = projAndFst @p @p 186 | 187 | -- | @since 0.1.1.0 188 | instance {-# OVERLAPPING #-} Decidable (p ==> p ||| q) 189 | 190 | -- | @since 0.1.1.0 191 | instance {-# OVERLAPPING #-} Provable (p ==> p ||| q) where 192 | prove = injOrLeft @p @q 193 | 194 | -- | @since 0.1.1.0 195 | instance {-# OVERLAPPING #-} Decidable (q ==> p ||| q) 196 | 197 | -- | @since 0.1.1.0 198 | instance {-# OVERLAPPING #-} Provable (q ==> p ||| q) where 199 | prove = injOrRight @p @q 200 | 201 | -- | @since 0.1.1.0 202 | instance {-# OVERLAPPING #-} Decidable (p ==> p ||| p) 203 | 204 | -- | @since 0.1.1.0 205 | instance {-# OVERLAPPING #-} Provable (p ==> p ||| p) where 206 | prove = injOrLeft @p @p 207 | 208 | -- | @'Implies' p q@ is a constraint that @p '==>' q@ is 'Provable'; that 209 | -- is, you can prove that @p@ implies @q@. 210 | type Implies p q = Provable (p ==> q) 211 | 212 | -- | @'Equiv' p q@ is a constraint that @p '<==>' q@ is 'Provable'; that 213 | -- is, you can prove that @p@ is logically equivalent to @q@. 214 | type Equiv p q = Provable (p <==> q) 215 | 216 | -- | If @q@ is provable, then so is @p '==>' q@. 217 | -- 218 | -- This can be used as an easy plug-in 'Provable' instance for @p '==>' q@ 219 | -- if @q@ is 'Provable': 220 | -- 221 | -- @ 222 | -- instance Provable (p ==> MyPred) where 223 | -- prove = proveImplies @MyPred 224 | -- @ 225 | -- 226 | -- This instance isn't provided polymorphically because of overlapping 227 | -- instance issues. 228 | proveImplies :: Prove q -> Prove (p ==> q) 229 | proveImplies q x _ = q x 230 | 231 | -- | Two-way implication, or logical equivalence 232 | type p <==> q = p ==> q &&& q ==> p 233 | 234 | infixr 1 <==> 235 | 236 | -- | From @'Impossible' @@ a@, you can prove anything. Essentially 237 | -- a lifted version of 'absurd'. 238 | explosion :: Impossible --> p 239 | explosion x v = absurd $ v x 240 | 241 | -- | 'Evident' can be proven from all predicates. 242 | atom :: p --> Evident 243 | atom = const 244 | 245 | -- | We cannot have both @p@ and @'Not' p@. 246 | -- 247 | -- (Renamed in v0.1.4.0; used to be @excludedMiddle@) 248 | -- 249 | -- @since 0.1.4.0 250 | complementation :: forall p. (p &&& Not p) --> Impossible 251 | complementation _ (p, notP) _ = notP p 252 | 253 | -- | @since 0.1.3.0 254 | instance {-# OVERLAPPING #-} Provable (p &&& Not p ==> Impossible) where 255 | prove = complementation @p 256 | 257 | -- | If p implies q, then not q implies not p. 258 | contrapositive :: 259 | (p --> q) -> 260 | (Not q --> Not p) 261 | contrapositive f x vQ p = vQ (f x p) 262 | 263 | -- | Reverse direction of 'contrapositive'. Only possible if @q@ is 264 | -- 'Decidable' on its own, without the help of @p@, which makes this much 265 | -- less useful. 266 | contrapositive' :: 267 | forall p q. 268 | Decidable q => 269 | (Not q --> Not p) -> 270 | (p --> q) 271 | contrapositive' f x p = elimDisproof (decide @q x) $ \vQ -> 272 | f x vQ p 273 | 274 | -- | Logical double negation. Only possible if @p@ is 'Decidable'. 275 | -- 276 | -- This is because in constructivist logic, not (not p) does not imply p. 277 | -- However, p implies not (not p) (see 'negateTwice'), and not (not (not 278 | -- p)) implies not p (see 'tripleNegation') 279 | doubleNegation :: forall p. Decidable p => Not (Not p) --> p 280 | doubleNegation x vvP = elimDisproof (decide @p x) $ \vP -> 281 | vvP vP 282 | 283 | -- | In constructivist logic, not (not (not p)) implies not p. 284 | -- 285 | -- @since 0.1.4.0 286 | tripleNegation :: forall p. Not (Not (Not p)) --> Not p 287 | tripleNegation _ vvvP p = vvvP $ \vP -> vP p 288 | 289 | -- | In constructivist logic, p implies not (not p). 290 | -- 291 | -- @since 0.1.4.0 292 | negateTwice :: p --> Not (Not p) 293 | negateTwice _ p vP = vP p 294 | 295 | -- | If @p '&&&' q@ is true, then so is @p@. 296 | projAndFst :: (p &&& q) --> p 297 | projAndFst _ = fst 298 | 299 | -- | If @p '&&&' q@ is true, then so is @q@. 300 | projAndSnd :: (p &&& q) --> q 301 | projAndSnd _ = snd 302 | 303 | -- | If @p@ is true, then so is @p '|||' q@. 304 | injOrLeft :: forall p q. p --> (p ||| q) 305 | injOrLeft _ = Left 306 | 307 | -- | If @q@ is true, then so is @p '|||' q@. 308 | injOrRight :: forall p q. q --> (p ||| q) 309 | injOrRight _ = Right 310 | -------------------------------------------------------------------------------- /src/Data/Type/Predicate/Param.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | -- | 15 | -- Module : Data.Type.Universe.Param 16 | -- Copyright : (c) Justin Le 2018 17 | -- License : BSD3 18 | -- 19 | -- Maintainer : justin@jle.im 20 | -- Stability : experimental 21 | -- Portability : non-portable 22 | -- 23 | -- Manipulate "parameterized predicates". See 'ParamPred' and 'Found' for 24 | -- more information. 25 | module Data.Type.Predicate.Param ( 26 | -- * Parameterized Predicates 27 | ParamPred, 28 | IsTC, 29 | EqBy, 30 | FlipPP, 31 | ConstPP, 32 | PPMap, 33 | PPMapV, 34 | InP, 35 | AnyMatch, 36 | TyPP, 37 | 38 | -- * Deciding and Proving 39 | Found, 40 | NotFound, 41 | Selectable, 42 | select, 43 | Searchable, 44 | search, 45 | inPNotNull, 46 | notNullInP, 47 | 48 | -- ** Type Constructors 49 | SelectableTC, 50 | selectTC, 51 | SearchableTC, 52 | searchTC, 53 | 54 | -- * Combining 55 | OrP, 56 | AndP, 57 | ) where 58 | 59 | import Data.Kind 60 | import Data.Singletons 61 | import Data.Singletons.Decide 62 | import Data.Singletons.Sigma 63 | import Data.Tuple.Singletons 64 | import Data.Type.Functor.Product 65 | import Data.Type.Predicate 66 | import Data.Type.Predicate.Logic 67 | import Data.Type.Universe 68 | 69 | -- | A parameterized predicate. See 'Found' for more information. 70 | type ParamPred k v = k -> Predicate v 71 | 72 | -- | Convert a parameterized predicate into a predicate on the parameter. 73 | -- 74 | -- A @'Found' p@ is a predicate on @p :: 'ParamPred' k v@ that tests a @k@ 75 | -- for the fact that there exists a @v@ where @'ParamPred' k v@ is satisfied. 76 | -- 77 | -- Intended as the basic interface for 'ParamPred', since it turns 78 | -- a 'ParamPred' into a normal 'Predicate', which can have 'Decidable' and 79 | -- 'Provable' instances. 80 | -- 81 | -- For some context, an instance of @'Provable' ('Found' P)@, where @P :: 82 | -- 'ParamPred' k v@, means that for any input @x :: k@, we can always find 83 | -- a @y :: v@ such that we have @P x \@\@ y@. 84 | -- 85 | -- In the language of quantifiers, it means that forall @x :: k@, there 86 | -- exists a @y :: v@ such that @P x \@\@ y@. 87 | -- 88 | -- For an instance of @'Decidable' ('Found' P)@, it means that for all @x 89 | -- :: k@, we can prove or disprove the fact that there exists a @y :: v@ 90 | -- such that @P x \@\@ y@. 91 | data Found :: ParamPred k v -> Predicate k 92 | 93 | type instance Apply (Found (p :: ParamPred k v)) a = Σ v (p a) 94 | 95 | -- | Convert a parameterized predicate into a predicate on the parameter. 96 | -- 97 | -- A @'Found' p@ is a predicate on @p :: 'ParamPred' k v@ that tests a @k@ 98 | -- for the fact that there /cannot exist/ a @v@ where @'ParamPred' k v@ is 99 | -- satisfied. That is, @'NotFound' P \@\@ x@ is satisfied if no @y :: v@ 100 | -- can exist where @P x \@\@ y@ is satisfied. 101 | -- 102 | -- For some context, an instance of @'Provable' ('NotFound' P)@, where @P 103 | -- :: 'ParamPred' k v@, means that for any input @x :: k@, we can always 104 | -- reject any @y :: v@ that claims to satisfy @P x \@\@ y@. 105 | -- 106 | -- In the language of quantifiers, it means that forall @x :: k@, there 107 | -- does not exist a @y :: v@ such that @P x \@\@ y@. 108 | -- 109 | -- For an instance of @'Decidable' ('Found' P)@, it means that for all @x 110 | -- :: k@, we can prove or disprove the fact that there does not exist a @y 111 | -- :: v@ such that @P x \@\@ y@. 112 | -- 113 | -- @since 0.1.2.0 114 | type NotFound (p :: ParamPred k v) = (Not (Found p) :: Predicate k) 115 | 116 | -- | Flip the arguments of a 'ParamPred'. 117 | data FlipPP :: ParamPred v k -> ParamPred k v 118 | 119 | type instance Apply (FlipPP p x) y = p y @@ x 120 | 121 | -- | Promote a @'Predicate' v@ to a @'ParamPred' k v@, ignoring the @k@ 122 | -- input. 123 | data ConstPP :: Predicate v -> ParamPred k v 124 | 125 | type instance Apply (ConstPP p k) v = p @@ v 126 | 127 | -- | @Found ('EqBy' f) \@\@ x@ is true if there exists some value when, 128 | -- with @f@ applied to it, is equal to @x@. 129 | -- 130 | -- See 'IsTC' for a useful specific application. 131 | -- 132 | -- @ 133 | -- 'EqBy' :: (v ~> k) -> 'ParamPred' k v 134 | -- 'Found' ('EqBy' f) :: 'Predicate' k 135 | -- @ 136 | -- 137 | -- @since 0.1.5.0 138 | data EqBy :: (v ~> k) -> ParamPred k v 139 | 140 | type instance Apply (EqBy f x) y = x :~: (f @@ y) 141 | 142 | -- | @Found ('IsTC' t) \@\@ x@ is true if @x@ was made using the unary type 143 | -- constructor @t@. 144 | -- 145 | -- For example: 146 | -- 147 | -- @ 148 | -- type IsJust = (Found (IsTC 'Just) :: Predicate (Maybe v)) 149 | -- @ 150 | -- 151 | -- makes a predicate where @IsJust \@\@ x@ is true if @x@ is 'Just', and 152 | -- false if @x@ is 'Nothing'. 153 | -- 154 | -- For a more general version, see 'EqBy' 155 | -- 156 | -- The kind of 'IsTC' is: 157 | -- 158 | -- @ 159 | -- 'IsTC' :: (v -> k) -> 'ParamPred' k v 160 | -- 'Found' ('IsTC' t) :: 'Predicate' k 161 | -- @ 162 | -- 163 | -- Applied to specific things: 164 | -- 165 | -- @ 166 | -- 'IsTC' ''Just' :: 'ParamPred' (Maybe v) v 167 | -- 'Found' ('IsTC' ''Just'') :: 'Predicate' (Maybe v) 168 | -- @ 169 | -- 170 | -- @since 0.1.5.0 171 | type IsTC t = EqBy (TyCon1 t) 172 | 173 | -- | Convert a normal '->' type constructor taking two arguments into 174 | -- a 'ParamPred'. 175 | -- 176 | -- @ 177 | -- 'TyPP' :: (k -> v -> 'Type') -> 'ParamPred' k v 178 | -- @ 179 | -- 180 | -- @since 0.1.4.0 181 | data TyPP :: (k -> v -> Type) -> ParamPred k v 182 | 183 | type instance Apply (TyPP t k) v = t k v 184 | 185 | -- | Pre-compose a function to a 'ParamPred'. Is essentially @'flip' 186 | -- ('.')@, but unfortunately defunctionalization doesn't work too well with 187 | -- that definition. 188 | data PPMap :: (k ~> j) -> ParamPred j v -> ParamPred k v 189 | 190 | type instance Apply (PPMap f p x) y = p (f @@ x) @@ y 191 | 192 | -- | Pre-compose a function to a 'ParamPred', but on the "value" side. 193 | -- 194 | -- @since 0.1.5.0 195 | data PPMapV :: (u ~> v) -> ParamPred k u -> ParamPred k v 196 | 197 | type instance Apply (PPMapV f p x) y = p x @@ (f @@ y) 198 | 199 | instance (Decidable (Found (p :: ParamPred j v)), SingI (f :: k ~> j)) => Decidable (Found (PPMap f p)) where 200 | decide = 201 | mapDecision 202 | (\case i :&: p -> i :&: p) 203 | (\case i :&: p -> i :&: p) 204 | . decide @(Found p) 205 | . applySing (sing :: Sing f) -- can just be sing @f in singletons 2.5, ghc 8.6+ 206 | 207 | instance (Provable (Found (p :: ParamPred j v)), SingI (f :: k ~> j)) => Provable (Found (PPMap f p)) where 208 | prove (x :: Sing a) = case prove @(Found p) ((sing :: Sing f) @@ x) of 209 | i :&: p -> i :&: p 210 | 211 | -- | A constraint that a @'ParamPred' k v@ is "searchable". It means that 212 | -- for any input @x :: k@, we can prove or disprove that there exists a @y 213 | -- :: v@ that satisfies @P x \@\@ y@. We can "search" for that @y@, and 214 | -- prove that it can or cannot be found. 215 | type Searchable p = Decidable (Found p) 216 | 217 | -- | A constraint that a @'ParamPred' k v@ s "selectable". It means that 218 | -- for any input @x :: k@, we can always find a @y :: v@ that satisfies @P 219 | -- x \@\@ y@. We can "select" that @y@, no matter what. 220 | type Selectable p = Provable (Found p) 221 | 222 | -- | The deciding/searching function for @'Searchable' p@. 223 | -- 224 | -- Because this is ambiguously typed, it must be called by applying the 225 | -- 'ParamPred': 226 | -- 227 | -- @ 228 | -- 'search' \@p 229 | -- @ 230 | -- 231 | -- See 'searchTC' and 'SearchableTC' for a version that isn't ambiguously 232 | -- typed, but only works when @p@ is a type constructor. 233 | search :: 234 | forall p. 235 | Searchable p => 236 | Decide (Found p) 237 | search = decide @(Found p) 238 | 239 | -- | The proving/selecting function for @'Selectable' p@. 240 | -- 241 | -- Because this is ambiguously typed, it must be called by applying the 242 | -- 'ParamPred': 243 | -- 244 | -- @ 245 | -- 'select' \@p 246 | -- @ 247 | -- 248 | -- See 'selectTC' and 'SelectableTC' for a version that isn't ambiguously 249 | -- typed, but only works when @p@ is a type constructor. 250 | select :: 251 | forall p. 252 | Selectable p => 253 | Prove (Found p) 254 | select = prove @(Found p) 255 | 256 | -- | If @T :: k -> v -> 'Type'@ is a type constructor, then @'SearchableTC' 257 | -- T@ is a constraint that @T@ is "searchable", in that you have 258 | -- a canonical function: 259 | -- 260 | -- @ 261 | -- 'searchTC' :: 'Sing' x -> 'Decision' (Σ v ('TyPP' T x)) 262 | -- @ 263 | -- 264 | -- That, given an @x :: k@, we can decide whether or not a @y :: v@ exists 265 | -- that satisfies @T x y@. 266 | -- 267 | -- Is essentially 'Searchable', except with /type constructors/ @k -> 268 | -- 'Type'@ instead of matchable type-level functions (that are @k ~> 269 | -- 'Type'@). Useful because 'searchTC' doesn't require anything fancy like 270 | -- TypeApplications to use. 271 | -- 272 | -- @since 0.1.4.0 273 | type SearchableTC t = Decidable (Found (TyPP t)) 274 | 275 | -- | If @T :: k -> v -> 'Type'@ is a type constructor, then @'Selectable' 276 | -- T@ is a constraint that @T@ is "selectable", in that you have 277 | -- a canonical function: 278 | -- 279 | -- @ 280 | -- 'selectTC' :: 'Sing' a -> Σ v ('TyPP' T x) 281 | -- @ 282 | -- 283 | -- That is, given an @x :: k@, we can /always/ find a @y :: k@ that 284 | -- satisfies @T x y@. 285 | -- 286 | -- Is essentially 'Selectable', except with /type constructors/ @k -> 287 | -- 'Type'@ instead of matchable type-level functions (that are @k ~> 288 | -- 'Type'@). Useful because 'selectTC' doesn't require anything fancy like 289 | -- TypeApplications to use. 290 | -- 291 | -- @since 0.1.4.0 292 | type SelectableTC t = Provable (Found (TyPP t)) 293 | 294 | -- | The canonical selecting function for @'Searchable' t@. 295 | -- 296 | -- Note that because @t@ must be an injective type constructor, you can use 297 | -- this without explicit type applications; the instance of 'SearchableTC' 298 | -- can be inferred from the result type. 299 | -- 300 | -- @since 0.1.4.0 301 | searchTC :: 302 | forall t. 303 | SearchableTC t => 304 | Decide (Found (TyPP t)) 305 | searchTC = search @(TyPP t) 306 | 307 | -- | The canonical selecting function for @'SelectableTC' t@. 308 | -- 309 | -- Note that because @t@ must be an injective type constructor, you can use 310 | -- this without explicit type applications; the instance of 'SelectableTC' 311 | -- can be inferred from the result type. 312 | -- 313 | -- @since 0.1.4.0 314 | selectTC :: 315 | forall t. 316 | SelectableTC t => 317 | Prove (Found (TyPP t)) 318 | selectTC = select @(TyPP t) 319 | 320 | -- | A @'ParamPred' (f k) k@. Parameterized on an @as :: f k@, returns 321 | -- a predicate that is true if there exists any @a :: k@ in @as@. 322 | -- 323 | -- Essentially 'NotNull'. 324 | type InP f = (ElemSym1 f :: ParamPred (f k) k) 325 | 326 | -- | @'NotNull' f@ is basically @'Found' ('InP' f)@. 327 | -- 328 | -- @since 0.1.2.0 329 | notNullInP :: NotNull f --> Found (InP f) 330 | notNullInP _ (WitAny i s) = s :&: i 331 | 332 | -- | @'NotNull' f@ is basically @'Found' ('InP' f)@. 333 | -- 334 | -- @since 0.1.2.0 335 | inPNotNull :: Found (InP f) --> NotNull f 336 | inPNotNull _ (s :&: i) = WitAny i s 337 | 338 | instance Universe f => Decidable (Found (InP f)) where 339 | decide = 340 | mapDecision 341 | (\case WitAny i s -> s :&: i) 342 | (\case s :&: i -> WitAny i s) 343 | . decide @(NotNull f) 344 | 345 | instance Decidable (NotNull f ==> Found (InP f)) 346 | instance Provable (NotNull f ==> Found (InP f)) where 347 | prove = notNullInP 348 | 349 | instance Decidable (Found (InP f) ==> NotNull f) 350 | instance Provable (Found (InP f) ==> NotNull f) where 351 | prove = inPNotNull 352 | 353 | -- | @'AnyMatch' f@ takes a parmaeterized predicate on @k@ (testing for 354 | -- a @v@) and turns it into a parameterized predicate on @f k@ (testing for 355 | -- a @v@). It "lifts" the domain into @f@. 356 | -- 357 | -- An @'AnyMatch' f p as@ is a predicate taking an argument @a@ and 358 | -- testing if @p a :: 'Predicate' k@ is satisfied for any item in @as :: 359 | -- f k@. 360 | -- 361 | -- A @'ParamPred' k v@ tests if a @k@ can create some @v@. The resulting 362 | -- @'ParamPred' (f k) v@ tests if any @k@ in @f k@ can create some @v@. 363 | data AnyMatch f :: ParamPred k v -> ParamPred (f k) v 364 | 365 | type instance Apply (AnyMatch f p as) a = Any f (FlipPP p a) @@ as 366 | 367 | instance (Universe f, Decidable (Found p)) => Decidable (Found (AnyMatch f p)) where 368 | decide = 369 | mapDecision 370 | (\case WitAny i (x :&: p) -> x :&: WitAny i p) 371 | (\case x :&: WitAny i p -> WitAny i (x :&: p)) 372 | . decide @(Any f (Found p)) 373 | 374 | -- | Disjunction on two 'ParamPred's, with appropriate 'Searchable' 375 | -- instance. Priority is given to the left predicate. 376 | -- 377 | -- @since 0.1.3.0 378 | data OrP :: ParamPred k v -> ParamPred k v -> ParamPred k v 379 | 380 | type instance Apply (OrP p q x) y = (p x ||| q x) @@ y 381 | 382 | -- | Conjunction on two 'ParamPred's, with appropriate 'Searchable' and 383 | -- 'Selectable' instances. 384 | -- 385 | -- @since 0.1.3.0 386 | data AndP :: ParamPred k v -> ParamPred k u -> ParamPred k (v, u) 387 | 388 | type instance Apply (AndP p q x) '(y, z) = (p x @@ y, q x @@ z) 389 | 390 | instance (Searchable p, Searchable q) => Decidable (Found (OrP p q)) where 391 | decide x = case search @p x of 392 | Proved (s :&: p) -> Proved $ s :&: Left p 393 | Disproved vp -> case search @q x of 394 | Proved (s :&: q) -> Proved $ s :&: Right q 395 | Disproved vq -> Disproved $ \case 396 | s :&: Left p -> vp (s :&: p) 397 | s :&: Right q -> vq (s :&: q) 398 | 399 | instance (Searchable p, Searchable q) => Decidable (Found (AndP p q)) where 400 | decide x = case search @p x of 401 | Proved (s :&: p) -> case search @q x of 402 | Proved (t :&: q) -> Proved $ STuple2 s t :&: (p, q) 403 | Disproved vq -> Disproved $ \case 404 | STuple2 _ t :&: (_, q) -> vq $ t :&: q 405 | Disproved vp -> Disproved $ \case 406 | STuple2 s _ :&: (p, _) -> vp $ s :&: p 407 | 408 | instance (Selectable p, Selectable q) => Provable (Found (AndP p q)) where 409 | prove x = case select @p x of 410 | s :&: p -> case select @q x of 411 | t :&: q -> STuple2 s t :&: (p, q) 412 | -------------------------------------------------------------------------------- /src/Data/Type/Predicate/Quantification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | -- | 11 | -- Module : Data.Type.Predicate.Quantification 12 | -- Copyright : (c) Justin Le 2018 13 | -- License : BSD3 14 | -- 15 | -- Maintainer : justin@jle.im 16 | -- Stability : experimental 17 | -- Portability : non-portable 18 | -- 19 | -- Higher-level predicates for quantifying predicates over universes and 20 | -- sets. 21 | module Data.Type.Predicate.Quantification ( 22 | -- * Any 23 | Any, 24 | WitAny (..), 25 | None, 26 | anyImpossible, 27 | 28 | -- ** Decision 29 | decideAny, 30 | idecideAny, 31 | decideNone, 32 | idecideNone, 33 | 34 | -- ** Entailment 35 | entailAny, 36 | ientailAny, 37 | entailAnyF, 38 | ientailAnyF, 39 | 40 | -- * All 41 | All, 42 | WitAll (..), 43 | NotAll, 44 | 45 | -- ** Decision 46 | decideAll, 47 | idecideAll, 48 | 49 | -- ** Entailment 50 | entailAll, 51 | ientailAll, 52 | entailAllF, 53 | ientailAllF, 54 | decideEntailAll, 55 | idecideEntailAll, 56 | 57 | -- * Logical interplay 58 | allToAny, 59 | allNotNone, 60 | noneAllNot, 61 | anyNotNotAll, 62 | notAllAnyNot, 63 | ) where 64 | 65 | import Data.Kind 66 | import Data.Singletons 67 | import Data.Singletons.Decide 68 | import Data.Type.Functor.Product 69 | import Data.Type.Predicate 70 | import Data.Type.Predicate.Logic 71 | import Data.Type.Universe 72 | 73 | -- | 'decideNone', but providing an 'Elem'. 74 | idecideNone :: 75 | forall f k (p :: k ~> Type) (as :: f k). 76 | Universe f => 77 | -- | predicate on value 78 | (forall a. Elem f as a -> Sing a -> Decision (p @@ a)) -> 79 | -- | predicate on collection 80 | (Sing as -> Decision (None f p @@ as)) 81 | idecideNone f xs = decideNot @(Any f p) $ idecideAny f xs 82 | 83 | -- | Lifts a predicate @p@ on an individual @a@ into a predicate that on 84 | -- a collection @as@ that is true if and only if /no/ item in @as@ 85 | -- satisfies the original predicate. 86 | -- 87 | -- That is, it turns a predicate of kind @k ~> Type@ into a predicate 88 | -- of kind @f k ~> Type@. 89 | decideNone :: 90 | forall f k (p :: k ~> Type). 91 | Universe f => 92 | -- | predicate on value 93 | Decide p -> 94 | -- | predicate on collection 95 | Decide (None f p) 96 | decideNone f = idecideNone (const f) 97 | 98 | -- | 'entailAny', but providing an 'Elem'. 99 | ientailAny :: 100 | forall f p q as. 101 | (Universe f, SingI as) => 102 | -- | implication 103 | (forall a. Elem f as a -> Sing a -> p @@ a -> q @@ a) -> 104 | Any f p @@ as -> 105 | Any f q @@ as 106 | ientailAny f (WitAny i x) = WitAny i (f i (indexSing i sing) x) 107 | 108 | -- | If there exists an @a@ s.t. @p a@, and if @p@ implies @q@, then there 109 | -- must exist an @a@ s.t. @q a@. 110 | entailAny :: 111 | forall f p q. 112 | Universe f => 113 | (p --> q) -> 114 | (Any f p --> Any f q) 115 | entailAny = tmap @(Any f) 116 | 117 | -- | 'entailAll', but providing an 'Elem'. 118 | ientailAll :: 119 | forall f p q as. 120 | (Universe f, SingI as) => 121 | -- | implication 122 | (forall a. Elem f as a -> Sing a -> p @@ a -> q @@ a) -> 123 | All f p @@ as -> 124 | All f q @@ as 125 | ientailAll f a = WitAll $ \i -> f i (indexSing i sing) (runWitAll a i) 126 | 127 | -- | If for all @a@ we have @p a@, and if @p@ implies @q@, then for all @a@ 128 | -- we must also have @p a@. 129 | entailAll :: 130 | forall f p q. 131 | Universe f => 132 | (p --> q) -> 133 | (All f p --> All f q) 134 | entailAll = tmap @(All f) 135 | 136 | -- | 'entailAnyF', but providing an 'Elem'. 137 | ientailAnyF :: 138 | forall f p q as h. 139 | Functor h => 140 | -- | implication in context 141 | (forall a. Elem f as a -> p @@ a -> h (q @@ a)) -> 142 | Any f p @@ as -> 143 | h (Any f q @@ as) 144 | ientailAnyF f = \case WitAny i x -> WitAny i <$> f i x 145 | 146 | -- | If @p@ implies @q@ under some context @h@, and if there exists some 147 | -- @a@ such that @p a@, then there must exist some @a@ such that @p q@ 148 | -- under that context @h@. 149 | -- 150 | -- @h@ might be something like, say, 'Maybe', to give predicate that is 151 | -- either provably true or unprovably false. 152 | -- 153 | -- Note that it is not possible to do this with @p a -> 'Decision' (q a)@. 154 | -- This is if the @p a -> 'Decision' (q a)@ implication is false, there 155 | -- it doesn't mean that there is /no/ @a@ such that @q a@, necessarily. 156 | -- There could have been an @a@ where @p@ does not hold, but @q@ does. 157 | entailAnyF :: 158 | forall f p q h. 159 | (Universe f, Functor h) => 160 | -- | implication in context 161 | (p --># q) h -> 162 | (Any f p --># Any f q) h 163 | entailAnyF f x a = 164 | withSingI x $ 165 | ientailAnyF @f @p @q (\i -> f (indexSing i x)) a 166 | 167 | -- | 'entailAllF', but providing an 'Elem'. 168 | ientailAllF :: 169 | forall f p q as h. 170 | (Universe f, Applicative h, SingI as) => 171 | -- | implication in context 172 | (forall a. Elem f as a -> p @@ a -> h (q @@ a)) -> 173 | All f p @@ as -> 174 | h (All f q @@ as) 175 | ientailAllF f a = 176 | fmap (prodAll getWit) 177 | . itraverseProd (\i _ -> Wit @q <$> f i (runWitAll a i)) 178 | $ singProd (sing @as) 179 | 180 | -- | If @p@ implies @q@ under some context @h@, and if we have @p a@ for 181 | -- all @a@, then we must have @q a@ for all @a@ under context @h@. 182 | entailAllF :: 183 | forall f p q h. 184 | (Universe f, Applicative h) => 185 | -- | implication in context 186 | (p --># q) h -> 187 | (All f p --># All f q) h 188 | entailAllF f x a = 189 | withSingI x $ 190 | ientailAllF @f @p @q (\i -> f (indexSing i x)) a 191 | 192 | -- | 'entailAllF', but providing an 'Elem'. 193 | idecideEntailAll :: 194 | forall f p q as. 195 | (Universe f, SingI as) => 196 | -- | decidable implication 197 | (forall a. Elem f as a -> p @@ a -> Decision (q @@ a)) -> 198 | All f p @@ as -> 199 | Decision (All f q @@ as) 200 | idecideEntailAll f a = idecideAll (\i _ -> f i (runWitAll a i)) sing 201 | 202 | -- | If we have @p a@ for all @a@, and @p a@ can be used to test for @q a@, 203 | -- then we can test all @a@s for @q a@. 204 | decideEntailAll :: 205 | forall f p q. 206 | Universe f => 207 | p -?> q -> 208 | All f p -?> All f q 209 | decideEntailAll = dmap @(All f) 210 | 211 | -- | It is impossible for any value in a collection to be 'Impossible'. 212 | -- 213 | -- @since 0.1.2.0 214 | anyImpossible :: Universe f => Any f Impossible --> Impossible 215 | anyImpossible _ (WitAny i p) = p . indexSing i 216 | 217 | -- | If any @a@ in @as@ does not satisfy @p@, then not all @a@ in @as@ 218 | -- satisfy @p@. 219 | -- 220 | -- @since 0.1.2.0 221 | anyNotNotAll :: Any f (Not p) --> NotAll f p 222 | anyNotNotAll _ (WitAny i v) a = v $ runWitAll a i 223 | 224 | -- | If not all @a@ in @as@ satisfy @p@, then there must be at least one 225 | -- @a@ in @as@ that does not satisfy @p@. Requires @'Decidable' p@ in 226 | -- order to locate that specific @a@. 227 | -- 228 | -- @since 0.1.2.0 229 | notAllAnyNot :: 230 | forall f p. 231 | (Universe f, Decidable p) => 232 | NotAll f p --> Any f (Not p) 233 | notAllAnyNot xs vAll = elimDisproof (decide @(Any f (Not p)) xs) $ \vAny -> 234 | vAll $ WitAll $ \i -> 235 | elimDisproof (decide @p (indexSing i xs)) $ \vP -> 236 | vAny $ WitAny i vP 237 | 238 | -- | If @p@ is false for all @a@ in @as@, then no @a@ in @as@ satisfies 239 | -- @p@. 240 | -- 241 | -- @since 0.1.2.0 242 | allNotNone :: All f (Not p) --> None f p 243 | allNotNone _ a (WitAny i v) = runWitAll a i v 244 | 245 | -- | If no @a@ in @as@ satisfies @p@, then @p@ is false for all @a@ in 246 | -- @as@. Requires @'Decidable' p@ to interrogate the input disproof. 247 | -- 248 | -- @since 0.1.2.0 249 | noneAllNot :: 250 | forall f p. 251 | (Universe f, Decidable p) => 252 | None f p --> All f (Not p) 253 | noneAllNot xs vAny = elimDisproof (decide @(All f (Not p)) xs) $ \vAll -> 254 | vAll $ WitAll $ \i p -> vAny $ WitAny i p 255 | 256 | -- | If something is true for all xs, then it must be true for at least one 257 | -- x in xs, provided that xs is not empty. 258 | -- 259 | -- @since 0.1.5.0 260 | allToAny :: (All f p &&& NotNull f) --> Any f p 261 | allToAny _ (a, WitAny i _) = WitAny i $ runWitAll a i 262 | -------------------------------------------------------------------------------- /src/Data/Type/Universe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE EmptyCase #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE InstanceSigs #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilyDependencies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | 15 | -- | 16 | -- Module : Data.Type.Universe 17 | -- Copyright : (c) Justin Le 2018 18 | -- License : BSD3 19 | -- 20 | -- Maintainer : justin@jle.im 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | -- 24 | -- A type family for "containers", intended for allowing lifting of 25 | -- predicates on @k@ to be predicates on containers @f k@. 26 | module Data.Type.Universe ( 27 | -- * Universe 28 | Elem, 29 | In, 30 | Universe (..), 31 | singAll, 32 | 33 | -- ** Instances 34 | Index (..), 35 | IJust (..), 36 | IRight (..), 37 | NEIndex (..), 38 | ISnd (..), 39 | IIdentity (..), 40 | 41 | -- ** Predicates 42 | All, 43 | WitAll (..), 44 | NotAll, 45 | Any, 46 | WitAny (..), 47 | None, 48 | Null, 49 | NotNull, 50 | 51 | -- *** Specialized 52 | IsJust, 53 | IsNothing, 54 | IsRight, 55 | IsLeft, 56 | 57 | -- * Decisions and manipulations 58 | decideAny, 59 | decideAll, 60 | genAll, 61 | igenAll, 62 | splitSing, 63 | pickElem, 64 | ) where 65 | 66 | import Data.Either.Singletons hiding (IsLeft, IsRight) 67 | import Data.Functor.Identity 68 | import Data.Functor.Identity.Singletons 69 | import Data.Kind 70 | import Data.List.NonEmpty (NonEmpty (..)) 71 | import qualified Data.List.NonEmpty.Singletons as NE 72 | import Data.List.Singletons hiding ( 73 | All, 74 | Any, 75 | Elem, 76 | ElemSym0, 77 | ElemSym1, 78 | ElemSym2, 79 | Null, 80 | ) 81 | import Data.Maybe.Singletons hiding (IsJust, IsNothing) 82 | import Data.Singletons 83 | import Data.Singletons.Decide 84 | import Data.Tuple.Singletons 85 | import Data.Type.Functor.Product 86 | import Data.Type.Predicate 87 | import Data.Type.Predicate.Logic 88 | import GHC.Generics ((:*:) (..)) 89 | import Prelude hiding (all, any) 90 | 91 | -- | A @'WitAny' p as@ is a witness that, for at least one item @a@ in the 92 | -- type-level collection @as@, the predicate @p a@ is true. 93 | data WitAny f :: (k ~> Type) -> f k -> Type where 94 | WitAny :: Elem f as a -> p @@ a -> WitAny f p as 95 | 96 | -- | An @'Any' f p@ is a predicate testing a collection @as :: f a@ for the 97 | -- fact that at least one item in @as@ satisfies @p@. Represents the 98 | -- "exists" quantifier over a given universe. 99 | -- 100 | -- This is mostly useful for its 'Decidable' and 'TFunctor' instances, 101 | -- which lets you lift predicates on @p@ to predicates on @'Any' f p@. 102 | data Any f :: Predicate k -> Predicate (f k) 103 | 104 | type instance Apply (Any f p) as = WitAny f p as 105 | 106 | -- | A @'WitAll' p as@ is a witness that the predicate @p a@ is true for all 107 | -- items @a@ in the type-level collection @as@. 108 | newtype WitAll f p (as :: f k) = WitAll {runWitAll :: forall a. Elem f as a -> p @@ a} 109 | 110 | -- | An @'All' f p@ is a predicate testing a collection @as :: f a@ for the 111 | -- fact that /all/ items in @as@ satisfy @p@. Represents the "forall" 112 | -- quantifier over a given universe. 113 | -- 114 | -- This is mostly useful for its 'Decidable', 'Provable', and 'TFunctor' 115 | -- instances, which lets you lift predicates on @p@ to predicates on @'All' 116 | -- f p@. 117 | data All f :: Predicate k -> Predicate (f k) 118 | 119 | type instance Apply (All f p) as = WitAll f p as 120 | 121 | instance (Universe f, Decidable p) => Decidable (Any f p) where 122 | decide = decideAny @f @_ @p $ decide @p 123 | 124 | instance (Universe f, Decidable p) => Decidable (All f p) where 125 | decide = decideAll @f @_ @p $ decide @p 126 | 127 | instance (Universe f, Provable p) => Decidable (NotNull f ==> Any f p) 128 | 129 | instance Provable p => Provable (NotNull f ==> Any f p) where 130 | prove _ (WitAny i s) = WitAny i (prove @p s) 131 | 132 | instance (Universe f, Provable p) => Provable (All f p) where 133 | prove xs = WitAll $ \i -> prove @p (indexSing i xs) 134 | 135 | instance Universe f => TFunctor (Any f) where 136 | tmap f xs (WitAny i x) = WitAny i (f (indexSing i xs) x) 137 | 138 | instance Universe f => TFunctor (All f) where 139 | tmap f xs a = WitAll $ \i -> f (indexSing i xs) (runWitAll a i) 140 | 141 | instance Universe f => DFunctor (All f) where 142 | dmap f xs a = idecideAll (\i x -> f x (runWitAll a i)) xs 143 | 144 | -- | Typeclass for a type-level container that you can quantify or lift 145 | -- type-level predicates over. 146 | class FProd f => Universe (f :: Type -> Type) where 147 | -- | 'decideAny', but providing an 'Elem'. 148 | idecideAny :: 149 | forall k (p :: k ~> Type) (as :: f k). 150 | () => 151 | -- | predicate on value 152 | (forall a. Elem f as a -> Sing a -> Decision (p @@ a)) -> 153 | -- | predicate on collection 154 | (Sing as -> Decision (Any f p @@ as)) 155 | 156 | -- | 'decideAll', but providing an 'Elem'. 157 | idecideAll :: 158 | forall k (p :: k ~> Type) (as :: f k). 159 | () => 160 | -- | predicate on value 161 | (forall a. Elem f as a -> Sing a -> Decision (p @@ a)) -> 162 | -- | predicate on collection 163 | (Sing as -> Decision (All f p @@ as)) 164 | 165 | allProd :: 166 | forall p g. 167 | () => 168 | (forall a. Sing a -> p @@ a -> g a) -> 169 | All f p --> TyPred (Prod f g) 170 | 171 | prodAll :: 172 | forall p g as. 173 | () => 174 | (forall a. g a -> p @@ a) -> 175 | Prod f g as -> 176 | All f p @@ as 177 | 178 | -- | Predicate that a given @as :: f k@ is empty and has no items in it. 179 | type Null f = (None f Evident :: Predicate (f k)) 180 | 181 | -- | Predicate that a given @as :: f k@ is not empty, and has at least one 182 | -- item in it. 183 | type NotNull f = (Any f Evident :: Predicate (f k)) 184 | 185 | -- | A @'None' f p@ is a predicate on a collection @as@ that no @a@ in @as@ 186 | -- satisfies predicate @p@. 187 | type None f p = (Not (Any f p) :: Predicate (f k)) 188 | 189 | -- | A @'NotAll' f p@ is a predicate on a collection @as@ that at least one 190 | -- @a@ in @as@ does not satisfy predicate @p@. 191 | type NotAll f p = (Not (All f p) :: Predicate (f k)) 192 | 193 | -- | Lifts a predicate @p@ on an individual @a@ into a predicate that on 194 | -- a collection @as@ that is true if and only if /any/ item in @as@ 195 | -- satisfies the original predicate. 196 | -- 197 | -- That is, it turns a predicate of kind @k ~> Type@ into a predicate 198 | -- of kind @f k ~> Type@. 199 | -- 200 | -- Essentially tests existential quantification. 201 | decideAny :: 202 | forall f k (p :: k ~> Type). 203 | Universe f => 204 | -- | predicate on value 205 | Decide p -> 206 | -- | predicate on collection 207 | Decide (Any f p) 208 | decideAny f = idecideAny (const f) 209 | 210 | -- | Lifts a predicate @p@ on an individual @a@ into a predicate that on 211 | -- a collection @as@ that is true if and only if /all/ items in @as@ 212 | -- satisfies the original predicate. 213 | -- 214 | -- That is, it turns a predicate of kind @k ~> Type@ into a predicate 215 | -- of kind @f k ~> Type@. 216 | -- 217 | -- Essentially tests universal quantification. 218 | decideAll :: 219 | forall f k (p :: k ~> Type). 220 | Universe f => 221 | -- | predicate on value 222 | Decide p -> 223 | -- | predicate on collection 224 | Decide (All f p) 225 | decideAll f = idecideAll (const f) 226 | 227 | -- | Split a @'Sing' as@ into a proof that all @a@ in @as@ exist. 228 | splitSing :: 229 | forall f k (as :: f k). 230 | Universe f => 231 | Sing as -> 232 | All f (TyPred Sing) @@ as 233 | splitSing = prodAll id . singProd 234 | 235 | -- | Automatically generate a witness for a member, if possible 236 | pickElem :: 237 | forall f k (as :: f k) a. 238 | (Universe f, SingI as, SingI a, SDecide k) => 239 | Decision (Elem f as a) 240 | pickElem = 241 | mapDecision 242 | (\case WitAny i Refl -> i) 243 | (\case i -> WitAny i Refl) 244 | . decide @(Any f (TyPred ((:~:) a))) 245 | $ sing 246 | 247 | -- | 'genAll', but providing an 'Elem'. 248 | igenAll :: 249 | forall f k (p :: k ~> Type) (as :: f k). 250 | Universe f => 251 | -- | always-true predicate on value 252 | (forall a. Elem f as a -> Sing a -> p @@ a) -> 253 | -- | always-true predicate on collection 254 | (Sing as -> All f p @@ as) 255 | igenAll f = prodAll (\(i :*: x) -> f i x) . imapProd (:*:) . singProd 256 | 257 | -- | If @p a@ is true for all values @a@ in @as@, then we have @'All' 258 | -- p as@. Basically witnesses the definition of 'All'. 259 | genAll :: 260 | forall f k (p :: k ~> Type). 261 | Universe f => 262 | -- | always-true predicate on value 263 | Prove p -> 264 | -- | always-true predicate on collection 265 | Prove (All f p) 266 | genAll f = prodAll f . singProd 267 | 268 | -- | Split a @'Sing' as@ into a proof that all @a@ in @as@ exist. 269 | singAll :: 270 | forall f k (as :: f k). 271 | Universe f => 272 | Sing as -> 273 | All f Evident @@ as 274 | singAll = prodAll id . singProd 275 | 276 | -- | Test that a 'Maybe' is 'Just'. 277 | -- 278 | -- @since 0.1.2.0 279 | type IsJust = (NotNull Maybe :: Predicate (Maybe k)) 280 | 281 | -- | Test that a 'Maybe' is 'Nothing'. 282 | -- 283 | -- @since 0.1.2.0 284 | type IsNothing = (Null Maybe :: Predicate (Maybe k)) 285 | 286 | -- | Test that an 'Either' is 'Right' 287 | -- 288 | -- @since 0.1.2.0 289 | type IsRight = (NotNull (Either j) :: Predicate (Either j k)) 290 | 291 | -- | Test that an 'Either' is 'Left' 292 | -- 293 | -- @since 0.1.2.0 294 | type IsLeft = (Null (Either j) :: Predicate (Either j k)) 295 | 296 | instance Universe [] where 297 | idecideAny :: 298 | forall k (p :: k ~> Type) (as :: [k]). 299 | () => 300 | (forall a. Elem [] as a -> Sing a -> Decision (p @@ a)) -> 301 | Sing as -> 302 | Decision (Any [] p @@ as) 303 | idecideAny f = \case 304 | SNil -> Disproved $ \case 305 | WitAny i _ -> case i of {} 306 | x `SCons` xs -> case f IZ x of 307 | Proved p -> Proved $ WitAny IZ p 308 | Disproved v -> case idecideAny @[] @_ @p (f . IS) xs of 309 | Proved (WitAny i p) -> Proved $ WitAny (IS i) p 310 | Disproved vs -> Disproved $ \case 311 | WitAny IZ p -> v p 312 | WitAny (IS i) p -> vs (WitAny i p) 313 | 314 | idecideAll :: 315 | forall k (p :: k ~> Type) (as :: [k]). 316 | () => 317 | (forall a. Elem [] as a -> Sing a -> Decision (p @@ a)) -> 318 | Sing as -> 319 | Decision (All [] p @@ as) 320 | idecideAll f = \case 321 | SNil -> Proved $ WitAll $ \case {} 322 | x `SCons` xs -> case f IZ x of 323 | Proved p -> case idecideAll @[] @_ @p (f . IS) xs of 324 | Proved a -> Proved $ WitAll $ \case 325 | IZ -> p 326 | IS i -> runWitAll a i 327 | Disproved v -> Disproved $ \a -> v $ WitAll (runWitAll a . IS) 328 | Disproved v -> Disproved $ \a -> v $ runWitAll a IZ 329 | 330 | allProd :: 331 | forall p g. 332 | () => 333 | (forall a. Sing a -> p @@ a -> g a) -> 334 | All [] p --> TyPred (Prod [] g) 335 | allProd f = go 336 | where 337 | go :: Sing as -> WitAll [] p as -> Prod [] g as 338 | go = \case 339 | SNil -> \_ -> RNil 340 | x `SCons` xs -> \a -> 341 | f x (runWitAll a IZ) 342 | :& go xs (WitAll (runWitAll a . IS)) 343 | 344 | prodAll :: 345 | forall p g as. 346 | () => 347 | (forall a. g a -> p @@ a) -> 348 | Prod [] g as -> 349 | All [] p @@ as 350 | prodAll f = go 351 | where 352 | go :: Prod [] g bs -> All [] p @@ bs 353 | go = \case 354 | RNil -> WitAll $ \case {} 355 | x :& xs -> WitAll $ \case 356 | IZ -> f x 357 | IS i -> runWitAll (go xs) i 358 | 359 | instance Universe Maybe where 360 | idecideAny f = \case 361 | SNothing -> Disproved $ \case WitAny i _ -> case i of {} 362 | SJust x -> case f IJust x of 363 | Proved p -> Proved $ WitAny IJust p 364 | Disproved v -> Disproved $ \case 365 | WitAny IJust p -> v p 366 | idecideAll f = \case 367 | SNothing -> Proved $ WitAll $ \case {} 368 | SJust x -> case f IJust x of 369 | Proved p -> Proved $ WitAll $ \case IJust -> p 370 | Disproved v -> Disproved $ \a -> v $ runWitAll a IJust 371 | allProd f = \case 372 | SNothing -> \_ -> PNothing 373 | SJust x -> \a -> PJust (f x (runWitAll a IJust)) 374 | prodAll f = \case 375 | PNothing -> WitAll $ \case {} 376 | PJust x -> WitAll $ \case IJust -> f x 377 | 378 | instance Universe (Either j) where 379 | idecideAny f = \case 380 | SLeft _ -> Disproved $ \case WitAny i _ -> case i of {} 381 | SRight x -> case f IRight x of 382 | Proved p -> Proved $ WitAny IRight p 383 | Disproved v -> Disproved $ \case 384 | WitAny IRight p -> v p 385 | idecideAll f = \case 386 | SLeft _ -> Proved $ WitAll $ \case {} 387 | SRight x -> case f IRight x of 388 | Proved p -> Proved $ WitAll $ \case IRight -> p 389 | Disproved v -> Disproved $ \a -> v $ runWitAll a IRight 390 | allProd f = \case 391 | SLeft w -> \_ -> PLeft w 392 | SRight x -> \a -> PRight (f x (runWitAll a IRight)) 393 | prodAll f = \case 394 | PLeft _ -> WitAll $ \case {} 395 | PRight x -> WitAll $ \case IRight -> f x 396 | 397 | instance Universe NonEmpty where 398 | idecideAny :: 399 | forall k (p :: k ~> Type) (as :: NonEmpty k). 400 | () => 401 | (forall a. Elem NonEmpty as a -> Sing a -> Decision (p @@ a)) -> 402 | Sing as -> 403 | Decision (Any NonEmpty p @@ as) 404 | idecideAny f (x NE.:%| xs) = case f NEHead x of 405 | Proved p -> Proved $ WitAny NEHead p 406 | Disproved v -> case idecideAny @[] @_ @p (f . NETail) xs of 407 | Proved (WitAny i p) -> Proved $ WitAny (NETail i) p 408 | Disproved vs -> Disproved $ \case 409 | WitAny i p -> case i of 410 | NEHead -> v p 411 | NETail i' -> vs (WitAny i' p) 412 | 413 | idecideAll :: 414 | forall k (p :: k ~> Type) (as :: NonEmpty k). 415 | () => 416 | (forall a. Elem NonEmpty as a -> Sing a -> Decision (p @@ a)) -> 417 | Sing as -> 418 | Decision (All NonEmpty p @@ as) 419 | idecideAll f (x NE.:%| xs) = case f NEHead x of 420 | Proved p -> case idecideAll @[] @_ @p (f . NETail) xs of 421 | Proved ps -> Proved $ WitAll $ \case 422 | NEHead -> p 423 | NETail i -> runWitAll ps i 424 | Disproved v -> Disproved $ \a -> v $ WitAll (runWitAll a . NETail) 425 | Disproved v -> Disproved $ \a -> v $ runWitAll a NEHead 426 | 427 | allProd :: 428 | forall p g. 429 | () => 430 | (forall a. Sing a -> p @@ a -> g a) -> 431 | All NonEmpty p --> TyPred (Prod NonEmpty g) 432 | allProd f (x NE.:%| xs) a = 433 | f x (runWitAll a NEHead) 434 | :&| allProd @[] @p f xs (WitAll (runWitAll a . NETail)) 435 | prodAll :: 436 | forall p g as. 437 | () => 438 | (forall a. g a -> p @@ a) -> 439 | Prod NonEmpty g as -> 440 | All NonEmpty p @@ as 441 | prodAll f (x :&| xs) = WitAll $ \case 442 | NEHead -> f x 443 | NETail i -> runWitAll (prodAll @[] @p f xs) i 444 | 445 | instance Universe ((,) j) where 446 | idecideAny f (STuple2 _ x) = case f ISnd x of 447 | Proved p -> Proved $ WitAny ISnd p 448 | Disproved v -> Disproved $ \case WitAny ISnd p -> v p 449 | idecideAll f (STuple2 _ x) = case f ISnd x of 450 | Proved p -> Proved $ WitAll $ \case ISnd -> p 451 | Disproved v -> Disproved $ \a -> v $ runWitAll a ISnd 452 | allProd f (STuple2 w x) a = PTup w $ f x (runWitAll a ISnd) 453 | prodAll f (PTup _ x) = WitAll $ \case ISnd -> f x 454 | 455 | -- | The single-pointed universe. 456 | instance Universe Identity where 457 | idecideAny f (SIdentity x) = 458 | mapDecision 459 | (WitAny IId) 460 | (\case WitAny IId p -> p) 461 | $ f IId x 462 | idecideAll f (SIdentity x) = 463 | mapDecision 464 | (\p -> WitAll $ \case IId -> p) 465 | (\y -> runWitAll y IId) 466 | $ f IId x 467 | allProd f (SIdentity x) a = PIdentity $ f x (runWitAll a IId) 468 | prodAll f (PIdentity x) = WitAll $ \case IId -> f x 469 | -------------------------------------------------------------------------------- /src/Data/Type/Universe/Subset.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | -- | 11 | -- Module : Data.Type.Universe.Subset 12 | -- Copyright : (c) Justin Le 2018 13 | -- License : BSD3 14 | -- 15 | -- Maintainer : justin@jle.im 16 | -- Stability : experimental 17 | -- Portability : non-portable 18 | -- 19 | -- Represent a decidable subset of a type-level collection. 20 | module Data.Type.Universe.Subset ( 21 | -- * Subset 22 | Subset, 23 | WitSubset (..), 24 | makeSubset, 25 | 26 | -- ** Subset manipulation 27 | intersection, 28 | union, 29 | symDiff, 30 | mergeSubset, 31 | imergeSubset, 32 | mapSubset, 33 | imapSubset, 34 | 35 | -- ** Subset extraction 36 | subsetToList, 37 | 38 | -- ** Subset tests 39 | subsetToAny, 40 | subsetToAll, 41 | subsetToNone, 42 | 43 | -- ** Subset construction 44 | emptySubset, 45 | fullSubset, 46 | ) where 47 | 48 | import Control.Applicative 49 | import Data.Kind 50 | import Data.Monoid (Alt (..)) 51 | import Data.Singletons 52 | import Data.Singletons.Decide 53 | import Data.Type.Functor.Product 54 | import Data.Type.Predicate 55 | import Data.Type.Predicate.Logic 56 | import Data.Type.Predicate.Quantification 57 | import Data.Type.Universe 58 | 59 | -- | A @'WitSubset' f p @@ as@ describes a /decidable/ subset of type-level 60 | -- collection @as@. 61 | newtype WitSubset f p (as :: f k) = WitSubset 62 | { runWitSubset :: forall a. Elem f as a -> Decision (p @@ a) 63 | } 64 | 65 | -- | A @'Subset' f p@ is a predicate that some decidable subset of an input 66 | -- @as@ is true. 67 | data Subset f :: (k ~> Type) -> (f k ~> Type) 68 | 69 | type instance Apply (Subset f p) as = WitSubset f p as 70 | 71 | instance (Universe f, Decidable p) => Decidable (Subset f p) 72 | instance (Universe f, Decidable p) => Provable (Subset f p) where 73 | prove = makeSubset @f @_ @p (\_ -> decide @p) 74 | 75 | -- | Create a 'Subset' from a predicate. 76 | makeSubset :: 77 | forall f k p (as :: f k). 78 | Universe f => 79 | (forall a. Elem f as a -> Sing a -> Decision (p @@ a)) -> 80 | Sing as -> 81 | Subset f p @@ as 82 | makeSubset f xs = WitSubset $ \i -> f i (indexSing i xs) 83 | 84 | -- | Turn a 'Subset' into a list (or any 'Alternative') of satisfied 85 | -- predicates. 86 | -- 87 | -- List is meant to include no duplicates. 88 | subsetToList :: 89 | forall f p t. 90 | (Universe f, Alternative t) => 91 | (Subset f p --># Any f p) t 92 | subsetToList xs s = getAlt $ (`ifoldMapSing` xs) $ \i _ -> Alt $ case runWitSubset s i of 93 | Proved p -> pure $ WitAny i p 94 | Disproved _ -> empty 95 | 96 | -- | Restrict a 'Subset' to a single (arbitrary) member, or fail if none 97 | -- exists. 98 | subsetToAny :: 99 | forall f p. 100 | Universe f => 101 | Subset f p -?> Any f p 102 | subsetToAny xs s = idecideAny (\i _ -> runWitSubset s i) xs 103 | 104 | -- | Construct an empty subset. 105 | emptySubset :: forall f as. (Universe f, SingI as) => Subset f Impossible @@ as 106 | emptySubset = prove @(Subset f Impossible) sing 107 | 108 | -- | Construct a full subset 109 | fullSubset :: forall f as. (Universe f, SingI as) => Subset f Evident @@ as 110 | fullSubset = prove @(Subset f Evident) sing 111 | 112 | -- | Test if a subset is empty. 113 | subsetToNone :: forall f p. Universe f => Subset f p -?> None f p 114 | subsetToNone xs s = idecideNone (\i _ -> runWitSubset s i) xs 115 | 116 | -- | Combine two subsets based on a decision function 117 | imergeSubset :: 118 | forall f k p q r (as :: f k). 119 | () => 120 | (forall a. Elem f as a -> Decision (p @@ a) -> Decision (q @@ a) -> Decision (r @@ a)) -> 121 | Subset f p @@ as -> 122 | Subset f q @@ as -> 123 | Subset f r @@ as 124 | imergeSubset f ps qs = WitSubset $ \i -> 125 | f i (runWitSubset ps i) (runWitSubset qs i) 126 | 127 | -- | Combine two subsets based on a decision function 128 | mergeSubset :: 129 | forall f k p q r (as :: f k). 130 | () => 131 | (forall a. Decision (p @@ a) -> Decision (q @@ a) -> Decision (r @@ a)) -> 132 | Subset f p @@ as -> 133 | Subset f q @@ as -> 134 | Subset f r @@ as 135 | mergeSubset f = imergeSubset (\(_ :: Elem f as a) p -> f @a p) 136 | 137 | -- | Subset intersection 138 | intersection :: 139 | forall f p q. 140 | () => 141 | ((Subset f p &&& Subset f q) --> Subset f (p &&& q)) 142 | intersection _ = uncurry $ imergeSubset $ \(_ :: Elem f as a) -> decideAnd @p @q @a 143 | 144 | -- | Subset union (left-biased) 145 | union :: 146 | forall f p q. 147 | () => 148 | ((Subset f p &&& Subset f q) --> Subset f (p ||| q)) 149 | union _ = uncurry $ imergeSubset $ \(_ :: Elem f as a) -> decideOr @p @q @a 150 | 151 | -- | Symmetric subset difference 152 | symDiff :: 153 | forall f p q. 154 | () => 155 | ((Subset f p &&& Subset f q) --> Subset f (p ^^^ q)) 156 | symDiff _ = uncurry $ imergeSubset $ \(_ :: Elem f as a) -> decideXor @p @q @a 157 | 158 | -- | Test if a subset is equal to the entire original collection 159 | subsetToAll :: 160 | forall f p. 161 | Universe f => 162 | Subset f p -?> All f p 163 | subsetToAll xs s = idecideAll (\i _ -> runWitSubset s i) xs 164 | 165 | -- | 'mapSubset', but providing an 'Elem'. 166 | imapSubset :: 167 | (forall a. Elem f as a -> p @@ a -> q @@ a) -> 168 | (forall a. Elem f as a -> q @@ a -> p @@ a) -> 169 | Subset f p @@ as -> 170 | Subset f q @@ as 171 | imapSubset f g s = WitSubset $ \i -> 172 | mapDecision (f i) (g i) (runWitSubset s i) 173 | 174 | -- | Map a bidirectional implication over a subset described by that 175 | -- implication. 176 | -- 177 | -- Implication needs to be bidirectional, or otherwise we can't produce 178 | -- a /decidable/ subset as a result. 179 | mapSubset :: 180 | Universe f => 181 | (p --> q) -> 182 | (q --> p) -> 183 | (Subset f p --> Subset f q) 184 | mapSubset f g xs = 185 | withSingI xs $ 186 | imapSubset 187 | (\i -> f (indexSing i xs)) 188 | (\i -> g (indexSing i xs)) 189 | --------------------------------------------------------------------------------