├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── LICENSE.md ├── README.md ├── linear-logic.cabal ├── src └── Linear │ ├── Logic.hs │ └── Logic │ ├── Day.hs │ ├── Functor.hs │ ├── Internal.hs │ ├── Orphans.hs │ ├── Plugin.hs │ ├── Unsafe.hs │ ├── Y.hs │ └── Yoneda.hs └── wip └── affine.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.12.1 12 | # 13 | # REGENDATA ("0.12.1",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | irc: 21 | name: Haskell-CI (IRC notification) 22 | runs-on: ubuntu-18.04 23 | needs: 24 | - linux 25 | if: ${{ always() && (github.repository == 'ekmett/linear-logic') }} 26 | strategy: 27 | fail-fast: false 28 | steps: 29 | - name: IRC success notification (irc.freenode.org#haskell-lens) 30 | uses: Gottox/irc-message-action@v1.1 31 | if: needs.linux.result == 'success' 32 | with: 33 | channel: "#haskell-lens" 34 | message: "\x0313linear-logic\x03/\x0306${{ github.ref }}\x03 \x0314${{ github.sha }}\x03 https://github.com/${{ github.repository }}/actions/runs/${{ github.run_id }} The build succeeded." 35 | nickname: github-actions 36 | server: irc.freenode.org 37 | - name: IRC failure notification (irc.freenode.org#haskell-lens) 38 | uses: Gottox/irc-message-action@v1.1 39 | if: needs.linux.result != 'success' 40 | with: 41 | channel: "#haskell-lens" 42 | message: "\x0313linear-logic\x03/\x0306${{ github.ref }}\x03 \x0314${{ github.sha }}\x03 https://github.com/${{ github.repository }}/actions/runs/${{ github.run_id }} The build failed." 43 | nickname: github-actions 44 | server: irc.freenode.org 45 | linux: 46 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 47 | runs-on: ubuntu-18.04 48 | container: 49 | image: buildpack-deps:bionic 50 | continue-on-error: ${{ matrix.allow-failure }} 51 | strategy: 52 | matrix: 53 | include: 54 | - compiler: ghc-9.0.1 55 | allow-failure: false 56 | fail-fast: false 57 | steps: 58 | - name: apt 59 | run: | 60 | apt-get update 61 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common 62 | apt-add-repository -y 'ppa:hvr/ghc' 63 | apt-get update 64 | apt-get install -y $CC cabal-install-3.4 65 | env: 66 | CC: ${{ matrix.compiler }} 67 | - name: Set PATH and environment variables 68 | run: | 69 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 70 | echo "LANG=C.UTF-8" >> $GITHUB_ENV 71 | echo "CABAL_DIR=$HOME/.cabal" >> $GITHUB_ENV 72 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> $GITHUB_ENV 73 | HCDIR=$(echo "/opt/$CC" | sed 's/-/\//') 74 | HCNAME=ghc 75 | HC=$HCDIR/bin/$HCNAME 76 | echo "HC=$HC" >> $GITHUB_ENV 77 | echo "HCPKG=$HCDIR/bin/$HCNAME-pkg" >> $GITHUB_ENV 78 | echo "HADDOCK=$HCDIR/bin/haddock" >> $GITHUB_ENV 79 | echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> $GITHUB_ENV 80 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 81 | echo "HCNUMVER=$HCNUMVER" >> $GITHUB_ENV 82 | echo "ARG_TESTS=--enable-tests" >> $GITHUB_ENV 83 | echo "ARG_BENCH=--enable-benchmarks" >> $GITHUB_ENV 84 | echo "HEADHACKAGE=false" >> $GITHUB_ENV 85 | echo "ARG_COMPILER=--$HCNAME --with-compiler=$HC" >> $GITHUB_ENV 86 | echo "GHCJSARITH=0" >> $GITHUB_ENV 87 | env: 88 | CC: ${{ matrix.compiler }} 89 | - name: env 90 | run: | 91 | env 92 | - name: write cabal config 93 | run: | 94 | mkdir -p $CABAL_DIR 95 | cat >> $CABAL_CONFIG < cabal-plan.xz 124 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 125 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 126 | rm -f cabal-plan.xz 127 | chmod a+x $HOME/.cabal/bin/cabal-plan 128 | cabal-plan --version 129 | - name: checkout 130 | uses: actions/checkout@v2 131 | with: 132 | path: source 133 | - name: initial cabal.project for sdist 134 | run: | 135 | touch cabal.project 136 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 137 | cat cabal.project 138 | - name: sdist 139 | run: | 140 | mkdir -p sdist 141 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 142 | - name: unpack 143 | run: | 144 | mkdir -p unpacked 145 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 146 | - name: generate cabal.project 147 | run: | 148 | PKGDIR_linear_logic="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/linear-logic-[0-9.]*')" 149 | echo "PKGDIR_linear_logic=${PKGDIR_linear_logic}" >> $GITHUB_ENV 150 | touch cabal.project 151 | touch cabal.project.local 152 | echo "packages: ${PKGDIR_linear_logic}" >> cabal.project 153 | echo "package linear-logic" >> cabal.project 154 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 155 | cat >> cabal.project <> cabal.project.local 158 | cat cabal.project 159 | cat cabal.project.local 160 | - name: dump install plan 161 | run: | 162 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 163 | cabal-plan 164 | - name: cache 165 | uses: actions/cache@v2 166 | with: 167 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 168 | path: ~/.cabal/store 169 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 170 | - name: install dependencies 171 | run: | 172 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 173 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 174 | - name: build 175 | run: | 176 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 177 | - name: cabal check 178 | run: | 179 | cd ${PKGDIR_linear_logic} || false 180 | ${CABAL} -vnormal check 181 | - name: haddock 182 | run: | 183 | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 184 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | old 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # License 2 | 3 | Licensed under either of 4 | * Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0) 5 | * BSD 2-Clause license (https://opensource.org/licenses/BSD-2-Clause) 6 | at your option. 7 | 8 | ## BSD 2-Clause License 9 | 10 | - Copyright 2021 Edward Kmett 11 | 12 | All rights reserved. 13 | 14 | Redistribution and use in source and binary forms, with or without 15 | modification, are permitted provided that the following conditions 16 | are met: 17 | 18 | 1. Redistributions of source code must retain the above copyright 19 | notice, this list of conditions and the following disclaimer. 20 | 21 | 2. Redistributions in binary form must reproduce the above copyright 22 | notice, this list of conditions and the following disclaimer in the 23 | documentation and/or other materials provided with the distribution. 24 | 25 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 26 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 27 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 28 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 29 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 30 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 31 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 32 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 33 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 34 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35 | POSSIBILITY OF SUCH DAMAGE. 36 | 37 | ## Apache License 38 | 39 | _Version 2.0, January 2004_ 40 | _<>_ 41 | 42 | ### Terms and Conditions for use, reproduction, and distribution 43 | 44 | #### 1. Definitions 45 | 46 | “License” shall mean the terms and conditions for use, reproduction, and 47 | distribution as defined by Sections 1 through 9 of this document. 48 | 49 | “Licensor” shall mean the copyright owner or entity authorized by the copyright 50 | owner that is granting the License. 51 | 52 | “Legal Entity” shall mean the union of the acting entity and all other entities 53 | that control, are controlled by, or are under common control with that entity. 54 | For the purposes of this definition, “control” means **(i)** the power, direct or 55 | indirect, to cause the direction or management of such entity, whether by 56 | contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the 57 | outstanding shares, or **(iii)** beneficial ownership of such entity. 58 | 59 | “You” (or “Your”) shall mean an individual or Legal Entity exercising 60 | permissions granted by this License. 61 | 62 | “Source” form shall mean the preferred form for making modifications, including 63 | but not limited to software source code, documentation source, and configuration 64 | files. 65 | 66 | “Object” form shall mean any form resulting from mechanical transformation or 67 | translation of a Source form, including but not limited to compiled object code, 68 | generated documentation, and conversions to other media types. 69 | 70 | “Work” shall mean the work of authorship, whether in Source or Object form, made 71 | available under the License, as indicated by a copyright notice that is included 72 | in or attached to the work (an example is provided in the Appendix below). 73 | 74 | “Derivative Works” shall mean any work, whether in Source or Object form, that 75 | is based on (or derived from) the Work and for which the editorial revisions, 76 | annotations, elaborations, or other modifications represent, as a whole, an 77 | original work of authorship. For the purposes of this License, Derivative Works 78 | shall not include works that remain separable from, or merely link (or bind by 79 | name) to the interfaces of, the Work and Derivative Works thereof. 80 | 81 | “Contribution” shall mean any work of authorship, including the original version 82 | of the Work and any modifications or additions to that Work or Derivative Works 83 | thereof, that is intentionally submitted to Licensor for inclusion in the Work 84 | by the copyright owner or by an individual or Legal Entity authorized to submit 85 | on behalf of the copyright owner. For the purposes of this definition, 86 | “submitted” means any form of electronic, verbal, or written communication sent 87 | to the Licensor or its representatives, including but not limited to 88 | communication on electronic mailing lists, source code control systems, and 89 | issue tracking systems that are managed by, or on behalf of, the Licensor for 90 | the purpose of discussing and improving the Work, but excluding communication 91 | that is conspicuously marked or otherwise designated in writing by the copyright 92 | owner as “Not a Contribution.” 93 | 94 | “Contributor” shall mean Licensor and any individual or Legal Entity on behalf 95 | of whom a Contribution has been received by Licensor and subsequently 96 | incorporated within the Work. 97 | 98 | #### 2. Grant of Copyright License 99 | 100 | Subject to the terms and conditions of this License, each Contributor hereby 101 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 102 | irrevocable copyright license to reproduce, prepare Derivative Works of, 103 | publicly display, publicly perform, sublicense, and distribute the Work and such 104 | Derivative Works in Source or Object form. 105 | 106 | #### 3. Grant of Patent License 107 | 108 | Subject to the terms and conditions of this License, each Contributor hereby 109 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, 110 | irrevocable (except as stated in this section) patent license to make, have 111 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where 112 | such license applies only to those patent claims licensable by such Contributor 113 | that are necessarily infringed by their Contribution(s) alone or by combination 114 | of their Contribution(s) with the Work to which such Contribution(s) was 115 | submitted. If You institute patent litigation against any entity (including a 116 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a 117 | Contribution incorporated within the Work constitutes direct or contributory 118 | patent infringement, then any patent licenses granted to You under this License 119 | for that Work shall terminate as of the date such litigation is filed. 120 | 121 | #### 4. Redistribution 122 | 123 | You may reproduce and distribute copies of the Work or Derivative Works thereof 124 | in any medium, with or without modifications, and in Source or Object form, 125 | provided that You meet the following conditions: 126 | 127 | * **(a)** You must give any other recipients of the Work or Derivative Works a copy of 128 | this License; and 129 | * **(b)** You must cause any modified files to carry prominent notices stating that You 130 | changed the files; and 131 | * **(c)** You must retain, in the Source form of any Derivative Works that You distribute, 132 | all copyright, patent, trademark, and attribution notices from the Source form 133 | of the Work, excluding those notices that do not pertain to any part of the 134 | Derivative Works; and 135 | * **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any 136 | Derivative Works that You distribute must include a readable copy of the 137 | attribution notices contained within such NOTICE file, excluding those notices 138 | that do not pertain to any part of the Derivative Works, in at least one of the 139 | following places: within a NOTICE text file distributed as part of the 140 | Derivative Works; within the Source form or documentation, if provided along 141 | with the Derivative Works; or, within a display generated by the Derivative 142 | Works, if and wherever such third-party notices normally appear. The contents of 143 | the NOTICE file are for informational purposes only and do not modify the 144 | License. You may add Your own attribution notices within Derivative Works that 145 | You distribute, alongside or as an addendum to the NOTICE text from the Work, 146 | provided that such additional attribution notices cannot be construed as 147 | modifying the License. 148 | 149 | You may add Your own copyright statement to Your modifications and may provide 150 | additional or different license terms and conditions for use, reproduction, or 151 | distribution of Your modifications, or for any such Derivative Works as a whole, 152 | provided Your use, reproduction, and distribution of the Work otherwise complies 153 | with the conditions stated in this License. 154 | 155 | #### 5. Submission of Contributions 156 | 157 | Unless You explicitly state otherwise, any Contribution intentionally submitted 158 | for inclusion in the Work by You to the Licensor shall be under the terms and 159 | conditions of this License, without any additional terms or conditions. 160 | Notwithstanding the above, nothing herein shall supersede or modify the terms of 161 | any separate license agreement you may have executed with Licensor regarding 162 | such Contributions. 163 | 164 | #### 6. Trademarks 165 | 166 | This License does not grant permission to use the trade names, trademarks, 167 | service marks, or product names of the Licensor, except as required for 168 | reasonable and customary use in describing the origin of the Work and 169 | reproducing the content of the NOTICE file. 170 | 171 | #### 7. Disclaimer of Warranty 172 | 173 | Unless required by applicable law or agreed to in writing, Licensor provides the 174 | Work (and each Contributor provides its Contributions) on an “AS IS” BASIS, 175 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, 176 | including, without limitation, any warranties or conditions of TITLE, 177 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are 178 | solely responsible for determining the appropriateness of using or 179 | redistributing the Work and assume any risks associated with Your exercise of 180 | permissions under this License. 181 | 182 | #### 8. Limitation of Liability 183 | 184 | In no event and under no legal theory, whether in tort (including negligence), 185 | contract, or otherwise, unless required by applicable law (such as deliberate 186 | and grossly negligent acts) or agreed to in writing, shall any Contributor be 187 | liable to You for damages, including any direct, indirect, special, incidental, 188 | or consequential damages of any character arising as a result of this License or 189 | out of the use or inability to use the Work (including but not limited to 190 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or 191 | any and all other commercial damages or losses), even if such Contributor has 192 | been advised of the possibility of such damages. 193 | 194 | #### 9. Accepting Warranty or Additional Liability 195 | 196 | While redistributing the Work or Derivative Works thereof, You may choose to 197 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or 198 | other liability obligations and/or rights consistent with this License. However, 199 | in accepting such obligations, You may act only on Your own behalf and on Your 200 | sole responsibility, not on behalf of any other Contributor, and only if You 201 | agree to indemnify, defend, and hold each Contributor harmless for any liability 202 | incurred by, or claims asserted against, such Contributor by reason of your 203 | accepting any such warranty or additional liability. 204 | 205 | _END OF TERMS AND CONDITIONS_ 206 | 207 | ### APPENDIX: How to apply the Apache License to your work 208 | 209 | To apply the Apache License to your work, attach the following boilerplate 210 | notice, with the fields enclosed by brackets `[]` replaced with your own 211 | identifying information. (Don't include the brackets!) The text should be 212 | enclosed in the appropriate comment syntax for the file format. We also 213 | recommend that a file or class name and description of purpose be included on 214 | the same “printed page” as the copyright notice for easier identification within 215 | third-party archives. 216 | 217 | Copyright [yyyy] [name of copyright owner] 218 | 219 | Licensed under the Apache License, Version 2.0 (the "License"); 220 | you may not use this file except in compliance with the License. 221 | You may obtain a copy of the License at 222 | 223 | http://www.apache.org/licenses/LICENSE-2.0 224 | 225 | Unless required by applicable law or agreed to in writing, software 226 | distributed under the License is distributed on an "AS IS" BASIS, 227 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 228 | See the License for the specific language governing permissions and 229 | limitations under the License. 230 | 231 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | linear-logic 2 | ============ 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/linear-logic.svg)](https://hackage.haskell.org/package/linear-logic) [![Build Status](https://github.com/ekmett/linear-logic/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/linear-logic/actions?query=workflow%3AHaskell-CI) 5 | 6 | This package encodes a version of intuitionistic linear logic on top of linear Haskell, using a variation of the 7 | technique described by Michael Shulman in [Linear Logic for Constructive Mathematics](https://arxiv.org/abs/1805.07518). Embedding a larger linear logic into the simple linear logic available to us in Linear Haskell means we are able to 8 | recover the full suite of linear unitors, not just two of them, meaning we model linear logic, rather than affine logic. 9 | 10 | The central idea is to track for each type not just its type of proofs, but also its type of refutations. 11 | 12 | Contact Information 13 | ------------------- 14 | 15 | Contributions and bug reports are welcome! 16 | 17 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 18 | 19 | -Edward Kmett 20 | -------------------------------------------------------------------------------- /linear-logic.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: linear-logic 3 | category: Logic 4 | license: BSD-2-Clause OR Apache-2.0 5 | license-file: LICENSE.md 6 | author: Edward A. Kmett 7 | maintainer: Edward A. Kmett 8 | stability: experimental 9 | homepage: https://github.com/ekmett/linear-logic/ 10 | bug-reports: https://github.com/ekmett/linear-logic/issues 11 | copyright: Copyright 2021 Edward A. Kmett 12 | version: 0 13 | build-type: Simple 14 | synopsis: linear logic 15 | description: 16 | This package provides a library for reasoning 17 | with linear logic on top of linear haskell. 18 | . 19 | 20 | by Michael Shulman provides a principled take on this topic. There he constructs 21 | an embedding of an affine logic into an intuitionistic logic via a Chu construction. 22 | . 23 | However, that version of things was only able to express an 'affine logic' where 24 | the pairs \(\top\) and @()@, \(\bot\) and @Void@ are made to coincide. 25 | . 26 | Reconstructing this technique on top of 27 | allows us to construct a full intuitionistic linear logic, while retaining Shulman's 28 | style of refutation. 29 | . 30 | +------------------------+--------------------------+-----------------------+ 31 | | | Additive | Multiplicative | 32 | +========================+==========================+=======================+ 33 | | Conjunction | @('&')@ w/ unit 'Top' | @(,)@ w/ unit @()@ | 34 | +------------------------+--------------------------+-----------------------+ 35 | | Disjunction | 'Either' w/ unit 'Void' | @('⅋')@ w/ unit 'Bot' | 36 | +------------------------+--------------------------+-----------------------+ 37 | . 38 | 'Either' (or @('+')@) takes the place of the traditional \(\oplus\) 39 | . 40 | '(,)' (or @('*')@) takes the place of the traditional \(\otimes\) 41 | . 42 | To use the alias for @('*')@, make sure to enable @{-# LANGUAGE NoStarIsType #-}@ 43 | . 44 | Negative polarity connectives are 'GHC.Types.RuntimeRep' polymorphic, 45 | but only currently have 'Prop' instances defined for ''LiftedRep' 46 | tested-with: ghc == 9.0.1 47 | 48 | extra-source-files: 49 | CHANGELOG.md 50 | README.md 51 | 52 | source-repository head 53 | type: git 54 | location: https://github.com/ekmett/linear-logic.git 55 | 56 | library 57 | hs-source-dirs: src 58 | default-language: Haskell2010 59 | build-depends: 60 | base, 61 | contravariant, 62 | dependent-sum, 63 | ghc, 64 | ghc-tcplugins-extra, 65 | some, 66 | ghc-prim, 67 | linear-base 68 | ghc-options: 69 | -Wall -fexpose-all-unfoldings -fspecialize-aggressively 70 | -fno-show-valid-hole-fits 71 | -Winferred-safe-imports -Wmissing-safe-haskell-mode 72 | 73 | exposed-modules: 74 | Linear.Logic 75 | Linear.Logic.Day 76 | Linear.Logic.Functor 77 | Linear.Logic.Unsafe 78 | Linear.Logic.Yoneda 79 | Linear.Logic.Internal 80 | Linear.Logic.Orphans 81 | Linear.Logic.Plugin 82 | Linear.Logic.Y 83 | -------------------------------------------------------------------------------- /src/Linear/Logic.hs: -------------------------------------------------------------------------------- 1 | {-# language ExplicitNamespaces #-} 2 | {-# language NoStarIsType #-} 3 | {-# language Trustworthy #-} 4 | 5 | -- | 6 | -- 7 | -- by Michael Shulman provides a principled take on this topic. There he constructs 8 | -- an embedding of an affine logic into an intuitionistic logic via a Chu construction. 9 | -- 10 | -- However, that version of things was only able to express an 'affine logic' where 11 | -- the pairs \(\top\) and @()@, \(\bot\) and @Void@ are made to coincide. 12 | -- 13 | -- Reconstructing this technique on top of 14 | -- allows us to construct a full intuitionistic linear logic, while retaining Shulman's 15 | -- style of refutation. 16 | -- 17 | -- +------------------------+--------------------------+-----------------------+ 18 | -- | | Additive | Multiplicative | 19 | -- +========================+==========================+=======================+ 20 | -- | Conjunction | @('&')@ w/ unit 'Top' | @(,)@ w/ unit @()@ | 21 | -- +------------------------+--------------------------+-----------------------+ 22 | -- | Disjunction | 'Either' w/ unit 'Void' | @('⅋')@ w/ unit 'Bot' | 23 | -- +------------------------+--------------------------+-----------------------+ 24 | -- 25 | -- 'Either' (or @('+')@) takes the place of the traditional \(\oplus\) 26 | -- 27 | -- '(,)' (or @('*')@) takes the place of the traditional \(\otimes\) 28 | -- 29 | -- To use the alias for @('*')@, make sure to enable @{-# LANGUAGE NoStarIsType #-}@ 30 | 31 | module Linear.Logic 32 | ( Prep, Prop'(Not,(!=)), Prop 33 | -- additive conjunction, with 34 | , type (&)(..), Top(..), type With, with, withL', withR', withL, withR 35 | -- additive disjunction, oplus 36 | , type (+), Void, Either(..), left, right 37 | -- multiplicative conjunction, (,) 38 | , type (*) -- () 39 | -- multiplciative disjunction, par 40 | , type (⅋)(..), Bot(..), type Par, par, parL', parR', parL, parR 41 | -- refutable "lollipop" implication 42 | , type (⊸)(..) 43 | , Lol(..), runLol, fun', fun, lolPar, contra, contra', contra'' 44 | , type (%->) 45 | , type (<#-)(..) 46 | -- equality and apartness 47 | , Iso(..), runIso, contraIso, contraIso', contraIso'' 48 | , type (⧟)(..) 49 | , type (#)(..) 50 | -- primitive implication 51 | , Nofun(..) 52 | -- ! modality 53 | , Ur(..) 54 | , extractUr 55 | , duplicateUr 56 | , dupUr 57 | , seely 58 | -- , contraseely 59 | , seelyTop 60 | , weakenUr, apUr 61 | , contractUr 62 | -- ? modality 63 | , WhyNot(..), because, whyNot 64 | , returnWhyNot, joinWhyNot 65 | , mem 66 | , Decidable 67 | -- Internals 68 | , Y(..) 69 | , linear 70 | -- consumable 71 | , tensorToWith 72 | , eitherToPar 73 | 74 | -- * infinite additives 75 | , DWith(..), runDWith, dwith 76 | , DSum(..) 77 | -- * indexed propositions 78 | , IProp'(..), IProp 79 | , type (:&:)(..) 80 | , type (:*:)(..) 81 | , type (:⅋:)(..) 82 | , type (:+:)(..) 83 | 84 | -- somewhat dubious 85 | , semiseely 86 | , semiseelyUnit 87 | ) where 88 | 89 | import Data.Dependent.Sum 90 | import GHC.Generics 91 | import Prelude.Linear hiding (Sum) 92 | import Linear.Logic.Internal 93 | import Linear.Logic.Functor 94 | import Linear.Logic.Y 95 | import Data.Void 96 | 97 | -------------------------------------------------------------------------------- /src/Linear/Logic/Day.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language LinearTypes #-} 3 | {-# language RankNTypes #-} 4 | {-# language LambdaCase #-} 5 | {-# language EmptyCase #-} 6 | {-# language ScopedTypeVariables #-} 7 | {-# language Trustworthy #-} 8 | {-# language BlockArguments #-} 9 | {-# language TypeOperators #-} 10 | {-# language ConstraintKinds #-} 11 | {-# language GADTs #-} 12 | {-# language NoImplicitPrelude #-} 13 | {-# language TypeFamilies #-} 14 | {-# language FlexibleContexts #-} 15 | {-# language TypeApplications #-} 16 | {-# options_ghc -Wno-unused-imports -fplugin Linear.Logic.Plugin #-} 17 | 18 | module Linear.Logic.Day where 19 | 20 | import Data.Kind 21 | import Data.Unrestricted.Linear (Ur(..)) 22 | import GHC.Types 23 | import Linear.Logic.Internal 24 | import Linear.Logic.Functor 25 | import Linear.Logic.Y 26 | import Prelude.Linear ((&)) 27 | 28 | -- | Day convolution of logical functors 29 | data Day f g a where 30 | Day :: (Prop' b, Prop' c) => ((b,c) ⊸ a) %1 -> f b %1 -> g c %1 -> Day f g a 31 | 32 | -- | refuted Day convolution of logical functors 33 | newtype Noday f g a = Noday 34 | ( forall b c. (Prop' b, Prop' c) => 35 | (a <#- (b,c)) ⅋ Not (f b) ⅋ Not (g c) 36 | ) 37 | 38 | instance (Functor f, Functor g, Prop' a) => Prop' (Day f g a) where 39 | type Not (Day f g a) = Noday f g a 40 | Day bca (fb :: f b) gc != Noday no = (bca,(fb,gc)) != no 41 | 42 | instance (Functor f, Functor g, Prop' a) => Prop' (Noday f g a) where 43 | type Not (Noday f g a) = Day f g a 44 | Noday no != Day bca (fb :: f b) gc = (bca,(fb,gc)) != no 45 | -------------------------------------------------------------------------------- /src/Linear/Logic/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language BlockArguments #-} 3 | {-# language DefaultSignatures #-} 4 | {-# language DerivingStrategies #-} 5 | {-# language EmptyCase #-} 6 | {-# language ExplicitNamespaces #-} 7 | {-# language ImportQualifiedPost #-} 8 | {-# language FlexibleContexts #-} 9 | {-# language FlexibleInstances #-} 10 | {-# language FunctionalDependencies #-} 11 | {-# language GADTs #-} 12 | {-# language LambdaCase #-} 13 | {-# language LinearTypes #-} 14 | {-# language NoImplicitPrelude #-} 15 | {-# language NoStarIsType #-} 16 | {-# language PolyKinds #-} 17 | {-# language QuantifiedConstraints #-} 18 | {-# language RankNTypes #-} 19 | {-# language RoleAnnotations #-} 20 | {-# language ScopedTypeVariables #-} 21 | {-# language StandaloneDeriving #-} 22 | {-# language StandaloneKindSignatures #-} 23 | {-# language StrictData #-} 24 | {-# language TupleSections #-} 25 | {-# language TypeApplications #-} 26 | {-# language TypeFamilies #-} 27 | {-# language TypeFamilyDependencies #-} 28 | {-# language TypeOperators #-} 29 | {-# language UndecidableInstances #-} 30 | {-# language UndecidableSuperClasses #-} 31 | {-# language ImportQualifiedPost #-} 32 | {-# language Trustworthy #-} 33 | -- {-# options_ghc -fplugin Linear.Logic.Plugin #-} -- TODO use this to kill Prep constraints 34 | 35 | -- {-# options_ghc -Wno-unused-imports #-} 36 | 37 | module Linear.Logic.Functor where 38 | 39 | import Data.Type.Equality 40 | import Data.Void (Void) 41 | import Data.Kind 42 | import GHC.Types 43 | import Linear.Logic.Internal 44 | import Linear.Logic.Y 45 | import Prelude.Linear hiding (id,(.),flip,Semigroup(..), Monoid(..)) 46 | 47 | type family NotApart (p :: Type -> Type -> Type) :: Type -> Type -> Type 48 | 49 | class 50 | ( forall a b. (Prop' a, Prop' b) => Prop' (p a b) 51 | , NotApart (NotIso p) ~ p 52 | ) => Iso p where 53 | type NotIso p = (q :: Type -> Type -> Type) | q -> p 54 | iso :: (forall c. Y (b ⊸ a) (a ⊸ b) c -> c) %1 -> p a b 55 | apart :: Not (p a b) %1 -> b # a 56 | notIso :: NotIso p b a :~: Not (p a b) 57 | notApart :: NotApart (NotIso p) a b :~: p a b 58 | 59 | class (Iso p, Profunctor p) => Lol (p :: Type -> Type -> Type) where 60 | lol :: (forall c. Y (Not b %1 -> Not a) (a %1 -> b) c -> c) %1 -> p a b 61 | apartR :: Not (p a b) %1 -> b <#- a 62 | 63 | type instance NotApart (#) = (⧟) 64 | instance Iso (⧟) where 65 | type NotIso (⧟) = (#) 66 | iso = Iso 67 | apart = \x -> x 68 | notIso = Refl 69 | notApart = Refl 70 | 71 | type instance NotApart (<#-) = (⊸) 72 | instance Iso (⊸) where 73 | type NotIso (⊸) = (<#-) 74 | iso f = f R 75 | apart (a :-#> nb) = ApartR a nb 76 | notIso = Refl 77 | notApart = Refl 78 | 79 | type instance NotApart Noimp = (⊃) 80 | instance Iso (⊃) where 81 | type NotIso (⊃) = Noimp 82 | iso f = Imp \case 83 | R -> fun (f R) 84 | L -> \nb -> whyNot \a -> a != runLol (f R) L nb 85 | apart (Noimp a nb) = ApartR a nb 86 | notIso = Refl 87 | notApart = Refl 88 | 89 | instance Lol (⊸) where 90 | lol = Lol 91 | apartR x = x 92 | 93 | type instance NotApart (Nofun m) = FUN m 94 | 95 | instance Iso (FUN m) where 96 | type NotIso (FUN m) = Nofun m 97 | iso f = \x -> fun' (f R) x 98 | apart (Nofun a nb) = ApartR a nb 99 | notIso = Refl 100 | notApart = Refl 101 | 102 | 103 | instance Lol (FUN m) where 104 | lol f = \x -> linear (f R) x 105 | apartR (Nofun a nb) = a :-#> nb 106 | 107 | instance Lol (⊃) where 108 | lol f = Imp \case 109 | R -> \x -> linear (f R) x 110 | L -> \nb -> whyNot \a -> a != f L nb 111 | apartR (Noimp a nb) = a :-#> nb 112 | 113 | -- | Derive a linear function from a linear logic impliciation. 114 | -- 115 | -- @ 116 | -- 'fun' :: forall a b. 'Prop' a => (a '⊸' b) %1 -> a %1 -> b 117 | -- @ 118 | -- 119 | fun' :: (a ⊸ b) %1 -> (a %1 -> b) 120 | fun' (Lol f) = lol f 121 | {-# inline fun' #-} 122 | 123 | fun :: (Lol l, Lol l') => l (a ⊸ b) (l' a b) 124 | fun = lol \case 125 | L -> apartR 126 | R -> \(Lol f) -> lol f 127 | {-# inline fun #-} 128 | 129 | funIso :: (Lol l, Iso i) => l (a ⧟ b) (i a b) 130 | funIso = lol \case 131 | L -> apart 132 | R -> \(Iso f) -> iso f 133 | 134 | class Category p where 135 | id :: Prop' a => p a a 136 | (.) :: (Prop' a, Prop' b, Prop' c) => p b c %1 -> p a b %1 -> p a c 137 | 138 | instance Category (FUN 'One) where 139 | id x = x 140 | f . g = \x -> f (g x) 141 | 142 | -- | Here we have the ability to provide more refutations, because we can walk 143 | -- all the way back to my arrows. This is internal to my logic. 144 | class (forall a b. (Prop' a, Prop' b) => Prop' (p a b)) => NiceCategory p where 145 | -- o :: p b c ⊸ p a b ⊸ p a c 146 | o :: (Lol l, Lol l', Prop a, Prop b, Prop c) => l (p b c) (l' (p a b) (p a c)) 147 | 148 | 149 | instance Category (⊸) where 150 | id = Lol \case L -> \x -> x; R -> \x -> x 151 | f . g = Lol \case 152 | L -> \c -> runLol g L (runLol f L c) 153 | R -> \a -> runLol f R (runLol g R a) 154 | 155 | instance NiceCategory (⊸) where 156 | o = lol \case 157 | L -> \nf -> apartR nf & \(a2b :-#> a :-#> nc) -> fun a2b a :-#> nc 158 | R -> \bc -> lol \case 159 | L -> \(a :-#> nc) -> a :-#> runLol bc L nc 160 | R -> (bc .) 161 | 162 | instance Category (⧟) where 163 | id = Iso \case L -> id; R -> id 164 | f . g = Iso \case 165 | L -> runIso g L . runIso f L 166 | R -> runIso f R . runIso g R 167 | 168 | instance NiceCategory (⧟) where 169 | o = lol \case 170 | L -> \nf -> apartR nf & \case 171 | iab :-#> ApartL na c -> ApartL (runLol (runIso iab L) L na) c 172 | iab :-#> ApartR a nc -> ApartR (runLol (runIso iab R) R a) nc 173 | R -> \bc -> lol \case 174 | L -> \case 175 | ApartL na c -> ApartL na (runLol (runIso bc L) R c) 176 | ApartR a nc -> ApartR a (runLol (runIso bc R) L nc) 177 | R -> (bc .) 178 | 179 | liftUr :: forall a b l l'. (Prep a, Prop' b, Lol l, Lol l') => l (Ur (a ⊸ b)) (l' (Ur a) b) 180 | -- liftUr :: (Prep a, Prop' b, Lol l, Lol l') => l (Ur (a ⊸ b)) (l' (Ur a) b) 181 | liftUr = lol \case 182 | R -> \(Ur a2b) -> lol \case 183 | R -> \(Ur a) -> fun' a2b a 184 | L -> \nb -> whyNot \a -> fun' a2b a != nb 185 | L -> \nf -> apartR nf & \(Ur a :-#> nb) -> whyNot \a2b -> fun' a2b a != nb 186 | 187 | class 188 | ( forall a. Prop' a => Prop' (f a) 189 | ) => Functor f where 190 | fmap' :: (Prop' a, Prop' b, Lol l, Lol l') => l (Ur (a ⊸ b)) (l' (f a) (f b)) 191 | 192 | fmap :: forall f a b l. (Functor f, Prop' a, Prop' b, Lol l) => (a ⊸ b) -> l (f a) (f b) 193 | fmap f = fmap' (Ur f) 194 | 195 | fmapIso' :: (Functor f, Prop' a, Prop' b, Lol l, Iso i) => l (Ur (a ⧟ b)) (i (f a) (f b)) 196 | fmapIso' = lol \case 197 | L -> \ni -> apart ni & \case 198 | ApartL nfa fb -> whyNot \a2b -> fmap (inv' a2b) fb != nfa 199 | ApartR fa nfb -> whyNot \a2b -> fmap (funIso a2b) fa != nfb 200 | R -> \(Ur a2b) -> iso \case 201 | L -> fmap (inv' a2b) 202 | R -> fmap (funIso a2b) 203 | 204 | fmapIso :: (Functor f, Prop' a, Prop' b, Iso i) => (a ⧟ b) -> i (f a) (f b) 205 | fmapIso f = fmapIso' (Ur f) 206 | 207 | instance Functor (FUN m a) where 208 | fmap' = lol \case 209 | L -> \nf -> apartR nf & \(a2b :-#> Nofun a nc) -> WhyNot \c2b -> a2b a != runLol c2b L nc 210 | R -> \(Ur xb) -> lol \case 211 | L -> linear \(Nofun a nb) -> Nofun a (runLol xb L nb) 212 | R -> \a2x a -> fun' xb (a2x a) 213 | 214 | instance Prop x => Functor ((⊃) x) where 215 | fmap' = lol \case 216 | L -> \nf -> apartR nf & \(xia :-#> Noimp x nb) -> 217 | WhyNot \a2b -> fun' a2b (runImp xia R x) != nb 218 | R -> \(Ur a2b) -> lol \case 219 | L -> linear \(Noimp x nb) -> Noimp x (contra' a2b nb) 220 | R -> \xia -> imp \case 221 | L -> linear \nb -> WhyNot \x -> runLol a2b R (impR' xia x) != nb 222 | R -> \x -> fun' a2b (impR' xia x) 223 | 224 | instance Prop x => Functor ((,) x) where 225 | fmap' = lol \case 226 | L -> \nf -> apartR nf & \((x,a) :-#> nxpnb) -> 227 | WhyNot \a2b -> x != parL' nxpnb (fun' a2b a) 228 | R -> \(Ur f) -> lol \case 229 | L -> \nxpnb -> par \case 230 | L -> \a -> parL' nxpnb (fun' f a) 231 | R -> \x -> contra' f (parR' nxpnb x) 232 | R -> \(x, a) -> (x, fun' f a) 233 | 234 | instance Prop x => Functor ((⊸) x) where 235 | -- fmap' = fun (dimap lolPar (inv' lolPar) . fmap') 236 | fmap' = lol \case 237 | L -> \nf -> apartR nf & \(x2a :-#> x :-#> nb) -> 238 | WhyNot \a2b -> fun' a2b (fun' x2a x) != nb 239 | R -> \(Ur f) -> lol \case 240 | L -> \x -> x & \(a :-#> nb) -> a :-#> contra' f nb 241 | R -> linear \g -> lol \case 242 | L -> linear \nb -> contra' g (contra' f nb) 243 | R -> \a -> fun' f (fun' g a) 244 | 245 | class Functor f => MFunctor f where 246 | mfmap :: (Prop a, Prop b, Lol l, Lol l') => l (a ⊸ b) (l' (f a) (f b)) 247 | 248 | mfmapTensor' :: (Prop x, Prop a, Prop b, Lol l) => (a ⊸ b) %1 -> l (x, a) (x, b) 249 | mfmapTensor' = \a2b -> lol \case 250 | L -> \nxpnb -> par \case 251 | L -> \a -> parL' nxpnb (fun' a2b a) 252 | R -> \x -> contra' a2b (parR' nxpnb x) 253 | R -> \(x,a) -> (x, fun' a2b a) 254 | 255 | mfmapIso :: (MFunctor f, Prop a, Prop b, Lol l, Iso i) => l (a ⧟ b) (i (f a) (f b)) 256 | mfmapIso = lol \case 257 | L -> \ni -> apart ni & \case 258 | ApartR fa nfb -> apart (contra' mfmap (fa :-#> nfb)) 259 | ApartL nfa fb -> swap $ apart (contra' mfmap (fb :-#> nfa)) 260 | R -> \a2b -> iso \case 261 | L -> mfmap (runIso a2b L) 262 | R -> mfmap (runIso a2b R) 263 | 264 | instance Prop x => MFunctor ((,) x) where 265 | mfmap = lol \case 266 | L -> \nf -> apartR nf & \((x,a) :-#> nxpnb) -> 267 | a :-#> (parR' nxpnb x) 268 | R -> mfmapTensor' 269 | 270 | instance Prop x => MFunctor ((⅋) x) where 271 | mfmap = lol \case 272 | L -> \nf -> apartR nf & \(xpa :-#> (nx, nb)) -> 273 | parR xpa nx :-#> nb 274 | R -> \x -> contra' (mfmapTensor' (contra' x)) 275 | 276 | -- lolPar :: (Iso iso, Prep a) => (a ⊸ b) `iso` (Not a ⅋ b) 277 | 278 | instance Prop x => MFunctor ((⊸) x) where 279 | mfmap = lol \case 280 | L -> \nf -> apartR nf & \(x2a :-#> x :-#> nb) -> fun' x2a x :-#> nb 281 | R -> \a2b -> lol \case 282 | L -> \(x :-#> nb) -> x :-#> contra' a2b nb 283 | R -> (a2b .) 284 | 285 | instance Prop x => MFunctor (FUN m x) where 286 | mfmap = lol \case 287 | L -> \nf -> apartR nf & linear \(x2a :-#> Nofun x nb) -> linear (:-#>) (x2a x) nb 288 | R -> \(a2b :: a ⊸ b) -> lol \case 289 | L -> linear \(Nofun x nb :: Nofun m b x) -> Nofun x (runLol a2b L nb) :: Nofun m a x 290 | R -> \x2a x -> fun' a2b (x2a x) 291 | 292 | instance Functor Ur where 293 | fmap' = lol \case 294 | L -> \nf -> apartR nf & \(Ur a :-#> f) -> 295 | WhyNot \p -> because f (fun' p a) 296 | R -> \(Ur f) -> lol \case 297 | L -> \(WhyNot cb) -> WhyNot \a -> cb (fun f a) 298 | R -> \(Ur a) -> Ur (fun f a) 299 | 300 | instance Functor WhyNot where 301 | fmap' = lol \case 302 | L -> \nf -> apartR nf & \case 303 | wna :-#> Ur nb -> 304 | whyNot \a2b -> because wna (contra' a2b nb) 305 | R -> \(Ur f) -> lol \case 306 | L -> \(Ur nb) -> Ur (contra' f nb) 307 | R -> \na2v -> whyNot \nb -> because na2v (contra' f nb) 308 | 309 | instance Prop a => Functor (Either a) where 310 | fmap' = lol \case 311 | L -> \nf -> apartR nf & \case 312 | Left a :-#> g -> whyNot \_ -> a != withL g 313 | Right b :-#> g -> whyNot \p -> fun' p b != withR g 314 | R -> \(Ur f) -> lol \case 315 | L -> \nawnb -> with \case 316 | L -> withL nawnb 317 | R -> contra' f (withR nawnb) 318 | R -> \case 319 | Left a -> Left a 320 | Right x -> Right (fun f x) 321 | 322 | instance Prop p => Functor ((&) p) where 323 | fmap' = lol \case 324 | L -> \nf -> apartR nf & \case 325 | pwa :-#> Left np -> whyNot \_ -> withL' pwa != np 326 | pwa :-#> Right nb -> whyNot \a2b -> fun' a2b (withR' pwa) != nb 327 | R -> \(Ur f) -> lol \case 328 | L -> \case 329 | Left np -> Left np 330 | Right nb -> Right (contra' f nb) 331 | R -> \pwa -> with \case 332 | L -> withL' pwa 333 | R -> fun' f (withR' pwa) 334 | 335 | instance Prop a => Functor ((⅋) a) where 336 | fmap' = lol \case 337 | L -> \nf -> apartR nf & \case 338 | apc :-#> (na,nb) -> 339 | WhyNot \c2b -> parR' apc na != contra' c2b nb 340 | R -> \(Ur f) -> lol \case 341 | L -> \(na,nb) -> (na, contra' f nb) 342 | R -> \apa1 -> par \case 343 | L -> \nb -> parL' apa1 (contra' f nb) 344 | R -> \na -> fun' f (parR' apa1 na) 345 | 346 | class (Functor f, Functor g) => Adjunction f g | f -> g, g -> f where 347 | adj :: (Iso iso, Prop a, Prop b) => iso (f a ⊸ b) (a ⊸ g b) 348 | 349 | instance Prop e => Adjunction ((,) e) ((⊸) e) where 350 | adj = iso \case 351 | L -> uncurryTensor' . flip 352 | R -> flip . curryTensor' 353 | 354 | -- | The directed apartness as the left adjoint of (⅋) e. Found in 355 | -- . 356 | instance Prop e => Adjunction ((<#-) e) ((⅋) e) where 357 | adj = iso \case 358 | L -> lol \case 359 | L -> \case 360 | (a :-#> ne) :-#> nb -> a :-#> (ne, nb) 361 | R -> \a2epb -> lol \case 362 | L -> \nb -> lol \case 363 | L -> \ne -> contra' a2epb (ne, nb) 364 | R -> \a -> parL' (fun' a2epb a) nb 365 | R -> \(a :-#> ne) -> parR' (fun' a2epb a) ne 366 | R -> lol \case 367 | L -> \(a :-#> (ne, nb)) -> (a :-#> ne) :-#> nb 368 | R -> \k -> lol \case 369 | L -> \(ne, nb) -> contra' (contra' k nb) ne 370 | R -> \a -> par \case 371 | L -> linear \nb -> fun' (contra' k nb) a 372 | R -> \ne -> fun' k (a :-#> ne) 373 | 374 | instance Prop b => Functor ((<#-) b) where 375 | fmap' = lol \case 376 | L -> \nk -> apartR nk & \case 377 | (a :-#> nb) :-#> c2b -> 378 | WhyNot \a2c -> fun' c2b (fun' a2c a) != nb 379 | R -> \(Ur a2c) -> lol \case 380 | L -> \c2b -> c2b . a2c 381 | R -> linear \(a :-#> nb) -> fun' a2c a :-#> nb 382 | 383 | class 384 | ( forall a. Prop' a => Prop' (f a) 385 | ) => Contravariant f where 386 | contramap' :: (Prop a, Prop b, Lol l, Lol l') => l (Ur (a ⊸ b)) (l' (f b) (f a)) 387 | 388 | 389 | contramap :: (Contravariant f, Prop a, Prop b, Lol l) => (a ⊸ b) -> l (f b) (f a) 390 | contramap f = contramap' (Ur f) 391 | 392 | class 393 | ( forall a. Prop a => Functor (t a) 394 | ) => Profunctor t where 395 | dimap' 396 | :: (Prop a, Prop b, Prop c, Prop d, Lol l, Lol l', Lol l'') 397 | => l (Ur (a ⊸ b)) (l' (Ur (c ⊸ d)) (l'' (t b c) (t a d))) 398 | 399 | dimap 400 | :: (Profunctor t, Prop a, Prop b, Prop c, Prop d, Lol l) 401 | => (a ⊸ b) -> (c ⊸ d) -> l (t b c) (t a d) 402 | dimap f g = dimap' (Ur f) (Ur g) 403 | 404 | dimapIso' 405 | :: (Profunctor t, Prop a, Prop b, Prop c, Prop d, Lol l, Lol l', Iso i) 406 | => l (Ur (a ⧟ b)) (l' (Ur (c ⧟ d)) (i (t b c) (t a d))) 407 | dimapIso' = lol \case 408 | L -> \ni -> apartR ni & \(Ur cd :-#> tbc2tad) -> apart tbc2tad & \case 409 | ApartL ntbc tad -> whyNot \ab -> dimap (runIso ab L) (runIso cd L) tad != ntbc 410 | ApartR tbc ntad -> whyNot \ab -> dimap (runIso ab R) (runIso cd R) tbc != ntad 411 | R -> \(Ur ab) -> lol \case 412 | L -> \nj -> apart nj & \case 413 | ApartL ntbc tad -> whyNot \cd -> dimap (runIso ab L) (runIso cd L) tad != ntbc 414 | ApartR tbc ntad -> whyNot \cd -> dimap (runIso ab R) (runIso cd R) tbc != ntad 415 | R -> \(Ur cd) -> iso \case 416 | -- improve the type of Y used by iso so we can refine this to a single def? 417 | L -> dimap (runIso ab L) (runIso cd L) 418 | R -> dimap (runIso ab R) (runIso cd R) 419 | 420 | dimapIso 421 | :: (Profunctor t, Prop a, Prop b, Prop c, Prop d, Iso i) 422 | => (a ⧟ b) -> (c ⧟ d) -> i (t b c) (t a d) 423 | dimapIso f g = dimapIso' (Ur f) (Ur g) 424 | 425 | instance Profunctor (⊸) where 426 | dimap' = lol \case 427 | L -> \nf -> apartR nf & \case 428 | Ur c2d :-#> nh -> apartR nh & \(b2c :-#> a :-#> nd) -> 429 | WhyNot \a2b -> fun' c2d (fun' b2c (fun' a2b a)) != nd 430 | R -> \(Ur f) -> lol \case 431 | L -> \ng -> apartR ng & \(b2c :-#> a :-#> nd) -> 432 | WhyNot \c2d -> fun' c2d (fun' b2c (fun' f a)) != nd 433 | R -> \(Ur g) -> lol \case 434 | L -> linear \(a :-#> nd) -> fun' f a :-#> contra' g nd 435 | R -> linear \h -> g . h . f 436 | 437 | instance Profunctor (<#-) where 438 | dimap' = lol \case 439 | L -> \ni -> apartR ni & \((Ur c2d) :-#> nj) -> 440 | apartR nj & \((c :-#> nb) :-#> d2a) -> 441 | WhyNot \a2b -> fun' a2b (fun' d2a (fun' c2d c)) != nb 442 | R -> \(Ur a2b) -> lol \case 443 | L -> \ni -> apartR ni & \((c :-#> nb) :-#> d2a) -> 444 | WhyNot \c2d -> fun' a2b (fun' d2a (fun' c2d c)) != nb 445 | R -> \(Ur c2d) -> lol \case 446 | L -> \d2a -> lol \case 447 | L -> linear \nb -> contra' c2d (contra' d2a (contra' a2b nb)) 448 | R -> \c -> fun' a2b (fun' d2a (fun' c2d c)) 449 | R -> linear \(c :-#> nb) -> fun' c2d c :-#> contra' a2b nb 450 | 451 | instance Prop y => Functor (Noimp y) where 452 | fmap' = lol \case 453 | L -> \ni -> apartR ni & \case 454 | Noimp a ny :-#> b2y -> 455 | WhyNot \a2b -> impR' b2y (fun' a2b a) != ny 456 | R -> \(Ur a2b) -> lol \case 457 | L -> \biy -> imp \case 458 | L -> \ny -> contra' (fmap a2b) (impL' biy ny) 459 | R -> \a -> impR' biy (fun' a2b a) 460 | R -> \(Noimp a ny) -> Noimp (fun' a2b a) ny 461 | 462 | instance Prop y => Functor (Nofun m y) where 463 | fmap' = lol \case 464 | L -> \ni -> apartR ni & \case 465 | Nofun a ny :-#> b2y -> WhyNot \a2b -> b2y (fun' a2b a) != ny 466 | R -> \(Ur (a2b :: a ⊸ b)) -> lol \case 467 | L -> \(b2y :: b %m -> y) a -> b2y (fun' a2b a) 468 | R -> linear \(Nofun a ny :: Nofun m y a) -> Nofun (fun' a2b a) ny 469 | 470 | instance Profunctor Noimp where 471 | dimap' = lol \case 472 | L -> \ni -> apartR ni & \case 473 | Ur c2d :-#> nj -> apartR nj & \case 474 | Noimp c nb :-#> d2a -> WhyNot \a2b -> fun' a2b (impR' d2a (fun' c2d c)) != nb 475 | R -> \(Ur a2b) -> lol \case 476 | L -> \nj -> apartR nj & \case 477 | Noimp c nb :-#> d2a -> WhyNot \c2d -> fun' a2b (impR' d2a (fun' c2d c)) != nb 478 | R -> \(Ur c2d) -> lol \case 479 | L -> linear \dia -> imp \case 480 | L -> \nb -> WhyNot \c -> dia != Noimp (fun' c2d c) (contra' a2b nb) 481 | R -> \c -> fun' a2b (impR' dia (fun' c2d c)) 482 | R -> linear \(Noimp c nb) -> Noimp (fun' c2d c) (contra' a2b nb) 483 | 484 | instance Profunctor (Nofun m) where 485 | dimap' = lol \case 486 | L -> \ni -> apartR ni & \case 487 | Ur c2d :-#> nj -> apartR nj & \case 488 | Nofun c nb :-#> d2a -> WhyNot \a2b -> fun' a2b (d2a (fun' c2d c)) != nb 489 | R -> \(Ur (a2b :: a ⊸ b)) -> lol \case 490 | L -> \ni -> apartR ni & \case 491 | Nofun c nb :-#> d2a -> WhyNot \c2d -> fun' a2b (d2a (fun' c2d c)) != nb 492 | R -> \(Ur (c2d :: c ⊸ d)) -> lol \case 493 | L -> \d2a -> (\c -> fun' a2b (d2a (fun' c2d c))) :: c %m -> b 494 | R -> linear \case 495 | (Nofun c nb :: Nofun m b c) -> 496 | Nofun (fun' c2d c) (contra' a2b nb) :: Nofun m a d 497 | 498 | instance Profunctor (FUN m) where 499 | dimap' = lol \case 500 | L -> \nf -> apartR nf & \case 501 | Ur c2d :-#> nh -> apartR nh & \case 502 | b2c :-#> Nofun a nd -> contra' c2d nd & \nc -> 503 | WhyNot \a2b -> b2c (fun' a2b a) != nc 504 | R -> \(Ur (a2b :: a ⊸ b)) -> lol \case 505 | L -> \ng -> apartR ng & linear \(b2c :-#> Nofun a nd) -> 506 | WhyNot \(c2d :: c ⊸ d) -> 507 | b2c != (Nofun (fun' a2b a) (contra' c2d nd) :: Nofun m c b) 508 | R -> \(Ur (c2d :: c ⊸ d)) -> lol \case 509 | R -> go where 510 | go :: (b %m -> c) %1 -> a %m -> d 511 | go b2c a = fun' c2d (b2c (fun' a2b a)) 512 | L -> go where 513 | go :: Nofun m d a %1 -> Nofun m c b 514 | go (Nofun a nd) = Nofun (fun' a2b a) (contra' c2d nd) 515 | 516 | instance Profunctor (⊃) where 517 | dimap' = lol \case 518 | L -> \ni -> apartR ni & \((Ur c2d) :-#> nj) -> 519 | apartR nj & \(bic :-#> Noimp a nd) -> 520 | WhyNot \a2b -> bic != Noimp (fun' a2b a) (contra' c2d nd) 521 | R -> \(Ur (a2b :: a ⊸ b)) -> lol \case 522 | L -> \ng -> apartR ng & \(bic :-#> Noimp a nd) -> 523 | WhyNot \c2d -> bic != Noimp (fun' a2b a) (contra' c2d nd) 524 | R -> \(Ur (c2d :: c ⊸ d)) -> lol \case 525 | L -> linear \(Noimp a nd) -> Noimp (fun' a2b a) (contra' c2d nd) 526 | R -> \bic -> imp \case 527 | L -> linear \nd -> WhyNot \a -> bic != Noimp (fun' a2b a) (contra' c2d nd) 528 | R -> \a -> fun' c2d (impR' bic (fun' a2b a)) 529 | 530 | class Profunctor t => MProfunctor t where 531 | mdimap 532 | :: (Prop a, Prop b, Prop c, Prop d, Lol l, Lol l', Lol l'') 533 | => l (a ⊸ b) (l' (c ⊸ d) (l'' (t b c) (t a d))) 534 | 535 | instance MProfunctor (⊸) where 536 | mdimap = lol \case 537 | L -> \ni -> apartR ni & \(c2d :-#> nj) -> 538 | apartR nj & \(b2c :-#> a :-#> nd) -> 539 | a :-#> contra' b2c (contra' c2d nd) 540 | R -> \a2b -> lol \case 541 | L -> \nk -> apartR nk & \(b2c :-#> a :-#> nd) -> fun' b2c (fun' a2b a) :-#> nd 542 | R -> \c2d -> lol \case 543 | L -> \(a :-#> nd) -> fun' a2b a :-#> contra' c2d nd 544 | R -> \b2c -> lol \case 545 | L -> \nd -> contra' a2b (contra' b2c (contra' c2d nd)) 546 | R -> \a -> fun' c2d (fun' b2c (fun' a2b a)) 547 | 548 | class 549 | ( forall a. Prop a => Functor (t a) 550 | ) => Bifunctor t where 551 | bimap' 552 | :: (Prop a, Prop b, Prop c, Prop d, Lol l, Lol l', Lol l'') 553 | => l (Ur (a ⊸ b)) (l' (Ur (c ⊸ d)) (l'' (t a c) (t b d))) 554 | 555 | bimap 556 | :: (Bifunctor t, Prop a, Prop b, Prop c, Prop d, Lol l) 557 | => (a ⊸ b) -> (c ⊸ d) -> l (t a c) (t b d) 558 | bimap f g = bimap' (Ur f) (Ur g) 559 | 560 | bimapIso' 561 | :: (Bifunctor t, Prop a, Prop b, Prop c, Prop d, Lol l, Lol l', Iso i) 562 | => l (Ur (a ⧟ b)) (l' (Ur (c ⧟ d)) (i (t a c) (t b d))) 563 | bimapIso' = lol \case 564 | L -> \ni -> apartR ni & \(Ur cd :-#> tbc2tad) -> apart tbc2tad & \case 565 | ApartL ntbc tad -> whyNot \ab -> bimap (runIso ab L) (runIso cd L) tad != ntbc 566 | ApartR tbc ntad -> whyNot \ab -> bimap (runIso ab R) (runIso cd R) tbc != ntad 567 | R -> \(Ur ab) -> lol \case 568 | L -> \nj -> apart nj & \case 569 | ApartL ntbc tad -> whyNot \cd -> bimap (runIso ab L) (runIso cd L) tad != ntbc 570 | ApartR tbc ntad -> whyNot \cd -> bimap (runIso ab R) (runIso cd R) tbc != ntad 571 | R -> \(Ur cd) -> iso \case 572 | -- improve the type of Y used by iso so we can refine this to a single def? 573 | L -> bimap (runIso ab L) (runIso cd L) 574 | R -> bimap (runIso ab R) (runIso cd R) 575 | 576 | bimapIso 577 | :: (Bifunctor t, Prop a, Prop b, Prop c, Prop d, Iso i) 578 | => (a ⧟ b) -> (c ⧟ d) -> i (t a c) (t b d) 579 | bimapIso f g = bimapIso' (Ur f) (Ur g) 580 | 581 | instance Bifunctor Either where 582 | bimap' = lol \case 583 | L -> \nf -> apartR nf & \(Ur c2d :-#> nk) -> 584 | apartR nk & \case 585 | Left a :-#> nbwnd -> WhyNot \a2b -> fun' a2b a != withL' nbwnd 586 | Right c :-#> nbwnd -> fun' c2d c != withR' nbwnd 587 | R -> \(Ur f) -> lol \case 588 | L -> \ng -> apartR ng & \case 589 | Left a :-#> nbwnd -> fun' f a != withL' nbwnd 590 | Right c :-#> nbwnd -> WhyNot \c2d -> fun' c2d c != withR' nbwnd 591 | R -> \(Ur g) -> lol \case 592 | L -> \nbwnd -> with \case 593 | L -> contra' f (withL nbwnd) 594 | R -> contra' g (withR nbwnd) 595 | R -> \case 596 | Left a -> Left (fun f a) 597 | Right c -> Right (fun g c) 598 | 599 | instance Bifunctor (,) where 600 | bimap' = lol \case 601 | L -> \nf -> apartR nf & \(Ur c2d :-#> nk) -> 602 | apartR nk & \((a,c) :-#> nbpnd) -> WhyNot \a2b -> 603 | fun' c2d c != parR' nbpnd (fun' a2b a) 604 | R -> \(Ur f) -> lol \case 605 | L -> \ng -> apartR ng & \((a, c) :-#> nbpnd) -> 606 | WhyNot \c2d -> fun' f a != parL' nbpnd (fun c2d c) 607 | R -> \(Ur g) -> lol \case 608 | L -> \nbpnd -> par \case 609 | L -> linear \c -> contra' f (parL' nbpnd (fun g c)) 610 | R -> linear \a -> contra' g (parR' nbpnd (fun f a)) 611 | R -> \(a, c) -> (fun f a, fun g c) 612 | 613 | instance Bifunctor (&) where 614 | bimap' = lol \case 615 | L -> \nf -> apartR nf & \(Ur c2d :-#> nk) -> 616 | apartR nk & \case 617 | awc :-#> Left nb -> WhyNot \a2b -> fun' a2b (withL' awc) != nb 618 | awc :-#> Right nd -> withR' awc != contra' c2d nd 619 | R -> \(Ur f) -> lol \case 620 | L -> \ng -> apartR ng & \case 621 | awc :-#> Left nb -> withL awc != contra' f nb 622 | awc :-#> Right nd -> WhyNot \c2d -> fun' c2d (withR awc) != nd 623 | R -> \(Ur g) -> lol \case 624 | L -> \case 625 | Left nb -> Left (contra' f nb) 626 | Right nd -> Right (contra' g nd) 627 | R -> \awc -> with \case 628 | L -> fun f (withL' awc) 629 | R -> fun g (withR' awc) 630 | 631 | instance Bifunctor (⅋) where 632 | bimap' = lol \case 633 | L -> \nf -> apartR nf & \(Ur c2d :-#> nk) -> 634 | apartR nk & \(apc :-#> (nb, nd)) -> 635 | whyNot \a2b -> parR apc (contra' a2b nb) != contra' c2d nd 636 | R -> \(Ur f) -> lol \case 637 | L -> \ng -> apartR ng & \(apc :-#> (nb, nd)) -> whyNot \c2d -> parR apc (contra' f nb) != contra' c2d nd 638 | R -> \(Ur g) -> lol \case 639 | L -> \(nb,nd) -> (contra' f nb, contra' g nd) 640 | R -> \apc -> par \case 641 | L -> \nd -> fun' f (parL' apc (contra' g nd)) 642 | R -> \nb -> fun' g (parR' apc (contra' f nb)) 643 | 644 | -- TODO MBifunctor 645 | 646 | class Bifunctor t => Semimonoidal t where 647 | assoc :: (Prop a, Prop b, Prop c, Iso iso) => t (t a b) c `iso` t a (t b c) 648 | 649 | unassoc :: (Semimonoidal t, Iso iso, Prop a, Prop b, Prop c) => t a (t b c) `iso` t (t a b) c 650 | unassoc = inv' assoc 651 | 652 | class (Prop (I t), Semimonoidal t) => Monoidal t where 653 | type I t :: Type 654 | lambda :: (Prop a, Iso iso) => a `iso` t (I t) a 655 | rho :: (Prop a, Iso iso) => a `iso` t a (I t) 656 | 657 | unlambda :: (Monoidal t, Prop a, Iso iso) => t (I t) a `iso` a 658 | unlambda = inv' lambda 659 | 660 | unrho :: (Monoidal t, Prop a, Iso iso) => t a (I t) `iso` a 661 | unrho = inv' rho 662 | 663 | class Symmetric t where 664 | swap :: (Prop a, Prop b, Iso iso) => t a b `iso` t b a 665 | 666 | class (Symmetric t, Monoidal t) => SymmetricMonoidal t 667 | 668 | instance Semimonoidal Either where 669 | assoc = assocEither 670 | 671 | instance Monoidal Either where 672 | type I Either = Void 673 | lambda = lambdaEither 674 | rho = rhoEither 675 | 676 | instance Symmetric Either where 677 | swap = swapEither 678 | 679 | instance SymmetricMonoidal Either 680 | 681 | instance Semimonoidal (,) where 682 | assoc = assocTensor 683 | 684 | instance Monoidal (,) where 685 | type I (,) = () 686 | lambda = lambdaTensor 687 | rho = rhoTensor 688 | 689 | instance Symmetric (,) where 690 | swap = swapTensor 691 | 692 | instance SymmetricMonoidal (,) 693 | 694 | instance Semimonoidal (&) where 695 | assoc = assocWith 696 | 697 | instance Monoidal (&) where 698 | type I (&) = Top 699 | lambda = lambdaWith 700 | rho = rhoWith 701 | 702 | instance Symmetric (&) where 703 | swap = swapWith 704 | 705 | instance SymmetricMonoidal (&) 706 | 707 | instance Semimonoidal (⅋) where 708 | assoc = assocPar 709 | 710 | instance Monoidal (⅋) where 711 | type I (⅋) = Bot 712 | lambda = lambdaPar 713 | rho = rhoPar 714 | 715 | instance Symmetric (⅋) where 716 | swap = swapPar 717 | {-# inline swap #-} 718 | 719 | instance SymmetricMonoidal (⅋) 720 | 721 | instance Symmetric (#) where 722 | swap = swapApart 723 | 724 | instance Symmetric (⧟) where 725 | swap = inv 726 | 727 | class (Functor f, Bifunctor p) => WeakDist f p where 728 | weakDist :: (Lol l, Prop b, Prop c) => l (f (p b c)) (p (f b) (f c)) 729 | default weakDist :: (Lol l, Prop b, Prop c, Dist f p) => l (f (p b c)) (p (f b) (f c)) 730 | weakDist = weakDist 731 | 732 | class WeakDist f p => Dist f p where 733 | dist :: (Iso iso, Prop b, Prop c) => iso (f (p b c)) (p (f b) (f c)) 734 | 735 | instance Prop a => WeakDist ((,) a) (&) where 736 | weakDist = lol \case 737 | L -> \case 738 | Left x -> fmap left x 739 | Right x -> fmap right x 740 | R -> \case 741 | (a, bwc) -> with \case 742 | L -> (a, withL bwc) 743 | R -> (a, withR bwc) 744 | 745 | -- | Hyland and de Paiva section 3.2 as @w@ 746 | interchangeTensorPar :: (Lol l, Prop a, Prop b, Prop c) => l (a * (b ⅋ c)) ((a * b) ⅋ c) 747 | interchangeTensorPar = lol \case 748 | L -> \(napnb, nc) -> par \case 749 | L -> \bpc -> parL' napnb (parL bpc nc) 750 | R -> \a -> (parR' napnb a, nc) 751 | R -> \(a, bpc) -> par \case 752 | L -> \nc -> (a, parL' bpc nc) 753 | R -> \napnb -> parR' bpc (parR' napnb a) 754 | 755 | -- | Hyland and dePaiva's paper on FILL in section 4 describes this map as problematic 756 | unrestricted :: (Prop a, Prop b) => (a ⅋ b ⊸ a) ⅋ b 757 | unrestricted = par \case 758 | L -> \nb -> lol \case 759 | L -> \na -> (na, nb) 760 | R -> \apb -> parL' apb nb 761 | R -> \(apb :-#> na) -> parR' apb na 762 | 763 | instance Prop a => WeakDist ((,) a) Either 764 | instance Prop a => Dist ((,) a) Either where 765 | dist = iso \case 766 | L -> lol \case 767 | L -> \f -> with \case 768 | L -> par \case 769 | L -> \b -> parL' f (Left b) 770 | R -> \a -> withL' (parR' f a) 771 | R -> par \case 772 | L -> \c -> parL' f (Right c) 773 | R -> \a -> withR' (parR' f a) 774 | R -> \case 775 | Left (a, b) -> (a, Left b) 776 | Right (a, c) -> (a, Right c) 777 | R -> lol \case 778 | L -> \q -> par \case 779 | L -> \case 780 | Left b -> parL' (withL' q) b 781 | Right c -> parL' (withR' q) c 782 | R -> \a -> with \case 783 | L -> parR' (withL' q) a 784 | R -> parR' (withR' q) a 785 | R -> \case 786 | (a, Left b) -> Left (a, b) 787 | (a, Right c) -> Right (a, c) 788 | 789 | instance Prop a => WeakDist ((⅋) a) (&) 790 | instance Prop a => Dist ((⅋) a) (&) where 791 | dist = iso \case 792 | L -> lol \case 793 | L -> \case 794 | (na, Left nb) -> Left (na, nb) 795 | (na, Right nc) -> Right (na, nc) 796 | R -> \f -> par \case 797 | L -> \case 798 | Left nb -> parL' (withL' f) nb 799 | Right nc -> parL' (withR' f) nc 800 | R -> \na -> with \case 801 | L -> parR' (withL' f) na 802 | R -> parR' (withR' f) na 803 | R -> lol \case 804 | L -> \case 805 | Left (na, nb) -> (na, Left nb) 806 | Right (na, nc) -> (na, Right nc) 807 | R -> \f -> with \case 808 | L -> fmap withL f 809 | R -> fmap withR f 810 | 811 | 812 | -- utilities 813 | 814 | -------------------------------------------------------------------------------- 815 | -- swaps 816 | -------------------------------------------------------------------------------- 817 | 818 | -- swap primitives 819 | 820 | swapPar'' :: p ⅋ q %1 -> q ⅋ p 821 | swapPar'' = \apb -> par \case 822 | L -> \na -> parR' apb na 823 | R -> \nb -> parL' apb nb 824 | 825 | swapEither'' :: p + q %1 -> q + p 826 | swapEither'' = \case 827 | Left p -> Right p 828 | Right q -> Left q 829 | 830 | swapWith'' :: p & q %1 -> q & p 831 | swapWith'' w = with \case 832 | L -> withR' w 833 | R -> withL' w 834 | 835 | swapTensor'' :: (p, q) %1 -> (q, p) 836 | swapTensor'' = \(p,q) -> (q,p) 837 | 838 | -- swap lolis 839 | 840 | swapPar' :: Lol l => l (p ⅋ q) (q ⅋ p) 841 | swapPar' = lol \case 842 | L -> swapTensor'' 843 | R -> swapPar'' 844 | 845 | swapEither' :: Lol l => l (p + q) (q + p) 846 | swapEither' = lol \case 847 | L -> swapWith'' 848 | R -> swapEither'' 849 | 850 | swapWith' :: Lol l => l (p & q) (q & p) 851 | swapWith' = lol \case 852 | L -> swapEither'' 853 | R -> swapWith'' 854 | 855 | swapTensor' :: Lol l => l (p * q) (q * p) 856 | swapTensor' = lol \case 857 | L -> swapPar'' 858 | R -> swapTensor'' 859 | 860 | -- swap isos 861 | 862 | swapPar :: Iso l => l (p ⅋ q) (q ⅋ p) 863 | swapPar = iso \case L -> swapPar'; R -> swapPar' 864 | 865 | swapEither :: Iso l => l (p + q) (q + p) 866 | swapEither = iso \case L -> swapEither'; R -> swapEither' 867 | 868 | swapWith :: Iso l => l (p & q) (q & p) 869 | swapWith = iso \case L -> swapWith'; R -> swapWith' 870 | 871 | swapTensor :: Iso l => l (p * q) (q * p) 872 | swapTensor = iso \case L -> swapTensor'; R -> swapTensor' 873 | 874 | -------------------------------------------------------------------------------- 875 | -- associativity 876 | -------------------------------------------------------------------------------- 877 | 878 | -- associtivity primitives 879 | 880 | assocEither'' :: (a + b) + c %1 -> a + (b + c) 881 | assocEither'' = \case 882 | Left (Left a) -> Left a 883 | Left (Right b) -> Right (Left b) 884 | Right c -> Right (Right c) 885 | {-# inline assocEither'' #-} 886 | 887 | assocTensor'' :: ((a, b), c) %1 -> (a, (b, c)) 888 | assocTensor'' = \((a, b), c) -> (a, (b, c)) 889 | {-# inline assocTensor'' #-} 890 | 891 | assocWith'' :: (a & b) & c %1 -> a & (b & c) 892 | assocWith'' = \abc -> with \case 893 | L -> withL' (withL' abc) 894 | R -> with \case 895 | L -> withR' (withL' abc) 896 | R -> withR' abc 897 | {-# inline assocWith'' #-} 898 | 899 | assocPar'' :: (a ⅋ b) ⅋ c %1 -> a ⅋ (b ⅋ c) 900 | assocPar'' = \apb_c -> par \case 901 | L -> \(nb, nc) -> parL' (parL' apb_c nc) nb 902 | R -> \na -> par \case 903 | L -> \nc -> parR' (parL' apb_c nc) na 904 | R -> \nb -> parR' apb_c (na,nb) 905 | {-# inline assocPar'' #-} 906 | 907 | unassocWith'' :: a & (b & c) %1 -> (a & b) & c 908 | unassocWith'' = \abc -> with \case 909 | L -> with \case 910 | L -> withL' abc 911 | R -> withL' (withR' abc) 912 | R -> withR' (withR' abc) 913 | {-# inline unassocWith'' #-} 914 | 915 | unassocPar'' :: a ⅋ (b ⅋ c) %1 -> (a ⅋ b) ⅋ c 916 | unassocPar'' = \a_bpc -> par \case 917 | L -> \nc -> par \case 918 | L -> \nb -> parL' a_bpc (nb,nc) 919 | R -> \na -> parL' (parR' a_bpc na) nc 920 | R -> \(na,nb) -> parR' (parR' a_bpc na) nb 921 | {-# inline unassocPar'' #-} 922 | 923 | unassocEither'' :: a + (b + c) %1 -> (a + b) + c 924 | unassocEither'' = \case 925 | Left a -> Left (Left a) 926 | Right (Left b) -> Left (Right b) 927 | Right (Right c) -> Right c 928 | {-# inline unassocEither'' #-} 929 | 930 | unassocTensor'' :: (a, (b, c)) %1 -> ((a, b), c) 931 | unassocTensor'' = \(na,(nb,nc)) -> ((na,nb),nc) 932 | {-# inline unassocTensor'' #-} 933 | 934 | -- associativity lollipops 935 | 936 | assocWith' :: Lol l => l ((a & b) & c) (a & (b & c)) 937 | assocWith' = lol \case L -> unassocEither''; R -> assocWith'' 938 | 939 | assocEither' :: Lol l => l ((a + b) + c) (a + (b + c)) 940 | assocEither' = lol \case L -> unassocWith''; R -> assocEither'' 941 | 942 | unassocWith' :: Lol l => l (a & (b & c)) ((a & b) & c) 943 | unassocWith' = lol \case L -> assocEither''; R -> unassocWith'' 944 | 945 | unassocEither' :: Lol l => l (a + (b + c)) ((a + b) + c) 946 | unassocEither' = lol \case L -> assocWith''; R -> unassocEither'' 947 | 948 | assocPar' :: Lol l => l ((a ⅋ b) ⅋ c) (a ⅋ (b ⅋ c)) 949 | assocPar' = lol \case L -> unassocTensor''; R -> assocPar'' 950 | 951 | assocTensor' :: Lol l => l ((a * b) * c) (a * (b * c)) 952 | assocTensor' = lol \case L -> unassocPar''; R -> assocTensor'' 953 | 954 | unassocPar' :: Lol l => l (a ⅋ (b ⅋ c)) ((a ⅋ b) ⅋ c) 955 | unassocPar' = lol \case L -> assocTensor''; R -> unassocPar'' 956 | 957 | unassocTensor' :: Lol l => l (a * (b * c)) ((a * b) * c) 958 | unassocTensor' = lol \case L -> assocPar''; R -> unassocTensor'' 959 | 960 | -- associativity isos 961 | 962 | assocEither :: Iso i => i ((a + b) + c) (a + (b + c)) 963 | assocEither = iso \case L -> unassocEither'; R -> assocEither' 964 | 965 | unassocEither :: Iso i => i (a + (b + c)) ((a + b) + c) 966 | unassocEither = iso \case L -> assocEither'; R -> unassocEither' 967 | 968 | assocWith :: Iso i => i ((a & b) & c) (a & (b & c)) 969 | assocWith = iso \case L -> unassocWith'; R -> assocWith' 970 | 971 | unassocWith :: Iso i => i (a & (b & c)) ((a & b) & c) 972 | unassocWith = iso \case L -> assocWith'; R -> unassocWith' 973 | 974 | assocTensor :: Iso i => i ((a * b) * c) (a * (b * c)) 975 | assocTensor = iso \case L -> unassocTensor'; R -> assocTensor' 976 | 977 | unassocTensor :: Iso i => i (a * (b * c)) ((a * b) * c) 978 | unassocTensor = iso \case L -> assocTensor'; R -> unassocTensor' 979 | 980 | assocPar :: Iso i => i ((a ⅋ b) ⅋ c) (a ⅋ (b ⅋ c)) 981 | assocPar = iso \case L -> unassocPar'; R -> assocPar' 982 | 983 | unassocPar :: Iso i => i (a ⅋ (b ⅋ c)) ((a ⅋ b) ⅋ c) 984 | unassocPar = iso \case L -> assocPar'; R -> unassocPar' 985 | 986 | -------------------------------------------------------------------------------- 987 | -- * lambda & rho 988 | -------------------------------------------------------------------------------- 989 | 990 | lambdaWith'' :: a %1 -> Top & a 991 | lambdaWith'' = \a -> with \case 992 | L -> Top a 993 | R -> a 994 | 995 | rhoWith'' :: a %1 -> a & Top 996 | rhoWith'' = \b -> with \case 997 | L -> b 998 | R -> Top b 999 | 1000 | lambdaEither'' :: a %1 -> Void + a 1001 | lambdaEither'' = Right 1002 | 1003 | rhoEither'' :: a %1 -> a + Void 1004 | rhoEither'' = Left 1005 | 1006 | lambdaPar'' :: Prop a => a %1 -> Bot ⅋ a 1007 | lambdaPar'' = \a -> par \case 1008 | L -> \na -> a != na 1009 | R -> \() -> a 1010 | 1011 | rhoPar'' :: Prop a => a %1 -> a ⅋ Bot 1012 | rhoPar'' = \b -> par \case 1013 | L -> \() -> b 1014 | R -> \nb -> b != nb 1015 | 1016 | lambdaTensor'' :: a %1 -> () * a 1017 | lambdaTensor'' = ((),) 1018 | 1019 | rhoTensor'' :: a %1 -> a * () 1020 | rhoTensor'' = (,()) 1021 | 1022 | unlambdaPar'' :: Bot ⅋ a %1 -> a 1023 | unlambdaPar'' = \bpa -> parR' bpa () 1024 | 1025 | unrhoPar'' :: a ⅋ Bot %1 -> a 1026 | unrhoPar'' = \apb -> parL' apb () 1027 | 1028 | unlambdaTensor'' :: ((),a) %1 -> a 1029 | unlambdaTensor'' = \((),a) -> a 1030 | 1031 | unrhoTensor'' :: (a,()) %1 -> a 1032 | unrhoTensor'' = \(na,()) -> na 1033 | 1034 | unlambdaEither'' :: Either Void a %1 -> a 1035 | unlambdaEither'' = \case 1036 | Right na -> na 1037 | Left v -> \case{} v 1038 | 1039 | unrhoEither'' :: Either a Void %1 -> a 1040 | unrhoEither'' = \case 1041 | Left na -> na 1042 | Right v -> \case{} v 1043 | 1044 | unlambdaWith'' :: Top & a %1 -> a 1045 | unlambdaWith'' = withR' 1046 | 1047 | unrhoWith'' :: a & Top %1 -> a 1048 | unrhoWith'' = withL 1049 | 1050 | -- left unitor lolis 1051 | 1052 | unlambdaEither' :: Lol l => l (Void + a) a 1053 | unlambdaEither' = lol \case L -> lambdaWith''; R -> unlambdaEither'' 1054 | 1055 | lambdaEither' :: Lol l => l a (Void + a) 1056 | lambdaEither' = lol \case L -> unlambdaWith''; R -> lambdaEither'' 1057 | 1058 | unlambdaWith' :: Lol l => l (Top & a) a 1059 | unlambdaWith' = lol \case L -> lambdaEither''; R -> unlambdaWith'' 1060 | 1061 | lambdaWith' :: Lol l => l a (Top & a) 1062 | lambdaWith' = lol \case L -> unlambdaEither''; R -> lambdaWith'' 1063 | 1064 | unlambdaTensor' :: (Lol l, Prop a) => l (() * a) a 1065 | unlambdaTensor' = lol \case L -> lambdaPar''; R -> unlambdaTensor'' 1066 | 1067 | lambdaTensor' :: Lol l => l a (() * a) 1068 | lambdaTensor' = lol \case L -> unlambdaPar''; R -> lambdaTensor'' 1069 | 1070 | unlambdaPar' :: Lol l => l (Bot ⅋ a) a 1071 | unlambdaPar' = lol \case L -> lambdaTensor''; R -> unlambdaPar'' 1072 | 1073 | lambdaPar' :: (Lol l, Prop a) => l a (Bot ⅋ a) 1074 | lambdaPar' = lol \case L -> unlambdaTensor''; R -> lambdaPar'' 1075 | 1076 | -- left unitor isos 1077 | 1078 | lambdaPar :: (Iso i, Prop a) => i a (Bot ⅋ a) 1079 | lambdaPar = iso \case L -> unlambdaPar'; R -> lambdaPar' 1080 | 1081 | unlambdaPar :: (Iso i, Prop a) => i (Bot ⅋ a) a 1082 | unlambdaPar = iso \case L -> lambdaPar'; R -> unlambdaPar' 1083 | 1084 | lambdaWith :: Iso i => i a (Top & a) 1085 | lambdaWith = iso \case L -> unlambdaWith'; R -> lambdaWith' 1086 | 1087 | unlambdaWith :: Iso i => i (Top & a) a 1088 | unlambdaWith = iso \case L -> lambdaWith'; R -> unlambdaWith' 1089 | 1090 | lambdaEither :: Iso i => i a (Void + a) 1091 | lambdaEither = iso \case L -> unlambdaEither'; R -> lambdaEither' 1092 | 1093 | unlambdaEither :: Iso i => i (Void + a) a 1094 | unlambdaEither = iso \case L -> lambdaEither'; R -> unlambdaEither' 1095 | 1096 | lambdaTensor :: (Iso i, Prop a) => i a (() * a) 1097 | lambdaTensor = iso \case L -> unlambdaTensor'; R -> lambdaTensor' 1098 | 1099 | unlambdaTensor :: (Iso i, Prop a) => i (() * a) a 1100 | unlambdaTensor = iso \case L -> lambdaTensor'; R -> unlambdaTensor' 1101 | 1102 | -- rho 1103 | 1104 | unrhoEither' :: Lol l => l (a + Void) a 1105 | unrhoEither' = lol \case L -> rhoWith''; R -> unrhoEither'' 1106 | 1107 | rhoEither' :: Lol l => l a (a + Void) 1108 | rhoEither' = lol \case L -> unrhoWith''; R -> rhoEither'' 1109 | 1110 | unrhoWith' :: Lol l => l (a & Top) a 1111 | unrhoWith' = lol \case L -> rhoEither''; R -> unrhoWith'' 1112 | 1113 | rhoWith' :: Lol l => l a (a & Top) 1114 | rhoWith' = lol \case L -> unrhoEither''; R -> rhoWith'' 1115 | 1116 | unrhoTensor' :: (Lol l, Prop a) => l (a * ()) a 1117 | unrhoTensor' = lol \case L -> rhoPar''; R -> unrhoTensor'' 1118 | 1119 | rhoTensor' :: Lol l => l a (a * ()) 1120 | rhoTensor' = lol \case L -> unrhoPar''; R -> rhoTensor'' 1121 | 1122 | unrhoPar' :: Lol l => l (a ⅋ Bot) a 1123 | unrhoPar' = lol \case L -> rhoTensor''; R -> unrhoPar'' 1124 | 1125 | rhoPar' :: (Lol l, Prop a) => l a (a ⅋ Bot) 1126 | rhoPar' = lol \case L -> unrhoTensor''; R -> rhoPar'' 1127 | 1128 | -- left unitor isos 1129 | 1130 | rhoPar :: (Iso i, Prop a) => i a (a ⅋ Bot) 1131 | rhoPar = iso \case L -> unrhoPar'; R -> rhoPar' 1132 | 1133 | unrhoPar :: (Iso i, Prop a) => i (a ⅋ Bot) a 1134 | unrhoPar = iso \case L -> rhoPar'; R -> unrhoPar' 1135 | 1136 | rhoWith :: Iso i => i a (a & Top) 1137 | rhoWith = iso \case L -> unrhoWith'; R -> rhoWith' 1138 | 1139 | unrhoWith :: Iso i => i (a & Top) a 1140 | unrhoWith = iso \case L -> rhoWith'; R -> unrhoWith' 1141 | 1142 | rhoEither :: Iso i => i a (a + Void) 1143 | rhoEither = iso \case L -> unrhoEither'; R -> rhoEither' 1144 | 1145 | unrhoEither :: Iso i => i (a + Void) a 1146 | unrhoEither = iso \case L -> rhoEither'; R -> unrhoEither' 1147 | 1148 | rhoTensor :: (Iso i, Prop a) => i a (a * ()) 1149 | rhoTensor = iso \case L -> unrhoTensor'; R -> rhoTensor' 1150 | 1151 | unrhoTensor :: (Iso i, Prop a) => i (a * ()) a 1152 | unrhoTensor = iso \case L -> rhoTensor'; R -> unrhoTensor' 1153 | 1154 | -------------------------------------------------------------------------------- 1155 | -- isos and apartness 1156 | -------------------------------------------------------------------------------- 1157 | 1158 | inv'' :: Iso i => (a ⧟ b) %1 -> i b a 1159 | inv'' (Iso f) = iso \case L -> f R; R -> f L 1160 | 1161 | inv' :: (Lol l, Iso i) => l (a ⧟ b) (i b a) 1162 | inv' = lol \case 1163 | L -> \x -> swapApart' (apart x) 1164 | R -> inv'' 1165 | 1166 | inv :: (Iso i) => i (a ⧟ b) (b ⧟ a) 1167 | inv = iso \case L -> inv'; R -> inv' 1168 | 1169 | swapApart'' :: a # b %1 -> b # a 1170 | swapApart'' (ApartL na b) = ApartR b na 1171 | swapApart'' (ApartR a nb) = ApartL nb a 1172 | 1173 | swapApart' :: Lol l => l (a # b) (b # a) 1174 | swapApart' = lol \case L -> inv''; R -> swapApart'' 1175 | 1176 | swapApart :: Iso iso => iso (a # b) (b # a) 1177 | swapApart = iso \case L -> swapApart'; R -> swapApart' 1178 | 1179 | -------------------------------------------------------------------------------- 1180 | -- currying 1181 | -------------------------------------------------------------------------------- 1182 | 1183 | curryTensor' 1184 | :: (Lol l, Lol l', Lol l'', Prep a, Prep b, Prep c) 1185 | => l ((a * b) ⊸ c) (l' a (l'' b c)) 1186 | curryTensor' = lol \case 1187 | L -> \nf -> apartR nf & 1188 | \(a :-#> y) -> apartR y & 1189 | \(b :-#> nc) -> (a,b) :-#> nc 1190 | R -> \f -> lol \case 1191 | L -> \nbc -> apartR nbc & 1192 | \(b :-#> nc) -> parL (contra' f nc) b 1193 | R -> \a -> lol \case 1194 | L -> \nc -> parR (contra' f nc) a 1195 | R -> \b -> fun f (a, b) 1196 | 1197 | uncurryTensor' 1198 | :: (Lol l, Lol l', Prep a, Prep b, Prep c) 1199 | => l (a ⊸ b ⊸ c) (l' (a * b) c) 1200 | uncurryTensor' = lol \case 1201 | L -> \nf -> apartR nf & 1202 | \((a,b) :-#> nc) -> a :-#> b :-#> nc 1203 | R -> \f -> lol \case 1204 | L -> \nc -> par \case 1205 | L -> \b -> contra' f (b :-#> nc) 1206 | R -> \a -> contra' (fun f a) nc 1207 | R -> \(a,b) -> fun (fun f a) b 1208 | 1209 | curryTensor 1210 | :: (Iso i, Prep a, Prep b, Prep c) 1211 | => i ((a * b) ⊸ c) (a ⊸ b ⊸ c) 1212 | curryTensor = iso \case 1213 | L -> uncurryTensor' 1214 | R -> curryTensor' 1215 | 1216 | uncurryTensor 1217 | :: (Iso i, Prep a, Prep b, Prep c) 1218 | => i (a ⊸ (b ⊸ c)) ((a * b) ⊸ c) 1219 | uncurryTensor = iso \case 1220 | L -> curryTensor' 1221 | R -> uncurryTensor' 1222 | 1223 | flip'' :: (Prep a, Prep b, Prep c, Lol l, Lol l') => (a ⊸ b ⊸ c) %1 -> l b (l' a c) 1224 | flip'' f = lol \case 1225 | L -> \nac -> apartR nac & \(a :-#> nc) -> contra' (fun' f a) nc 1226 | R -> \b -> lol \case 1227 | L -> \nc -> contra' f (b :-#> nc) 1228 | R -> \a -> fun' (fun' f a) b 1229 | 1230 | flip' :: (Prep a, Prep b, Prep c, Lol l, Lol l', Lol l'') => l (a ⊸ b ⊸ c) (l' b (l'' a c)) 1231 | flip' = lol \case 1232 | L -> \nbac -> apartR nbac & \(b :-#> nac) -> 1233 | apartR nac & \(a :-#> nc) -> a :-#> b :-#> nc 1234 | R -> flip'' 1235 | 1236 | flip :: (Prep a, Prep b, Prep c, Iso iso) => iso (a ⊸ b ⊸ c) (b ⊸ a ⊸ c) 1237 | flip = iso \case 1238 | L -> flip' 1239 | R -> flip' 1240 | 1241 | -------------------------------------------------------------------------------- 1242 | -- Interplay between connectives that needs weakening 1243 | -------------------------------------------------------------------------------- 1244 | 1245 | tensorToWith 1246 | :: (Lol l, Prop p, Consumable p, Prop q, Consumable q) 1247 | => l (p * q) (p & q) 1248 | tensorToWith = lol \case 1249 | L -> \case 1250 | Left np -> par \case 1251 | L -> \q -> lseq q np 1252 | R -> \p -> p != np 1253 | Right nq -> par \case 1254 | L -> \q -> q != nq 1255 | R -> \p -> lseq p nq 1256 | R -> \(p, q) -> with \case 1257 | L -> lseq q p 1258 | R -> lseq p q 1259 | 1260 | eitherToPar 1261 | :: (Lol l, Consumable p, Consumable q, Prop p, Prop q) 1262 | => l (Not p + Not q) (Not p ⅋ Not q) 1263 | eitherToPar = contra' tensorToWith 1264 | 1265 | -------------------------------------------------------------------------------- 1266 | -- Excluded middle and decidability 1267 | -------------------------------------------------------------------------------- 1268 | 1269 | -- | multiplicative excluded-middle, equivalent to multiplicative law of non-contradiction 1270 | mem :: Prep p => p ⅋ Not p 1271 | mem = par \case L -> \x -> x; R -> \x -> x 1272 | 1273 | -- | additive excluded middle, or additive law of non-contradiction is a property of a proposition 1274 | -- not a law. 1275 | type Decidable p = p + Not p 1276 | 1277 | -------------------------------------------------------------------------------- 1278 | -- Ur is a Seely comonad 1279 | -------------------------------------------------------------------------------- 1280 | 1281 | seely'' :: Ur (p & q) %1 -> Ur p * Ur q 1282 | seely'' = \(Ur pwq) -> (Ur (withL pwq), Ur (withR pwq)) 1283 | 1284 | unseely'' :: (Ur p * Ur q) %1 -> Ur (p & q) 1285 | unseely'' = \(Ur p, Ur q) -> Ur (with \case L -> p; R -> q) 1286 | 1287 | contraseely'' :: WhyNot p ⅋ WhyNot q %1 -> WhyNot (p + q) 1288 | contraseely'' = \r -> WhyNot \pwq -> because (parL' r (Ur (withR pwq))) (withL pwq) 1289 | 1290 | contraunseely'' :: WhyNot (p + q) %1 -> WhyNot p ⅋ WhyNot q 1291 | contraunseely'' = \n -> par \case 1292 | L -> \(Ur q) -> WhyNot \p -> because n (with \case L -> p; R -> q) 1293 | R -> \(Ur p) -> WhyNot \q -> because n (with \case L -> p; R -> q) 1294 | 1295 | seely' :: Lol l => l (Ur (p & q)) (Ur p * Ur q) 1296 | seely' = lol \case L -> contraseely''; R -> seely'' 1297 | 1298 | unseely' :: Lol l => l (Ur p * Ur q) (Ur (p & q)) 1299 | unseely' = lol \case L -> contraunseely''; R -> unseely'' 1300 | 1301 | -- contraseely' :: Lol l => l (WhyNot p ⅋ WhyNot q) (WhyNot (p + q)) 1302 | -- contraseely' = lol \case L -> seely''; R -> contraseely'' 1303 | 1304 | -- contraunseely' :: Lol l => l (WhyNot (p + q)) (WhyNot p ⅋ WhyNot q) 1305 | -- contraunseely' = lol \case L -> unseely''; R -> contraunseely'' 1306 | 1307 | -- | \(!\) is a 1308 | -- 1309 | -- A seely comonad is a strong monoidal functor from cartesian monoidal structure to 1310 | -- symmetric monoidal structure. 1311 | seely :: Iso i => i (Ur (p & q)) (Ur p * Ur q) 1312 | seely = iso \case L -> unseely'; R -> seely' 1313 | 1314 | -- contraseely :: Iso i => i (WhyNot p ⅋ WhyNot q) (WhyNot (p + q)) 1315 | -- contraseely = iso \case L -> contraunseely'; R -> contraseely' 1316 | 1317 | seelyTop'' :: Ur Top %1 -> () 1318 | seelyTop'' = consume 1319 | 1320 | contraunseelyTop'' :: WhyNot Void %1 -> Bot 1321 | contraunseelyTop'' = \n -> because n (Top ()) 1322 | 1323 | contraseelyTop'' :: Bot %1 -> WhyNot Void 1324 | contraseelyTop'' = \(Bot f) -> WhyNot \t -> f t 1325 | 1326 | unseelyTop'' :: () %1 -> Ur Top 1327 | unseelyTop'' = \() -> Ur (Top ()) 1328 | 1329 | seelyTop :: Iso iso => iso (Ur Top) () 1330 | seelyTop = iso \case 1331 | L -> lol \case 1332 | L -> contraunseelyTop'' 1333 | R -> unseelyTop'' 1334 | R -> lol \case 1335 | L -> contraseelyTop'' 1336 | R -> seelyTop'' 1337 | 1338 | -- | valid in a semicartesian *-autonomous lattice 1339 | -- 1340 | -- This is generally not valid in linear logic, but holds 1341 | -- in affine logic, and seems to hold here. 1342 | semiseely :: (Iso i, Prep p) => i (Ur (p * q)) (Ur p * Ur q) 1343 | semiseely = iso \case 1344 | L -> lol \case 1345 | L -> \k -> par \case 1346 | L -> \(Ur q) -> WhyNot \p -> because k (p, q) 1347 | R -> \(Ur p) -> WhyNot \q -> because k (p, q) 1348 | R -> \(Ur p, Ur q) -> Ur (p, q) 1349 | R -> lol \case 1350 | L -> \x -> WhyNot \(p,q) -> because (parR' x (Ur p)) q 1351 | R -> \(Ur (p, q)) -> (Ur p, Ur q) 1352 | 1353 | semiseelyUnit :: Iso i => i (Ur ()) () 1354 | semiseelyUnit = iso \case 1355 | L -> lol \case 1356 | L -> \n -> because n () 1357 | R -> \() -> Ur () 1358 | R -> lol \case 1359 | L -> \b -> WhyNot \p -> b != p 1360 | R -> \(Ur ()) -> () 1361 | 1362 | -- | 1363 | -- @ 1364 | -- 'weakenUr' :: forall p q. 'Prop' p => p ⊸ 'Ur' q ⊸ p 1365 | -- @ 1366 | weakenUr :: (Prop p, Lol l, Lol l') => l p (l' (Ur q) p) 1367 | weakenUr = lol \case 1368 | L -> \x -> apartR x & \(Ur {} :-#> np) -> np 1369 | R -> \p -> lol \case 1370 | L -> \np -> p != np 1371 | R -> \Ur{} -> p 1372 | {-# inline weakenUr #-} 1373 | 1374 | apUr :: forall p q. (Prep p, Prep q) => Ur (p ⊸ q) ⊸ Ur p ⊸ Ur q 1375 | apUr = lol \case 1376 | L -> \(Ur p :-#> WhyNot nq) -> whyNot \nppq -> nq (fun nppq p) 1377 | R -> \(Ur nppq) -> lol \case 1378 | L -> \(WhyNot nq) -> whyNot \p -> nq (fun nppq p) 1379 | R -> \(Ur p) -> Ur (fun nppq p) 1380 | {-# inline apUr #-} 1381 | 1382 | extractUr :: (Lol l, Prop p) => l (Ur p) p 1383 | extractUr = lol \case 1384 | L -> \np -> whyNot \p -> p != np 1385 | R -> \(Ur p) -> p 1386 | {-# inline extractUr #-} 1387 | 1388 | duplicateUr :: Lol l => l (Ur p) (Ur (Ur p)) 1389 | duplicateUr = lol \case 1390 | L -> \(WhyNot f) -> WhyNot \p -> f (Ur p) 1391 | R -> \(Ur p) -> Ur (Ur p) 1392 | {-# inline duplicateUr #-} 1393 | 1394 | dupUr :: (Iso i, Prop a) => i (Ur a) (Ur a * Ur a) 1395 | dupUr = iso \case 1396 | L -> lol \case 1397 | L -> \n -> par \case 1398 | L -> (n !=) 1399 | R -> (n !=) 1400 | R -> \(Ur a, Ur{}) -> (Ur a) 1401 | R -> lol \case 1402 | L -> \p -> WhyNot \a -> because (parR' p (Ur a)) a 1403 | R -> \(Ur a) -> (Ur a, Ur a) 1404 | 1405 | contractUr :: (Prep p, Prop q) => (Ur p ⊸ Ur p ⊸ q) ⊸ Ur p ⊸ q 1406 | contractUr = lol \case 1407 | L -> \(Ur p :-#> nq) -> (Ur p :-#> (Ur p :-#> nq)) 1408 | R -> \x -> lol \case 1409 | L -> \nq -> whyNot \p -> contra' (fun x (Ur p)) nq != Ur p 1410 | R -> \(Ur p) -> fun (fun x (Ur p)) (Ur p) 1411 | {-# inline contractUr #-} 1412 | 1413 | returnWhyNot :: (Lol l, Prop p) => l p (WhyNot p) 1414 | returnWhyNot = contra' extractUr 1415 | {-# inline returnWhyNot #-} 1416 | 1417 | joinWhyNot :: (Lol l, Prep p) => l (WhyNot (WhyNot p)) (WhyNot p) 1418 | joinWhyNot = contra' duplicateUr 1419 | {-# inline joinWhyNot #-} 1420 | 1421 | withL :: Lol l => l (a & b) a 1422 | withL = lol \case 1423 | L -> Left 1424 | R -> withL' 1425 | 1426 | withR :: Lol l => l (a & b) b 1427 | withR = lol \case 1428 | L -> Right 1429 | R -> withR' 1430 | 1431 | left :: Lol l => l a (a + b) 1432 | left = lol \case 1433 | L -> withL' 1434 | R -> Left 1435 | 1436 | right :: Lol l => l b (a + b) 1437 | right = lol \case 1438 | L -> withR' 1439 | R -> Right 1440 | 1441 | parR :: (Lol l, Lol l', Prep a) => l (a ⅋ b) (l' (Not a) b) 1442 | parR = lol \case 1443 | L -> \g -> apartR g & \(x :-#> y) -> (x, y) 1444 | R -> \p -> lol \case 1445 | L -> parL' p 1446 | R -> parR' p 1447 | 1448 | parL :: (Lol l, Lol l', Prep b) => l (a ⅋ b) (l' (Not b) a) 1449 | parL = lol \case 1450 | L -> \g -> apartR g & \(x :-#> y) -> (y, x) 1451 | R -> \p -> lol \case 1452 | L -> parR' p 1453 | R -> parL' p 1454 | 1455 | contra'' :: forall l p q. (Lol l, Prep p, Prep q) => p ⊸ q %1 -> l (Not q) (Not p) 1456 | contra'' = \(Lol f) -> lol \case 1457 | L -> \na -> f R na 1458 | R -> \nb -> f L nb 1459 | 1460 | contra' :: forall l l' p q. (Lol l, Lol l', Prep p, Prep q) => l (p ⊸ q) (l' (Not q) (Not p)) 1461 | contra' = lol \case 1462 | L -> \nf -> apartR nf & \(p :-#> nq) -> nq :-#> p 1463 | R -> contra'' 1464 | 1465 | contra'ish :: forall l l' p q. (Lol l, Lol l', Prop p, Prop q) => l (p ⊸ q) (l' (Not q) (Not p)) 1466 | contra'ish = lol \case 1467 | L -> \nf -> apartR nf & \(p :-#> nq) -> nq :-#> p 1468 | R -> contra'' 1469 | 1470 | contra :: forall iso p q. (Iso iso, Prep p, Prep q) => iso (p ⊸ q) (Not q ⊸ Not p) 1471 | contra = iso \case 1472 | L -> contra' 1473 | R -> contra' 1474 | 1475 | contraIso'' :: forall iso p q. (Iso iso, Prep p, Prep q) => p ⧟ q %1 -> iso (Not q) (Not p) 1476 | contraIso'' = \(Iso f) -> iso \case 1477 | L -> contra' (f L) 1478 | R -> contra' (f R) 1479 | 1480 | contraIso' :: forall l iso p q. (Lol l, Iso iso, Prep p, Prep q) => l (p ⧟ q) (iso (Not q) (Not p)) 1481 | contraIso' = lol \case 1482 | L -> \x -> apart x & \case 1483 | ApartL p nq -> ApartL nq p 1484 | ApartR p nq -> ApartR nq p 1485 | R -> contraIso'' 1486 | 1487 | contraIso :: forall iso p q. (Iso iso, Prep p, Prep q) => iso (p ⧟ q) (Not q ⧟ Not p) 1488 | contraIso = iso \case 1489 | L -> contraIso' 1490 | R -> contraIso' 1491 | 1492 | lolPar :: (Iso iso, Prep a) => (a ⊸ b) `iso` (Not a ⅋ b) 1493 | lolPar = iso \case 1494 | L -> lol \case 1495 | L -> \(a :-#> nb) -> (a, nb) 1496 | R -> \(Par f) -> Lol f 1497 | R -> lol \case 1498 | L -> \(a, nb) -> a :-#> nb 1499 | R -> \(Lol f) -> Par f 1500 | 1501 | class Prop a => Semigroup a where 1502 | (<>) :: (Lol l, Lol l') => l a (l' a a) 1503 | 1504 | class Semigroup a => Monoid a where 1505 | mempty :: a 1506 | 1507 | instance Semigroup () where 1508 | (<>) = lol \case 1509 | L -> \ni -> apartR ni & \case a :-#> na -> a != na 1510 | R -> \() -> fun id 1511 | 1512 | top :: Lol l => l a Top 1513 | top = lol \case R -> Top; L -> \case 1514 | 1515 | absurd :: Lol l => l Void a 1516 | absurd = lol \case 1517 | L -> Top 1518 | R -> \case 1519 | 1520 | instance Semigroup Top where 1521 | (<>) = curryTensor' top 1522 | 1523 | instance Monoid () where 1524 | mempty = () 1525 | 1526 | instance Monoid Top where 1527 | mempty = top () 1528 | 1529 | instance Semigroup Void where 1530 | (<>) = absurd 1531 | 1532 | mksemi :: (Lol l, Lol l', Prop a) => (a %1 -> a ⊸ a) %1 -> l a (l' a a) 1533 | mksemi f = lol \case 1534 | L -> \ni -> apartR ni & \(p :-#> np) -> (p != np) f 1535 | R -> \x -> fun (f x) 1536 | 1537 | instance Semigroup Bot where 1538 | (<>) = mksemi \(Bot k) -> lol \case 1539 | L -> \u -> k (Top u) 1540 | R -> \b -> k (Top b) 1541 | 1542 | instance (Semigroup a, Semigroup b) => Semigroup (a, b) where 1543 | (<>) = mksemi \(a,b) -> lol \case 1544 | L -> \napnb -> parR napnb a != b 1545 | R -> \(c,d) -> (a <> c, b <>d) 1546 | 1547 | instance (Semigroup a, Semigroup b) => Semigroup (a & b) where 1548 | (<>) = mksemi \awb -> lol \case 1549 | L -> \case 1550 | Left na -> withL' awb != na 1551 | Right nb -> withR' awb != nb 1552 | R -> \cwd -> with \case 1553 | L -> withL' awb <> withL' cwd 1554 | R -> withR' awb <> withR' cwd 1555 | 1556 | instance (Monoid a, Monoid b) => Monoid (a, b) where 1557 | mempty = (mempty, mempty) 1558 | 1559 | instance (Monoid a, Monoid b) => Monoid (a & b) where 1560 | mempty = with \case 1561 | L -> mempty 1562 | R -> mempty 1563 | 1564 | -- strong closed functors 1565 | class Functor f => Applicative f where 1566 | pure :: (Prop a, Lol l) => l a (f a) 1567 | (<*>) 1568 | :: (Prop a, Prop b, Lol l, Lol l') 1569 | => l (f (a ⊸ b)) (l' (f a) (f b)) 1570 | 1571 | liftA2 1572 | :: (Prop a, Prop b, Prop c, Lol l, Lol l', Lol l'') 1573 | => l (a ⊸ b ⊸ c) (l' (f a) (l'' (f b) (f c))) 1574 | (<*>) = liftA2 id 1575 | 1576 | -- LNL ? 1577 | -- 1578 | -- F :: Hask -> L 1579 | -- U :: L -> Hask are both symmetric monoidal. 1580 | -- 1581 | -- F -| U UF is a monad, FU is a comonad 1582 | -- 1583 | -- F a %1 -> b ~ a -> U b 1584 | -- 1585 | -- data F a where 1586 | -- F :: a -> F a 1587 | -- 1588 | -- data U b where 1589 | -- U :: b %1 -> U b 1590 | -- 1591 | -- Ur = FU 1592 | -- 1593 | -- ! 1594 | -- 1595 | -- Moggi is a monad on Hask, which internally carries linear values? 1596 | -------------------------------------------------------------------------------- /src/Linear/Logic/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# language BlockArguments #-} 2 | {-# language ConstraintKinds #-} 3 | {-# language DerivingStrategies #-} 4 | {-# language EmptyCase #-} 5 | {-# language ExplicitNamespaces #-} 6 | {-# language FlexibleContexts #-} 7 | {-# language ViewPatterns #-} 8 | {-# language FlexibleInstances #-} 9 | {-# language DataKinds #-} 10 | {-# language NoImplicitPrelude #-} 11 | {-# language GADTs #-} 12 | {-# language LambdaCase #-} 13 | {-# language LinearTypes #-} 14 | {-# language NoStarIsType #-} 15 | {-# language ImportQualifiedPost #-} 16 | {-# language PolyKinds #-} 17 | {-# language QuantifiedConstraints #-} 18 | {-# language RankNTypes #-} 19 | {-# language RoleAnnotations #-} 20 | {-# language Trustworthy #-} 21 | {-# language StandaloneDeriving #-} 22 | {-# language StandaloneKindSignatures #-} 23 | {-# language StrictData #-} 24 | {-# language TupleSections #-} 25 | {-# language TypeApplications #-} 26 | {-# language TypeFamilies #-} 27 | {-# language TypeFamilyDependencies #-} 28 | {-# language TypeOperators #-} 29 | {-# language UndecidableInstances #-} 30 | {-# language UndecidableSuperClasses #-} 31 | {-# options_haddock not-home #-} 32 | {-# options_ghc -Wno-unused-imports #-} -- toLinear is too damn convenient while debugging to keep erasing it 33 | 34 | module Linear.Logic.Internal where 35 | 36 | import Control.Applicative (Const(..)) 37 | import Control.Category qualified as C 38 | import Data.Dependent.Sum 39 | import Data.Kind 40 | import Data.Void 41 | import Data.Functor.Product 42 | import Data.Functor.Sum 43 | import Data.Type.Equality 44 | import GHC.Generics 45 | import GHC.Types 46 | import Prelude.Linear hiding (Sum) 47 | import Linear.Logic.Orphans () 48 | import Linear.Logic.Y 49 | import Unsafe.Linear (toLinear) 50 | 51 | -- not is merely involutive. used to avoid passing dictionaries when they aren't used 52 | type Prep a = Not (Not a) ~ a 53 | 54 | class Prep a => Prop' a where 55 | -- | \(a^\bot\). The type of refutations of \(a\) 56 | -- 57 | -- \(a^{\bot^\bot} \) = \(a\) 58 | type Not a = c | c -> a 59 | -- | \(a\) and \(a^\bot\) together yield a contradiction. 60 | -- 61 | -- @ 62 | -- ('!=') :: a %1 -> 'Not' a %1 -> r 63 | -- @ 64 | (!=) :: a %1 -> Not a %1 -> r 65 | 66 | -- avoids UndecidableSuperClasses 67 | type Prop a = (Prop' a, Prop' (Not a)) 68 | 69 | -- | The unit for multiplicative conjunction, \(\texttt{()}\) 70 | -- 71 | -- \(\texttt{()}^\bot\) ≡ \(\bot\) 72 | instance Prop' () where 73 | type Not () = Bot 74 | x != Bot b = b (Top x) 75 | {-# inline (!=) #-} 76 | 77 | -- | The unit for additive disjunction, \(\texttt{Void}\) 78 | -- 79 | -- \(\texttt{Void}^\bot\) ≡ \(\top\) 80 | instance Prop' Void where 81 | type Not Void = Top 82 | v != Top a = \case{} v a 83 | {-# inline (!=) #-} 84 | 85 | -- | 'Top' can hold any unwanted environment, which allows it to work 86 | -- as a unit for @('&')@. 87 | 88 | data Top where 89 | -- | 'Top' :: a %1 -> 'Top' 90 | Top :: a %1 -> Top 91 | 92 | -- | 'Bot' acts as a unit for @('⅋')@ 93 | -- 94 | -- Defined via ?0 = Bot = WhyNot Void = forall r. Not Void %1 -> r = (forall r. Top %1 -> r) 95 | data Bot where 96 | Bot :: (forall a. Top %1 -> a) %1 -> Bot 97 | 98 | instance Consumable Bot where 99 | consume (Bot f) = f (Top ()) 100 | 101 | instance Dupable Bot where 102 | dup2 (Bot f) = f (Top ()) 103 | 104 | -- | The unit for additive conjunction, \(\top\) 105 | -- 106 | -- \(\top^\bot\) ≡ \(\texttt{Void}\) 107 | instance Prop' Top where 108 | type Not Top = Void 109 | Top a != v = \case{} v a 110 | {-# inline (!=) #-} 111 | 112 | -- | The unit for multiplicative disjunction, \(\bot\) 113 | -- 114 | -- \(\bot^\bot\) ≡ \(\texttt{()}\) 115 | instance Prop' Bot where 116 | type Not Bot = () 117 | Bot a != x = a (Top x) 118 | {-# inline (!=) #-} 119 | 120 | {- 121 | -- | Used to request a given side from 'With' or 'Par'. 122 | -- 123 | -- An unlifted version of this is suplied by Linear.Logic.Y 124 | type role Y nominal nominal nominal 125 | type Y :: i -> i -> i -> Type 126 | data Y a b c where 127 | L :: Y a b a 128 | R :: Y a b b 129 | -} 130 | 131 | -- With can be runtime rep polymorphic 132 | infixr 3 & 133 | type role (&) nominal nominal 134 | type (&) :: Type -> Type -> Type 135 | 136 | newtype a & b = With (forall c. Y a b c -> c) 137 | 138 | type With = (&) 139 | 140 | -- | Introduce a @'With'/('&')@ connective. 141 | -- 142 | -- Usage: 143 | -- 144 | -- @ 145 | -- 'with' \case 146 | -- 'L' -> ... 147 | -- 'R' -> ... 148 | -- @ 149 | -- 150 | -- @ 151 | -- 'with' :: (forall c. 'Y' a b c -> c) %1 -> a '&' b 152 | -- @ 153 | with :: (forall c. Y a b c -> c) %1 -> a & b 154 | with = With 155 | {-# inline with #-} 156 | 157 | runWith :: a & b %1 -> Y a b c -> c 158 | runWith (With f) = f 159 | 160 | -- | Eliminate a @'With'/('&')@ connective and extract the left choice. 161 | -- 162 | -- @ 163 | -- 'withL'' ('with' \case 'L' -> x; 'R' -> y) ≡ x 164 | -- @ 165 | -- 166 | -- @ 167 | -- 'withL'' :: a '&' b %1 -> a 168 | -- @ 169 | withL' :: a & b %1 -> a 170 | withL' (With f) = f L 171 | {-# inline withL' #-} 172 | 173 | -- | Eliminate a 'With'/('&') connective and extract the right choice. 174 | -- 175 | -- @ 176 | -- 'withR' ('with' \case 'L' -> x; 'R' -> y) ≡ y 177 | -- @ 178 | -- 179 | -- @ 180 | -- 'withR' :: a '&' b %1 -> b 181 | -- @ 182 | withR' :: a & b %1 -> b 183 | withR' (With f) = f R 184 | {-# inline withR' #-} 185 | 186 | instance (Prop' a, Prop' b) => Prop' (a & b) where 187 | type Not (a & b) = Not a + Not b 188 | w != Left a = withL' w != a 189 | w != Right b = withR' w != b 190 | {-# inline (!=) #-} 191 | 192 | infixr 2 + 193 | type (+) = Either 194 | 195 | instance (Prop' a, Prop' b) => Prop' (Either a b) where 196 | type Not (Either a b) = Not a & Not b 197 | Left a != w = a != withL' w 198 | Right a != w = a != withR' w 199 | {-# inline (!=) #-} 200 | 201 | infixr 3 * 202 | type (*) = (,) 203 | 204 | infixr 2 ⅋ 205 | type (⅋) :: Type -> Type -> Type 206 | type role (⅋) nominal nominal 207 | -- | \(\par\) is multiplicative disjunction. 208 | newtype a ⅋ b = Par (forall c. Y (Not b %1 -> a) (Not a %1 -> b) c -> c) 209 | 210 | type Par = (⅋) 211 | 212 | -- | Introduce a @'par'/('⅋')@ connective. 213 | -- 214 | -- Usage: 215 | -- 216 | -- @ 217 | -- 'par' \case 218 | -- 'L' -> ... 219 | -- 'R' -> ... 220 | -- @ 221 | -- 222 | -- When developing using holes, you may want to temporarily substitute 'Linear.Logic.Unsafe.unsafePar' 223 | -- until all the holes have been solved, then putting this in instead once everything typechecks. 224 | -- 225 | -- @ 226 | -- 'par' :: (forall c. 'Y' ('Not' b %1 -> a) ('Not' a %1 -> b) c %1 -> c) %1 -> a '⅋' b 227 | -- @ 228 | par :: (forall c. Y (Not b %1 -> a) (Not a %1 -> b) c -> c) %1 -> a ⅋ b 229 | par = Par 230 | {-# inline par #-} 231 | 232 | -- | Eliminate a @'par'/('⅋')@ connective, given refutation of the @b@, supply proof of @a@. 233 | -- 234 | -- @ 235 | -- 'parL'' ('par' \case 'L' -> x; 'R' -> y) ≡ x 236 | -- @ 237 | -- 238 | -- @ 239 | -- 'parL'' :: a '⅋' b %1 -> 'Not' b %1 -> a 240 | -- @ 241 | parL' :: a ⅋ b %1 -> Not b %1 -> a 242 | parL' (Par p) = p L 243 | {-# inline parL' #-} 244 | 245 | -- | Eliminate a @'par'/('⅋')@ connective, given refutation of the @a@, supply proof of @b@. 246 | -- 247 | -- @ 248 | -- parR (par \case L -> x; R -> y) ≡ y 249 | -- @ 250 | -- 251 | -- @ 252 | -- 'parR' :: a '⅋' b %1 -> 'Not' a %1 -> b 253 | -- @ 254 | parR' :: a ⅋ b %1 -> Not a %1 -> b 255 | parR' (Par p) = p R 256 | {-# inline parR' #-} 257 | 258 | instance (Prop' a, Prep b) => Prop' (a * b) where 259 | type Not (a * b) = Not a ⅋ Not b 260 | (a, b) != p = a != parL' p b 261 | {-# inline (!=) #-} 262 | 263 | instance (Prop' a, Prep b) => Prop' (a ⅋ b) where 264 | type Not (a ⅋ b) = Not a * Not b 265 | p != (a, b) = parL' p b != a 266 | {-# inline (!=) #-} 267 | 268 | -- | This instance is for @(a %1 -> b)@ despite haddock's lies. 269 | -- The injective type family on @Not@ forces me to use a flexible 270 | -- instance, rather than have the instance self-improve 271 | instance Prop' b => Prop' (a %m -> b) where 272 | type Not (a %m -> b) = Nofun m b a 273 | f != (Nofun a nb) = f a != nb 274 | {-# inline (!=) #-} 275 | 276 | -- | The refutations of a linear haskell arrow are the same as the refutation of ⊸. 277 | data Nofun m b a where 278 | Nofun :: a %m -> Not b %1 -> Nofun m b a 279 | 280 | deriving stock instance (Show a, Show (Not b)) => Show (Nofun m b a) 281 | deriving stock instance (Read a, Read (Not b)) => Read (Nofun m b a) 282 | -- deriving stock instance (Eq a, Eq (Not b)) => Eq (Nofun m a b) 283 | -- deriving stock instance (Ord a, Ord (Not b)) => Ord (Nofun m a b) 284 | 285 | instance Prop' b => Prop' (Nofun m b a) where 286 | type Not (Nofun m b a) = a %m -> b 287 | Nofun a nb != f = f a != nb 288 | {-# inline (!=) #-} 289 | 290 | infixr 0 ⊸ 291 | 292 | type (%->) = FUN 'One 293 | 294 | -- | \(\multimap\) could be defined in terms of \(⅋\), but then I couldn't hang instances off it. 295 | -- 296 | -- type p ⊸ q = Not p ⅋ q 297 | 298 | newtype a ⊸ b = Lol (forall c. Y (Not b %1 -> Not a) (a %1 -> b) c -> c) 299 | 300 | data b <#- a where (:-#>) :: a %1 -> Not b %1 -> b <#- a 301 | 302 | -- data a -#> b where (:-#>) :: a %1 -> Not b %1 -> a -#> b 303 | infixl 0 <#- 304 | infixr 3 :-#> 305 | 306 | newtype a ⧟ b = Iso (forall c. Y (b ⊸ a) (a ⊸ b) c -> c) 307 | infixr 0 ⧟ 308 | 309 | runLol :: a ⊸ b %1 -> Y (Not b %1 -> Not a) (a %1 -> b) c -> c 310 | runLol (Lol f) = f 311 | 312 | runIso :: a ⧟ b %1 -> Y (b ⊸ a) (a ⊸ b) c -> c 313 | runIso (Iso f) = f 314 | 315 | -- | Sometimes linear haskell needs some help to infer that we really want linear usage 316 | linear :: (a %1 -> b) %1 -> a %1 -> b 317 | linear = id 318 | 319 | instance C.Category (⊸) where 320 | id = Lol \case L -> id; R -> id 321 | f . g = Lol \case 322 | L -> linear \c -> runLol g L (runLol f L c) 323 | R -> linear \a -> runLol f R (runLol g R a) 324 | 325 | instance C.Category (⧟) where 326 | id = Iso \case L -> C.id; R -> C.id 327 | f . g = Iso \case 328 | L -> runIso g L C.. runIso f L 329 | R -> runIso f R C.. runIso g R 330 | 331 | data b # a 332 | = ApartL (Not a) b 333 | | ApartR a (Not b) 334 | 335 | instance (Prop' a, Prop' b) => Prop' (a ⧟ b) where 336 | type Not (a ⧟ b) = b # a 337 | Iso f != ApartR a nb = f R != (a :-#> nb) 338 | Iso f != ApartL na b = f L != (b :-#> na) 339 | 340 | instance (Prop' a, Prop' b) => Prop' (b # a) where 341 | type Not (b # a) = a ⧟ b 342 | ApartR a nb != Iso f = f R != (a :-#> nb) 343 | ApartL na b != Iso f = f L != (b :-#> na) 344 | 345 | instance (Prep a, Prop' b) => Prop' (a ⊸ b) where 346 | type Not (a ⊸ b) = b <#- a 347 | f != (a :-#> nb) = runLol f R a != nb 348 | 349 | instance (Prep a, Prop' b) => Prop' (b <#- a) where 350 | type Not (b <#- a) = a ⊸ b 351 | (a :-#> nb) != f = runLol f R a != nb 352 | 353 | deriving stock instance (Show a, Show (Not b)) => Show (b <#- a) 354 | deriving stock instance (Read a, Read (Not b)) => Read (b <#- a) 355 | -- deriving stock instance (Eq a, Eq (Not b)) => Eq (a # b) 356 | -- deriving stock instance (Ord a, Ord (Not b)) => Ord (a # b) 357 | 358 | -- | The \(?a\) or "why not?" modality. 359 | type role WhyNot nominal 360 | newtype WhyNot a = WhyNot (forall r. Not a -> r) 361 | 362 | whyNot :: (forall r. Not a -> r) %1 -> WhyNot a 363 | whyNot = WhyNot 364 | 365 | because :: WhyNot a %1 -> Not a -> r 366 | because (WhyNot a) = a 367 | {-# inline because #-} 368 | 369 | -- | The exponential, or unrestricted modality, \( !a \) 370 | -- 371 | -- This embeds arbitrary non-linear Haskell values into 'Prop'. 372 | instance Prep a => Prop' (Ur a) where 373 | type Not (Ur a) = WhyNot (Not a) 374 | Ur a != f = because f a 375 | {-# inline (!=) #-} 376 | 377 | instance Prep a => Prop' (WhyNot a) where 378 | type Not (WhyNot a) = Ur (Not a) 379 | f != Ur a = because f a 380 | {-# inline (!=) #-} 381 | 382 | -- | 383 | -- @ 384 | -- data DSum f g where 385 | -- (:=>) :: !(f a) -> g a -> DSum f g 386 | 387 | -- DSum (Y a b) Identity ~ Either a b 388 | -- DWith (Y a b) Identity ~ a & b 389 | -- @ 390 | newtype DWith f g = DWith (forall x. f x %1 -> g x) 391 | 392 | dwith :: (forall x. f x %1 -> g x) %1 -> DWith f g 393 | dwith = DWith 394 | 395 | runDWith :: DWith f g %1 -> f x %1 -> g x 396 | runDWith (DWith f) = f 397 | 398 | type IPrep f = INot (INot f) ~ f 399 | 400 | class 401 | ( IPrep f 402 | , forall a. Prop' (f a) 403 | ) => IProp' (f :: i -> Type) where 404 | type INot (f :: i -> Type) = (c :: i -> Type) | c -> f 405 | icontradict :: f a %1 -> INot f a %1 -> r 406 | inot :: INot f a :~: Not (f a) 407 | 408 | type IProp f = (IProp' f, IProp' (INot f)) 409 | 410 | instance Prop' a => IProp' (Const a) where 411 | type INot (Const a) = Const (Not a) 412 | inot = Refl 413 | icontradict (Const a) (Const na) = a != na 414 | 415 | instance Prop' a => Prop' (Const a b) where 416 | type Not (Const a b) = Const (Not a) b 417 | Const a != Const na = a != na 418 | 419 | instance IProp' g => Prop' (DWith f g) where 420 | type Not (DWith f g) = DSum f (INot g) 421 | h != (f :=> g) = icontradict (runDWith h f) g 422 | 423 | instance IProp' g => Prop' (DSum f g) where 424 | type Not (DSum f g) = DWith f (INot g) 425 | (f :=> g) != h = icontradict g (runDWith h f) 426 | 427 | type (:&:) :: forall i. (i -> Type) -> (i -> Type) -> i -> Type 428 | newtype (:&:) f g a = IWith (forall h. Y f g h -> h a) 429 | 430 | instance (IProp' f, IProp' g) => Prop' ((:&:) f g a) where 431 | type Not ((:&:) f g a) = (INot f :+: INot g) a 432 | (!=) (IWith f) = \case 433 | L1 g -> icontradict (f L) g 434 | R1 g -> icontradict (f R) g 435 | 436 | instance (IProp' f, IProp' g) => Prop' ((:+:) f g a) where 437 | type Not ((:+:) f g a) = (INot f :&: INot g) a 438 | L1 g != IWith f = icontradict g (f L) 439 | R1 g != IWith f = icontradict g (f R) 440 | 441 | instance (IProp' f, IProp' g) => IProp' (f :&: g) where 442 | type INot (f :&: g) = INot f :+: INot g 443 | icontradict (IWith f) = \case 444 | L1 g -> icontradict (f L) g 445 | R1 g -> icontradict (f R) g 446 | inot = Refl 447 | 448 | instance (IProp' f, IProp' g) => IProp' (f :+: g) where 449 | type INot (f :+: g) = INot f :&: INot g 450 | icontradict s (IWith f) = s & \case 451 | L1 g -> icontradict g (f L) 452 | R1 g -> icontradict g (f R) 453 | inot = Refl 454 | 455 | newtype (:⅋:) (a :: i -> Type) (b :: i -> Type) (x :: i) = 456 | IPar (forall (c :: Type). Y (INot b x %1 -> a x) (INot a x %1 -> b x) c -> c) 457 | 458 | instance (IProp' f, IProp' g) => Prop' ((f :*: g) a) where 459 | type Not ((f :*: g) a) = (INot f :⅋: INot g) a 460 | (f :*: g) != IPar h = icontradict g (h R f) 461 | 462 | instance (IProp' f, IProp' g) => Prop' ((f :⅋: g) a) where 463 | type Not ((f :⅋: g) a) = (INot f :*: INot g) a 464 | IPar h != (f :*: g) = icontradict (h R f) g 465 | 466 | instance (IProp' f, IProp' g) => IProp' (f :*: g) where 467 | type INot (f :*: g) = INot f :⅋: INot g 468 | icontradict (f :*: g) (IPar h) = icontradict g (h R f) 469 | inot = Refl 470 | 471 | instance (IProp' f, IProp' g) => IProp' (f :⅋: g) where 472 | type INot (f :⅋: g) = INot f :*: INot g 473 | icontradict (IPar h) (f :*: g) = icontradict (h R f) g 474 | inot = Refl 475 | 476 | -- | Ur a ⊸ b 477 | newtype a ⊃ b = Imp 478 | (forall c. (Prop' a, Prop' b) => Y (Not b %1 -> WhyNot (Not a)) (a -> b) c -> c) 479 | 480 | infixr 0 ⊃ 481 | 482 | imp :: (forall c. (Prop' a, Prop' b) => Y (Not b %1 -> WhyNot (Not a)) (a -> b) c -> c) %1 -> a ⊃ b 483 | imp = Imp 484 | 485 | runImp :: (Prop' a, Prop' b) => (a ⊃ b) %1 -> Y (Not b %1 -> WhyNot (Not a)) (a -> b) c -> c 486 | runImp (Imp f) = f 487 | 488 | impR' :: (Prop' a, Prop' b) => (a ⊃ b) %1 -> a -> b 489 | impR' f = runImp f R 490 | 491 | impL' :: (Prop' a, Prop' b) => (a ⊃ b) %1 -> Not b %1 -> WhyNot (Not a) 492 | impL' f = runImp f L 493 | 494 | data Noimp b a where 495 | Noimp :: a -> Not b %1 -> Noimp b a 496 | 497 | instance (Prop' a, Prop' b) => Prop' (a ⊃ b) where 498 | type Not (a ⊃ b) = Noimp b a 499 | f != Noimp a b = runImp f R a != b 500 | 501 | instance (Prop' a, Prop' b) => Prop' (Noimp b a) where 502 | type Not (Noimp b a) = a ⊃ b 503 | Noimp a b != f = runImp f R a != b 504 | 505 | -- FTensor would match hkd. DFoo would match dependent-sum, dependent-hashmap. change hkd? 506 | -- we need some way to talk about a partitioning/swizzling of a list into two lists 507 | -- then you can project out subsets of the rows with a swizzle. then this generalizes to 'f's 508 | -- that can be swizzled into 'g's and 'h's? 509 | -- newtype DTensor :: [i] -> (i -> Type) -> Type 510 | -- newtype DPar :: [i] -> (i -> Type) -> Type 511 | -- ⊸ ⅋ 512 | --newtype a ⇀ b = Partial (a ⊸ WhyNot b) 513 | -- a ⇀ b = Not a ⅋ WhyNot b = WhyNot b ⅋ Not a = Not (WhyNot b) ⊸ Not a = Ur b ⊸ Not a = b ⊃ Not a 514 | -------------------------------------------------------------------------------- /src/Linear/Logic/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# language NoImplicitPrelude #-} 2 | {-# language StandaloneDeriving #-} 3 | {-# language DerivingStrategies #-} 4 | {-# language ImportQualifiedPost #-} 5 | {-# language LambdaCase #-} 6 | {-# language EmptyCase #-} 7 | {-# language Trustworthy #-} 8 | {-# options_ghc -Wno-orphans #-} 9 | 10 | module Linear.Logic.Orphans where 11 | 12 | import Control.Category as C 13 | import Data.Kind 14 | import Data.Void 15 | import Prelude.Linear 16 | import Prelude qualified 17 | 18 | instance {-# OVERLAPPABLE #-} C.Category (FUN m) where 19 | id x = x 20 | f . g = \x -> f (g x) 21 | 22 | deriving stock instance Show a => Show (Ur a) 23 | deriving stock instance Read a => Read (Ur a) 24 | deriving stock instance Prelude.Eq a => Prelude.Eq (Ur a) 25 | deriving stock instance Prelude.Ord a => Prelude.Ord (Ur a) 26 | 27 | instance Consumable Void where 28 | consume = \case 29 | 30 | instance Dupable Void where 31 | dup2 = \case 32 | -------------------------------------------------------------------------------- /src/Linear/Logic/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# language BlockArguments #-} 2 | {-# language LambdaCase #-} 3 | {-# language Trustworthy #-} 4 | {-# language RecordWildCards #-} 5 | {-# options_ghc -Wno-unused-matches #-} 6 | 7 | module Linear.Logic.Plugin where 8 | 9 | -- import Control.Monad 10 | import Control.Monad.IO.Class 11 | -- import Data.Foldable (traverse_) 12 | import GHC.Builtin.Names 13 | import GHC.Builtin.Types 14 | import GHC.Builtin.Types.Prim 15 | -- import GHC.Core 16 | -- import GHC.Core.Coercion 17 | import GHC.Core.Predicate 18 | import GHC.Core.Type 19 | -- import GHC.Core.TyCo.Rep 20 | import GHC.Driver.Plugins (Plugin(..), defaultPlugin, purePlugin) 21 | -- import GHC.Driver.Session 22 | import GHC.Types.Name.Occurrence 23 | import GHC.Tc.Plugin 24 | import GHC.Tc.Types 25 | import GHC.Tc.Types.Constraint 26 | import GHC.Tc.Types.Evidence 27 | import GHC.TcPluginM.Extra (tracePlugin, evByFiat) 28 | -- import GHC.Types.Var 29 | import GHC.Unit.Module.Name 30 | -- import GHC.Unit.Types 31 | import GHC.Utils.Outputable 32 | 33 | -- Not (Not a) ~ b ==> a ~ b 34 | 35 | -- TODO: want (Prop a) and have Prop (Not a) -- give me Prop (Not (Not a)) 36 | 37 | plugin :: Plugin 38 | plugin = defaultPlugin 39 | { tcPlugin = \_ -> Just logicPlugin 40 | , pluginRecompile = purePlugin 41 | } where 42 | 43 | logicPlugin :: TcPlugin 44 | logicPlugin = tracePlugin "linear-logic" 45 | TcPlugin 46 | { tcPluginInit = tcPluginIO $ pure () 47 | , tcPluginSolve = solveLogic 48 | , tcPluginStop = const $ pure () 49 | } 50 | 51 | io :: IO a -> TcPluginM a 52 | io = unsafeTcPluginTcM . liftIO 53 | 54 | pp :: Outputable a => a -> String 55 | pp = showSDocUnsafe . ppr 56 | 57 | -- TODO: this is going to require me to rummage through givens for parts 58 | 59 | solveLogic :: () -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult 60 | solveLogic () givens _deriveds wanteds = do 61 | Found _ lli <- findImportedModule (mkModuleName "Linear.Logic.Internal") Nothing 62 | notName <- lookupOrig lli (mkTcOcc "Not") 63 | notTyCon <- tcLookupTyCon notName 64 | let notKey = getUnique notTyCon 65 | 66 | 67 | {- 68 | unless (null wanteds) $ io do 69 | putStrLn "solveLogic\n" 70 | putStrLn " wanteds:" 71 | traverse_ (\x -> putStrLn $ " " ++ pp (ctLocSpan (ctLoc x)) ++ " " ++ pp x) wanteds 72 | putStrLn " givens:" 73 | traverse_ (\x -> putStrLn $ " " ++ pp (ctLocSpan (ctLoc x)) ++ " " ++ pp x) givens 74 | putStrLn "\n\n" 75 | -} 76 | 77 | let 78 | 79 | {- 80 | is :: Type -> Type -> Bool 81 | is (TyVarTy x) (TyVarTy x') = varUnique x == varUnique x' 82 | -- is _ _ = False 83 | 84 | isNot :: Type -> Type -> Ct -> Bool 85 | isNot y x g = case classifyPredType $ ctEvPred $ ctEvidence g of 86 | EqPred NomEq ny' x' 87 | | Just (n1, [y']) <- splitTyConApp_maybe ny', hasKey n1 notKey 88 | -> is y y' && is x x' 89 | _ -> False 90 | 91 | findNot :: Type -> Type -> [Ct] -> Bool 92 | findNot y x = any (isNot y x) 93 | -} 94 | 95 | runEvExpr (EvExpr x) = x 96 | runEvExpr _ = error "runEvExpr" 97 | 98 | tryToSolve :: Ct -> TcPluginM ([(EvTerm,Ct)],[Ct]) 99 | tryToSolve ct = case classifyPredType $ ctEvPred $ ctEvidence ct of 100 | EqPred NomEq nnx y 101 | | Just (n1, [nx]) <- splitTyConApp_maybe nnx, hasKey n1 notKey 102 | , Just (n2, [x]) <- splitTyConApp_maybe nx, hasKey n2 notKey 103 | -> do 104 | wantedEvidence <- newWanted (ctLoc ct) $ mkTyConApp eqPrimTyCon [liftedTypeKind,liftedTypeKind,x,y] 105 | -- io $ putStrLn $ "not-not: " ++ pp nnx ++ " ~ " ++ pp y ++ " if " ++ pp x ++ " ~ " ++ pp y 106 | pure ([(evByFiat "not-not" nnx y, ct)],[mkNonCanonical wantedEvidence]) 107 | EqPred NomEq y nnx 108 | | Just (n1, [nx]) <- splitTyConApp_maybe nnx, hasKey n1 notKey 109 | , Just (n2, [x]) <- splitTyConApp_maybe nx, hasKey n2 notKey 110 | -> do 111 | wantedEvidence <- newWanted (ctLoc ct) $ mkTyConApp eqPrimTyCon [liftedTypeKind,liftedTypeKind,x,y] 112 | -- io $ putStrLn $ "not-not: " ++ pp y ++ " ~ " ++ pp nnx ++ " if " ++ pp x ++ " ~ " ++ pp y 113 | pure ([(evByFiat "not-not" nnx y, ct)],[mkNonCanonical wantedEvidence]) 114 | EqPred NomEq nx y 115 | | Just (n1, [x]) <- splitTyConApp_maybe nx, hasKey n1 notKey 116 | -- we want Not x ~ y, ok, look for given Not y ~ x and say 'yup' 117 | -> do 118 | {- 119 | if findNot y x givens 120 | then do 121 | io $ putStrLn $ "not-given: " ++ pp nx ++ " ~ " ++ pp y ++ " given Not " ++ pp y ++ " ~ " ++ pp x 122 | pure ([(evByFiat "not-given" nx y, ct)],[]) 123 | else do 124 | io $ putStrLn $ "confused by " ++ pp nx ++ " ~ " ++ pp y 125 | pure ([],[]) 126 | 127 | 128 | -} 129 | let nnx = mkTyConApp notTyCon [nx] 130 | givenEvidence <- newGiven 131 | (ctLoc ct) 132 | (mkTyConApp eqPrimTyCon [liftedTypeKind,liftedTypeKind,nnx,x]) 133 | (runEvExpr $ evByFiat "not-not-ish" nnx x) 134 | -- io $ putStrLn $ "not-notish: " ++ pp nnx ++ " ~# " ++ pp x 135 | pure ([],[mkNonCanonical givenEvidence]) 136 | EqPred n x y -> do 137 | -- io $ putStrLn $ "I think " ++ pp n ++ " " ++ pp x ++ pp y ++ " is none of my business" 138 | pure ([],[]) 139 | ClassPred c [_star, nnx, y] 140 | | hasKey c eqTyConKey 141 | , Just (n1, [nx]) <- splitTyConApp_maybe nnx, hasKey n1 notKey 142 | , Just (n2, [x]) <- splitTyConApp_maybe nx, hasKey n2 notKey 143 | -> do 144 | -- io $ putStrLn $ "Ooh ooh ooh: " ++ show (pp c, pp x, pp y) 145 | wantedEvidence <- newWanted (ctLoc ct) $ mkTyConApp eqPrimTyCon [liftedTypeKind,liftedTypeKind,x,y] 146 | 147 | 148 | pure ([(evDataConApp eqDataCon [liftedTypeKind,x,y] [runEvExpr $ evByFiat "not-not" x y], ct)],[mkNonCanonical wantedEvidence]) 149 | ClassPred c tys -> do 150 | -- io $ putStrLn $ "ClassPred " ++ show (pp c, pp tys) 151 | pure ([],[]) 152 | IrredPred ty -> do 153 | -- io $ putStrLn $ "IrredPred " ++ pp ty 154 | pure ([],[]) 155 | ForAllPred as bs cs -> do 156 | -- io $ putStrLn $ "ForAllPred " ++ show (pp as, pp bs, pp cs) 157 | pure ([],[]) 158 | 159 | results <- traverse tryToSolve wanteds 160 | pure $ TcPluginOk (results >>= fst) (results >>= snd) 161 | -------------------------------------------------------------------------------- /src/Linear/Logic/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE Unsafe #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE LinearTypes #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE GADTs #-} 8 | 9 | module Linear.Logic.Unsafe 10 | ( toLinear 11 | , unsafePar 12 | ) where 13 | 14 | import Linear.Logic 15 | import Unsafe.Linear (toLinear) 16 | 17 | -- | When developing proofs it is often handy to lie about multiplicity, 18 | -- while you are still filling in holes. This enables that workflow. 19 | -- When you are done, you can convert from 'unsafePar' back to 'par' 20 | -- 21 | -- 'toLinear' can also come in handy temporarily during this 22 | -- process. 23 | unsafePar :: (forall c. Y (Not b -> a) (Not a -> b) c -> c) %1 -> a ⅋ b 24 | unsafePar f = par \case 25 | L -> toLinear (f L) 26 | R -> toLinear (f R) 27 | -------------------------------------------------------------------------------- /src/Linear/Logic/Y.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | {-# LANGUAGE StandaloneKindSignatures #-} 6 | 7 | -- #define LIFTED_Y 0 8 | 9 | #ifdef LIFTED_Y 10 | {-# LANGUAGE Safe #-} 11 | #else 12 | {-# LANGUAGE Trustworthy #-} 13 | {-# LANGUAGE UnliftedNewtypes #-} 14 | {-# LANGUAGE MagicHash #-} 15 | {-# LANGUAGE PatternSynonyms #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | {-# LANGUAGE ScopedTypeVariables #-} 18 | {-# LANGUAGE TypeOperators #-} 19 | {-# LANGUAGE ViewPatterns #-} 20 | {-# LANGUAGE RankNTypes #-} 21 | {-# LANGUAGE LinearTypes #-} 22 | {-# options_haddock not-home #-} 23 | {-# options_ghc -Wno-incomplete-patterns #-} 24 | #endif 25 | 26 | module Linear.Logic.Y 27 | ( Y(L,R) 28 | ) where 29 | 30 | import Data.Kind 31 | 32 | #ifdef LIFTED_Y 33 | 34 | type Y :: i -> i -> i -> Type 35 | type role Y nominal nominal nominal 36 | data Y a b c where 37 | L :: Y a b a 38 | R :: Y a b b 39 | 40 | #else 41 | 42 | import GHC.Prim 43 | import GHC.Types 44 | import Unsafe.Coerce 45 | 46 | type Y' :: i -> i -> i -> Type 47 | type role Y' nominal nominal nominal 48 | data Y' a b c where 49 | L' :: Y' a b a 50 | R' :: Y' a b b 51 | 52 | upY :: Y a b c %1 -> Y' a b c 53 | upY (Y 0#) = unsafeCoerce L' 54 | upY (Y 1#) = unsafeCoerce R' 55 | 56 | type Y :: i -> i -> i -> TYPE 'IntRep 57 | type role Y nominal nominal nominal 58 | newtype Y a b c = Y Int# 59 | 60 | pattern L :: forall i (a :: i) (b :: i) (c :: i). () => a ~ c => Y a b c 61 | pattern L <- (upY -> L') where 62 | L = Y 0# 63 | 64 | pattern R :: forall i (a :: i) (b :: i) (c :: i). () => b ~ c => Y a b c 65 | pattern R <- (upY -> R') where 66 | R = Y 1# 67 | 68 | {-# COMPLETE L, R #-} 69 | #endif 70 | -------------------------------------------------------------------------------- /src/Linear/Logic/Yoneda.hs: -------------------------------------------------------------------------------- 1 | {-# language LinearTypes #-} 2 | {-# language RankNTypes #-} 3 | {-# language LambdaCase #-} 4 | {-# language EmptyCase #-} 5 | {-# language ScopedTypeVariables #-} 6 | {-# language Trustworthy #-} 7 | {-# language FlexibleContexts #-} 8 | {-# language BlockArguments #-} 9 | {-# language TypeOperators #-} 10 | {-# language ConstraintKinds #-} 11 | {-# language GADTs #-} 12 | {-# language NoImplicitPrelude #-} 13 | {-# language TypeFamilies #-} 14 | {-# language TypeApplications #-} 15 | {-# options_ghc -Wno-unused-imports #-} 16 | 17 | module Linear.Logic.Yoneda 18 | ( Yoneda(..) 19 | , Noneda(..) 20 | , liftYoneda 21 | , lowerYoneda' 22 | , lowerYoneda 23 | , Coyoneda(..) 24 | , Cononeda(..), cononeda, runCononeda 25 | , liftCoyoneda' 26 | , liftCoyoneda 27 | , lowerCoyoneda 28 | ) where 29 | 30 | import Data.Kind 31 | import GHC.Types 32 | import Data.Unrestricted.Linear (Ur(..)) 33 | import Linear.Logic.Internal 34 | import Linear.Logic.Functor 35 | import Linear.Logic.Y 36 | 37 | newtype Yoneda f a = Yoneda (forall r. Prop' r => Ur (a ⊸ r) ⊸ f r) 38 | 39 | data Noneda f a where 40 | Noneda :: Prop' r => {-# unpack #-} !(f r <#- Ur (a ⊸ r)) %1 -> Noneda f a 41 | 42 | instance (Functor f, Prop' a) => Prop' (Yoneda f a) where 43 | type Not (Yoneda f a) = Noneda f a 44 | Yoneda y != Noneda n = y != n 45 | 46 | instance (Functor f, Prop' a) => Prop' (Noneda f a) where 47 | type Not (Noneda f a) = Yoneda f a 48 | Noneda y != Yoneda n = y != n 49 | 50 | runYoneda :: Prop' r => Yoneda f a %1 -> (a ⊸ r) -> f r 51 | runYoneda (Yoneda f) a2r = fun' f (Ur a2r) 52 | 53 | lowerYoneda' :: (Prop' a, Lol l) => l (Yoneda f a) (f a) 54 | lowerYoneda' = lol \case 55 | L -> \nfa -> Noneda (Ur id :-#> nfa) 56 | R -> \f -> runYoneda f id 57 | 58 | liftYoneda :: forall f a i. (Functor f, Prop' a, Iso i) => i (f a) (Yoneda f a) 59 | liftYoneda = iso \case 60 | L -> lowerYoneda' 61 | R -> lol \case 62 | L -> \(Noneda (Ur (a2r :: a ⊸ r) :-#> nfr)) -> runLol (fmap @f @a @r a2r) L nfr 63 | R -> \fa -> Yoneda do 64 | lol \case 65 | R -> \f -> fmap' f fa 66 | L -> \nfr -> whyNot \a2r -> fmap a2r fa != nfr 67 | 68 | lowerYoneda :: forall f a i. (Functor f, Prop' a, Iso i) => i (Yoneda f a) (f a) 69 | lowerYoneda = inv' liftYoneda 70 | 71 | data Coyoneda f a where 72 | Coyoneda :: Prop' r => (r ⊸ a) -> f r %1 -> Coyoneda f a 73 | 74 | newtype Cononeda f a = Cononeda (forall r. Prop' r => f r ⊸ WhyNot (a <#- r)) 75 | 76 | runCononeda :: forall r l a f. (Prop' r, Lol l) => Cononeda f a %1 -> l (f r) (WhyNot (a <#- r)) 77 | runCononeda (Cononeda f) = fun f 78 | 79 | instance (Functor f, Prop' a) => Prop' (Coyoneda f a) where 80 | type Not (Coyoneda f a) = Cononeda f a 81 | Coyoneda r2a fr != k = because (runCononeda k fr) r2a 82 | 83 | instance (Functor f, Prop' a) => Prop' (Cononeda f a) where 84 | type Not (Cononeda f a) = Coyoneda f a 85 | k != Coyoneda r2a fr = because (runCononeda k fr) r2a 86 | 87 | cononeda :: (forall r. Prop' r => f r ⊸ WhyNot (a <#- r)) %1 -> Cononeda f a 88 | cononeda = Cononeda 89 | 90 | -- | avoids the Functor constraint 91 | liftCoyoneda' :: forall a f l. (Prop a, Lol l) => l (f a) (Coyoneda f a) 92 | liftCoyoneda' = lol \case 93 | L -> \k -> runLol (runCononeda @a @(⊸) k) L (Ur id) 94 | R -> Coyoneda id 95 | 96 | liftCoyoneda :: forall f a i. (Functor f, Prop a, Iso i) => i (f a) (Coyoneda f a) 97 | liftCoyoneda = iso \case 98 | L -> lol \case 99 | L -> \nfa -> cononeda do 100 | lol \case 101 | L -> \(Ur r2a) -> runLol (fmap r2a) L nfa 102 | R -> \fr -> whyNot \r2a -> fmap r2a fr != nfa 103 | R -> \(Coyoneda r2a fa) -> fmap r2a fa 104 | R -> liftCoyoneda' 105 | 106 | lowerCoyoneda :: forall f a i. (Functor f, Prop a, Iso i) => i (Coyoneda f a) (f a) 107 | lowerCoyoneda = inv' liftCoyoneda 108 | -------------------------------------------------------------------------------- /wip/affine.hs: -------------------------------------------------------------------------------- 1 | {- cabal: 2 | build-depends: base, constraints 3 | -} 4 | {-# language TypeFamilies, TypeFamilyDependencies, ConstraintKinds, ScopedTypeVariables, NoStarIsType, TypeOperators, TypeApplications, GADTs, AllowAmbiguousTypes, FunctionalDependencies, UndecidableSuperClasses, UndecidableInstances, FlexibleInstances, QuantifiedConstraints, BlockArguments, RankNTypes, FlexibleContexts, StandaloneKindSignatures, DefaultSignatures #-} 5 | 6 | -- ⊷, ≕, =∘, =◯ These choices all look like something out of Star Trek, so let's boldly go... 7 | 8 | import Data.Constraint hiding (top, bottom, Bottom) 9 | import Data.Kind 10 | import Data.Some 11 | import Data.Void 12 | import Unsafe.Coerce 13 | 14 | class (Not p ~ Never p) => Never p where 15 | never :: p => Dict r 16 | 17 | class (Prop (Not p), Not (Not p) ~ p) => Prop (p :: Constraint) where 18 | type Not p :: Constraint 19 | type Not p = Never p 20 | 21 | contradiction :: (p, Not p) => Dict r 22 | default contradiction :: (Not p ~ Never p, p, Not p) => Dict r 23 | contradiction = never @p 24 | 25 | instance (Prop p, Not p ~ Never p) => Prop (Never p) where 26 | type Not (Never p) = p 27 | contradiction = never @p 28 | 29 | instance Prop (Bounded a) 30 | instance Prop (Num a) 31 | 32 | instance Never (Bounded Void) where never = absurd minBound 33 | instance Never (Num Void) where never = absurd (fromInteger 0) 34 | 35 | class (p, q) => p * q 36 | instance (p, q) => p * q 37 | 38 | class (Not p => q, Not q => p) => p ⅋ q 39 | instance (Not p => q, Not q => p) => p ⅋ q 40 | 41 | instance (Prop p, Prop q) => Prop (p ⅋ q) where 42 | type Not (p ⅋ q) = Not p * Not q 43 | contradiction = contradiction @p 44 | 45 | instance (Prop p, Prop q) => Prop (p * q) where 46 | type Not (p * q) = Not p ⅋ Not q 47 | contradiction = contradiction @p 48 | 49 | infixr 0 ⊸ 50 | type (⊸) p = (⅋) (Not p) 51 | 52 | fun :: (Prop p, Prop q, p) => (p ⊸ q) :- q 53 | fun = Sub Dict 54 | 55 | contra :: (Prop p, Prop q, Not q) => (p ⊸ q) :- Not p 56 | contra = Sub Dict 57 | 58 | class (p, q) => p & q 59 | instance (p, q) => p & q 60 | 61 | class p + q where 62 | runEither :: (p => Dict r) -> (q => Dict r) -> Dict r 63 | 64 | data G p q k = G ((forall r. (p => Dict r) -> (q => Dict r) -> Dict r)) 65 | 66 | -- (Eq a + Ord [a]) :- Eq [a] 67 | 68 | inl :: forall p q. p :- (p + q) 69 | inl = Sub let 70 | go :: (p => Dict r) -> (q => Dict r) -> Dict r 71 | go pr _ = pr 72 | in unsafeCoerce (G go) 73 | 74 | inr :: forall q p. q :- (p + q) 75 | inr = Sub let 76 | go :: (p => Dict r) -> (q => Dict r) -> Dict r 77 | go _ qr = qr 78 | in unsafeCoerce (G go) 79 | 80 | instance (Prop p, Prop q) => Prop (p & q) where 81 | type Not (p & q) = Not p + Not q 82 | contradiction = runEither @(Not p) @(Not q) (contradiction @p) (contradiction @q) 83 | 84 | instance (Prop p, Prop q) => Prop (p + q) where 85 | type Not (p + q) = Not p & Not q 86 | contradiction = runEither @p @q (contradiction @(Not p)) (contradiction @(Not q)) 87 | 88 | withL' :: (p & q) :- p 89 | withL' = Sub Dict 90 | 91 | withR' :: (p & q) :- q 92 | withR' = Sub Dict 93 | 94 | -- now we need to get into more serious dictionary manipulation 95 | 96 | -- withL :: Dict (p & q ⊸ p) 97 | -- withL = Dict 98 | 99 | 100 | type (⊷) :: Constraint -> Constraint -> Type 101 | data p ⊷ q = Lol (p :- q) (Not q :- Not p) -- should be a with, haskell side 102 | 103 | embedLol :: forall p q. (Prop p, Prop q) => (p ⊸ q) => p ⊷ q 104 | embedLol = Lol (Sub Dict) $ Sub case contra @p @q of 105 | Sub Dict -> Dict 106 | 107 | {- 108 | 109 | class Mk p q where runFun :: p => q 110 | instance (p => q) => Mk p q where runFun = Dict 111 | 112 | data Box p = Box p 113 | 114 | lift :: (p :- Dict q) => 115 | lift 116 | unsafeCoerce (Box (&)) :: Dict (Mk p) 117 | 118 | p -> (p -> r) -> r 119 | 120 | projectLol :: forall p q. (Prop p, Prop q) => (p ⊷ q) -> Dict (p ⊸ q) 121 | projectLol = error "TODO" 122 | 123 | apply :: forall p q. (p => q) => (p :- q) 124 | apply = Sub Dict 125 | -} 126 | 127 | {- 128 | data Box a = Box a 129 | 130 | class Top where 131 | top :: Some Dict 132 | 133 | mkTop :: a => Dict Top 134 | mkTop = a => unsafeCoerce (Box (Some (Dict @a)) 135 | 136 | top' :: a :- Top 137 | top = 138 | 139 | instance Prop Top where 140 | type Not Top = Zero 141 | 142 | instance Prop () where 143 | type Not () = Bot 144 | 145 | class Zero where 146 | zero :: a 147 | 148 | zero :: Dict (Zero ⊸ a) 149 | zero = Sub Dict 150 | 151 | instance Prop Zero where 152 | type Not Zero = Top 153 | 154 | class Bot where 155 | --bot :: (forall r. Top => r) -> 156 | 157 | instance Prop Bottom where 158 | contradiction = _ 159 | -} 160 | 161 | main = return () 162 | 163 | --------------------------------------------------------------------------------