├── .envrc ├── .gitattributes ├── .github └── workflows │ ├── cabal.yml │ └── nix.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── flake.lock ├── flake.nix ├── lambda-calculus-hs.cabal ├── main ├── 00-SimplyTypedEvaluation.hs ├── 01-BidirectionalTypechecking.hs ├── 02-NormalizationByEvaluation.hs ├── 03-Elaboration.hs ├── 04-TypedHoles.hs ├── 05-SystemT.hs ├── 06-Records.hs ├── 07-Subtyping.hs ├── 08-NominalInductiveTypes.hs └── old │ ├── LambdaPi.hs │ ├── MLTT.hs │ ├── SimplyTyped.hs │ ├── SimplyTypedElab.hs │ ├── SimplyTypedModules.hs │ ├── SimplyTypedNBE.hs │ ├── SimplyTypedPatterns.hs │ ├── SystemF.hs │ ├── SystemFOmega.hs │ ├── SystemOmega.hs │ ├── SystemT.hs │ ├── Untyped.hs │ └── UntypedNBE.hs └── scripts.nix /.envrc: -------------------------------------------------------------------------------- 1 | # this line sources your `.envrc.local` file 2 | source_env_if_exists .envrc.local 3 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.tex linguist-vendored 2 | -------------------------------------------------------------------------------- /.github/workflows/cabal.yml: -------------------------------------------------------------------------------- 1 | # NOTE: This should be a good reference for github actions w.r.t haskell 2 | # https://markkarpov.com/post/github-actions-for-haskell-ci.html 3 | 4 | name: cabal:build 5 | on: 6 | push: 7 | branches: 8 | - main 9 | pull_request: 10 | branches: 11 | - main 12 | types: 13 | - opened 14 | - synchronize 15 | 16 | jobs: 17 | check-format: 18 | if: "!contains(github.event.pull_request.labels.*.name, 'ignore-server-format-checks')" 19 | runs-on: ubuntu-latest 20 | steps: 21 | - uses: actions/checkout@v2 22 | - name: Check format 23 | run: | 24 | ORMOLU_VERSION="0.5.0.0" 25 | ORMOLU_URL="https://github.com/tweag/ormolu/releases/download/${ORMOLU_VERSION}/ormolu-Linux.zip" 26 | echo "Downloading from ${ORMOLU_URL}" 27 | curl --fail --location --output ormolu.zip "${ORMOLU_URL}" 28 | unzip ormolu.zip 29 | ./ormolu --mode check $(git ls-files '*.hs') 30 | 31 | build-test: 32 | runs-on: ubuntu-latest 33 | 34 | # NOTE: once the library is ready to be released into the wild 35 | # we could use this code block to run the tests and build the exe. 36 | # on multiple GHC versions and perhaps even multiple cabal versions 37 | strategy: 38 | matrix: 39 | cabal: ["3.4"] 40 | ghc: ["8.10.7", "9.0.2", "9.2.7", "9.4.5"] 41 | 42 | steps: 43 | - name: "Checkout" 44 | uses: actions/checkout@v2 45 | 46 | - name: "Setup" 47 | uses: haskell/actions/setup@v1.2 48 | id: setup-haskell-cabal 49 | with: 50 | ghc-version: "8.10.7" 51 | cabal-version: "3.4" 52 | 53 | - name: "Cache" 54 | uses: actions/cache@v2 55 | env: 56 | cache-name: cache-cabal 57 | with: 58 | path: | 59 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 60 | dist-newstyle 61 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 62 | restore-keys: | 63 | ${{ runner.os }}-build-${{ env.cache-name }}- 64 | ${{ runner.os }}-build- 65 | ${{ runner.os }}- 66 | 67 | - name: "Build" 68 | run: cabal build 69 | 70 | # NOTE: keeping these here for future versions 71 | # - name: "Test" 72 | # run: cabal test $CONFIG 73 | # 74 | # - run: cabal haddock $CONFIG 75 | # - run: cabal sdist 76 | -------------------------------------------------------------------------------- /.github/workflows/nix.yml: -------------------------------------------------------------------------------- 1 | 2 | name: nix:build 3 | on: 4 | push: 5 | branches: 6 | - main 7 | pull_request: 8 | branches: 9 | - main 10 | types: 11 | - opened 12 | - synchronize 13 | jobs: 14 | tests: 15 | runs-on: ubuntu-latest 16 | steps: 17 | - name: Checkout 🛎️ 18 | uses: actions/checkout@v3 19 | 20 | - name: Install Nix ❄ 21 | uses: cachix/install-nix-action@v20 22 | with: 23 | extra_nix_config: | 24 | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} 25 | 26 | - name: Link Cachix 🔌 27 | uses: cachix/cachix-action@v12 28 | with: 29 | name: cofree-coffee 30 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 31 | 32 | - name: Deploy 🚀 33 | run: nix build 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | /presentation/_minted-presentation/ 3 | /.envrc.local 4 | /.direnv/ 5 | /result 6 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for SimplyTypedPresentation 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | HS_FILES = $(shell git ls-files '*.hs' '*.hs-boot') 2 | CHANGED_HS_FILES = $(shell git diff --diff-filter=d --name-only `git merge-base HEAD origin/main` | grep '.*\(\.hs\|hs-boot\)$$') 3 | NIX_FILES = $(shell git ls-files '*.nix' 'nix/*.nix') 4 | SHELL_FILES = $(shell git ls-files '*.sh') 5 | CHANGED_SHELL_FILES = $(shell git diff --diff-filter=d --name-only `git merge-base HEAD origin/main` | grep '.*\.sh$$') 6 | 7 | NIX_FMT = nixpkgs-fmt 8 | ORMOLU = ormolu 9 | ORMOLU_VERSION = $(shell $(ORMOLU) --version | awk 'NR==1 { print $$2 }') 10 | 11 | # Run Shellcheck with access to any file that's sourced, relative to the script's own directory 12 | SHELLCHECK = shellcheck --external-sources --source-path=SCRIPTDIR 13 | 14 | .PHONY: check-ormolu-version 15 | check-ormolu-version: 16 | @if ! [ "$(ORMOLU_VERSION)" = "$(ORMOLU_CHECK_VERSION)" ]; then \ 17 | echo "WARNING: ormolu version mismatch, expected $(ORMOLU_CHECK_VERSION) but got $(ORMOLU_VERSION)"; \ 18 | fi 19 | 20 | .PHONY: format-hs 21 | ## format-hs: auto-format Haskell source code using ormolu 22 | format-hs: check-ormolu-version 23 | @echo running $(ORMOLU) --mode inplace 24 | @$(ORMOLU) --mode inplace $(HS_FILES) 25 | 26 | .PHONY: format-hs-changed 27 | ## format-hs-changed: auto-format Haskell source code using ormolu (changed files only) 28 | format-hs-changed: check-ormolu-version 29 | @echo running $(ORMOLU) --mode inplace 30 | @if [ -n "$(CHANGED_HS_FILES)" ]; then \ 31 | $(ORMOLU) --mode inplace $(CHANGED_HS_FILES); \ 32 | fi 33 | 34 | .PHONY: check-format-hs 35 | ## check-format-hs: check Haskell source code formatting using ormolu 36 | check-format-hs: check-ormolu-version 37 | @echo running $(ORMOLU) --mode check 38 | @$(ORMOLU) --mode check $(HS_FILES) 39 | 40 | .PHONY: check-format-hs-changed 41 | ## check-format-hs-changed: check Haskell source code formatting using ormolu (changed-files-only) 42 | check-format-hs-changed: check-ormolu-version 43 | @echo running $(ORMOLU) --mode check 44 | @if [ -n "$(CHANGED_HS_FILES)" ]; then \ 45 | $(ORMOLU) --mode check $(CHANGED_HS_FILES); \ 46 | fi 47 | 48 | .PHONY: format-nix 49 | ## format-nix: auto-format Nix source code using `nixpkgs-fmt` 50 | format-nix: 51 | @if command -v $(NIX_FMT) > /dev/null; then \ 52 | echo "running $(NIX_FMT)"; \ 53 | $(NIX_FMT) $(NIX_FILES); \ 54 | else \ 55 | echo "$(NIX_FMT) is not installed; skipping"; \ 56 | fi 57 | 58 | .PHONY: check-format-nix 59 | ## check-format-nix: check Nix source code using `nixpkgs-fmt` 60 | check-format-nix: 61 | @if command -v $(NIX_FMT) > /dev/null; then \ 62 | echo "running $(NIX_FMT) --check"; \ 63 | $(NIX_FMT) --check $(NIX_FILES); \ 64 | else \ 65 | echo "$(NIX_FMT) is not installed; skipping"; \ 66 | fi 67 | 68 | .PHONY: format 69 | format: format-hs format-nix 70 | 71 | .PHONY: format-changed 72 | format-changed: format-hs-changed format-nix 73 | 74 | .PHONY: check-format 75 | check-format: check-format-hs check-format-nix 76 | 77 | .PHONY: check-format-changed 78 | check-format-changed: check-format-hs-changed check-format-nix 79 | 80 | .PHONY: lint-shell 81 | ## lint-shell: lint shell scripts using `shellcheck` 82 | lint-shell: 83 | @echo running shellcheck 84 | @$(SHELLCHECK) $(SHELL_FILES) 85 | 86 | .PHONY: lint-shell-changed 87 | ## lint-shell-changed: lint shell scripts using `shellcheck` (changed files only) 88 | lint-shell-changed: 89 | @echo running shellcheck 90 | @if [ -n "$(CHANGED_SHELL_FILES)" ]; then \ 91 | $(SHELLCHECK) $(CHANGED_SHELL_FILES); \ 92 | fi 93 | 94 | .PHONY: build-all 95 | ## build-all: build all haskell packages, or "have i broken anything?" 96 | build-all: $(GENERATED_CABAL_FILES) 97 | cabal build all --enable-tests --enable-benchmarks 98 | 99 | .PHONY: build-tests 100 | ## build-tests: build non-pro graphql executable tests 101 | build-tests: $(GENERATED_CABAL_FILES) 102 | cabal build chat-bots-contrib-test 103 | 104 | .PHONY: clean 105 | ## build-tests: build non-pro graphql executable tests 106 | clean: $(GENERATED_CABAL_FILES) 107 | cabal clean 108 | 109 | .PHONY: test 110 | ## test-no-backends 111 | # the leftover tests with no particular backend, like Remote Schemas 112 | test: 113 | cabal test all 114 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Lambda Calculus Examples 2 | 3 | A series of Lambda Calculus implementations starting from Simply Typed 4 | evaluation, then work up through bidirectional typechecking, 5 | normalization by evaluation, elaboration and then various type system 6 | extensions. 7 | 8 | The goal is to provide best practices examples of all the features you 9 | might want to include in your custom language in one place. 10 | 11 | - [X] SimplyTypedEvaluation 12 | - [X] BidirectionalTypechecking 13 | - [X] NormalizationByEvaluation 14 | - [X] Elaboration 15 | - [X] TypedHoles 16 | - [X] SystemT 17 | - [X] Records 18 | - [X] Subtyping 19 | - [X] Inductive Types (with eliminator based pattern matching) 20 | - [ ] Row Polymorphism 21 | - [ ] System F 22 | - [ ] System Omega 23 | - [ ] Linear Types 24 | - [ ] Case-Trees 25 | - [ ] Martin-Lof Type Theory (Pi and Sigma Types) 26 | - [ ] Equality 27 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1731533236, 9 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1717179513, 24 | "narHash": "sha256-vboIEwIQojofItm2xGCdZCzW96U85l9nDW3ifMuAIdM=", 25 | "owner": "nixos", 26 | "repo": "nixpkgs", 27 | "rev": "63dacb46bf939521bdc93981b4cbb7ecb58427a0", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "nixos", 32 | "ref": "24.05", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "root": { 38 | "inputs": { 39 | "flake-utils": "flake-utils", 40 | "nixpkgs": "nixpkgs" 41 | } 42 | }, 43 | "systems": { 44 | "locked": { 45 | "lastModified": 1681028828, 46 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 47 | "owner": "nix-systems", 48 | "repo": "default", 49 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "nix-systems", 54 | "repo": "default", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Single file Lambda Calculus implementations and presentation slides."; 3 | 4 | inputs = { 5 | nixpkgs.url = github:nixos/nixpkgs/24.05; 6 | flake-utils.url = github:numtide/flake-utils; 7 | }; 8 | 9 | outputs = { self , nixpkgs , flake-utils }: 10 | flake-utils.lib.eachDefaultSystem (system: 11 | let 12 | compilerVersion = "ghc982"; 13 | pkgs = nixpkgs.legacyPackages.${system}; 14 | hsPkgs = pkgs.haskell.packages.${compilerVersion}.override { 15 | overrides = hfinal: hprev: { 16 | lambda-calculus-hs = hfinal.callCabal2nix "lambda-calculus-hs" ./. { }; 17 | }; 18 | }; 19 | in 20 | rec { 21 | packages = 22 | flake-utils.lib.flattenTree 23 | { lambda-calculus-hs = hsPkgs.lambda-calculus-hs; 24 | default = hsPkgs.lambda-calculus-hs; 25 | }; 26 | 27 | devShells = { 28 | default = hsPkgs.shellFor { 29 | withHoogle = true; 30 | packages = p: [ 31 | p.lambda-calculus-hs 32 | ]; 33 | buildInputs = with pkgs; 34 | [ 35 | cabal-install 36 | cabal2nix 37 | haskell-language-server 38 | haskellPackages.ghcid 39 | haskellPackages.fourmolu 40 | haskellPackages.cabal-fmt 41 | ] 42 | ++ (builtins.attrValues (import ./scripts.nix { s = pkgs.writeShellScriptBin; })); 43 | }; 44 | }; 45 | 46 | formatter = pkgs.nixfmt-rfc-style; 47 | }); 48 | } 49 | -------------------------------------------------------------------------------- /lambda-calculus-hs.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: lambda-calculus-hs 3 | version: 0.1.0.0 4 | -- synopsis: 5 | -- description: 6 | -- bug-reports: 7 | -- license: 8 | license-file: LICENSE 9 | author: Solomon Bothwell 10 | maintainer: ssbothwell@gmail.com 11 | -- copyright: 12 | -- category: 13 | build-type: Simple 14 | extra-source-files: CHANGELOG.md 15 | 16 | common common-settings 17 | default-language: Haskell2010 18 | default-extensions: 19 | DeriveFoldable 20 | DeriveFunctor 21 | DerivingStrategies 22 | GeneralizedNewtypeDeriving 23 | ImportQualifiedPost 24 | LambdaCase 25 | NamedFieldPuns 26 | OverloadedStrings 27 | RecordWildCards 28 | StrictData 29 | 30 | ghc-options: 31 | -Wall 32 | -Wcpp-undef 33 | -Widentities 34 | -Wincomplete-record-updates 35 | -Wincomplete-uni-patterns 36 | -Wpartial-fields 37 | -Werror=missing-home-modules 38 | -Wall 39 | -Wcpp-undef 40 | -Widentities 41 | -Wincomplete-record-updates 42 | -Wincomplete-uni-patterns 43 | -Wpartial-fields 44 | -Werror=missing-home-modules 45 | 46 | executable Untyped 47 | import: common-settings 48 | main-is: old/Untyped.hs 49 | hs-source-dirs: main 50 | build-depends: base >= 2 && <5, mtl, transformers, containers 51 | 52 | executable SimplyTypedModules 53 | import: common-settings 54 | main-is: old/SimplyTypedModules.hs 55 | hs-source-dirs: main 56 | build-depends: base >= 2 && <5, mtl, transformers, containers 57 | 58 | executable SimplyTypedPatterns 59 | import: common-settings 60 | main-is: old/SimplyTypedPatterns.hs 61 | hs-source-dirs: main 62 | build-depends: base >= 2 && <5, mtl, transformers, containers, lens 63 | 64 | executable SystemF 65 | import: common-settings 66 | main-is: old/SystemF.hs 67 | hs-source-dirs: main 68 | build-depends: base >= 2 && <5, mtl, transformers, containers, lens 69 | 70 | executable SystemOmega 71 | import: common-settings 72 | main-is: old/SystemOmega.hs 73 | hs-source-dirs: main 74 | build-depends: base >= 2 && <5, mtl, transformers, containers, lens 75 | 76 | executable SystemFOmega 77 | import: common-settings 78 | main-is: old/SystemFOmega.hs 79 | hs-source-dirs: main 80 | build-depends: base >= 2 && <5, mtl, transformers, containers, lens 81 | 82 | executable LambdaPi 83 | import: common-settings 84 | main-is: old/LambdaPi.hs 85 | hs-source-dirs: main 86 | build-depends: base >= 2 && <5, mtl, transformers, containers, lens 87 | 88 | executable UntypedNBE 89 | import: common-settings 90 | main-is: old/UntypedNBE.hs 91 | hs-source-dirs: main 92 | build-depends: base >= 2 && <5, mtl, transformers, containers 93 | 94 | executable MLTT 95 | import: common-settings 96 | main-is: old/MLTT.hs 97 | hs-source-dirs: main 98 | build-depends: base >= 2 && <5, mtl, transformers, containers 99 | 100 | executable 00-SimplyTypedEvaluation 101 | import: common-settings 102 | main-is: 00-SimplyTypedEvaluation.hs 103 | hs-source-dirs: main 104 | build-depends: base >= 2 && <5, mtl, transformers, containers 105 | 106 | executable 01-BidirectionalTypechecking 107 | import: common-settings 108 | main-is: 01-BidirectionalTypechecking.hs 109 | hs-source-dirs: main 110 | build-depends: base >= 2 && <5, mtl, transformers, containers 111 | 112 | executable 02-NormalizationByEvaluation 113 | import: common-settings 114 | main-is: 02-NormalizationByEvaluation.hs 115 | hs-source-dirs: main 116 | build-depends: base >= 2 && <5, mtl, transformers, containers 117 | 118 | executable 03-Elaboration 119 | import: common-settings 120 | main-is: 03-Elaboration.hs 121 | hs-source-dirs: main 122 | build-depends: base >= 2 && <5, mtl, transformers, containers 123 | 124 | executable 04-TypedHoles 125 | import: common-settings 126 | main-is: 04-TypedHoles.hs 127 | hs-source-dirs: main 128 | build-depends: base >= 2 && <5, mtl, transformers, containers 129 | 130 | executable 05-SystemT 131 | import: common-settings 132 | main-is: 05-SystemT.hs 133 | hs-source-dirs: main 134 | build-depends: base >= 2 && <5, mtl, transformers, containers 135 | 136 | executable 06-Records 137 | import: common-settings 138 | main-is: 06-Records.hs 139 | hs-source-dirs: main 140 | build-depends: base >= 2 && <5, mtl, transformers, containers, these, semialign 141 | 142 | executable 07-Subtyping 143 | import: common-settings 144 | main-is: 07-Subtyping.hs 145 | hs-source-dirs: main 146 | build-depends: base >= 2 && <5, mtl, transformers, containers, these, semialign, scientific 147 | 148 | executable 08-NominalInductiveTypes 149 | import: common-settings 150 | main-is: 08-NominalInductiveTypes.hs 151 | hs-source-dirs: main 152 | build-depends: base >= 2 && <5, mtl, transformers, containers, these, semialign, scientific -------------------------------------------------------------------------------- /main/00-SimplyTypedEvaluation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | 3 | module Main where 4 | 5 | -------------------------------------------------------------------------------- 6 | 7 | import Data.Maybe (fromMaybe) 8 | import Data.String 9 | 10 | -------------------------------------------------------------------------------- 11 | -- Utils 12 | 13 | data SnocList a 14 | = Snoc (SnocList a) a 15 | | Nil 16 | deriving (Show, Eq, Ord, Functor, Foldable) 17 | 18 | nth :: SnocList a -> Int -> Maybe a 19 | nth xs i 20 | | i < 0 = Nothing 21 | | otherwise = 22 | let go = \case 23 | (Nil, _) -> Nothing 24 | (Snoc _ x, 0) -> Just x 25 | (Snoc xs' _, i') -> go (xs', i' - 1) 26 | in go (xs, i) 27 | 28 | -------------------------------------------------------------------------------- 29 | -- Types 30 | 31 | -- | 'Term' represents the concrete syntax of our langage generated 32 | -- from text by a parser. 33 | data Term 34 | = Var Ix 35 | | Lam Name Term 36 | | Ap Term Term 37 | | Pair Term Term 38 | | Fst Term 39 | | Snd Term 40 | | Unit 41 | | Anno Type Term 42 | deriving stock (Show, Eq, Ord) 43 | 44 | data Type 45 | = FuncTy Type Type 46 | | PairTy Type Type 47 | | UnitTy 48 | deriving stock (Show, Eq, Ord) 49 | 50 | -- | 'Value' is the evaluated form of expressions in our language. 51 | data Value 52 | = VLam Name Closure 53 | | VPair Value Value 54 | | VUnit 55 | deriving stock (Show, Eq, Ord) 56 | 57 | -- | Debruijn Indices 58 | -- 59 | -- 'Ix' is used to reference lambda bound terms with respect to 60 | -- α-conversion. The index 'n' represents the value bound by the 'n' 61 | -- lambda counting outward from the site of the index. 62 | -- 63 | -- λ.λ.λ.2 64 | -- ^-----^ 65 | newtype Ix 66 | = Ix Int 67 | deriving newtype (Show, Eq, Ord) 68 | 69 | -- | Debruijn Levels 70 | -- 71 | -- Similar to Debruijn Indices but counting inward from the outermost 72 | -- lambda. 73 | -- 74 | -- λ.λ.λ.0 75 | -- ^-----^ 76 | -- 77 | -- Levels eliminate the need to reindex free variables when weakening 78 | -- the context. This is useful in our 'Value' representation of 79 | -- lambdas where we have a 'Closure' holding a stack of free variables. 80 | newtype Lvl 81 | = Lvl Int 82 | deriving newtype (Show, Eq, Ord) 83 | 84 | incLevel :: Lvl -> Lvl 85 | incLevel (Lvl n) = Lvl (1 + n) 86 | 87 | newtype Name = Name {getName :: String} 88 | deriving newtype (Show, Eq, Ord, IsString) 89 | 90 | data Closure = Closure {env :: SnocList Value, body :: Term} 91 | deriving stock (Show, Eq, Ord) 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Evaluator 95 | 96 | eval :: SnocList Value -> Term -> Value 97 | eval env = \case 98 | Var (Ix ix) -> fromMaybe (error "internal error") $ nth env ix 99 | Lam bndr body -> VLam bndr (Closure env body) 100 | Ap tm1 tm2 -> 101 | let fun = eval env tm1 102 | arg = eval env tm2 103 | in doApply fun arg 104 | Pair tm1 tm2 -> 105 | let tm1' = eval env tm1 106 | tm2' = eval env tm2 107 | in VPair tm1' tm2' 108 | Fst tm -> doFst $ eval env tm 109 | Snd tm -> doSnd $ eval env tm 110 | Anno _ty tm -> eval env tm 111 | Unit -> VUnit 112 | 113 | doApply :: Value -> Value -> Value 114 | doApply (VLam _ clo) arg = instantiateClosure clo arg 115 | doApply _ _ = error "impossible case in doApply" 116 | 117 | doFst :: Value -> Value 118 | doFst (VPair a _b) = a 119 | doFst _ = error "impossible case in doFst" 120 | 121 | doSnd :: Value -> Value 122 | doSnd (VPair _a b) = b 123 | doSnd _ = error "impossible case in doSnd" 124 | 125 | instantiateClosure :: Closure -> Value -> Value 126 | instantiateClosure (Closure env body) v = eval (Snoc env v) body 127 | 128 | -------------------------------------------------------------------------------- 129 | -- Main 130 | 131 | run :: Term -> Value 132 | run = eval Nil 133 | 134 | main :: IO () 135 | main = print $ run (Ap idenT' Unit) 136 | 137 | -- λx. x 138 | idenT :: Term 139 | idenT = 140 | Anno 141 | (UnitTy `FuncTy` UnitTy) 142 | (Lam (Name "x") (Var (Ix 0))) 143 | 144 | -- λf. f 145 | idenT' :: Term 146 | idenT' = 147 | Anno 148 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 149 | (Lam (Name "f") (Var (Ix 0))) 150 | 151 | -- λx. λy. x 152 | constT :: Term 153 | constT = 154 | Anno 155 | (UnitTy `FuncTy` (UnitTy `FuncTy` UnitTy)) 156 | (Lam (Name "x") (Lam (Name "_") (Var (Ix 1)))) 157 | 158 | -- λf. λx. f x 159 | applyT :: Term 160 | applyT = 161 | Anno 162 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 163 | (Lam (Name "f") (Lam (Name "x") (Ap (Var (Ix 1)) (Var (Ix 0))))) 164 | -------------------------------------------------------------------------------- /main/01-BidirectionalTypechecking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | 3 | module Main where 4 | 5 | -------------------------------------------------------------------------------- 6 | 7 | import Control.Monad.Except (MonadError (..)) 8 | import Control.Monad.Identity 9 | import Control.Monad.Reader (MonadReader (..)) 10 | import Control.Monad.Trans.Except (ExceptT (..)) 11 | import Control.Monad.Trans.Reader (Reader, ReaderT (..)) 12 | import Data.String 13 | 14 | -------------------------------------------------------------------------------- 15 | -- Utils 16 | 17 | data SnocList a 18 | = Snoc (SnocList a) a 19 | | Nil 20 | deriving (Show, Eq, Ord, Functor, Foldable) 21 | 22 | nth :: SnocList a -> Int -> Maybe a 23 | nth xs i 24 | | i < 0 = Nothing 25 | | otherwise = 26 | let go = \case 27 | (Nil, _) -> Nothing 28 | (Snoc _ x, 0) -> Just x 29 | (Snoc xs' _, i') -> go (xs', i' - 1) 30 | in go (xs, i) 31 | 32 | -------------------------------------------------------------------------------- 33 | -- Types 34 | 35 | -- | 'Term' represents the concrete syntax of our langage generated 36 | -- from text by a parser. 37 | data Term 38 | = Var Ix 39 | | Lam Name Term 40 | | Ap Term Term 41 | | Pair Term Term 42 | | Fst Term 43 | | Snd Term 44 | | Unit 45 | | Anno Type Term 46 | deriving stock (Show, Eq, Ord) 47 | 48 | data Type 49 | = FuncTy Type Type 50 | | PairTy Type Type 51 | | UnitTy 52 | deriving stock (Show, Eq, Ord) 53 | 54 | -- | 'Value' is the evaluated form of expressions in our language. 55 | data Value 56 | = VLam Name Closure 57 | | VPair Value Value 58 | | VUnit 59 | deriving stock (Show, Eq, Ord) 60 | 61 | -- | Debruijn Indices 62 | -- 63 | -- 'Ix' is used to reference lambda bound terms with respect to 64 | -- α-conversion. The index 'n' represents the value bound by the 'n' 65 | -- lambda counting outward from the site of the index. 66 | -- 67 | -- λ.λ.λ.2 68 | -- ^-----^ 69 | newtype Ix 70 | = Ix Int 71 | deriving newtype (Show, Eq, Ord) 72 | 73 | -- | Debruijn Levels 74 | -- 75 | -- Similar to Debruijn Indices but counting inward from the outermost 76 | -- lambda. 77 | -- 78 | -- λ.λ.λ.0 79 | -- ^-----^ 80 | -- 81 | -- Levels eliminate the need to reindex free variables when weakening 82 | -- the context. This is useful in our 'Value' representation of 83 | -- lambdas where we have a 'Closure' holding a stack of free variables. 84 | newtype Lvl 85 | = Lvl Int 86 | deriving newtype (Show, Eq, Ord) 87 | 88 | incLevel :: Lvl -> Lvl 89 | incLevel (Lvl n) = Lvl (1 + n) 90 | 91 | newtype Name = Name {getName :: String} 92 | deriving newtype (Show, Eq, Ord, IsString) 93 | 94 | data Closure = Closure {env :: SnocList Value, body :: Term} 95 | deriving stock (Show, Eq, Ord) 96 | 97 | -------------------------------------------------------------------------------- 98 | -- Environment 99 | 100 | newtype Env = Env {getEnv :: SnocList Type} 101 | deriving stock (Show, Eq, Ord) 102 | 103 | initEnv :: Env 104 | initEnv = Env Nil 105 | 106 | extendEnv :: Type -> Env -> Env 107 | extendEnv ty (Env env) = Env (Snoc env ty) 108 | 109 | resolveVar :: Env -> Ix -> Maybe Type 110 | resolveVar ctx (Ix ix) = nth (getEnv ctx) ix 111 | 112 | -------------------------------------------------------------------------------- 113 | -- Typechecker 114 | 115 | data Error 116 | = TypeError String 117 | | OutOfScopeError Ix 118 | deriving (Show) 119 | 120 | newtype TypecheckM a = TypecheckM {runTypecheckM :: Env -> Either Error a} 121 | deriving 122 | (Functor, Applicative, Monad, MonadReader Env, MonadError Error) 123 | via ExceptT Error (Reader Env) 124 | 125 | newtype Check = Check {runCheck :: Type -> TypecheckM ()} 126 | 127 | newtype Synth = Synth {runSynth :: TypecheckM Type} 128 | 129 | synth :: Term -> Synth 130 | synth = \case 131 | Var bndr -> varTactic bndr 132 | Ap tm1 tm2 -> applyTactic (synth tm1) (check tm2) 133 | Fst tm -> fstTactic (synth tm) 134 | Snd tm -> sndTactic (synth tm) 135 | Anno ty tm -> annoTactic ty (check tm) 136 | tm -> Synth $ throwError $ TypeError $ "Cannot synthesize type for " <> show tm 137 | 138 | check :: Term -> Check 139 | check (Lam _ body) = lamTactic (check body) 140 | check Unit = unitTactic 141 | check (Pair tm1 tm2) = pairTactic (check tm1) (check tm2) 142 | check tm = subTactic (synth tm) 143 | 144 | -- | Var Tactic 145 | -- 146 | -- (x : A) ∈ Γ 147 | -- ─────────── Var⇒ 148 | -- Γ ⊢ x ⇒ A 149 | varTactic :: Ix -> Synth 150 | varTactic ix = Synth $ do 151 | ctx <- ask 152 | maybe (throwError $ OutOfScopeError ix) pure $ resolveVar ctx ix 153 | 154 | -- | Sub Tactic 155 | -- 156 | -- Γ ⊢ e ⇒ A A ≡ B 157 | -- ──────────────── Sub⇐ 158 | -- Γ ⊢ e ⇐ B 159 | subTactic :: Synth -> Check 160 | subTactic (Synth synth') = Check $ \ty1 -> do 161 | ty2 <- synth' 162 | if ty2 == ty1 163 | then pure () 164 | else throwError $ TypeError $ "Expected: " <> show ty1 <> ", but got: " <> show ty2 165 | 166 | -- | Anno Tactic 167 | -- 168 | -- Γ ⊢ e ⇐ A 169 | -- ─────────────── Anno⇒ 170 | -- Γ ⊢ (e : A) ⇒ A 171 | annoTactic :: Type -> Check -> Synth 172 | annoTactic ty (Check checkAnno) = Synth $ do 173 | checkAnno ty 174 | pure ty 175 | 176 | -- | Unit Introduction Tactic 177 | -- 178 | -- ───────────── Unit⇐ 179 | -- Γ ⊢ () ⇐ Unit 180 | unitTactic :: Check 181 | unitTactic = Check $ \case 182 | UnitTy -> pure () 183 | ty -> throwError $ TypeError $ "Expected Unit type but got: " <> show ty 184 | 185 | -- | Lambda Introduction Tactic 186 | -- 187 | -- Γ, x : A₁ ⊢ e ⇐ A₂ 188 | -- ──────────────────── LamIntro⇐ 189 | -- Γ ⊢ (λx.e) ⇐ A₁ → A₂ 190 | lamTactic :: Check -> Check 191 | lamTactic (Check bodyTac) = Check $ \case 192 | a `FuncTy` b -> do 193 | local (extendEnv a) $ bodyTac b 194 | pure () 195 | _ -> throwError $ TypeError "Tried to introduce a lambda at a non-function type" 196 | 197 | -- | Lambda Elination Tactic 198 | -- 199 | -- Γ ⊢ e₁ ⇒ A → B Γ ⊢ e₂ ⇐ A 200 | -- ────────────────────────── LamElim⇐ 201 | -- Γ ⊢ e₁ e₂ ⇒ B 202 | applyTactic :: Synth -> Check -> Synth 203 | applyTactic (Synth funcTac) (Check argTac) = 204 | Synth $ 205 | funcTac >>= \case 206 | (a `FuncTy` b) -> do 207 | argTac a 208 | pure b 209 | ty -> throwError $ TypeError $ "Expected a function type but got " <> show ty 210 | 211 | -- | Pair Introduction Tactic 212 | -- 213 | -- Γ ⊢ a ⇐ A Γ ⊢ b ⇐ B 214 | -- ───────────────────── Pair⇐ 215 | -- Γ ⊢ (a , b) ⇐ A × B 216 | pairTactic :: Check -> Check -> Check 217 | pairTactic (Check checkFst) (Check checkSnd) = Check $ \case 218 | PairTy a b -> do 219 | checkFst a 220 | checkSnd b 221 | pure () 222 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 223 | 224 | -- | Pair Fst Elimination Tactic 225 | -- 226 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 227 | -- ───────────────────── Fst⇒ 228 | -- Γ ⊢ t₁ ⇒ A 229 | fstTactic :: Synth -> Synth 230 | fstTactic (Synth synthPair) = 231 | Synth $ 232 | synthPair >>= \case 233 | PairTy ty1 _ty2 -> pure ty1 234 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 235 | 236 | -- | Pair Snd Elimination Tactic 237 | -- 238 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 239 | -- ───────────────────── Snd⇒ 240 | -- Γ ⊢ t₂ ⇒ A 241 | sndTactic :: Synth -> Synth 242 | sndTactic (Synth synthPair) = 243 | Synth $ 244 | synthPair >>= \case 245 | PairTy _ty1 ty2 -> pure ty2 246 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 247 | 248 | -------------------------------------------------------------------------------- 249 | -- Evaluator 250 | 251 | newtype EvalM a = EvalM {runEvalM :: SnocList Value -> a} 252 | deriving 253 | (Functor, Applicative, Monad, MonadReader (SnocList Value)) 254 | via Reader (SnocList Value) 255 | 256 | eval :: Term -> EvalM Value 257 | eval = \case 258 | Var (Ix ix) -> do 259 | env <- ask 260 | maybe (error "internal error") pure $ nth env ix 261 | Lam bndr body -> do 262 | env <- ask 263 | pure $ VLam bndr (Closure env body) 264 | Ap tm1 tm2 -> do 265 | fun <- eval tm1 266 | arg <- eval tm2 267 | doApply fun arg 268 | Pair tm1 tm2 -> do 269 | tm1' <- eval tm1 270 | tm2' <- eval tm2 271 | pure $ VPair tm1' tm2' 272 | Fst tm -> eval tm >>= doFst 273 | Snd tm -> eval tm >>= doSnd 274 | Anno _ty tm -> eval tm 275 | Unit -> pure VUnit 276 | 277 | doApply :: Value -> Value -> EvalM Value 278 | doApply (VLam _ clo) arg = instantiateClosure clo arg 279 | doApply _ _ = error "impossible case in doApply" 280 | 281 | doFst :: Value -> EvalM Value 282 | doFst (VPair a _b) = pure a 283 | doFst _ = error "impossible case in doFst" 284 | 285 | doSnd :: Value -> EvalM Value 286 | doSnd (VPair _a b) = pure b 287 | doSnd _ = error "impossible case in doSnd" 288 | 289 | instantiateClosure :: Closure -> Value -> EvalM Value 290 | instantiateClosure (Closure env body) v = local (const $ Snoc env v) $ eval body 291 | 292 | -------------------------------------------------------------------------------- 293 | -- Main 294 | 295 | run :: Term -> Either Error Value 296 | run term = 297 | flip runEvalM Nil . eval . const term <$> runTypecheckM (runSynth $ synth term) initEnv 298 | 299 | main :: IO () 300 | main = 301 | case run (Ap idenT Unit) of 302 | Left err -> print err 303 | Right val -> print val 304 | 305 | -- λx. x 306 | idenT :: Term 307 | idenT = 308 | Anno 309 | (UnitTy `FuncTy` UnitTy) 310 | (Lam (Name "x") (Var (Ix 0))) 311 | 312 | -- λf. f 313 | idenT' :: Term 314 | idenT' = 315 | Anno 316 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 317 | (Lam (Name "f") (Var (Ix 0))) 318 | 319 | -- λx. λy. x 320 | constT :: Term 321 | constT = 322 | Anno 323 | (UnitTy `FuncTy` (UnitTy `FuncTy` UnitTy)) 324 | (Lam (Name "x") (Lam (Name "_") (Var (Ix 1)))) 325 | 326 | -- λf. λx. f x 327 | applyT :: Term 328 | applyT = 329 | Anno 330 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 331 | (Lam (Name "f") (Lam (Name "x") (Ap (Var (Ix 1)) (Var (Ix 0))))) 332 | -------------------------------------------------------------------------------- /main/02-NormalizationByEvaluation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | 4 | module Main where 5 | 6 | -------------------------------------------------------------------------------- 7 | 8 | import Control.Monad ((>=>), foldM) 9 | import Control.Monad.Except (MonadError (..)) 10 | import Control.Monad.Identity 11 | import Control.Monad.Reader (MonadReader (..)) 12 | import Control.Monad.Trans.Except (ExceptT (..)) 13 | import Control.Monad.Trans.Reader (Reader, ReaderT (..)) 14 | import Data.String 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Utils 18 | 19 | data SnocList a 20 | = Snoc (SnocList a) a 21 | | Nil 22 | deriving (Show, Eq, Ord, Functor, Foldable) 23 | 24 | nth :: SnocList a -> Int -> Maybe a 25 | nth xs i 26 | | i < 0 = Nothing 27 | | otherwise = 28 | let go = \case 29 | (Nil, _) -> Nothing 30 | (Snoc _ x, 0) -> Just x 31 | (Snoc xs' _, i') -> go (xs', i' - 1) 32 | in go (xs, i) 33 | 34 | -------------------------------------------------------------------------------- 35 | -- Types 36 | 37 | -- | 'Term' represents the concrete syntax of our langage generated 38 | -- from text by a parser. 39 | data Term 40 | = Var Ix 41 | | Lam Name Term 42 | | Ap Term Term 43 | | Pair Term Term 44 | | Fst Term 45 | | Snd Term 46 | | Unit 47 | | Anno Type Term 48 | deriving stock (Show, Eq, Ord) 49 | 50 | data Type 51 | = FuncTy Type Type 52 | | PairTy Type Type 53 | | UnitTy 54 | deriving stock (Show, Eq, Ord) 55 | 56 | -- | 'Value' is the evaluated form of expressions in our language. 57 | data Value 58 | = VNeutral Type Neutral 59 | | VLam Name Closure 60 | | VPair Value Value 61 | | VUnit 62 | deriving stock (Show, Eq, Ord) 63 | 64 | -- | Debruijn Indices 65 | -- 66 | -- 'Ix' is used to reference lambda bound terms with respect to 67 | -- α-conversion. The index 'n' represents the value bound by the 'n' 68 | -- lambda counting outward from the site of the index. 69 | -- 70 | -- λ.λ.λ.2 71 | -- ^-----^ 72 | newtype Ix 73 | = Ix Int 74 | deriving newtype (Show, Eq, Ord) 75 | 76 | -- | Debruijn Levels 77 | -- 78 | -- Similar to Debruijn Indices but counting inward from the outermost 79 | -- lambda. 80 | -- 81 | -- λ.λ.λ.0 82 | -- ^-----^ 83 | -- 84 | -- Levels eliminate the need to reindex free variables when weakening 85 | -- the context. This is useful in our 'Value' representation of 86 | -- lambdas where we have a 'Closure' holding a stack of free variables. 87 | newtype Lvl 88 | = Lvl Int 89 | deriving newtype (Show, Eq, Ord) 90 | 91 | initLevel :: Lvl 92 | initLevel = Lvl 0 93 | 94 | incLevel :: Lvl -> Lvl 95 | incLevel (Lvl n) = Lvl (1 + n) 96 | 97 | newtype Name = Name {getName :: String} 98 | deriving newtype (Show, Eq, Ord, IsString) 99 | 100 | data Neutral = Neutral {head :: Head, spine :: SnocList Frame} 101 | deriving stock (Show, Eq, Ord) 102 | 103 | newtype Head 104 | = VVar Lvl 105 | deriving (Show, Eq, Ord) 106 | 107 | data Frame 108 | = VApp Type Value 109 | | VFst 110 | | VSnd 111 | deriving stock (Show, Eq, Ord) 112 | 113 | pushFrame :: Neutral -> Frame -> Neutral 114 | pushFrame Neutral {..} frame = Neutral {head = head, spine = Snoc spine frame} 115 | 116 | data Closure = Closure {env :: SnocList Value, body :: Term} 117 | deriving stock (Show, Eq, Ord) 118 | 119 | -------------------------------------------------------------------------------- 120 | -- Environment 121 | 122 | newtype Env = Env {getEnv :: SnocList Type} 123 | deriving stock (Show, Eq, Ord) 124 | 125 | initEnv :: Env 126 | initEnv = Env Nil 127 | 128 | extendEnv :: Type -> Env -> Env 129 | extendEnv ty (Env env) = Env (Snoc env ty) 130 | 131 | resolveVar :: Env -> Ix -> Maybe Type 132 | resolveVar ctx (Ix ix) = nth (getEnv ctx) ix 133 | 134 | -------------------------------------------------------------------------------- 135 | -- Typechecker 136 | 137 | data Error 138 | = TypeError String 139 | | OutOfScopeError Ix 140 | deriving (Show) 141 | 142 | newtype TypecheckM a = TypecheckM {runTypecheckM :: Env -> Either Error a} 143 | deriving 144 | (Functor, Applicative, Monad, MonadReader Env, MonadError Error) 145 | via ExceptT Error (Reader Env) 146 | 147 | newtype Check = Check {runCheck :: Type -> TypecheckM ()} 148 | 149 | newtype Synth = Synth {runSynth :: TypecheckM Type} 150 | 151 | synth :: Term -> Synth 152 | synth = \case 153 | Var bndr -> varTactic bndr 154 | Ap tm1 tm2 -> applyTactic (synth tm1) (check tm2) 155 | Fst tm -> fstTactic (synth tm) 156 | Snd tm -> sndTactic (synth tm) 157 | Anno ty tm -> annoTactic ty (check tm) 158 | tm -> Synth $ throwError $ TypeError $ "Cannot synthesize type for " <> show tm 159 | 160 | check :: Term -> Check 161 | check (Lam _ body) = lamTactic (check body) 162 | check Unit = unitTactic 163 | check (Pair tm1 tm2) = pairTactic (check tm1) (check tm2) 164 | check tm = subTactic (synth tm) 165 | 166 | -- | Var Tactic 167 | -- 168 | -- (x : A) ∈ Γ 169 | -- ─────────── Var⇒ 170 | -- Γ ⊢ x ⇒ A 171 | varTactic :: Ix -> Synth 172 | varTactic ix = Synth $ do 173 | ctx <- ask 174 | maybe (throwError $ OutOfScopeError ix) pure $ resolveVar ctx ix 175 | 176 | -- | Sub Tactic 177 | -- 178 | -- Γ ⊢ e ⇒ A A ≡ B 179 | -- ──────────────── Sub⇐ 180 | -- Γ ⊢ e ⇐ B 181 | subTactic :: Synth -> Check 182 | subTactic (Synth synth') = Check $ \ty1 -> do 183 | ty2 <- synth' 184 | if ty2 == ty1 185 | then pure () 186 | else throwError $ TypeError $ "Expected: " <> show ty1 <> ", but got: " <> show ty2 187 | 188 | -- | Anno Tactic 189 | -- 190 | -- Γ ⊢ e ⇐ A 191 | -- ─────────────── Anno⇒ 192 | -- Γ ⊢ (e : A) ⇒ A 193 | annoTactic :: Type -> Check -> Synth 194 | annoTactic ty (Check checkAnno) = Synth $ do 195 | checkAnno ty 196 | pure ty 197 | 198 | -- | Unit Introduction Tactic 199 | -- 200 | -- ───────────── Unit⇐ 201 | -- Γ ⊢ () ⇐ Unit 202 | unitTactic :: Check 203 | unitTactic = Check $ \case 204 | UnitTy -> pure () 205 | ty -> throwError $ TypeError $ "Expected Unit type but got: " <> show ty 206 | 207 | -- | Lambda Introduction Tactic 208 | -- 209 | -- Γ, x : A₁ ⊢ e ⇐ A₂ 210 | -- ──────────────────── LamIntro⇐ 211 | -- Γ ⊢ (λx.e) ⇐ A₁ → A₂ 212 | lamTactic :: Check -> Check 213 | lamTactic (Check bodyTac) = Check $ \case 214 | a `FuncTy` b -> do 215 | local (extendEnv a) $ bodyTac b 216 | pure () 217 | _ -> throwError $ TypeError "Tried to introduce a lambda at a non-function type" 218 | 219 | -- | Lambda Elination Tactic 220 | -- 221 | -- Γ ⊢ e₁ ⇒ A → B Γ ⊢ e₂ ⇐ A 222 | -- ────────────────────────── LamElim⇐ 223 | -- Γ ⊢ e₁ e₂ ⇒ B 224 | applyTactic :: Synth -> Check -> Synth 225 | applyTactic (Synth funcTac) (Check argTac) = 226 | Synth $ 227 | funcTac >>= \case 228 | (a `FuncTy` b) -> do 229 | argTac a 230 | pure b 231 | ty -> throwError $ TypeError $ "Expected a function type but got " <> show ty 232 | 233 | -- | Pair Introduction Tactic 234 | -- 235 | -- Γ ⊢ a ⇐ A Γ ⊢ b ⇐ B 236 | -- ───────────────────── Pair⇐ 237 | -- Γ ⊢ (a , b) ⇐ A × B 238 | pairTactic :: Check -> Check -> Check 239 | pairTactic (Check checkFst) (Check checkSnd) = Check $ \case 240 | PairTy a b -> do 241 | checkFst a 242 | checkSnd b 243 | pure () 244 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 245 | 246 | -- | Pair Fst Elimination Tactic 247 | -- 248 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 249 | -- ───────────────────── Fst⇒ 250 | -- Γ ⊢ t₁ ⇒ A 251 | fstTactic :: Synth -> Synth 252 | fstTactic (Synth synthPair) = 253 | Synth $ 254 | synthPair >>= \case 255 | PairTy ty1 _ty2 -> pure ty1 256 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 257 | 258 | -- | Pair Snd Elimination Tactic 259 | -- 260 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 261 | -- ───────────────────── Snd⇒ 262 | -- Γ ⊢ t₂ ⇒ A 263 | sndTactic :: Synth -> Synth 264 | sndTactic (Synth synthPair) = 265 | Synth $ 266 | synthPair >>= \case 267 | PairTy _ty1 ty2 -> pure ty2 268 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 269 | 270 | -------------------------------------------------------------------------------- 271 | -- Evaluator 272 | 273 | newtype EvalM a = EvalM {runEvalM :: SnocList Value -> a} 274 | deriving 275 | (Functor, Applicative, Monad, MonadReader (SnocList Value)) 276 | via Reader (SnocList Value) 277 | 278 | eval :: Term -> EvalM Value 279 | eval = \case 280 | Var (Ix ix) -> do 281 | env <- ask 282 | maybe (error "internal error") pure $ nth env ix 283 | Lam bndr body -> do 284 | env <- ask 285 | pure $ VLam bndr (Closure env body) 286 | Ap tm1 tm2 -> do 287 | fun <- eval tm1 288 | arg <- eval tm2 289 | doApply fun arg 290 | Pair tm1 tm2 -> do 291 | tm1' <- eval tm1 292 | tm2' <- eval tm2 293 | pure $ VPair tm1' tm2' 294 | Fst tm -> eval tm >>= doFst 295 | Snd tm -> eval tm >>= doSnd 296 | Anno _ty tm -> eval tm 297 | Unit -> pure VUnit 298 | 299 | doApply :: Value -> Value -> EvalM Value 300 | doApply (VLam _ clo) arg = instantiateClosure clo arg 301 | doApply (VNeutral (FuncTy ty1 ty2) neu) arg = pure $ VNeutral ty2 (pushFrame neu (VApp ty1 arg)) 302 | doApply _ _ = error "impossible case in doApply" 303 | 304 | doFst :: Value -> EvalM Value 305 | doFst (VPair a _b) = pure a 306 | doFst _ = error "impossible case in doFst" 307 | 308 | doSnd :: Value -> EvalM Value 309 | doSnd (VPair _a b) = pure b 310 | doSnd _ = error "impossible case in doSnd" 311 | 312 | instantiateClosure :: Closure -> Value -> EvalM Value 313 | instantiateClosure (Closure env body) v = local (const $ Snoc env v) $ eval body 314 | 315 | -------------------------------------------------------------------------------- 316 | -- Quoting 317 | 318 | quote :: Lvl -> Type -> Value -> EvalM Term 319 | quote l (FuncTy ty1 ty2) (VLam bndr clo@(Closure _env _body)) = do 320 | body <- bindVar ty1 l $ \v l' -> do 321 | clo <- instantiateClosure clo v 322 | quote l' ty2 clo 323 | pure $ Lam bndr body 324 | quote l (FuncTy ty1 ty2) f = do 325 | body <- bindVar ty1 l $ \v l' -> 326 | doApply f v >>= quote l' ty2 327 | pure $ Lam "_" body 328 | quote l (PairTy ty1 ty2) (VPair tm1 tm2) = do 329 | tm1' <- quote l ty1 tm1 330 | tm2' <- quote l ty2 tm2 331 | pure $ Pair tm1' tm2' 332 | quote l _ (VNeutral _ neu) = quoteNeutral l neu 333 | quote _ _ VUnit = pure Unit 334 | quote _ _ _ = error "impossible case in quote" 335 | 336 | bindVar :: Type -> Lvl -> (Value -> Lvl -> a) -> a 337 | bindVar ty lvl f = 338 | let v = VNeutral ty $ Neutral (VVar lvl) Nil 339 | in f v $ incLevel lvl 340 | 341 | quoteLevel :: Lvl -> Lvl -> Ix 342 | quoteLevel (Lvl l) (Lvl x) = Ix (l - (x + 1)) 343 | 344 | quoteNeutral :: Lvl -> Neutral -> EvalM Term 345 | quoteNeutral l Neutral {..} = foldM (quoteFrame l) (quoteHead l head) spine 346 | 347 | quoteHead :: Lvl -> Head -> Term 348 | quoteHead l (VVar x) = Var $ quoteLevel l x 349 | 350 | quoteFrame :: Lvl -> Term -> Frame -> EvalM Term 351 | quoteFrame l tm = \case 352 | VApp ty arg -> Ap tm <$> quote l ty arg 353 | VFst -> pure $ Fst tm 354 | VSnd -> pure $ Snd tm 355 | 356 | -------------------------------------------------------------------------------- 357 | -- Main 358 | 359 | run :: Term -> Either Error Term 360 | run term = do 361 | type' <- runTypecheckM (runSynth $ synth term) initEnv 362 | pure $ flip runEvalM Nil $ (eval >=> quote initLevel type') term 363 | 364 | main :: IO () 365 | main = 366 | case run (Ap idenT Unit) of 367 | Left err -> print err 368 | Right val -> print val 369 | 370 | -- λx. x 371 | idenT :: Term 372 | idenT = 373 | Anno 374 | (UnitTy `FuncTy` UnitTy) 375 | (Lam (Name "x") (Var (Ix 0))) 376 | 377 | -- λf. f 378 | idenT' :: Term 379 | idenT' = 380 | Anno 381 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 382 | (Lam (Name "f") (Var (Ix 0))) 383 | 384 | -- λx. λy. x 385 | constT :: Term 386 | constT = 387 | Anno 388 | (UnitTy `FuncTy` (UnitTy `FuncTy` UnitTy)) 389 | (Lam (Name "x") (Lam (Name "_") (Var (Ix 1)))) 390 | 391 | -- λf. λx. f x 392 | applyT :: Term 393 | applyT = 394 | Anno 395 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 396 | (Lam (Name "f") (Lam (Name "x") (Ap (Var (Ix 1)) (Var (Ix 0))))) 397 | -------------------------------------------------------------------------------- /main/03-Elaboration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | 4 | module Main where 5 | 6 | -------------------------------------------------------------------------------- 7 | 8 | import Control.Monad (foldM) 9 | import Control.Monad.Except (MonadError (..)) 10 | import Control.Monad.Identity 11 | import Control.Monad.Reader (MonadReader (..)) 12 | import Control.Monad.Trans.Except (ExceptT (..)) 13 | import Control.Monad.Trans.Reader (Reader, ReaderT (..)) 14 | import Data.Foldable (find) 15 | import Data.Maybe (fromMaybe) 16 | import Data.String 17 | 18 | -------------------------------------------------------------------------------- 19 | -- Utils 20 | 21 | data SnocList a 22 | = Snoc (SnocList a) a 23 | | Nil 24 | deriving (Show, Eq, Ord, Functor, Foldable) 25 | 26 | nth :: SnocList a -> Int -> Maybe a 27 | nth xs i 28 | | i < 0 = Nothing 29 | | otherwise = 30 | let go = \case 31 | (Nil, _) -> Nothing 32 | (Snoc _ x, 0) -> Just x 33 | (Snoc xs' _, i') -> go (xs', i' - 1) 34 | in go (xs, i) 35 | 36 | -------------------------------------------------------------------------------- 37 | -- Types 38 | 39 | -- | 'Term' represents the concrete syntax of our langage generated 40 | -- from text by a parser. 41 | data Term 42 | = Var Name 43 | | Lam Name Term 44 | | Ap Term Term 45 | | Pair Term Term 46 | | Fst Term 47 | | Snd Term 48 | | Unit 49 | | Anno Type Term 50 | deriving stock (Show, Eq, Ord) 51 | 52 | data Type 53 | = FuncTy Type Type 54 | | PairTy Type Type 55 | | UnitTy 56 | deriving stock (Show, Eq, Ord) 57 | 58 | -- | 'Syntax' is the internal abstract syntax of our language. We 59 | -- elaborate 'Term' values into 'Syntax' during typechecking. 60 | data Syntax 61 | = SVar Ix 62 | | SLam Name Syntax 63 | | SAp Syntax Syntax 64 | | SPair Syntax Syntax 65 | | SFst Syntax 66 | | SSnd Syntax 67 | | SUnit 68 | deriving stock (Show, Eq, Ord) 69 | 70 | -- | 'Value' is the evaluated form of expressions in our language. 71 | data Value 72 | = VNeutral Type Neutral 73 | | VLam Name Closure 74 | | VPair Value Value 75 | | VUnit 76 | deriving stock (Show, Eq, Ord) 77 | 78 | -- | Debruijn Indices 79 | -- 80 | -- 'Ix' is used to reference lambda bound terms with respect to 81 | -- α-conversion. The index 'n' represents the value bound by the 'n' 82 | -- lambda counting outward from the site of the index. 83 | -- 84 | -- λ.λ.λ.2 85 | -- ^-----^ 86 | newtype Ix 87 | = Ix Int 88 | deriving newtype (Show, Eq, Ord) 89 | 90 | -- | Debruijn Levels 91 | -- 92 | -- Similar to Debruijn Indices but counting inward from the outermost 93 | -- lambda. 94 | -- 95 | -- λ.λ.λ.0 96 | -- ^-----^ 97 | -- 98 | -- Levels eliminate the need to reindex free variables when weakening 99 | -- the context. This is useful in our 'Value' representation of 100 | -- lambdas where we have a 'Closure' holding a stack of free variables. 101 | newtype Lvl 102 | = Lvl Int 103 | deriving newtype (Show, Eq, Ord) 104 | 105 | initLevel :: Lvl 106 | initLevel = Lvl 0 107 | 108 | incLevel :: Lvl -> Lvl 109 | incLevel (Lvl n) = Lvl (1 + n) 110 | 111 | newtype Name = Name {getName :: String} 112 | deriving newtype (Show, Eq, Ord, IsString) 113 | 114 | data Neutral = Neutral {head :: Head, spine :: SnocList Frame} 115 | deriving stock (Show, Eq, Ord) 116 | 117 | newtype Head 118 | = VVar Lvl 119 | deriving (Show, Eq, Ord) 120 | 121 | data Frame 122 | = VApp Type Value 123 | | VFst 124 | | VSnd 125 | deriving stock (Show, Eq, Ord) 126 | 127 | pushFrame :: Neutral -> Frame -> Neutral 128 | pushFrame Neutral {..} frame = Neutral {head = head, spine = Snoc spine frame} 129 | 130 | data Closure = Closure {env :: SnocList Value, body :: Syntax} 131 | deriving stock (Show, Eq, Ord) 132 | 133 | -------------------------------------------------------------------------------- 134 | -- Environment 135 | 136 | data Cell = Cell 137 | { cellName :: Name, 138 | cellType :: Type, 139 | cellValue :: Value 140 | } 141 | deriving stock (Show, Eq, Ord) 142 | 143 | data Env = Env 144 | { locals :: SnocList Value, 145 | localNames :: [Cell], 146 | size :: Int 147 | } 148 | deriving stock (Show, Eq, Ord) 149 | 150 | initEnv :: Env 151 | initEnv = Env Nil [] 0 152 | 153 | extendLocalNames :: Env -> Cell -> Env 154 | extendLocalNames e@Env {localNames} cell = e {localNames = cell : localNames} 155 | 156 | bindCell :: Cell -> Env -> Env 157 | bindCell cell@Cell {..} Env {..} = 158 | Env 159 | { locals = Snoc locals cellValue, 160 | localNames = cell : localNames, 161 | size = size + 1 162 | } 163 | 164 | resolveCell :: Env -> Name -> Maybe Cell 165 | resolveCell Env {..} bndr = find ((== bndr) . cellName) localNames 166 | 167 | freshVar :: Env -> Type -> Value 168 | freshVar Env {size} ty = VNeutral ty $ Neutral (VVar $ Lvl size) Nil 169 | 170 | freshCell :: Env -> Name -> Type -> Cell 171 | freshCell ctx name ty = Cell name ty (freshVar ctx ty) 172 | 173 | -------------------------------------------------------------------------------- 174 | -- Typechecker 175 | 176 | data Error 177 | = TypeError String 178 | | OutOfScopeError Name 179 | deriving (Show) 180 | 181 | newtype TypecheckM a = TypecheckM {runTypecheckM :: Env -> Either Error a} 182 | deriving 183 | (Functor, Applicative, Monad, MonadReader Env, MonadError Error) 184 | via ExceptT Error (Reader Env) 185 | 186 | newtype Check = Check {runCheck :: Type -> TypecheckM Syntax} 187 | 188 | newtype Synth = Synth {runSynth :: TypecheckM (Type, Syntax)} 189 | 190 | synth :: Term -> Synth 191 | synth = \case 192 | Var bndr -> varTactic bndr 193 | Ap tm1 tm2 -> applyTactic (synth tm1) (check tm2) 194 | Fst tm -> fstTactic (synth tm) 195 | Snd tm -> sndTactic (synth tm) 196 | Anno ty tm -> annoTactic ty (check tm) 197 | tm -> Synth $ throwError $ TypeError $ "Cannot synthesize type for " <> show tm 198 | 199 | check :: Term -> Check 200 | check (Lam bndr body) = lamTactic bndr (check body) 201 | check Unit = unitTactic 202 | check (Pair tm1 tm2) = pairTactic (check tm1) (check tm2) 203 | check tm = subTactic (synth tm) 204 | 205 | -- | Var Tactic 206 | -- 207 | -- (x : A) ∈ Γ 208 | -- ─────────── Var⇒ 209 | -- Γ ⊢ x ⇒ A 210 | varTactic :: Name -> Synth 211 | varTactic bndr = Synth $ do 212 | ctx <- ask 213 | 214 | case resolveCell ctx bndr of 215 | Just Cell {..} -> do 216 | let quoted = flip runEvalM (locals ctx) $ quote (Lvl $ size ctx) cellType cellValue 217 | pure (cellType, quoted) 218 | Nothing -> throwError $ OutOfScopeError bndr 219 | 220 | -- | Sub Tactic 221 | -- 222 | -- Γ ⊢ e ⇒ A A ≡ B 223 | -- ──────────────── Sub⇐ 224 | -- Γ ⊢ e ⇐ B 225 | subTactic :: Synth -> Check 226 | subTactic (Synth synth) = Check $ \ty1 -> do 227 | (ty2, tm) <- synth 228 | if ty2 == ty1 229 | then pure tm 230 | else throwError $ TypeError $ "Expected: " <> show ty1 <> ", but got: " <> show ty2 231 | 232 | -- | Anno Tactic 233 | -- 234 | -- Γ ⊢ e ⇐ A 235 | -- ─────────────── Anno⇒ 236 | -- Γ ⊢ (e : A) ⇒ A 237 | annoTactic :: Type -> Check -> Synth 238 | annoTactic ty (Check check) = Synth $ do 239 | tm <- check ty 240 | pure (ty, tm) 241 | 242 | -- | Unit Introduction Tactic 243 | -- 244 | -- ───────────── Unit⇐ 245 | -- Γ ⊢ () ⇐ Unit 246 | unitTactic :: Check 247 | unitTactic = Check $ \case 248 | UnitTy -> pure SUnit 249 | ty -> throwError $ TypeError $ "Expected Unit type but got: " <> show ty 250 | 251 | -- | Lambda Introduction Tactic 252 | -- 253 | -- Γ, x : A₁ ⊢ e ⇐ A₂ 254 | -- ──────────────────── LamIntro⇐ 255 | -- Γ ⊢ (λx.e) ⇐ A₁ → A₂ 256 | lamTactic :: Name -> Check -> Check 257 | lamTactic bndr (Check bodyTac) = Check $ \case 258 | a `FuncTy` b -> do 259 | ctx <- ask 260 | let var = freshCell ctx bndr a 261 | fiber <- local (bindCell var) $ bodyTac b 262 | pure $ SLam bndr fiber 263 | _ -> throwError $ TypeError "Tried to introduce a lambda at a non-function type" 264 | 265 | -- | Lambda Elination Tactic 266 | -- 267 | -- Γ ⊢ e₁ ⇒ A → B Γ ⊢ e₂ ⇐ A 268 | -- ────────────────────────── LamElim⇐ 269 | -- Γ ⊢ e₁ e₂ ⇒ B 270 | applyTactic :: Synth -> Check -> Synth 271 | applyTactic (Synth funcTac) (Check argTac) = 272 | Synth $ 273 | funcTac >>= \case 274 | (a `FuncTy` b, f) -> do 275 | arg <- argTac a 276 | pure (b, SAp f arg) 277 | (ty, _) -> throwError $ TypeError $ "Expected a function type but got " <> show ty 278 | 279 | -- | Pair Introduction Tactic 280 | -- 281 | -- Γ ⊢ a ⇐ A Γ ⊢ b ⇐ B 282 | -- ───────────────────── Pair⇐ 283 | -- Γ ⊢ (a , b) ⇐ A × B 284 | pairTactic :: Check -> Check -> Check 285 | pairTactic (Check checkFst) (Check checkSnd) = Check $ \case 286 | PairTy a b -> do 287 | tm1 <- checkFst a 288 | tm2 <- checkSnd b 289 | pure (SPair tm1 tm2) 290 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 291 | 292 | -- | Pair Fst Elimination Tactic 293 | -- 294 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 295 | -- ───────────────────── Fst⇒ 296 | -- Γ ⊢ t₁ ⇒ A 297 | fstTactic :: Synth -> Synth 298 | fstTactic (Synth synth) = 299 | Synth $ 300 | synth >>= \case 301 | (PairTy ty1 _ty2, SPair tm1 _tm2) -> pure (ty1, tm1) 302 | (ty, _) -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 303 | 304 | -- | Pair Snd Elimination Tactic 305 | -- 306 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 307 | -- ───────────────────── Snd⇒ 308 | -- Γ ⊢ t₂ ⇒ A 309 | sndTactic :: Synth -> Synth 310 | sndTactic (Synth synth) = 311 | Synth $ 312 | synth >>= \case 313 | (PairTy _ty1 ty2, SPair _tm1 tm2) -> pure (ty2, tm2) 314 | (ty, _) -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 315 | 316 | -------------------------------------------------------------------------------- 317 | -- Evaluator 318 | 319 | newtype EvalM a = EvalM {runEvalM :: SnocList Value -> a} 320 | deriving 321 | (Functor, Applicative, Monad, MonadReader (SnocList Value)) 322 | via Reader (SnocList Value) 323 | 324 | eval :: Syntax -> EvalM Value 325 | eval = \case 326 | SVar (Ix ix) -> do 327 | env <- ask 328 | pure $ fromMaybe (error "internal error") $ nth env ix 329 | SLam bndr body -> do 330 | env <- ask 331 | pure $ VLam bndr (Closure env body) 332 | SAp tm1 tm2 -> do 333 | fun <- eval tm1 334 | arg <- eval tm2 335 | doApply fun arg 336 | SPair tm1 tm2 -> do 337 | tm1' <- eval tm1 338 | tm2' <- eval tm2 339 | pure $ VPair tm1' tm2' 340 | SFst tm -> eval tm >>= doFst 341 | SSnd tm -> eval tm >>= doSnd 342 | SUnit -> pure VUnit 343 | 344 | doApply :: Value -> Value -> EvalM Value 345 | doApply (VLam _ clo) arg = instantiateClosure clo arg 346 | doApply (VNeutral (FuncTy ty1 ty2) neu) arg = pure $ VNeutral ty2 (pushFrame neu (VApp ty1 arg)) 347 | doApply _ _ = error "impossible case in doApply" 348 | 349 | doFst :: Value -> EvalM Value 350 | doFst (VPair a _b) = pure a 351 | doFst _ = error "impossible case in doFst" 352 | 353 | doSnd :: Value -> EvalM Value 354 | doSnd (VPair _a b) = pure b 355 | doSnd _ = error "impossible case in doSnd" 356 | 357 | instantiateClosure :: Closure -> Value -> EvalM Value 358 | instantiateClosure (Closure env body) v = local (const $ Snoc env v) $ eval body 359 | 360 | -------------------------------------------------------------------------------- 361 | -- Quoting 362 | 363 | quote :: Lvl -> Type -> Value -> EvalM Syntax 364 | quote l (FuncTy ty1 ty2) (VLam bndr clo@(Closure _env _body)) = do 365 | body <- bindVar ty1 l $ \v l' -> do 366 | clo <- instantiateClosure clo v 367 | quote l' ty2 clo 368 | pure $ SLam bndr body 369 | quote l (FuncTy ty1 ty2) f = do 370 | body <- bindVar ty1 l $ \v l' -> 371 | doApply f v >>= quote l' ty2 372 | pure $ SLam "_" body 373 | quote l (PairTy ty1 ty2) (VPair tm1 tm2) = do 374 | tm1' <- quote l ty1 tm1 375 | tm2' <- quote l ty2 tm2 376 | pure $ SPair tm1' tm2' 377 | quote l _ (VNeutral _ neu) = quoteNeutral l neu 378 | quote _ _ VUnit = pure SUnit 379 | quote _ _ _ = error "impossible case in quote" 380 | 381 | quoteLevel :: Lvl -> Lvl -> Ix 382 | quoteLevel (Lvl l) (Lvl x) = Ix (l - (x + 1)) 383 | 384 | quoteNeutral :: Lvl -> Neutral -> EvalM Syntax 385 | quoteNeutral l Neutral {..} = foldM (quoteFrame l) (quoteHead l head) spine 386 | 387 | quoteHead :: Lvl -> Head -> Syntax 388 | quoteHead l (VVar x) = SVar (quoteLevel l x) 389 | 390 | quoteFrame :: Lvl -> Syntax -> Frame -> EvalM Syntax 391 | quoteFrame l tm = \case 392 | VApp ty arg -> SAp tm <$> quote l ty arg 393 | VFst -> pure $ SFst tm 394 | VSnd -> pure $ SSnd tm 395 | 396 | bindVar :: Type -> Lvl -> (Value -> Lvl -> a) -> a 397 | bindVar ty lvl f = 398 | let v = VNeutral ty $ Neutral (VVar lvl) Nil 399 | in f v $ incLevel lvl 400 | 401 | -------------------------------------------------------------------------------- 402 | -- Main 403 | 404 | run :: Term -> Either Error Syntax 405 | run term = do 406 | (type', syntax) <- runTypecheckM (runSynth $ synth term) initEnv 407 | let result = flip runEvalM Nil $ do 408 | value <- eval syntax 409 | quote initLevel type' value 410 | pure result 411 | 412 | main :: IO () 413 | main = 414 | case run (Ap idenT Unit) of 415 | Left err -> print err 416 | Right result -> print result 417 | 418 | -- λx. x 419 | idenT :: Term 420 | idenT = 421 | Anno 422 | (UnitTy `FuncTy` UnitTy) 423 | (Lam (Name "x") (Var "x")) 424 | 425 | -- λf. f 426 | idenT' :: Term 427 | idenT' = 428 | Anno 429 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 430 | (Lam (Name "f") (Var "f")) 431 | 432 | -- λx. λy. x 433 | constT :: Term 434 | constT = 435 | Anno 436 | (UnitTy `FuncTy` (UnitTy `FuncTy` UnitTy)) 437 | (Lam (Name "x") (Lam (Name "_") (Var "f"))) 438 | 439 | -- λf. λx. f x 440 | applyT :: Term 441 | applyT = 442 | Anno 443 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 444 | (Lam (Name "f") (Lam (Name "x") (Ap (Var "f") (Var "x")))) 445 | -------------------------------------------------------------------------------- /main/04-TypedHoles.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | 4 | module Main where 5 | 6 | -------------------------------------------------------------------------------- 7 | 8 | import Control.Monad (foldM) 9 | import Control.Monad.Except (MonadError (..)) 10 | import Control.Monad.Identity 11 | import Control.Monad.Reader (MonadReader (..)) 12 | import Control.Monad.Trans.Except (ExceptT (..)) 13 | import Control.Monad.Trans.Reader (Reader, ReaderT (..)) 14 | import Control.Monad.Trans.Writer.Strict (WriterT (..)) 15 | import Control.Monad.Writer.Strict (MonadWriter (..)) 16 | import Data.Foldable (find) 17 | import Data.Maybe (fromMaybe) 18 | import Data.String 19 | 20 | -------------------------------------------------------------------------------- 21 | -- Utils 22 | 23 | data SnocList a 24 | = Snoc (SnocList a) a 25 | | Nil 26 | deriving (Show, Eq, Ord, Functor, Foldable) 27 | 28 | nth :: SnocList a -> Int -> Maybe a 29 | nth xs i 30 | | i < 0 = Nothing 31 | | otherwise = 32 | let go = \case 33 | (Nil, _) -> Nothing 34 | (Snoc _ x, 0) -> Just x 35 | (Snoc xs' _, i') -> go (xs', i' - 1) 36 | in go (xs, i) 37 | 38 | -------------------------------------------------------------------------------- 39 | -- Types 40 | 41 | -- | 'Term' represents the concrete syntax of our langage generated 42 | -- from text by a parser. 43 | data Term 44 | = Var Name 45 | | Lam Name Term 46 | | Ap Term Term 47 | | Pair Term Term 48 | | Fst Term 49 | | Snd Term 50 | | Unit 51 | | Anno Type Term 52 | | Hole 53 | deriving stock (Show, Eq, Ord) 54 | 55 | data Type 56 | = FuncTy Type Type 57 | | PairTy Type Type 58 | | UnitTy 59 | deriving stock (Show, Eq, Ord) 60 | 61 | -- | 'Syntax' is the internal abstract syntax of our language. We 62 | -- elaborate 'Term' values into 'Syntax' during typechecking. 63 | data Syntax 64 | = SVar Ix 65 | | SLam Name Syntax 66 | | SAp Syntax Syntax 67 | | SPair Syntax Syntax 68 | | SFst Syntax 69 | | SSnd Syntax 70 | | SUnit 71 | | SHole Type 72 | deriving stock (Show, Eq, Ord) 73 | 74 | -- | 'Value' is the evaluated form of expressions in our language. 75 | data Value 76 | = VNeutral Type Neutral 77 | | VLam Name Closure 78 | | VPair Value Value 79 | | VUnit 80 | deriving stock (Show, Eq, Ord) 81 | 82 | -- | Debruijn Indices 83 | -- 84 | -- 'Ix' is used to reference lambda bound terms with respect to 85 | -- α-conversion. The index 'n' represents the value bound by the 'n' 86 | -- lambda counting outward from the site of the index. 87 | -- 88 | -- λ.λ.λ.2 89 | -- ^-----^ 90 | newtype Ix 91 | = Ix Int 92 | deriving newtype (Show, Eq, Ord) 93 | 94 | -- | Debruijn Levels 95 | -- 96 | -- Similar to Debruijn Indices but counting inward from the outermost 97 | -- lambda. 98 | -- 99 | -- λ.λ.λ.0 100 | -- ^-----^ 101 | -- 102 | -- Levels eliminate the need to reindex free variables when weakening 103 | -- the context. This is useful in our 'Value' representation of 104 | -- lambdas where we have a 'Closure' holding a stack of free variables. 105 | newtype Lvl 106 | = Lvl Int 107 | deriving newtype (Show, Eq, Ord) 108 | 109 | initLevel :: Lvl 110 | initLevel = Lvl 0 111 | 112 | incLevel :: Lvl -> Lvl 113 | incLevel (Lvl n) = Lvl (1 + n) 114 | 115 | newtype Name = Name {getName :: String} 116 | deriving newtype (Show, Eq, Ord, IsString) 117 | 118 | data Neutral = Neutral {head :: Head, spine :: SnocList Frame} 119 | deriving stock (Show, Eq, Ord) 120 | 121 | data Head 122 | = VVar Lvl 123 | | VHole Type 124 | deriving (Show, Eq, Ord) 125 | 126 | data Frame 127 | = VApp Type Value 128 | | VFst 129 | | VSnd 130 | deriving stock (Show, Eq, Ord) 131 | 132 | pushFrame :: Neutral -> Frame -> Neutral 133 | pushFrame Neutral {..} frame = Neutral {head = head, spine = Snoc spine frame} 134 | 135 | data Closure = Closure {env :: SnocList Value, body :: Syntax} 136 | deriving stock (Show, Eq, Ord) 137 | 138 | -------------------------------------------------------------------------------- 139 | -- Environment 140 | 141 | data Cell = Cell 142 | { cellName :: Name, 143 | cellType :: Type, 144 | cellValue :: Value 145 | } 146 | deriving stock (Show, Eq, Ord) 147 | 148 | data Env = Env 149 | { locals :: SnocList Value, 150 | localNames :: [Cell], 151 | size :: Int, 152 | holes :: [Type] 153 | } 154 | deriving stock (Show, Eq, Ord) 155 | 156 | initEnv :: Env 157 | initEnv = Env Nil [] 0 mempty 158 | 159 | extendLocalNames :: Env -> Cell -> Env 160 | extendLocalNames e@Env {localNames} cell = e {localNames = cell : localNames} 161 | 162 | extendHoles :: Type -> Env -> Env 163 | extendHoles ty e@Env {holes} = e {holes = ty : holes} 164 | 165 | bindCell :: Cell -> Env -> Env 166 | bindCell cell@Cell {..} Env {..} = 167 | Env 168 | { locals = Snoc locals cellValue, 169 | localNames = cell : localNames, 170 | size = size + 1, 171 | holes = holes 172 | } 173 | 174 | resolveCell :: Env -> Name -> Maybe Cell 175 | resolveCell Env {..} bndr = find ((== bndr) . cellName) localNames 176 | 177 | freshVar :: Env -> Type -> Value 178 | freshVar Env {size} ty = VNeutral ty $ Neutral (VVar $ Lvl size) Nil 179 | 180 | freshCell :: Env -> Name -> Type -> Cell 181 | freshCell ctx name ty = Cell name ty (freshVar ctx ty) 182 | 183 | -------------------------------------------------------------------------------- 184 | -- Typechecker 185 | 186 | data Error 187 | = TypeError String 188 | | OutOfScopeError Name 189 | deriving (Show) 190 | 191 | newtype Holes = Holes {getHoles :: [Type]} 192 | deriving newtype (Show, Semigroup, Monoid) 193 | 194 | newtype TypecheckM a = TypecheckM {runTypecheckM :: Env -> (Either Error a, Holes)} 195 | deriving 196 | (Functor, Applicative, Monad, MonadReader Env, MonadError Error, MonadWriter Holes) 197 | via (ExceptT Error (WriterT Holes (Reader Env))) 198 | 199 | newtype Check = Check {runCheck :: Type -> TypecheckM Syntax} 200 | 201 | newtype Synth = Synth {runSynth :: TypecheckM (Type, Syntax)} 202 | 203 | synth :: Term -> Synth 204 | synth = \case 205 | Var bndr -> varTactic bndr 206 | Ap tm1 tm2 -> applyTactic (synth tm1) (check tm2) 207 | Fst tm -> fstTactic (synth tm) 208 | Snd tm -> sndTactic (synth tm) 209 | Anno ty tm -> annoTactic ty (check tm) 210 | Hole -> Synth $ throwError $ TypeError "Cannot sythesize holes" 211 | tm -> Synth $ throwError $ TypeError $ "Cannot synthesize type for " <> show tm 212 | 213 | check :: Term -> Check 214 | check (Lam bndr body) = lamTactic bndr (check body) 215 | check Unit = unitTactic 216 | check (Pair tm1 tm2) = pairTactic (check tm1) (check tm2) 217 | check Hole = holeTactic 218 | check tm = subTactic (synth tm) 219 | 220 | -- | Var Tactic 221 | -- 222 | -- (x : A) ∈ Γ 223 | -- ─────────── Var⇒ 224 | -- Γ ⊢ x ⇒ A 225 | varTactic :: Name -> Synth 226 | varTactic bndr = Synth $ do 227 | ctx <- ask 228 | 229 | case resolveCell ctx bndr of 230 | Just Cell {..} -> do 231 | let quoted = flip runEvalM (locals ctx) $ quote (Lvl $ size ctx) cellType cellValue 232 | pure (cellType, quoted) 233 | Nothing -> throwError $ OutOfScopeError bndr 234 | 235 | -- | Sub Tactic 236 | -- 237 | -- Γ ⊢ e ⇒ A A ≡ B 238 | -- ──────────────── Sub⇐ 239 | -- Γ ⊢ e ⇐ B 240 | subTactic :: Synth -> Check 241 | subTactic (Synth synth) = Check $ \ty1 -> do 242 | (ty2, tm) <- synth 243 | if ty2 == ty1 244 | then pure tm 245 | else throwError $ TypeError $ "Expected: " <> show ty1 <> ", but got: " <> show ty2 246 | 247 | -- | Anno Tactic 248 | -- 249 | -- Γ ⊢ e ⇐ A 250 | -- ─────────────── Anno⇒ 251 | -- Γ ⊢ (e : A) ⇒ A 252 | annoTactic :: Type -> Check -> Synth 253 | annoTactic ty (Check check) = Synth $ do 254 | tm <- check ty 255 | pure (ty, tm) 256 | 257 | -- | Unit Introduction Tactic 258 | -- 259 | -- ───────────── Unit⇐ 260 | -- Γ ⊢ () ⇐ Unit 261 | unitTactic :: Check 262 | unitTactic = Check $ \case 263 | UnitTy -> pure SUnit 264 | ty -> throwError $ TypeError $ "Expected Unit type but got: " <> show ty 265 | 266 | -- | Lambda Introduction Tactic 267 | -- 268 | -- Γ, x : A₁ ⊢ e ⇐ A₂ 269 | -- ──────────────────── LamIntro⇐ 270 | -- Γ ⊢ (λx.e) ⇐ A₁ → A₂ 271 | lamTactic :: Name -> Check -> Check 272 | lamTactic bndr (Check bodyTac) = Check $ \case 273 | a `FuncTy` b -> do 274 | ctx <- ask 275 | let var = freshCell ctx bndr a 276 | fiber <- local (bindCell var) $ bodyTac b 277 | pure $ SLam bndr fiber 278 | _ -> throwError $ TypeError "Tried to introduce a lambda at a non-function type" 279 | 280 | -- | Lambda Elination Tactic 281 | -- 282 | -- Γ ⊢ e₁ ⇒ A → B Γ ⊢ e₂ ⇐ A 283 | -- ────────────────────────── LamElim⇐ 284 | -- Γ ⊢ e₁ e₂ ⇒ B 285 | applyTactic :: Synth -> Check -> Synth 286 | applyTactic (Synth funcTac) (Check argTac) = 287 | Synth $ 288 | funcTac >>= \case 289 | (a `FuncTy` b, f) -> do 290 | arg <- argTac a 291 | pure (b, SAp f arg) 292 | (ty, _) -> throwError $ TypeError $ "Expected a function type but got " <> show ty 293 | 294 | -- | Pair Introduction Tactic 295 | -- 296 | -- Γ ⊢ a ⇐ A Γ ⊢ b ⇐ B 297 | -- ───────────────────── Pair⇐ 298 | -- Γ ⊢ (a , b) ⇐ A × B 299 | pairTactic :: Check -> Check -> Check 300 | pairTactic (Check checkFst) (Check checkSnd) = Check $ \case 301 | PairTy a b -> do 302 | tm1 <- checkFst a 303 | tm2 <- checkSnd b 304 | pure (SPair tm1 tm2) 305 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 306 | 307 | -- | Pair Fst Elimination Tactic 308 | -- 309 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 310 | -- ───────────────────── Fst⇒ 311 | -- Γ ⊢ t₁ ⇒ A 312 | fstTactic :: Synth -> Synth 313 | fstTactic (Synth synth) = 314 | Synth $ 315 | synth >>= \case 316 | (PairTy ty1 _ty2, SPair tm1 _tm2) -> pure (ty1, tm1) 317 | (ty, _) -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 318 | 319 | -- | Pair Snd Elimination Tactic 320 | -- 321 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 322 | -- ───────────────────── Snd⇒ 323 | -- Γ ⊢ t₂ ⇒ A 324 | sndTactic :: Synth -> Synth 325 | sndTactic (Synth synth) = 326 | Synth $ 327 | synth >>= \case 328 | (PairTy _ty1 ty2, SPair _tm1 tm2) -> pure (ty2, tm2) 329 | (ty, _) -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 330 | 331 | -- | Type Hole Tactic 332 | -- 333 | -- 334 | -- ────────── Hole⇐ 335 | -- Γ ⊢ ? ⇐ A 336 | holeTactic :: Check 337 | holeTactic = Check $ \ty -> do 338 | tell (Holes [ty]) 339 | pure (SHole ty) 340 | 341 | -------------------------------------------------------------------------------- 342 | -- Evaluator 343 | 344 | newtype EvalM a = EvalM {runEvalM :: SnocList Value -> a} 345 | deriving 346 | (Functor, Applicative, Monad, MonadReader (SnocList Value)) 347 | via Reader (SnocList Value) 348 | 349 | eval :: Syntax -> EvalM Value 350 | eval = \case 351 | SVar (Ix ix) -> do 352 | env <- ask 353 | pure $ fromMaybe (error "internal error") $ nth env ix 354 | SLam bndr body -> do 355 | env <- ask 356 | pure $ VLam bndr (Closure env body) 357 | SAp tm1 tm2 -> do 358 | fun <- eval tm1 359 | arg <- eval tm2 360 | doApply fun arg 361 | SPair tm1 tm2 -> do 362 | tm1' <- eval tm1 363 | tm2' <- eval tm2 364 | pure $ VPair tm1' tm2' 365 | SFst tm -> eval tm >>= doFst 366 | SSnd tm -> eval tm >>= doSnd 367 | SUnit -> pure VUnit 368 | SHole ty -> pure $ VNeutral ty (Neutral (VHole ty) Nil) 369 | 370 | doApply :: Value -> Value -> EvalM Value 371 | doApply (VLam _ clo) arg = instantiateClosure clo arg 372 | doApply (VNeutral (FuncTy ty1 ty2) neu) arg = pure $ VNeutral ty2 (pushFrame neu (VApp ty1 arg)) 373 | doApply _ _ = error "impossible case in doApply" 374 | 375 | doFst :: Value -> EvalM Value 376 | doFst (VPair a _b) = pure a 377 | doFst _ = error "impossible case in doFst" 378 | 379 | doSnd :: Value -> EvalM Value 380 | doSnd (VPair _a b) = pure b 381 | doSnd _ = error "impossible case in doSnd" 382 | 383 | instantiateClosure :: Closure -> Value -> EvalM Value 384 | instantiateClosure (Closure env body) v = local (const $ Snoc env v) $ eval body 385 | 386 | -------------------------------------------------------------------------------- 387 | -- Quoting 388 | 389 | quote :: Lvl -> Type -> Value -> EvalM Syntax 390 | quote l (FuncTy ty1 ty2) (VLam bndr clo@(Closure _env _body)) = do 391 | body <- bindVar ty1 l $ \v l' -> do 392 | clo <- instantiateClosure clo v 393 | quote l' ty2 clo 394 | pure $ SLam bndr body 395 | quote l (FuncTy ty1 ty2) f = do 396 | body <- bindVar ty1 l $ \v l' -> 397 | doApply f v >>= quote l' ty2 398 | pure $ SLam "_" body 399 | quote l (PairTy ty1 ty2) (VPair tm1 tm2) = do 400 | tm1' <- quote l ty1 tm1 401 | tm2' <- quote l ty2 tm2 402 | pure $ SPair tm1' tm2' 403 | quote l _ (VNeutral _ neu) = quoteNeutral l neu 404 | quote _ _ VUnit = pure SUnit 405 | quote _ _ _ = error "impossible case in quote" 406 | 407 | quoteLevel :: Lvl -> Lvl -> Ix 408 | quoteLevel (Lvl l) (Lvl x) = Ix (l - (x + 1)) 409 | 410 | quoteNeutral :: Lvl -> Neutral -> EvalM Syntax 411 | quoteNeutral l Neutral {..} = foldM (quoteFrame l) (quoteHead l head) spine 412 | 413 | quoteHead :: Lvl -> Head -> Syntax 414 | quoteHead l (VVar lvl) = SVar (quoteLevel l lvl) 415 | quoteHead _ (VHole ty) = SHole ty 416 | 417 | quoteFrame :: Lvl -> Syntax -> Frame -> EvalM Syntax 418 | quoteFrame l tm = \case 419 | VApp ty arg -> SAp tm <$> quote l ty arg 420 | VFst -> pure $ SFst tm 421 | VSnd -> pure $ SSnd tm 422 | 423 | bindVar :: Type -> Lvl -> (Value -> Lvl -> a) -> a 424 | bindVar ty lvl f = 425 | let v = VNeutral ty $ Neutral (VVar lvl) Nil 426 | in f v $ incLevel lvl 427 | 428 | -------------------------------------------------------------------------------- 429 | -- Main 430 | 431 | run :: Term -> Either (Error, Holes) (Syntax, Holes) 432 | run term = 433 | case runTypecheckM (runSynth $ synth term) initEnv of 434 | (Left err, holes) -> Left (err, holes) 435 | (Right (type', syntax), holes) -> do 436 | let result = flip runEvalM Nil $ do 437 | value <- eval syntax 438 | quote initLevel type' value 439 | pure (result, holes) 440 | 441 | main :: IO () 442 | main = 443 | case run (Ap idenT Hole) of 444 | Left err -> print err 445 | Right result -> print result 446 | 447 | -- λx. x 448 | idenT :: Term 449 | idenT = 450 | Anno 451 | (UnitTy `FuncTy` UnitTy) 452 | (Lam (Name "x") Hole) 453 | 454 | -- λf. f 455 | idenT' :: Term 456 | idenT' = 457 | Anno 458 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 459 | (Lam (Name "f") (Var "f")) 460 | 461 | -- λx. λy. x 462 | constT :: Term 463 | constT = 464 | Anno 465 | (UnitTy `FuncTy` (UnitTy `FuncTy` UnitTy)) 466 | (Lam (Name "x") (Lam (Name "_") (Var "f"))) 467 | 468 | -- λf. λx. f x 469 | applyT :: Term 470 | applyT = 471 | Anno 472 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 473 | (Lam (Name "f") (Lam (Name "x") (Ap (Var "f") (Var "x")))) 474 | -------------------------------------------------------------------------------- /main/05-SystemT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | 4 | module Main where 5 | 6 | -------------------------------------------------------------------------------- 7 | 8 | import Control.Monad (foldM) 9 | import Control.Monad.Except (MonadError (..)) 10 | import Control.Monad.Identity 11 | import Control.Monad.Reader (MonadReader (..)) 12 | import Control.Monad.Trans.Except (ExceptT (..)) 13 | import Control.Monad.Trans.Reader (Reader, ReaderT (..)) 14 | import Control.Monad.Trans.Writer.Strict (WriterT (..)) 15 | import Control.Monad.Writer.Strict (MonadWriter (..)) 16 | import Data.Foldable (find) 17 | import Data.Maybe (fromMaybe) 18 | import Data.String 19 | 20 | -------------------------------------------------------------------------------- 21 | -- Utils 22 | 23 | data SnocList a 24 | = Snoc (SnocList a) a 25 | | Nil 26 | deriving (Show, Eq, Ord, Functor, Foldable) 27 | 28 | nth :: SnocList a -> Int -> Maybe a 29 | nth xs i 30 | | i < 0 = Nothing 31 | | otherwise = 32 | let go = \case 33 | (Nil, _) -> Nothing 34 | (Snoc _ x, 0) -> Just x 35 | (Snoc xs' _, i') -> go (xs', i' - 1) 36 | in go (xs, i) 37 | 38 | -------------------------------------------------------------------------------- 39 | -- Types 40 | 41 | -- | 'Term' represents the concrete syntax of our langage generated 42 | -- from text by a parser. 43 | data Term 44 | = Var Name 45 | | Lam Name Term 46 | | Ap Term Term 47 | | Pair Term Term 48 | | Fst Term 49 | | Snd Term 50 | | Unit 51 | | Tru 52 | | Fls 53 | | If Term Term Term 54 | | Zero 55 | | Succ Term 56 | | NatRec Term Term Term 57 | | Anno Type Term 58 | | Hole 59 | deriving stock (Show, Eq, Ord) 60 | 61 | data Type 62 | = FuncTy Type Type 63 | | PairTy Type Type 64 | | UnitTy 65 | | BoolTy 66 | | NatTy 67 | deriving stock (Show, Eq, Ord) 68 | 69 | -- | 'Syntax' is the internal abstract syntax of our language. We 70 | -- elaborate 'Term' values into 'Syntax' during typechecking. 71 | data Syntax 72 | = SVar Ix 73 | | SLam Name Syntax 74 | | SAp Syntax Syntax 75 | | SPair Syntax Syntax 76 | | SFst Syntax 77 | | SSnd Syntax 78 | | SUnit 79 | | STru 80 | | SFls 81 | | SIf Syntax Syntax Syntax 82 | | SZero 83 | | SSucc Syntax 84 | | SNatRec Syntax Syntax Syntax 85 | | SHole Type 86 | deriving stock (Show, Eq, Ord) 87 | 88 | -- | 'Value' is the evaluated form of expressions in our language. 89 | data Value 90 | = VNeutral Type Neutral 91 | | VLam Name Closure 92 | | VPair Value Value 93 | | VUnit 94 | | VTru 95 | | VFls 96 | | VZero 97 | | VSucc Value 98 | deriving stock (Show, Eq, Ord) 99 | 100 | -- | Debruijn Indices 101 | -- 102 | -- 'Ix' is used to reference lambda bound terms with respect to 103 | -- α-conversion. The index 'n' represents the value bound by the 'n' 104 | -- lambda counting outward from the site of the index. 105 | -- 106 | -- λ.λ.λ.2 107 | -- ^-----^ 108 | newtype Ix 109 | = Ix Int 110 | deriving newtype (Show, Eq, Ord) 111 | 112 | -- | Debruijn Levels 113 | -- 114 | -- Similar to Debruijn Indices but counting inward from the outermost 115 | -- lambda. 116 | -- 117 | -- λ.λ.λ.0 118 | -- ^-----^ 119 | -- 120 | -- Levels eliminate the need to reindex free variables when weakening 121 | -- the context. This is useful in our 'Value' representation of 122 | -- lambdas where we have a 'Closure' holding a stack of free variables. 123 | newtype Lvl 124 | = Lvl Int 125 | deriving newtype (Show, Eq, Ord) 126 | 127 | initLevel :: Lvl 128 | initLevel = Lvl 0 129 | 130 | incLevel :: Lvl -> Lvl 131 | incLevel (Lvl n) = Lvl (1 + n) 132 | 133 | newtype Name = Name {getName :: String} 134 | deriving newtype (Show, Eq, Ord, IsString) 135 | 136 | data Neutral = Neutral {head :: Head, spine :: SnocList Frame} 137 | deriving stock (Show, Eq, Ord) 138 | 139 | data Head 140 | = VVar Lvl 141 | | VHole Type 142 | deriving (Show, Eq, Ord) 143 | 144 | data Frame 145 | = VApp Type Value 146 | | VFst 147 | | VSnd 148 | | VIf Type Value Value 149 | | VNatRec Type Value Value 150 | deriving stock (Show, Eq, Ord) 151 | 152 | pushFrame :: Neutral -> Frame -> Neutral 153 | pushFrame Neutral {..} frame = Neutral {head = head, spine = Snoc spine frame} 154 | 155 | data Closure = Closure {env :: SnocList Value, body :: Syntax} 156 | deriving stock (Show, Eq, Ord) 157 | 158 | -------------------------------------------------------------------------------- 159 | -- Environment 160 | 161 | data Cell = Cell 162 | { cellName :: Name, 163 | cellType :: Type, 164 | cellValue :: Value 165 | } 166 | deriving stock (Show, Eq, Ord) 167 | 168 | data Env = Env 169 | { locals :: SnocList Value, 170 | localNames :: [Cell], 171 | size :: Int, 172 | -- | Holes encountered during typechecking 173 | holes :: [Type] 174 | } 175 | deriving stock (Show, Eq, Ord) 176 | 177 | initEnv :: Env 178 | initEnv = Env Nil [] 0 mempty 179 | 180 | extendLocalNames :: Env -> Cell -> Env 181 | extendLocalNames e@Env {localNames} cell = e {localNames = cell : localNames} 182 | 183 | extendHoles :: Type -> Env -> Env 184 | extendHoles ty e@Env {holes} = e {holes = ty : holes} 185 | 186 | bindCell :: Cell -> Env -> Env 187 | bindCell cell@Cell {..} Env {..} = 188 | Env 189 | { locals = Snoc locals cellValue, 190 | localNames = cell : localNames, 191 | size = size + 1, 192 | holes = holes 193 | } 194 | 195 | resolveCell :: Env -> Name -> Maybe Cell 196 | resolveCell Env {..} bndr = find ((== bndr) . cellName) localNames 197 | 198 | freshVar :: Env -> Type -> Value 199 | freshVar Env {size} ty = VNeutral ty $ Neutral (VVar $ Lvl size) Nil 200 | 201 | freshCell :: Env -> Name -> Type -> Cell 202 | freshCell ctx name ty = Cell name ty (freshVar ctx ty) 203 | 204 | -------------------------------------------------------------------------------- 205 | -- Typechecker 206 | 207 | data Error 208 | = TypeError String 209 | | OutOfScopeError Name 210 | deriving (Show) 211 | 212 | newtype Holes = Holes {getHoles :: [Type]} 213 | deriving newtype (Show, Semigroup, Monoid) 214 | 215 | newtype TypecheckM a = TypecheckM {runTypecheckM :: Env -> (Either Error a, Holes)} 216 | deriving 217 | (Functor, Applicative, Monad, MonadReader Env, MonadError Error, MonadWriter Holes) 218 | via (ExceptT Error (WriterT Holes (Reader Env))) 219 | 220 | newtype Check = Check {runCheck :: Type -> TypecheckM Syntax} 221 | 222 | newtype Synth = Synth {runSynth :: TypecheckM (Type, Syntax)} 223 | 224 | synth :: Term -> Synth 225 | synth = \case 226 | Var bndr -> varTactic bndr 227 | Ap tm1 tm2 -> applyTactic (synth tm1) (check tm2) 228 | Fst tm -> fstTactic (synth tm) 229 | Snd tm -> sndTactic (synth tm) 230 | Anno ty tm -> annoTactic ty (check tm) 231 | Hole -> Synth $ throwError $ TypeError "Cannot sythesize holes" 232 | tm -> Synth $ throwError $ TypeError $ "Cannot synthesize type for " <> show tm 233 | 234 | check :: Term -> Check 235 | check (Lam bndr body) = lamTactic bndr (check body) 236 | check Unit = unitTactic 237 | check (Pair tm1 tm2) = pairTactic (check tm1) (check tm2) 238 | check Hole = holeTactic 239 | check (If tm1 tm2 tm3) = ifTactic (check tm1) (check tm2) (check tm3) 240 | check Tru = trueTactic 241 | check Fls = falseTactic 242 | check Zero = zeroTactic 243 | check (Succ tm) = succTactic (check tm) 244 | check (NatRec tm1 tm2 n) = natRecTactic (check tm1) (check tm2) (check n) 245 | check tm = subTactic (synth tm) 246 | 247 | -- | Var Tactic 248 | -- 249 | -- (x : A) ∈ Γ 250 | -- ─────────── Var⇒ 251 | -- Γ ⊢ x ⇒ A 252 | varTactic :: Name -> Synth 253 | varTactic bndr = Synth $ do 254 | ctx <- ask 255 | 256 | case resolveCell ctx bndr of 257 | Just Cell {..} -> do 258 | let quoted = flip runEvalM (locals ctx) $ quote (Lvl $ size ctx) cellType cellValue 259 | pure (cellType, quoted) 260 | Nothing -> throwError $ OutOfScopeError bndr 261 | 262 | -- | Sub Tactic 263 | -- 264 | -- Γ ⊢ e ⇒ A A ≡ B 265 | -- ──────────────── Sub⇐ 266 | -- Γ ⊢ e ⇐ B 267 | subTactic :: Synth -> Check 268 | subTactic (Synth synth) = Check $ \ty1 -> do 269 | (ty2, tm) <- synth 270 | if ty2 == ty1 271 | then pure tm 272 | else throwError $ TypeError $ "Expected: " <> show ty1 <> ", but got: " <> show ty2 273 | 274 | -- | Anno Tactic 275 | -- 276 | -- Γ ⊢ e ⇐ A 277 | -- ─────────────── Anno⇒ 278 | -- Γ ⊢ (e : A) ⇒ A 279 | annoTactic :: Type -> Check -> Synth 280 | annoTactic ty (Check check) = Synth $ do 281 | tm <- check ty 282 | pure (ty, tm) 283 | 284 | -- | Unit Introduction Tactic 285 | -- 286 | -- ───────────── Unit⇐ 287 | -- Γ ⊢ () ⇐ Unit 288 | unitTactic :: Check 289 | unitTactic = Check $ \case 290 | UnitTy -> pure SUnit 291 | ty -> throwError $ TypeError $ "Expected Unit type but got: " <> show ty 292 | 293 | -- | Lambda Introduction Tactic 294 | -- 295 | -- Γ, x : A₁ ⊢ e ⇐ A₂ 296 | -- ──────────────────── LamIntro⇐ 297 | -- Γ ⊢ (λx.e) ⇐ A₁ → A₂ 298 | lamTactic :: Name -> Check -> Check 299 | lamTactic bndr (Check bodyTac) = Check $ \case 300 | a `FuncTy` b -> do 301 | ctx <- ask 302 | let var = freshCell ctx bndr a 303 | fiber <- local (bindCell var) $ bodyTac b 304 | pure $ SLam bndr fiber 305 | ty -> throwError $ TypeError $ "Tried to introduce a lambda at a non-function type: " <> show ty 306 | 307 | -- | Lambda Elination Tactic 308 | -- 309 | -- Γ ⊢ e₁ ⇒ A → B Γ ⊢ e₂ ⇐ A 310 | -- ────────────────────────── LamElim⇐ 311 | -- Γ ⊢ e₁ e₂ ⇒ B 312 | applyTactic :: Synth -> Check -> Synth 313 | applyTactic (Synth funcTac) (Check argTac) = 314 | Synth $ 315 | funcTac >>= \case 316 | (a `FuncTy` b, f) -> do 317 | arg <- argTac a 318 | pure (b, SAp f arg) 319 | (ty, _) -> throwError $ TypeError $ "Expected a function type but got " <> show ty 320 | 321 | -- | Pair Introduction Tactic 322 | -- 323 | -- Γ ⊢ a ⇐ A Γ ⊢ b ⇐ B 324 | -- ───────────────────── Pair⇐ 325 | -- Γ ⊢ (a , b) ⇐ A × B 326 | pairTactic :: Check -> Check -> Check 327 | pairTactic (Check checkFst) (Check checkSnd) = Check $ \case 328 | PairTy a b -> do 329 | tm1 <- checkFst a 330 | tm2 <- checkSnd b 331 | pure (SPair tm1 tm2) 332 | ty -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 333 | 334 | -- | Pair Fst Elimination Tactic 335 | -- 336 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 337 | -- ───────────────────── Fst⇒ 338 | -- Γ ⊢ t₁ ⇒ A 339 | fstTactic :: Synth -> Synth 340 | fstTactic (Synth synth) = 341 | Synth $ 342 | synth >>= \case 343 | (PairTy ty1 _ty2, SPair tm1 _tm2) -> pure (ty1, tm1) 344 | (ty, _) -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 345 | 346 | -- | Pair Snd Elimination Tactic 347 | -- 348 | -- Γ ⊢ (t₁ , t₂) ⇒ A × B 349 | -- ───────────────────── Snd⇒ 350 | -- Γ ⊢ t₂ ⇒ A 351 | sndTactic :: Synth -> Synth 352 | sndTactic (Synth synth) = 353 | Synth $ 354 | synth >>= \case 355 | (PairTy _ty1 ty2, SPair _tm1 tm2) -> pure (ty2, tm2) 356 | (ty, _) -> throwError $ TypeError $ "Expected a Pair but got " <> show ty 357 | 358 | -- | Type Hole Tactic 359 | -- 360 | -- 361 | -- ────────── Hole⇐ 362 | -- Γ ⊢ ? ⇐ A 363 | holeTactic :: Check 364 | holeTactic = Check $ \ty -> do 365 | tell (Holes [ty]) 366 | pure (SHole ty) 367 | 368 | -- | Bool-False Introduction Tactic 369 | -- 370 | -- ──────────────── False⇐ 371 | -- Γ ⊢ False ⇐ Unit 372 | falseTactic :: Check 373 | falseTactic = Check $ \case 374 | BoolTy -> pure SFls 375 | ty -> throwError $ TypeError $ "Expected Bool type but got: " <> show ty 376 | 377 | -- | Bool-True Introduction Tactic 378 | -- 379 | -- ──────────────── True⇐ 380 | -- Γ ⊢ True ⇐ Unit 381 | trueTactic :: Check 382 | trueTactic = Check $ \case 383 | BoolTy -> pure STru 384 | ty -> throwError $ TypeError $ "Expected Bool type but got: " <> show ty 385 | 386 | -- | Bool Elimination Tactic 387 | -- 388 | -- Γ ⊢ t₁ ⇐ Bool Γ ⊢ t₂ ⇐ T Γ ⊢ t₃ ⇐ T 389 | -- ───────────────────────────────────── If⇐ 390 | -- Γ ⊢ If t₁ then t₂ else t₃ ⇐ Bool 391 | ifTactic :: Check -> Check -> Check -> Check 392 | ifTactic (Check checkT1) (Check checkT2) (Check checkT3) = Check $ \ty -> do 393 | tm1 <- checkT1 BoolTy 394 | tm2 <- checkT2 ty 395 | tm3 <- checkT3 ty 396 | pure (SIf tm1 tm2 tm3) 397 | 398 | -- | ℕ-Zero Introduction Tactic 399 | -- 400 | -- ───────── Zero⇐ 401 | -- Γ ⊢ 0 ⇐ ℕ 402 | zeroTactic :: Check 403 | zeroTactic = Check $ \case 404 | NatTy -> pure SZero 405 | ty -> throwError $ TypeError $ "Expected ℕ type but got: " <> show ty 406 | 407 | -- | ℕ-Succ Introdution Tactic 408 | -- 409 | -- Γ ⊢ t ⇐ ℕ 410 | -- ────────────── Succ⇐ 411 | -- Γ ⊢ Succ 0 ⇐ ℕ 412 | succTactic :: Check -> Check 413 | succTactic (Check check) = Check $ \case 414 | NatTy -> SSucc <$> check NatTy 415 | ty -> throwError $ TypeError $ "Expected ℕ type but got: " <> show ty 416 | 417 | -- | Nat Recursion Tactic 418 | -- 419 | -- Γ ⊢ s ⇐ ℕ Γ ⊢ t₁ ⇐ T Γ ⊢ t₂ ⇐ ℕ → T → T 420 | -- ───────────────────────────────────────── ℕ-Elim⇐ 421 | -- Γ ⊢ elim t₁ t₂ s ⇐ T 422 | natRecTactic :: Check -> Check -> Check -> Check 423 | natRecTactic (Check zeroTac) (Check succTac) (Check scrutTac) = 424 | Check $ \ty -> do 425 | scrutinee <- scrutTac NatTy 426 | tm1 <- zeroTac ty 427 | tm2 <- succTac (NatTy `FuncTy` (ty `FuncTy` ty)) 428 | pure (SNatRec tm1 tm2 scrutinee) 429 | 430 | -------------------------------------------------------------------------------- 431 | -- Evaluator 432 | 433 | newtype EvalM a = EvalM {runEvalM :: SnocList Value -> a} 434 | deriving 435 | (Functor, Applicative, Monad, MonadReader (SnocList Value)) 436 | via Reader (SnocList Value) 437 | 438 | eval :: Syntax -> EvalM Value 439 | eval = \case 440 | SVar (Ix ix) -> do 441 | env <- ask 442 | pure $ fromMaybe (error "internal error") $ nth env ix 443 | SLam bndr body -> do 444 | env <- ask 445 | pure $ VLam bndr (Closure env body) 446 | SAp tm1 tm2 -> do 447 | fun <- eval tm1 448 | arg <- eval tm2 449 | doApply fun arg 450 | SPair tm1 tm2 -> do 451 | tm1' <- eval tm1 452 | tm2' <- eval tm2 453 | pure $ VPair tm1' tm2' 454 | SFst tm -> eval tm >>= doFst 455 | SSnd tm -> eval tm >>= doSnd 456 | SUnit -> pure VUnit 457 | STru -> pure VTru 458 | SFls -> pure VFls 459 | SIf p t1 t2 -> do 460 | p' <- eval p 461 | t1' <- eval t1 462 | t2' <- eval t2 463 | doIf p' t1' t2' 464 | SZero -> pure VZero 465 | SSucc tm -> VSucc <$> eval tm 466 | SNatRec tm1 tm2 n -> do 467 | n' <- eval n 468 | tm1' <- eval tm1 469 | tm2' <- eval tm2 470 | doNatRec n' tm1' tm2' 471 | SHole ty -> pure $ VNeutral ty (Neutral (VHole ty) Nil) 472 | 473 | doApply :: Value -> Value -> EvalM Value 474 | doApply (VLam _ clo) arg = instantiateClosure clo arg 475 | doApply (VNeutral (FuncTy ty1 ty2) neu) arg = pure $ VNeutral ty2 (pushFrame neu (VApp ty1 arg)) 476 | doApply _ _ = error "impossible case in doApply" 477 | 478 | doFst :: Value -> EvalM Value 479 | doFst (VPair a _b) = pure a 480 | doFst _ = error "impossible case in doFst" 481 | 482 | doSnd :: Value -> EvalM Value 483 | doSnd (VPair _a b) = pure b 484 | doSnd _ = error "impossible case in doSnd" 485 | 486 | doIf :: Value -> Value -> Value -> EvalM Value 487 | doIf VTru t1 _ = pure t1 488 | doIf VFls _ t2 = pure t2 489 | doIf (VNeutral ty neu) t1 t2 = pure $ VNeutral BoolTy (pushFrame neu (VIf ty t1 t2)) 490 | doIf _ _ _ = error "impossible case in doIf" 491 | 492 | doNatRec :: Value -> Value -> Value -> EvalM Value 493 | doNatRec VZero z _f = pure z 494 | doNatRec (VSucc n) z f = do 495 | hd <- doApply f n 496 | tl <- doNatRec n z f 497 | doApply hd tl 498 | doNatRec (VNeutral ty neu) z f = do 499 | pure $ VNeutral ty $ pushFrame neu $ VNatRec ty z f 500 | doNatRec _ _ _ = error "impossible case in doNatRec" 501 | 502 | instantiateClosure :: Closure -> Value -> EvalM Value 503 | instantiateClosure (Closure env body) v = local (const $ Snoc env v) $ eval body 504 | 505 | -------------------------------------------------------------------------------- 506 | -- Quoting 507 | 508 | quote :: Lvl -> Type -> Value -> EvalM Syntax 509 | quote l (FuncTy ty1 ty2) (VLam bndr clo@(Closure _env _body)) = do 510 | body <- bindVar ty1 l $ \v l' -> do 511 | clo <- instantiateClosure clo v 512 | quote l' ty2 clo 513 | pure $ SLam bndr body 514 | quote l (FuncTy ty1 ty2) f = do 515 | body <- bindVar ty1 l $ \v l' -> 516 | doApply f v >>= quote l' ty2 517 | pure $ SLam "_" body 518 | quote l (PairTy ty1 ty2) (VPair tm1 tm2) = do 519 | tm1' <- quote l ty1 tm1 520 | tm2' <- quote l ty2 tm2 521 | pure $ SPair tm1' tm2' 522 | quote l _ (VNeutral _ neu) = quoteNeutral l neu 523 | quote _ _ VUnit = pure SUnit 524 | quote _ _ VTru = pure STru 525 | quote _ _ VFls = pure SFls 526 | quote _ _ VZero = pure SZero 527 | quote l ty (VSucc tm) = SSucc <$> quote l ty tm 528 | quote _ ty tm = error $ "impossible case in quote:\n" <> show ty <> "\n" <> show tm 529 | 530 | quoteLevel :: Lvl -> Lvl -> Ix 531 | quoteLevel (Lvl l) (Lvl x) = Ix (l - (x + 1)) 532 | 533 | quoteNeutral :: Lvl -> Neutral -> EvalM Syntax 534 | quoteNeutral l Neutral {..} = foldM (quoteFrame l) (quoteHead l head) spine 535 | 536 | quoteHead :: Lvl -> Head -> Syntax 537 | quoteHead l (VVar lvl) = SVar (quoteLevel l lvl) 538 | quoteHead _ (VHole ty) = SHole ty 539 | 540 | quoteFrame :: Lvl -> Syntax -> Frame -> EvalM Syntax 541 | quoteFrame l tm = \case 542 | VApp ty arg -> SAp tm <$> quote l ty arg 543 | VFst -> pure $ SFst tm 544 | VSnd -> pure $ SSnd tm 545 | VIf ty t1 t2 -> liftA2 (SIf tm) (quote l ty t1) (quote l ty t2) 546 | VNatRec ty tm1 tm2 -> liftA2 (SNatRec tm) (quote l ty tm1) (quote l (NatTy `FuncTy` (ty `FuncTy` ty)) tm2) 547 | 548 | bindVar :: Type -> Lvl -> (Value -> Lvl -> a) -> a 549 | bindVar ty lvl f = 550 | let v = VNeutral ty $ Neutral (VVar lvl) Nil 551 | in f v $ incLevel lvl 552 | 553 | -------------------------------------------------------------------------------- 554 | -- Main 555 | 556 | run :: Term -> Either (Error, Holes) (Syntax, Holes) 557 | run term = 558 | case runTypecheckM (runSynth $ synth term) initEnv of 559 | (Left err, holes) -> Left (err, holes) 560 | (Right (type', syntax), holes) -> do 561 | let result = flip runEvalM Nil $ do 562 | value <- eval syntax 563 | quote initLevel type' value 564 | pure (result, holes) 565 | 566 | main :: IO () 567 | main = 568 | case run addT of 569 | Left err -> print err 570 | Right result -> print result 571 | 572 | addT :: Term 573 | addT = 574 | Anno 575 | (NatTy `FuncTy` (NatTy `FuncTy` NatTy)) 576 | (Lam "n" (Lam "m" (NatRec (Var "m") (Lam "x" (Lam "y" (Succ (Var "y")))) (Var "n")))) 577 | 578 | -- λp. if p then False else True 579 | notT :: Term 580 | notT = 581 | Anno 582 | (BoolTy `FuncTy` BoolTy) 583 | (Lam "x" (If (Var "x") Fls Tru)) 584 | 585 | -- λx. x 586 | idenT :: Term 587 | idenT = 588 | Anno 589 | (UnitTy `FuncTy` UnitTy) 590 | (Lam "x" Hole) 591 | 592 | -- λf. f 593 | idenT' :: Term 594 | idenT' = 595 | Anno 596 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 597 | (Lam "f" (Var "f")) 598 | 599 | -- λx. λy. x 600 | constT :: Term 601 | constT = 602 | Anno 603 | (UnitTy `FuncTy` (UnitTy `FuncTy` UnitTy)) 604 | (Lam "x" (Lam (Name "_") (Var "x"))) 605 | 606 | -- λf. λx. f x 607 | applyT :: Term 608 | applyT = 609 | Anno 610 | ((UnitTy `FuncTy` UnitTy) `FuncTy` (UnitTy `FuncTy` UnitTy)) 611 | (Lam "f" (Lam "x" (Ap (Var "f") (Var "x")))) 612 | -------------------------------------------------------------------------------- /main/old/LambdaPi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | 6 | module Main where 7 | 8 | import Control.Monad.Except 9 | import Control.Monad.Reader 10 | import Control.Monad.State 11 | import Data.List ((\\)) 12 | import Data.Map (Map) 13 | import Data.Map.Strict qualified as M 14 | import Debug.Trace 15 | 16 | ------------- 17 | --- Terms --- 18 | ------------- 19 | 20 | type Name = String 21 | 22 | data Term 23 | = Var Name 24 | | Universe Int 25 | | Pi Name Term Term 26 | | Abs Name Term Term 27 | | App Term Term 28 | | Sigma Name Term Term 29 | deriving (Show, Eq) 30 | 31 | type Gamma = [(String, (Term, Maybe Term))] 32 | 33 | extend :: Name -> (Term, Maybe Term) -> Gamma -> Gamma 34 | extend bndr t gamma = (bndr, t) : gamma 35 | 36 | lookupType :: Name -> Gamma -> Maybe Term 37 | lookupType name gamma = fst <$> lookup name gamma 38 | 39 | lookupValue :: Name -> Gamma -> Maybe Term 40 | lookupValue name gamma = snd =<< lookup name gamma 41 | 42 | ---------------------- 43 | --- Pretty Printer --- 44 | ---------------------- 45 | 46 | class Show a => Pretty a where 47 | pretty :: a -> String 48 | pretty = show 49 | 50 | instance Pretty Term where 51 | pretty = \case 52 | Var x -> x 53 | App t1 t2 -> pretty t1 ++ " " ++ pretty t2 54 | Abs bndr ty t0 -> "(λ" ++ bndr ++ " : " ++ pretty ty ++ ". " ++ pretty t0 ++ ")" 55 | Pi bndr t1 t2 -> "(Π" ++ bndr ++ " : " ++ pretty t1 ++ ". " ++ pretty t2 ++ ")" 56 | Universe k -> "Type" ++ show k 57 | 58 | ------------------------ 59 | --- Alpha Conversion --- 60 | ------------------------ 61 | 62 | data Stream a = Stream a (Stream a) 63 | 64 | data AlphaContext = AlphaContext 65 | { _names :: Stream String, 66 | _register :: Map String String 67 | } 68 | 69 | names :: [String] 70 | names = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 71 | 72 | stream :: [String] -> Stream String 73 | stream (x : xs) = Stream x (stream xs) 74 | 75 | alpha :: Term -> State AlphaContext Term 76 | alpha = \case 77 | Var x -> do 78 | mx <- gets (M.lookup x . _register) 79 | case mx of 80 | Just x' -> pure $ Var x' 81 | Nothing -> error "Something impossible happened" 82 | App t1 t2 -> do 83 | t1' <- alpha t1 84 | t2' <- alpha t2 85 | pure $ App t1' t2' 86 | t@(Abs bndr ty term) -> do 87 | Stream fresh rest <- gets _names 88 | registry <- gets _register 89 | ty' <- alpha ty 90 | put $ AlphaContext rest (M.insert bndr fresh registry) 91 | term' <- alpha term 92 | pure $ Abs fresh ty' term' 93 | t@(Pi bndr ty1 ty2) -> do 94 | Stream fresh rest <- gets _names 95 | registry <- gets _register 96 | ty1' <- alpha ty1 97 | put $ AlphaContext rest (M.insert bndr fresh registry) 98 | ty2' <- alpha ty2 99 | pure $ Pi fresh ty1' ty2' 100 | t@(Sigma bndr ty1 ty2) -> do 101 | Stream fresh rest <- gets _names 102 | registry <- gets _register 103 | ty1' <- alpha ty1 104 | put $ AlphaContext rest (M.insert bndr fresh registry) 105 | ty2' <- alpha ty2 106 | pure $ Sigma fresh ty1' ty2' 107 | t -> pure t 108 | 109 | emptyContext :: AlphaContext 110 | emptyContext = AlphaContext (stream names) (M.empty) 111 | 112 | alphaconvert :: Term -> Term 113 | alphaconvert term = evalState (alpha term) emptyContext 114 | 115 | -------------------- 116 | --- Typechecking --- 117 | -------------------- 118 | 119 | data TypeErr = TypeError deriving (Show, Eq) 120 | 121 | newtype InferM a = InferM {unInferM :: ExceptT TypeErr (Reader Gamma) a} 122 | deriving (Functor, Applicative, Monad, MonadReader Gamma, MonadError TypeErr) 123 | 124 | runInferM :: InferM a -> Either TypeErr a 125 | runInferM = flip runReader [] . runExceptT . unInferM 126 | 127 | infer :: Term -> InferM Term 128 | infer = \case 129 | Var x -> asks (lookupType x) >>= maybe (throwError TypeError) pure 130 | App t1 t2 -> 131 | infer t1 >>= normalize >>= \case 132 | Pi bndr ty1 ty2 -> do 133 | ty1' <- infer t2 134 | isEqual <- equal ty1 ty1' 135 | if isEqual 136 | then pure $ subst bndr t2 ty2 137 | else throwError TypeError 138 | _ -> throwError TypeError 139 | Abs bndr ty t -> do 140 | inferUniverse ty 141 | t' <- local (extend bndr (ty, Nothing)) (infer t) 142 | pure $ Pi bndr ty t' 143 | Pi bndr t1 t2 -> do 144 | k1 <- inferUniverse t1 145 | k2 <- local (extend bndr (t1, Nothing)) (inferUniverse t2) 146 | pure $ Universe (max k1 k2) 147 | Sigma bndr t1 t2 -> do 148 | k1 <- inferUniverse t1 149 | k2 <- inferUniverse t2 150 | pure $ Universe (max k1 k2) 151 | Universe k -> pure $ Universe (k + 1) 152 | 153 | inferUniverse :: Term -> InferM Int 154 | inferUniverse t = 155 | infer t >>= normalize >>= \case 156 | Universe k -> pure k 157 | _ -> throwError TypeError 158 | 159 | equal :: Term -> Term -> InferM Bool 160 | equal e1 e2 = 161 | case (e1, e2) of 162 | (Var x, Var y) -> pure $ x == y 163 | (App t1 t2, App t1' t2') -> (&&) <$> equal t1 t1' <*> equal t2 t2' 164 | (Universe k, Universe k') -> pure $ k == k' 165 | (Pi bndr t1 t2, Pi bndr' t1' t2') -> 166 | if t1 == t1' 167 | then equal t2 (subst bndr' (Var bndr) t2') 168 | else pure False 169 | (Abs bndr ty t, Abs bndr' ty' t') -> 170 | if ty == ty' 171 | then equal t (subst bndr' (Var bndr) t') 172 | else pure False 173 | (Sigma bndr t1 t2, Sigma bndr' t1' t2') -> 174 | if t1 == t1' 175 | then equal t2 (subst bndr' (Var bndr) t2') 176 | else pure False 177 | _ -> pure False 178 | 179 | --------------------- 180 | --- Normalization --- 181 | --------------------- 182 | 183 | normalize :: Term -> InferM Term 184 | normalize t = case t of 185 | Var x -> asks (lookupValue x) >>= maybe (pure t) normalize 186 | App t1 t2 -> do 187 | t2' <- normalize t2 188 | normalize t1 >>= \case 189 | Abs bndr _ t -> normalize (subst bndr t2' t) 190 | t1' -> pure $ App t1' t2' 191 | Abs bndr ty t -> do 192 | ty' <- normalize ty 193 | t' <- local (extend bndr (ty, Nothing)) (normalize t) 194 | pure $ Abs bndr ty' t' 195 | Pi bndr t1 t2 -> do 196 | t1' <- normalize t1 197 | t2' <- local (extend bndr (t1, Nothing)) (normalize t2) 198 | pure $ Pi bndr t1' t2' 199 | Sigma bndr t1 t2 -> do 200 | t1' <- normalize t1 201 | t2' <- local (extend bndr (t1, Nothing)) (normalize t2) 202 | pure $ Sigma bndr t1' t2' 203 | t -> pure t 204 | 205 | -------------------- 206 | --- Substitution --- 207 | -------------------- 208 | 209 | subst :: String -> Term -> Term -> Term 210 | subst x s = \case 211 | Var x' | x == x' -> s 212 | Var y -> Var y 213 | App t1 t2 -> App (subst x s t1) (subst x s t2) 214 | Abs y ty t1 215 | | x /= y && y `notElem` freevars s -> Abs y (subst x s ty) (subst x s t1) 216 | | otherwise -> error "oops name collision" 217 | Pi y t1 t2 218 | | x /= y && y `notElem` freevars s -> Pi y (subst x s t1) (subst x s t2) 219 | | otherwise -> error "oops name collision" 220 | Universe k -> Universe k 221 | 222 | freevars :: Term -> [String] 223 | freevars = \case 224 | Var x -> [x] 225 | Abs x ty t -> freevars ty ++ (freevars t \\ [x]) 226 | Pi x t1 t2 -> freevars t1 ++ (freevars t2 \\ [x]) 227 | App t1 t2 -> freevars t1 ++ freevars t2 228 | Universe k -> [] 229 | 230 | -------------------- 231 | --- Sample Terms --- 232 | -------------------- 233 | 234 | identity :: Int -> Term 235 | identity n = Abs "A" (Universe n) (Abs "x" (Var "A") (Var "x")) 236 | 237 | identityType :: Int -> Term 238 | identityType n = (Pi "B" (Universe n) (Pi "y" (Var "B") (Var "B"))) 239 | 240 | appTest :: Term 241 | appTest = App (App (identity 1) (identityType 0)) (identity 0) 242 | 243 | constant :: Term 244 | constant = 245 | Abs "A" (Universe 0) $ 246 | Abs "B" (Universe 0) $ 247 | Abs "x" (Var "A") $ 248 | Abs "y" (Var "B") (Var "x") 249 | 250 | ------------ 251 | --- Main --- 252 | ------------ 253 | 254 | check :: Term -> Either TypeErr String 255 | check = runInferM . fmap pretty . infer 256 | 257 | main :: IO () 258 | main = do 259 | let t = alphaconvert appTest 260 | putStrLn (pretty t) 261 | mapM_ putStrLn (check t) 262 | mapM_ putStrLn $ runInferM $ fmap pretty $ normalize t 263 | -------------------------------------------------------------------------------- /main/old/MLTT.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | 3 | module Main where 4 | 5 | -------------------------------------------------------------------------------- 6 | 7 | import Control.Monad (foldM) 8 | import Data.Bool (bool) 9 | import Data.Foldable (find, sequenceA_) 10 | import Data.Maybe (fromMaybe) 11 | import Data.String 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Utils 15 | 16 | data SnocList a 17 | = Snoc (SnocList a) a 18 | | Nil 19 | deriving (Show, Eq, Ord, Functor, Foldable) 20 | 21 | zipSnocWith :: (a -> b -> c) -> SnocList a -> SnocList b -> SnocList c 22 | zipSnocWith f = go 23 | where 24 | go Nil _ = Nil 25 | go _ Nil = Nil 26 | go (Snoc as a) (Snoc bs b) = Snoc (go as bs) (f a b) 27 | 28 | zipSnocWithM_ :: (Applicative m) => (a -> b -> m c) -> SnocList a -> SnocList b -> m () 29 | zipSnocWithM_ f xs ys = sequenceA_ (zipSnocWith f xs ys) 30 | 31 | nth :: SnocList a -> Int -> Maybe a 32 | nth xs i 33 | | i < 0 = Nothing 34 | | otherwise = 35 | let go = \case 36 | (Nil, _) -> Nothing 37 | (Snoc _ x, 0) -> Just x 38 | (Snoc xs' _, i') -> go (xs', i' - 1) 39 | in go (xs, i) 40 | 41 | -------------------------------------------------------------------------------- 42 | -- Environment 43 | 44 | data Cell = Cell 45 | { cellName :: Name, 46 | cellType :: Value, 47 | cellValue :: Value 48 | } 49 | deriving stock (Show, Eq, Ord) 50 | 51 | data Env = Env 52 | { locals :: SnocList Value, 53 | localNames :: [Cell], 54 | size :: Int 55 | } 56 | deriving stock (Show, Eq, Ord) 57 | 58 | initEnv :: Env 59 | initEnv = Env Nil [] 0 60 | 61 | extendLocalNames :: Env -> Cell -> Env 62 | extendLocalNames e@Env {localNames} cell = e {localNames = cell : localNames} 63 | 64 | bindVar :: Env -> Cell -> Env 65 | bindVar Env {..} cell@Cell {..} = 66 | Env 67 | { locals = Snoc locals cellValue, 68 | localNames = cell : localNames, 69 | size = size + 1 70 | } 71 | 72 | -------------------------------------------------------------------------------- 73 | -- Terms 74 | 75 | -- NOTE: 'ConcreteSyntax' would also contain spans if we were parsing. 76 | data ConcreteSyntax 77 | = CSVar Name 78 | | CSPi Name ConcreteSyntax ConcreteSyntax 79 | | CSAbs Name ConcreteSyntax 80 | | CSApp ConcreteSyntax [ConcreteSyntax] 81 | | CSSigma Name ConcreteSyntax ConcreteSyntax 82 | | CSPair ConcreteSyntax ConcreteSyntax 83 | | CSFst ConcreteSyntax 84 | | CSSnd ConcreteSyntax 85 | | CSUnit 86 | | CSUnitTy 87 | | CSTrue 88 | | CSFalse 89 | | CSBoolTy 90 | | CSIf ConcreteSyntax ConcreteSyntax ConcreteSyntax ConcreteSyntax 91 | | CSAnno ConcreteSyntax ConcreteSyntax 92 | | CSHole 93 | | CSUniv 94 | deriving stock (Show, Eq, Ord) 95 | 96 | data Syntax 97 | = SVar Ix 98 | | SPi Name Syntax Syntax 99 | | SAbs Name Syntax 100 | | SApp Syntax Syntax 101 | | SSigma Name Syntax Syntax 102 | | SPair Syntax Syntax 103 | | SFst Syntax 104 | | SSnd Syntax 105 | | SUnit 106 | | SUnitTy 107 | | STrue 108 | | SFalse 109 | | SBoolTy 110 | | -- | Motive Scrutinee Then Else 111 | SIf Syntax Syntax Syntax Syntax 112 | | SHole Syntax Int 113 | | SUniv 114 | deriving stock (Show, Eq, Ord) 115 | 116 | data Value 117 | = VNeutral Value Neutral 118 | | VPi Name Value Closure 119 | | VLam Name Closure 120 | | VSigma Name Value Closure 121 | | VPair Value Value 122 | | VUnit 123 | | VUnitTy 124 | | VTrue 125 | | VFalse 126 | | VBoolTy 127 | | VUniv 128 | deriving stock (Show, Eq, Ord) 129 | 130 | data Neutral = Neutral {head :: Head, spine :: SnocList Frame} 131 | deriving stock (Show, Eq, Ord) 132 | 133 | data Head 134 | = VVar Lvl 135 | | VHole Value Int 136 | deriving (Show, Eq, Ord) 137 | 138 | data Frame 139 | = -- | Type Arg 140 | VApp Value Value 141 | | VFst 142 | | VSnd 143 | | -- | Motive Then Else 144 | VIf Value Value Value 145 | deriving stock (Show, Eq, Ord) 146 | 147 | pushFrame :: Neutral -> Frame -> Neutral 148 | pushFrame Neutral {..} frame = Neutral {head = head, spine = Snoc spine frame} 149 | 150 | data Closure = Closure {env :: SnocList Value, body :: Syntax} 151 | deriving stock (Show, Eq, Ord) 152 | 153 | -- | Debruijn Indices 154 | -- 155 | -- λ.λ.λ.2 156 | -- ^-----^ 157 | newtype Ix 158 | = Ix Int 159 | deriving newtype (Show, Eq, Ord) 160 | 161 | -- | Debruijn Levels 162 | -- 163 | -- λ.λ.λ.0 164 | -- ^-----^ 165 | newtype Lvl 166 | = Lvl Int 167 | deriving newtype (Show, Eq, Ord) 168 | 169 | incLevel :: Lvl -> Lvl 170 | incLevel (Lvl n) = Lvl (1 + n) 171 | 172 | newtype Name = Name {getName :: String} 173 | deriving newtype (Show, Eq, Ord, IsString) 174 | 175 | data Error 176 | = NotInScope Name 177 | | TypeError String 178 | | TypeHole Syntax 179 | | HoleInSynth 180 | deriving (Show) 181 | 182 | -------------------------------------------------------------------------------- 183 | -- Typechecking 184 | 185 | resolveCell :: Env -> Name -> Maybe Cell 186 | resolveCell Env {..} bndr = find ((== bndr) . cellName) localNames 187 | 188 | synth :: Env -> ConcreteSyntax -> Either Error (Value, Syntax) -- (Type × Term) 189 | synth ctx = \case 190 | CSVar bndr -> 191 | case resolveCell ctx bndr of 192 | Just Cell {..} -> pure (cellType, quote (Lvl $ size ctx) cellType cellValue) 193 | Nothing -> Left $ NotInScope bndr 194 | CSUniv -> pure (VUniv, SUniv) -- Type is in type 195 | CSPi bndr a b -> do 196 | base <- check ctx a VUniv 197 | let vbase = eval (locals ctx) base 198 | let baseCell = freshCell ctx bndr vbase 199 | fam <- check (bindVar ctx baseCell) b VUniv 200 | pure (VUniv, SPi bndr base fam) 201 | CSApp f args -> do 202 | f' <- synth ctx f 203 | foldM (synAp ctx) f' args 204 | CSSigma bndr a b -> do 205 | base <- check ctx a VUniv 206 | let vbase = eval (locals ctx) base 207 | let baseCell = freshCell ctx bndr vbase 208 | fam <- check (bindVar ctx baseCell) b VUniv 209 | pure (VUniv, SSigma bndr base fam) 210 | CSFst a -> do 211 | synth ctx a >>= \case 212 | (VSigma _ a _clo, tm) -> 213 | pure (a, SFst tm) 214 | _ -> Left $ TypeError "Expected element of Σ." 215 | CSSnd a -> do 216 | synth ctx a >>= \case 217 | (VSigma _ _ clo, tm) -> 218 | let fiber = instantiateClosure clo $ doFst (eval (locals ctx) tm) 219 | in pure (fiber, SSnd tm) 220 | _ -> Left $ TypeError "Expected element of Σ." 221 | CSTrue -> pure (VBoolTy, STrue) 222 | CSFalse -> pure (VBoolTy, SFalse) 223 | CSUnit -> pure (VUnitTy, SUnit) 224 | CSUnitTy -> pure (VUniv, SUnitTy) 225 | CSBoolTy -> pure (VUniv, SBoolTy) 226 | CSIf mot scrut tru fls -> do 227 | -- check the motive against '(_ : Bool) → Univ' 228 | mot' <- check ctx mot $ VPi "_" VBoolTy $ Closure (locals ctx) SUniv 229 | -- evaluate the motive 230 | let vmot = eval (locals ctx) mot' 231 | -- check the true branch against 'motive True' 232 | tru' <- check ctx tru (doApply vmot VTrue) 233 | -- check the false branch against 'motive False' 234 | fls' <- check ctx fls (doApply vmot VFalse) 235 | -- synth the scrutinee 236 | (scrutTy, scrutTm) <- synth ctx scrut 237 | -- evaluate the scrutinee 238 | let vscrut = eval (locals ctx) scrutTm 239 | -- if the scrutinee is type 'Bool' then return: 240 | -- 1. The motive applied against the scrut to get the final returned type. 241 | -- 2. The normalized 'if' statement built from all the normalized components. 242 | case scrutTy of 243 | VBoolTy -> pure (doApply vmot vscrut, SIf mot' scrutTm tru' fls') 244 | _ -> Left $ TypeError $ "Scrutinee does not evaluate to a Bool: " <> show scrut 245 | CSAnno tm ty -> do 246 | ty' <- eval (locals ctx) <$> check ctx ty VUniv 247 | tm' <- check ctx tm ty' 248 | pure (ty', tm') 249 | CSHole -> Left HoleInSynth 250 | t -> Left $ TypeError $ "cannot synthesize type for: " <> show t 251 | 252 | synAp :: Env -> (Value, Syntax) -> ConcreteSyntax -> Either Error (Value, Syntax) 253 | synAp ctx (VPi _ a clo, f) arg = do 254 | arg' <- check ctx arg a 255 | let fiber = instantiateClosure clo (eval (locals ctx) arg') 256 | pure (fiber, SApp f arg') 257 | synAp _ ty _ = Left $ TypeError $ "Not a function type: " <> show ty 258 | 259 | check :: Env -> ConcreteSyntax -> Value -> Either Error Syntax 260 | check ctx (CSAbs bndr body) ty = 261 | case ty of 262 | VPi _ a clo -> do 263 | let var = freshCell ctx bndr a 264 | let fiber = instantiateClosure clo a 265 | body <- check (bindVar ctx var) body fiber 266 | pure $ SAbs bndr body 267 | ty' -> Left $ TypeError $ "Abs requires a function type, but got a: " <> show ty' 268 | check ctx (CSPair a b) ty = 269 | case ty of 270 | VSigma _ a' clo -> do 271 | t1 <- check ctx a a' 272 | t2 <- check ctx b $ instantiateClosure clo (eval (locals ctx) t1) 273 | pure $ SPair t1 t2 274 | _ -> Left $ TypeError "Expected element of Σ." 275 | check ctx CSHole ty = do 276 | -- Note: For demonstration purposes here we simply return the first 277 | -- hole encountered. However, in a more complete system we would 278 | -- convert from a Concrete Syntax hole to a Syntax hole and have 279 | -- some effect to accumulate all the holes: 280 | 281 | -- label <- freshHole 282 | -- let hole = SHole ty label 283 | -- logHole hole 284 | -- pure hole 285 | 286 | -- This would allow us to continue typechecking and collect all the 287 | -- holes for reporting to the user. The required Hole constructors 288 | -- are included in our types to hint at this but the actual 289 | -- implementation is deferred so as to not obscure the core 290 | -- elaborator behavior. 291 | Left $ TypeHole $ quote (Lvl $ size ctx) ty VUniv 292 | check ctx t1 goal = do 293 | (actual, tm) <- synth ctx t1 294 | case equate (size ctx) VUniv goal actual of 295 | Just _ -> pure tm 296 | Nothing -> Left $ TypeError $ "Expected type " <> show goal <> " but received " <> show actual 297 | 298 | freshVar :: Int -> Value -> Value 299 | freshVar size ty = VNeutral ty $ Neutral (VVar $ Lvl size) Nil 300 | 301 | freshCell :: Env -> Name -> Value -> Cell 302 | freshCell ctx name ty = Cell name ty (freshVar (size ctx) ty) 303 | 304 | -------------------------------------------------------------------------------- 305 | -- Conversion Checker 306 | 307 | equate :: Int -> Value -> Value -> Value -> Maybe () 308 | equate env _ (VNeutral _ neu1) (VNeutral _ neu2) = equateNeu env neu1 neu2 309 | equate env _ (VPi _ a1 clo1) (VPi _ a2 clo2) = do 310 | equate env VUniv a1 a2 311 | let v = freshVar env a1 312 | equate (1 + env) VUniv (instantiateClosure clo1 v) (instantiateClosure clo2 v) 313 | equate env (VPi _ a clo) v1 v2 = do 314 | let x = freshVar env a 315 | fiber = instantiateClosure clo x 316 | equate env fiber (doApply v1 x) (doApply v2 x) 317 | equate env _ (VSigma _ a1 clo1) (VSigma _ a2 clo2) = do 318 | equate env VUniv a1 a2 319 | let v = freshVar env a1 320 | equate (1 + env) VUniv (instantiateClosure clo1 v) (instantiateClosure clo2 v) 321 | equate env (VSigma _ a clo) v1 v2 = do 322 | equate env a (doFst v1) (doFst v2) 323 | let fiber = instantiateClosure clo v1 324 | equate env fiber (doSnd v1) (doSnd v2) 325 | equate _ _ VUnit VUnit = pure () 326 | equate _ _ VTrue VTrue = pure () 327 | equate _ _ VFalse VFalse = pure () 328 | equate _ _ VBoolTy VBoolTy = pure () 329 | equate _ _ VUnitTy VUnitTy = pure () 330 | equate _ _ VUniv VUniv = pure () 331 | equate _ _ _ _ = Nothing 332 | 333 | equateNeu :: Int -> Neutral -> Neutral -> Maybe () 334 | equateNeu env (Neutral hd1 frame1) (Neutral hd2 frame2) = do 335 | equateHead hd1 hd2 336 | zipSnocWithM_ (equateFrame env) frame1 frame2 337 | 338 | equateHead :: Head -> Head -> Maybe () 339 | equateHead (VVar lvl1) (VVar lvl2) = bool Nothing (Just ()) (lvl1 == lvl2) 340 | equateHead (VHole _ n) (VHole _ m) = bool Nothing (Just ()) (n == m) 341 | equateHead _ _ = Nothing 342 | 343 | equateFrame :: Int -> Frame -> Frame -> Maybe () 344 | equateFrame env (VApp ty1 arg1) (VApp _ arg2) = equate env ty1 arg1 arg2 345 | equateFrame _ VFst VFst = pure () 346 | equateFrame _ VSnd VSnd = pure () 347 | equateFrame _ _ _ = Nothing 348 | 349 | -------------------------------------------------------------------------------- 350 | -- Evaluation 351 | 352 | eval :: SnocList Value -> Syntax -> Value 353 | eval env = \case 354 | SVar (Ix ix) -> fromMaybe (error "internal error") $ nth env ix 355 | SPi bndr a b -> VPi bndr (eval env a) (Closure env b) 356 | SAbs bndr body -> VLam bndr (Closure env body) 357 | SApp t1 t2 -> 358 | let fun = eval env t1 359 | arg = eval env t2 360 | in doApply fun arg 361 | SSigma bndr a b -> VSigma bndr (eval env a) (Closure env b) 362 | SPair a b -> VPair (eval env a) (eval env b) 363 | SFst a -> doFst (eval env a) 364 | SSnd b -> doSnd (eval env b) 365 | STrue -> VTrue 366 | SFalse -> VFalse 367 | SUnit -> VUnit 368 | SUnitTy -> VUnitTy 369 | SBoolTy -> VBoolTy 370 | SIf mot scrut t2 t3 -> doIf (eval env mot) (eval env scrut) (eval env t2) (eval env t3) 371 | SHole ty ix -> 372 | let ty' = eval env ty 373 | in VNeutral ty' $ Neutral (VHole ty' ix) Nil 374 | SUniv -> VUniv 375 | 376 | doApply :: Value -> Value -> Value 377 | doApply (VLam _ clo) arg = 378 | instantiateClosure clo arg 379 | doApply (VNeutral (VPi _ a clo) neu) arg = 380 | let fiber = instantiateClosure clo arg 381 | in VNeutral fiber (pushFrame neu (VApp a arg)) 382 | doApply _ _ = error "Internal Error: impossible case in doApply" 383 | 384 | instantiateClosure :: Closure -> Value -> Value 385 | instantiateClosure (Closure env body) v = eval (Snoc env v) body 386 | 387 | doIf :: Value -> Value -> Value -> Value -> Value 388 | doIf motive scrut t1 t2 = 389 | case scrut of 390 | VTrue -> t1 391 | VFalse -> t2 392 | VNeutral VBoolTy neu -> 393 | let fiber = doApply motive scrut 394 | in VNeutral fiber (pushFrame neu (VIf motive t1 t2)) 395 | _ -> error "Internal Error: impossible case in doIf" 396 | 397 | doFst :: Value -> Value 398 | doFst (VPair a _b) = a 399 | doFst (VNeutral (VSigma _ a _clo) neu) = 400 | VNeutral a (pushFrame neu VFst) 401 | doFst _ = error "Internal Error: impossible case in doFst" 402 | 403 | doSnd :: Value -> Value 404 | doSnd (VPair _a b) = b 405 | doSnd v@(VNeutral (VSigma _ _a clo) neu) = 406 | let fiber = instantiateClosure clo (doFst v) 407 | in VNeutral fiber (pushFrame neu VSnd) 408 | doSnd _ = error "Internal Error: impossible case in doSnd" 409 | 410 | quote :: Lvl -> Value -> Value -> Syntax 411 | quote _ VUnitTy _ = SUnit 412 | quote _ VBoolTy VTrue = STrue 413 | quote _ VBoolTy VFalse = SFalse 414 | quote l (VPi _ a cloTy) (VLam bndr clo) = 415 | let arg = VNeutral a $ Neutral (VVar l) Nil 416 | body = quote (incLevel l) (instantiateClosure cloTy arg) (instantiateClosure clo arg) 417 | in SAbs bndr body 418 | quote l (VPi bndr a clo) v = 419 | let arg = VNeutral a $ Neutral (VVar l) Nil 420 | body = quote (incLevel l) (instantiateClosure clo arg) $ doApply v arg 421 | in SAbs bndr body 422 | quote l _ (VPi bndr a clo) = 423 | let qa = quote l VUniv a 424 | arg = VNeutral a $ Neutral (VVar l) Nil 425 | b = quote (incLevel l) VUniv (instantiateClosure clo arg) 426 | in SPi bndr qa b 427 | quote l _ (VSigma bndr a clo) = 428 | let qa = quote l VUniv a 429 | arg = VNeutral a $ Neutral (VVar l) Nil 430 | b = quote (incLevel l) VUniv (instantiateClosure clo arg) 431 | in SSigma bndr qa b 432 | quote l (VSigma _bndr a clo) (VPair v1 v2) = 433 | let t1 = quote l a v1 434 | t2 = quote l (instantiateClosure clo v1) v2 435 | in SPair t1 t2 436 | quote l (VSigma _bndr a clo) v = 437 | let v1 = doFst v 438 | t1 = quote l a v1 439 | t2 = quote l (instantiateClosure clo v1) (doSnd v) 440 | in SPair t1 t2 441 | quote l ty1 (VNeutral ty2 neu) = 442 | if ty1 == ty2 443 | then quoteNeutral l neu 444 | else error "Internal error while quoting neutral" 445 | quote _ _ VUnitTy = SUnitTy 446 | quote _ _ VBoolTy = SBoolTy 447 | quote _ _ VUniv = SUniv 448 | quote _ _ v = error $ "Could not quote value: " <> show v 449 | 450 | quoteLevel :: Lvl -> Lvl -> Ix 451 | quoteLevel (Lvl l) (Lvl x) = Ix (l - (x + 1)) 452 | 453 | quoteNeutral :: Lvl -> Neutral -> Syntax 454 | quoteNeutral l Neutral {..} = foldl (quoteFrame l) (quoteHead l head) spine 455 | 456 | quoteHead :: Lvl -> Head -> Syntax 457 | quoteHead l = \case 458 | VVar x -> SVar (quoteLevel l x) 459 | VHole ty ix -> (SHole (quote l VUniv ty) ix) 460 | 461 | quoteFrame :: Lvl -> Syntax -> Frame -> Syntax 462 | quoteFrame l t1 (VApp ty arg) = SApp t1 (quote l ty arg) 463 | quoteFrame _ t1 VFst = SFst t1 464 | quoteFrame _ t1 VSnd = SSnd t1 465 | quoteFrame l t1 (VIf mot t2 t3) = 466 | SIf (quote l (VPi "_" VBoolTy $ Closure Nil SUniv) mot) t1 (quote l (doApply mot VTrue) t2) (quote l (doApply mot VFalse) t3) 467 | 468 | normalize :: ConcreteSyntax -> Syntax 469 | normalize term = 470 | case synth initEnv term of 471 | Right (ty, term') -> 472 | let val = eval Nil term' 473 | in quote (Lvl 0) ty val 474 | Left err -> error $ show err 475 | 476 | -------------------------------------------------------------------------------- 477 | -- Prettyprinter 478 | 479 | pp :: SnocList Name -> Syntax -> String 480 | pp env = \case 481 | SVar (Ix ix) -> maybe ("![bad index " <> show ix <> "]!") getName $ nth env ix 482 | SPi bndr ty tm -> "( " <> getName bndr <> " : " <> pp env ty <> ") -> " <> pp (Snoc env bndr) tm 483 | SAbs bndr body -> "λ " <> getName bndr <> " . " <> pp (Snoc env bndr) body 484 | SApp t1 t2 -> pp env t1 <> " " <> pp env t2 485 | SSigma bndr a b -> "Σ[ " <> getName bndr <> " ∈ " <> pp env a <> " ] " <> pp (Snoc env bndr) b 486 | SPair a b -> pp env a <> " × " <> pp env b 487 | SFst a -> "fst " <> pp env a 488 | SSnd b -> "snd" <> pp env b 489 | STrue -> "True" 490 | SFalse -> "False" 491 | SUnit -> "Unit" 492 | SIf _ t1 t2 t3 -> "if " <> pp env t1 <> " then " <> pp env t2 <> " else " <> pp env t3 493 | SHole _ ix -> "_" <> show ix 494 | SBoolTy -> "Bool" 495 | SUnitTy -> "Unit" 496 | SUniv -> "Type" 497 | 498 | -------------------------------------------------------------------------------- 499 | -- Main 500 | 501 | -- | (A : Type) → (x : A) → A 502 | idenT :: ConcreteSyntax 503 | idenT = 504 | CSAnno 505 | (CSAbs "A" (CSAbs "x" (CSVar "x"))) 506 | (CSPi "A" CSUniv (CSPi "x" (CSVar "A") (CSVar "A"))) 507 | 508 | -- | (A : Type) → (B : Type) → (x : A) → (y : B) → A 509 | constT :: ConcreteSyntax 510 | constT = 511 | CSAnno 512 | (CSAbs "A" (CSAbs "B" (CSAbs "x" (CSAbs "_" (CSVar "x"))))) 513 | (CSPi "A" CSUniv (CSPi "B" CSUniv (CSPi "x" (CSVar "A") (CSPi "y" (CSVar "B") (CSVar "A"))))) 514 | 515 | -- | Bool → Bool 516 | notT :: ConcreteSyntax 517 | notT = 518 | CSAnno 519 | (CSAbs "p" (CSIf (CSAbs "x" CSBoolTy) (CSVar "p") CSFalse CSTrue)) 520 | (CSPi "_" CSBoolTy CSBoolTy) 521 | 522 | main :: IO () 523 | main = do 524 | let term = CSApp constT [CSBoolTy, CSUnitTy, CSTrue, CSUnit] 525 | term' = CSApp notT [CSFalse] 526 | case synth initEnv notT of 527 | Left err -> print err 528 | Right (ty, tm) -> do 529 | putStrLn $ "Type: " <> show ty 530 | putStrLn $ "Type Pretty: " <> pp Nil (quote (Lvl 0) VUniv ty) 531 | let val = eval Nil tm 532 | putStrLn "" 533 | putStrLn $ "Syntax: " <> show tm 534 | putStrLn $ "Syntax Pretty: " <> pp Nil tm 535 | putStrLn "" 536 | putStrLn $ "Value: " <> show val 537 | putStrLn $ "Quoted: " <> show (quote (Lvl 0) ty val) 538 | putStrLn $ "Quoted Pretty: " <> pp Nil (quote (Lvl 0) ty val) 539 | -------------------------------------------------------------------------------- /main/old/SimplyTyped.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | 6 | module Main where 7 | 8 | import Control.Monad.Except 9 | import Control.Monad.Reader 10 | import Control.Monad.State 11 | import Data.List ((\\)) 12 | import Data.Map (Map) 13 | import qualified Data.Map.Strict as M 14 | 15 | ------------- 16 | --- Terms --- 17 | ------------- 18 | 19 | data Term 20 | = Var String 21 | | Abs String Type Term 22 | | App Term Term 23 | | Unit 24 | | T 25 | | F 26 | | If Term Term Term 27 | | Anno Term Type 28 | deriving (Show) 29 | 30 | data Type = Type :-> Type | UnitT | BoolT 31 | deriving (Show, Eq) 32 | 33 | type Gamma = [(String, Type)] 34 | 35 | data TypeErr = TypeError deriving (Show, Eq) 36 | 37 | ------------------------ 38 | --- Alpha Conversion --- 39 | ------------------------ 40 | 41 | data Stream a = Stream a (Stream a) 42 | 43 | data AlphaContext = AlphaContext {_names :: Stream String, _register :: Map String String} 44 | 45 | names :: [String] 46 | names = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 47 | 48 | stream :: [String] -> Stream String 49 | stream (x : xs) = Stream x (stream xs) 50 | 51 | alpha :: Term -> State AlphaContext Term 52 | alpha = \case 53 | (Var x) -> do 54 | mx <- gets (M.lookup x . _register) 55 | case mx of 56 | Just x' -> pure $ Var x' 57 | Nothing -> error "Something impossible happened" 58 | (App t1 t2) -> do 59 | t1' <- alpha t1 60 | t2' <- alpha t2 61 | pure $ App t1' t2' 62 | t@(Abs bndr ty term) -> do 63 | (Stream fresh rest) <- gets _names 64 | registry <- gets _register 65 | put $ AlphaContext rest (M.insert bndr fresh registry) 66 | term' <- alpha term 67 | pure $ Abs fresh ty term' 68 | (If t1 t2 t3) -> do 69 | t1' <- alpha t1 70 | t2' <- alpha t2 71 | t3' <- alpha t3 72 | pure (If t1' t2' t3') 73 | t -> pure t 74 | 75 | emptyContext :: AlphaContext 76 | emptyContext = AlphaContext (stream names) (M.empty) 77 | 78 | alphaconvert :: Term -> Term 79 | alphaconvert term = evalState (alpha term) emptyContext 80 | 81 | -------------------- 82 | --- Typechecking --- 83 | -------------------- 84 | 85 | newtype TypecheckM a = TypecheckM {unTypecheckM :: ExceptT TypeErr (Reader Gamma) a} 86 | deriving (Functor, Applicative, Monad, MonadReader Gamma, MonadError TypeErr) 87 | 88 | runTypecheckM :: TypecheckM Type -> Either TypeErr Type 89 | runTypecheckM = flip runReader [] . runExceptT . unTypecheckM 90 | 91 | typecheck :: Term -> TypecheckM Type 92 | typecheck = \case 93 | Var x -> do 94 | ty <- asks $ lookup x 95 | maybe (throwError TypeError) pure ty 96 | Abs bndr ty1 trm -> do 97 | ty2 <- local ((:) (bndr, ty1)) (typecheck trm) 98 | pure $ ty1 :-> ty2 99 | App t1 t2 -> do 100 | ty1 <- typecheck t1 101 | case ty1 of 102 | tyA :-> tyB -> do 103 | ty2 <- typecheck t2 104 | if tyA == ty2 then pure tyB else throwError TypeError 105 | _ -> throwError TypeError 106 | Unit -> pure UnitT 107 | T -> pure BoolT 108 | F -> pure BoolT 109 | If t0 t1 t2 -> do 110 | ty0 <- typecheck t0 111 | ty1 <- typecheck t1 112 | ty2 <- typecheck t2 113 | if ty0 == BoolT && ty1 == ty2 114 | then pure ty1 115 | else throwError TypeError 116 | Anno trm ty -> do 117 | ty' <- typecheck trm 118 | if ty == ty' 119 | then pure ty 120 | else throwError TypeError 121 | 122 | -------------------- 123 | --- Substitution --- 124 | -------------------- 125 | 126 | subst :: String -> Term -> Term -> Term 127 | subst x s = \case 128 | (Var x') | x == x' -> s 129 | (Var y) -> Var y 130 | (Abs y ty t1) 131 | | x /= y && y `notElem` freevars s -> Abs y ty (subst x s t1) 132 | | otherwise -> error "oops name collision" 133 | (App t1 t2) -> App (subst x s t1) (subst x s t2) 134 | (If t0 t1 t2) -> If (subst x s t0) (subst x s t1) (subst x s t2) 135 | T -> T 136 | F -> F 137 | Unit -> Unit 138 | 139 | freevars :: Term -> [String] 140 | freevars = \case 141 | (Var x) -> [x] 142 | (Abs x ty t) -> freevars t \\ [x] 143 | (App t1 t2) -> freevars t1 ++ freevars t2 144 | (If t0 t1 t2) -> freevars t0 ++ freevars t1 ++ freevars t2 145 | 146 | ------------------ 147 | --- Evaluation --- 148 | ------------------ 149 | 150 | isVal :: Term -> Bool 151 | isVal = \case 152 | Abs {} -> True 153 | T -> True 154 | F -> True 155 | Unit -> True 156 | _ -> False 157 | 158 | singleEval :: Term -> Maybe Term 159 | singleEval = \case 160 | (App (Abs x ty t12) v2) | isVal v2 -> Just $ subst x v2 t12 161 | (App v1@Abs {} t2) -> App v1 <$> singleEval t2 162 | (App t1 t2) -> flip App t2 <$> singleEval t1 163 | (If T t2 t3) -> pure t2 164 | (If F t2 t3) -> pure t3 165 | _ -> Nothing 166 | 167 | multiStepEval :: Term -> Term 168 | multiStepEval t = maybe t multiStepEval (singleEval t) 169 | 170 | ------------ 171 | --- Main --- 172 | ------------ 173 | 174 | notT :: Term 175 | notT = Abs "p" BoolT (If (Var "p") F T) 176 | 177 | main :: IO () 178 | main = 179 | let term = alphaconvert (App notT T) 180 | in case runTypecheckM $ typecheck term of 181 | Left e -> print e 182 | Right _ -> print (multiStepEval term) 183 | -------------------------------------------------------------------------------- /main/old/SimplyTypedElab.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE StrictData #-} 9 | {-# LANGUAGE TupleSections #-} 10 | 11 | module Main where 12 | 13 | -------------------------------------------------------------------------------- 14 | 15 | import Control.Monad.State 16 | import Data.Foldable (find) 17 | import Data.Functor (($>)) 18 | import Data.List ((\\)) 19 | import Data.Map (Map) 20 | import qualified Data.Map.Strict as M 21 | import Data.Maybe (fromMaybe) 22 | import Debug.Trace 23 | import GHC.Conc (labelThread) 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Utils 27 | 28 | data SnocList a 29 | = Snoc (SnocList a) a 30 | | Nil 31 | deriving (Show, Eq, Ord, Functor, Foldable) 32 | 33 | nth :: SnocList a -> Int -> Maybe a 34 | nth xs i 35 | | i < 0 = Nothing 36 | | otherwise = 37 | let go = \case 38 | (Nil, _) -> Nothing 39 | (Snoc _ x, 0) -> Just x 40 | (Snoc xs _, i) -> go (xs, i - 1) 41 | in go (xs, i) 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Environment 45 | 46 | data Cell = Cell 47 | { cellName :: Name, 48 | cellType :: Type, 49 | cellValue :: Value 50 | } 51 | deriving stock (Show, Eq, Ord) 52 | 53 | data Env = Env 54 | { locals :: SnocList Value, 55 | localNames :: [Cell], 56 | size :: Int 57 | } 58 | deriving stock (Show, Eq, Ord) 59 | 60 | initEnv :: Env 61 | initEnv = Env Nil [] 0 62 | 63 | extendLocalNames :: Env -> Cell -> Env 64 | extendLocalNames e@Env {localNames} cell = e {localNames = cell : localNames} 65 | 66 | bindVar :: Env -> Cell -> Env 67 | bindVar Env {..} cell@Cell {..} = 68 | Env 69 | { locals = Snoc locals cellValue, 70 | localNames = cell : localNames, 71 | size = size + 1 72 | } 73 | 74 | -------------------------------------------------------------------------------- 75 | -- Terms 76 | 77 | data Type = Type :-> Type | UnitT | BoolT 78 | deriving stock (Show, Eq, Ord) 79 | 80 | -- NOTE: 'ConcreteSyntax' would also contain spans if we were parsing. 81 | data ConcreteSyntax 82 | = CSVar Name 83 | | CSAbs Name ConcreteSyntax 84 | | CSApp ConcreteSyntax [ConcreteSyntax] 85 | | CSUnit 86 | | CSTrue 87 | | CSFalse 88 | | CSIf ConcreteSyntax ConcreteSyntax ConcreteSyntax 89 | | CSAnno ConcreteSyntax Type 90 | | CSHole 91 | deriving stock (Show, Eq, Ord) 92 | 93 | data Syntax 94 | = SVar Ix 95 | | SAbs Name Syntax 96 | | SApp Syntax Syntax 97 | | SUnit 98 | | STrue 99 | | SFalse 100 | | SIf Syntax Syntax Syntax 101 | | SHole Type Int 102 | deriving stock (Show, Eq, Ord) 103 | 104 | data Value 105 | = VNeutral Type Neutral 106 | | VLam Name Closure 107 | | VTrue 108 | | VFalse 109 | | VUnit 110 | deriving stock (Show, Eq, Ord) 111 | 112 | data Neutral = Neutral {head :: Head, spine :: SnocList Frame} 113 | deriving stock (Show, Eq, Ord) 114 | 115 | data Head 116 | = VVar Lvl 117 | | VHole Type Int 118 | deriving (Show, Eq, Ord) 119 | 120 | data Frame = VApp {ty :: Type, arg :: Value} 121 | deriving stock (Show, Eq, Ord) 122 | 123 | pushFrame :: Neutral -> Frame -> Neutral 124 | pushFrame Neutral {..} frame = Neutral {head = head, spine = Snoc spine frame} 125 | 126 | data Closure = Closure {env :: EvalEnv, body :: Syntax} 127 | deriving stock (Show, Eq, Ord) 128 | 129 | -- | Debruijn Indices 130 | -- 131 | -- λ.λ.λ.2 132 | -- ^-----^ 133 | newtype Ix 134 | = Ix Int 135 | deriving newtype (Show, Eq, Ord) 136 | 137 | -- | Debruijn Levels 138 | -- 139 | -- λ.λ.λ.0 140 | -- ^-----^ 141 | newtype Lvl 142 | = Lvl Int 143 | deriving newtype (Show, Eq, Ord) 144 | 145 | incLevel :: Lvl -> Lvl 146 | incLevel (Lvl n) = Lvl (1 + n) 147 | 148 | newtype Name = Name {getName :: String} 149 | deriving newtype (Show, Eq, Ord) 150 | 151 | data Error 152 | = NotFound 153 | | TypeError String 154 | | TypeHole Type 155 | | HoleInSynth 156 | deriving (Show) 157 | 158 | -------------------------------------------------------------------------------- 159 | -- Typechecking 160 | 161 | resolveCell :: Env -> Name -> Maybe Cell 162 | resolveCell Env {..} bndr = find ((== bndr) . cellName) localNames 163 | 164 | synth :: Env -> ConcreteSyntax -> Either Error (Type, Syntax) 165 | synth ctx = \case 166 | CSVar bndr -> 167 | case resolveCell ctx bndr of 168 | Just Cell {..} -> pure (cellType, quote (Lvl $ size ctx) cellType cellValue) 169 | Nothing -> Left NotFound 170 | CSApp f args -> do 171 | f' <- synth ctx f 172 | foldM (synAp ctx) f' args 173 | CSTrue -> pure (BoolT, STrue) 174 | CSFalse -> pure (BoolT, SFalse) 175 | CSUnit -> pure (UnitT, SUnit) 176 | CSIf t1 t2 t3 -> do 177 | check ctx t1 BoolT 178 | t2' <- synth ctx t2 179 | t3' <- synth ctx t3 180 | if fst t2' == fst t3' 181 | then pure t2' 182 | else Left $ TypeError $ "Type mismatch: " <> show (fst t2') <> " /= " <> show (fst t3') 183 | CSAnno t1 ty -> (ty,) <$> check ctx t1 ty 184 | CSHole -> Left HoleInSynth 185 | _ -> Left $ TypeError "cannot synthesize type." 186 | 187 | synAp :: Env -> (Type, Syntax) -> ConcreteSyntax -> Either Error (Type, Syntax) 188 | synAp ctx (tyA :-> tyB, f) arg = do 189 | arg' <- check ctx arg tyA 190 | pure (tyB, SApp f arg') 191 | synAp _ ty _ = Left $ TypeError $ "Not a function type: " <> show ty 192 | 193 | check :: Env -> ConcreteSyntax -> Type -> Either Error Syntax 194 | check ctx a@(CSAbs bndr body) ty = 195 | case ty of 196 | tyA :-> tyB -> do 197 | let var = freshCell ctx bndr tyA 198 | fiber <- check (bindVar ctx var) body tyB 199 | pure $ SAbs bndr fiber 200 | ty' -> Left $ TypeError $ "Abs requires a function type, but got a: " <> show ty' 201 | check ctx CSHole ty = do 202 | -- Note: For demonstration purposes here we simply return the first 203 | -- hole encountered. However, in a more complete system we would 204 | -- convert from a Concrete Syntax hole to a Syntax hole and have 205 | -- some effect to accumulate all the holes: 206 | 207 | -- label <- freshHole 208 | -- let hole = SHole ty label 209 | -- logHole hole 210 | -- pure hole 211 | 212 | -- This would allow us to continue typechecking and collect all the 213 | -- holes for reporting to the user. The required Hole constructors 214 | -- are included in our types to hint at this but the actual 215 | -- implementation is deferred so as to not obscure the core 216 | -- elaborator behavior. 217 | Left $ TypeHole ty 218 | check ctx t1 ty = do 219 | (ty', t1') <- synth ctx t1 220 | if ty' == ty 221 | then pure t1' 222 | else Left $ TypeError $ "Expected type " <> show ty <> " but got " <> show ty' 223 | 224 | freshVar :: Env -> Type -> Value 225 | freshVar Env {size} ty = VNeutral ty $ Neutral (VVar $ Lvl size) Nil 226 | 227 | freshCell :: Env -> Name -> Type -> Cell 228 | freshCell ctx name ty = Cell name ty (freshVar ctx ty) 229 | 230 | -------------------------------------------------------------------------------- 231 | -- Evaluation 232 | 233 | newtype EvalEnv = EvalEnv (SnocList Value, Int) 234 | deriving stock (Show, Eq, Ord) 235 | 236 | initEvalEnv :: EvalEnv 237 | initEvalEnv = EvalEnv (Nil, 0) 238 | 239 | extendEvalEnv :: EvalEnv -> Value -> EvalEnv 240 | extendEvalEnv e@(EvalEnv (locals, size)) val = EvalEnv (Snoc locals val, size + 1) 241 | 242 | eval :: EvalEnv -> Syntax -> Value 243 | eval env@(EvalEnv (locals, size)) = \case 244 | SVar (Ix ix) -> fromMaybe (error "internal error") $ nth locals ix 245 | SAbs bndr body -> VLam bndr (Closure env body) 246 | SApp t1 t2 -> 247 | let fun = eval env t1 248 | arg = eval env t2 249 | in doApply fun arg 250 | STrue -> VTrue 251 | SFalse -> VFalse 252 | SUnit -> VUnit 253 | SIf t1 t2 t3 -> doIf (eval env t1) (eval env t2) (eval env t3) 254 | SHole ty ix -> VNeutral ty $ Neutral (VHole ty ix) Nil 255 | 256 | doApply :: Value -> Value -> Value 257 | doApply (VLam _ clo) arg = 258 | instantiateClosure clo arg 259 | doApply (VNeutral (ty1 :-> ty2) neu) arg = 260 | VNeutral ty2 (pushFrame neu (VApp ty1 arg)) 261 | doApply t1 t2 = error "Internal error: impossible case in doApply" 262 | 263 | instantiateClosure :: Closure -> Value -> Value 264 | instantiateClosure (Closure env body) v = eval (extendEvalEnv env v) body 265 | 266 | doIf :: Value -> Value -> Value -> Value 267 | doIf VTrue t2 t3 = t2 268 | doIf VFalse t2 t3 = t3 269 | 270 | quote :: Lvl -> Type -> Value -> Syntax 271 | quote _ UnitT _ = SUnit 272 | quote _ BoolT VTrue = STrue 273 | quote _ BoolT VFalse = SFalse 274 | quote l ty@(tyA :-> tyB) v@(VLam bndr clo@(Closure env body)) = 275 | let xVal = VNeutral tyA $ Neutral (VVar l) Nil 276 | in SAbs bndr $ quote (incLevel l) tyB $ instantiateClosure clo xVal 277 | quote l ty@(tyA :-> tyB) v = 278 | let xVal = VNeutral tyA $ Neutral (VVar l) Nil 279 | in SAbs (Name "_") $ quote (incLevel l) tyB $ doApply v xVal 280 | quote l ty1 (VNeutral ty2 neu) = 281 | if ty1 == ty2 282 | then quoteNeutral l neu 283 | else error "Internal error while quoting" 284 | 285 | quoteLevel :: Lvl -> Lvl -> Ix 286 | quoteLevel env@(Lvl l) (Lvl x) = Ix (l - (x + 1)) 287 | 288 | quoteNeutral :: Lvl -> Neutral -> Syntax 289 | quoteNeutral l Neutral {..} = foldl (quoteFrame l) (quoteHead l head) spine 290 | 291 | quoteHead :: Lvl -> Head -> Syntax 292 | quoteHead l = \case 293 | VVar x -> SVar (quoteLevel l x) 294 | VHole ty ix -> (SHole ty ix) 295 | 296 | quoteFrame :: Lvl -> Syntax -> Frame -> Syntax 297 | quoteFrame l t1 VApp {..} = SApp t1 (quote l ty arg) 298 | 299 | normalize :: ConcreteSyntax -> Syntax 300 | normalize term = 301 | case synth initEnv term of 302 | Right (ty, term') -> 303 | let val = eval initEvalEnv term' 304 | in quote (Lvl 0) ty val 305 | Left err -> error $ show err 306 | 307 | -------------------------------------------------------------------------------- 308 | -- Prettyprinter 309 | 310 | pp :: SnocList Name -> Syntax -> String 311 | pp env = \case 312 | SVar (Ix ix) -> maybe ("![bad index " <> show ix <> "]!") getName $ nth env ix 313 | SAbs bndr body -> "λ " <> getName bndr <> " . " <> pp (Snoc env bndr) body 314 | SApp t1 t2 -> pp env t1 <> " " <> pp env t2 315 | STrue -> "True" 316 | SFalse -> "False" 317 | SUnit -> "Unit" 318 | SIf t1 t2 t3 -> "if " <> pp env t2 <> " then " <> pp env t2 <> " else " <> pp env t3 319 | SHole _ ix -> "_" <> show ix 320 | 321 | -------------------------------------------------------------------------------- 322 | -- Main 323 | 324 | -- λx. x 325 | idenT :: ConcreteSyntax 326 | idenT = CSAnno (CSAbs (Name "x") (CSVar (Name "x"))) (UnitT :-> UnitT) 327 | 328 | -- λx. λy. x 329 | constT :: ConcreteSyntax 330 | constT = CSAnno (CSAbs (Name "x") (CSAbs (Name "_") (CSVar (Name "x")))) (BoolT :-> (UnitT :-> BoolT)) 331 | 332 | notT :: ConcreteSyntax 333 | notT = 334 | CSAnno 335 | (CSAbs (Name "p") (CSIf (CSVar (Name "p")) CSTrue CSFalse)) 336 | (BoolT :-> BoolT) 337 | 338 | main :: IO () 339 | main = do 340 | -- let term = CSApp (CSApp constT [CSTrue]) [CSUnit] 341 | let term = CSAnno (CSAbs (Name "f") (CSVar (Name "f"))) ((BoolT :-> BoolT) :-> (BoolT :-> BoolT)) 342 | case synth initEnv term of 343 | Left err -> print err 344 | Right (ty, tm) -> do 345 | let val = eval initEvalEnv tm 346 | putStrLn $ "Type: " <> show ty 347 | putStrLn $ "Syntax: " <> show tm 348 | putStrLn $ "Syntax Pretty: " <> pp Nil tm 349 | putStrLn $ "Value: " <> show val 350 | putStrLn $ "Quoted: " <> show (quote (Lvl 0) ty val) 351 | putStrLn $ "Quoted Pretty: " <> pp Nil (quote (Lvl 0) ty val) 352 | -------------------------------------------------------------------------------- /main/old/SimplyTypedModules.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | 6 | module Main where 7 | 8 | import Control.Monad 9 | import Control.Monad.Except 10 | import Control.Monad.Reader 11 | import Control.Monad.State 12 | import Data.List (foldl', (\\)) 13 | import Data.Map (Map) 14 | import Data.Map.Strict qualified as M 15 | 16 | --------------- 17 | --- Grammar --- 18 | --------------- 19 | 20 | data Term 21 | = Var String 22 | | Abs String Type Term 23 | | App Term Term 24 | | Unit 25 | | T 26 | | F 27 | | If Term Term Term 28 | deriving (Show) 29 | 30 | data Type = Type :-> Type | UnitT | BoolT 31 | deriving (Show, Eq) 32 | 33 | -- We store transient types and declarations in tuple now: 34 | type Gamma = [(String, (Type, Maybe Term))] 35 | 36 | data TypeErr = TypeError deriving (Show, Eq) 37 | 38 | ------------------------ 39 | --- Alpha Conversion --- 40 | ------------------------ 41 | 42 | data Stream a = Stream a (Stream a) 43 | 44 | data AlphaContext = AlphaContext {_names :: Stream String, _register :: Map String String} 45 | 46 | names :: [String] 47 | names = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 48 | 49 | stream :: [String] -> Stream String 50 | stream (x : xs) = Stream x (stream xs) 51 | 52 | alpha :: Term -> State AlphaContext Term 53 | alpha = \case 54 | (Var x) -> do 55 | mx <- gets (M.lookup x . _register) 56 | case mx of 57 | Just x' -> pure $ Var x' 58 | Nothing -> pure $ Var x 59 | (App t1 t2) -> do 60 | t1' <- alpha t1 61 | t2' <- alpha t2 62 | pure $ App t1' t2' 63 | t@(Abs bndr ty term) -> do 64 | (Stream fresh rest) <- gets _names 65 | registry <- gets _register 66 | put $ AlphaContext rest (M.insert bndr fresh registry) 67 | term' <- alpha term 68 | pure $ Abs fresh ty term' 69 | (If t1 t2 t3) -> do 70 | t1' <- alpha t1 71 | t2' <- alpha t2 72 | t3' <- alpha t3 73 | pure (If t1' t2' t3') 74 | t -> pure t 75 | 76 | emptyContext :: AlphaContext 77 | emptyContext = AlphaContext (stream names) (M.empty) 78 | 79 | alphaconvert :: Term -> Term 80 | alphaconvert term = evalState (alpha term) emptyContext 81 | 82 | -------------------- 83 | --- Typechecking --- 84 | -------------------- 85 | 86 | newtype TypecheckM a = TypecheckM {unTypecheckM :: ExceptT TypeErr (Reader Gamma) a} 87 | deriving (Functor, Applicative, Monad, MonadReader Gamma, MonadError TypeErr) 88 | 89 | extendTypecheckM :: Gamma -> TypecheckM a -> Either TypeErr a 90 | extendTypecheckM gamma = flip runReader gamma . runExceptT . unTypecheckM 91 | 92 | runTypecheckM :: TypecheckM a -> Either TypeErr a 93 | runTypecheckM = flip runReader [] . runExceptT . unTypecheckM 94 | 95 | extendType :: String -> Type -> Gamma -> Gamma 96 | extendType bndr t gamma = (bndr, (t, Nothing)) : gamma 97 | 98 | extendTerm :: String -> Type -> Maybe Term -> Gamma -> Gamma 99 | extendTerm bndr ty t gamma = (bndr, (ty, t)) : gamma 100 | 101 | lookupType :: String -> Gamma -> Maybe Type 102 | lookupType s gamma = fst <$> lookup s gamma 103 | 104 | typecheck :: Term -> TypecheckM Type 105 | typecheck = \case 106 | Var x -> do 107 | ty <- asks $ lookupType x 108 | maybe (throwError TypeError) pure ty 109 | Abs bndr ty1 trm -> do 110 | ty2 <- local (extendType bndr ty1) (typecheck trm) 111 | pure $ ty1 :-> ty2 112 | App t1 t2 -> do 113 | ty1 <- typecheck t1 114 | case ty1 of 115 | tyA :-> tyB -> do 116 | ty2 <- typecheck t2 117 | if tyA == ty2 then pure ty1 else throwError TypeError 118 | _ -> throwError TypeError 119 | Unit -> pure UnitT 120 | T -> pure BoolT 121 | F -> pure BoolT 122 | If t0 t1 t2 -> do 123 | ty0 <- typecheck t0 124 | ty1 <- typecheck t1 125 | ty2 <- typecheck t2 126 | if ty0 == BoolT && ty1 == ty2 127 | then pure ty1 128 | else throwError TypeError 129 | 130 | -------------------- 131 | --- Substitution --- 132 | -------------------- 133 | 134 | subst :: String -> Term -> Term -> Term 135 | subst x s = \case 136 | (Var x') | x == x' -> s 137 | (Var y) -> Var y 138 | (Abs y ty t1) 139 | | x /= y && y `notElem` freevars s -> Abs y ty (subst x s t1) 140 | | otherwise -> error "oops name collision" 141 | (App t1 t2) -> App (subst x s t1) (subst x s t2) 142 | (If t0 t1 t2) -> If (subst x s t0) (subst x s t1) (subst x s t2) 143 | T -> T 144 | F -> F 145 | Unit -> Unit 146 | 147 | freevars :: Term -> [String] 148 | freevars = \case 149 | (Var x) -> [x] 150 | (Abs x ty t) -> freevars t \\ [x] 151 | (App t1 t2) -> freevars t1 ++ freevars t2 152 | (If t0 t1 t2) -> freevars t0 ++ freevars t1 ++ freevars t2 153 | 154 | ------------------ 155 | --- Evaluation --- 156 | ------------------ 157 | 158 | isVal :: Term -> Bool 159 | isVal = \case 160 | Abs {} -> True 161 | T -> True 162 | F -> True 163 | Unit -> True 164 | _ -> False 165 | 166 | singleEval :: Term -> Maybe Term 167 | singleEval = \case 168 | (App (Abs x ty t12) v2) | isVal v2 -> Just $ subst x v2 t12 169 | (App v1@Abs {} t2) -> App v1 <$> singleEval t2 170 | (App t1 t2) -> flip App t2 <$> singleEval t1 171 | (If T t2 t3) -> pure t2 172 | (If F t2 t3) -> pure t3 173 | _ -> Nothing 174 | 175 | multiStepEval :: Term -> Term 176 | multiStepEval t = maybe t multiStepEval (singleEval t) 177 | 178 | --------------- 179 | --- Modules --- 180 | --------------- 181 | 182 | data Module = Module {declarations :: [(String, Term)]} 183 | deriving (Show) 184 | 185 | checkDecl :: (String, Term) -> TypecheckM (String, (Type, Maybe Term)) 186 | checkDecl (bndr, term) = do 187 | ty <- typecheck term 188 | pure (bndr, (ty, Just term)) 189 | 190 | checkModule :: Module -> TypecheckM () 191 | checkModule (Module []) = pure () 192 | checkModule (Module (x : xs)) = do 193 | (bndr, (ty, term)) <- checkDecl x 194 | local (extendTerm bndr ty term) $ checkModule (Module xs) 195 | 196 | checkModule' :: Module -> StateT Gamma TypecheckM () 197 | checkModule' (Module xs) = forM_ xs $ \x -> do 198 | gamma <- get 199 | (bndr, (ty, term)) <- lift $ local (const gamma) (checkDecl x) 200 | modify (extendTerm bndr ty term) 201 | 202 | runCheckModule :: Module -> Either TypeErr () 203 | runCheckModule mod = runTypecheckM $ evalStateT (checkModule' mod) [] 204 | 205 | inlineTerms :: [(String, Term)] -> Term -> Term 206 | inlineTerms xs term = 207 | let f term (x, t) = case term of 208 | Var x' | x == x' -> t 209 | Abs bndr ty t1 -> Abs bndr ty (f t1 (x, t)) 210 | App t1 t2 -> App (f t1 (x, t)) (f t2 (x, t)) 211 | If t1 t2 t3 -> If (f t1 (x, t)) (f t2 (x, t)) (f t3 (x, t)) 212 | t -> t 213 | in foldl' f term xs 214 | 215 | data Zipper a = Z [a] a [a] 216 | deriving (Show) 217 | 218 | inlineModule :: Module -> Term 219 | inlineModule (Module [x]) = snd x 220 | inlineModule (Module (x : xs)) = 221 | let f (Z left curr []) = inlineTerms left (snd curr) 222 | f (Z left curr (r : ight)) = f $ Z ((inlineTerms left <$> curr) : left) r ight 223 | in f $ Z [] x xs 224 | 225 | execModule :: Module -> Either TypeErr Term 226 | execModule m@(Module decls) = 227 | let main = inlineModule (Module (fmap alphaconvert <$> decls)) 228 | in runCheckModule m >> pure (multiStepEval main) 229 | 230 | ------------ 231 | --- Main --- 232 | ------------ 233 | 234 | notT :: Term 235 | notT = Abs "p" BoolT (If (Var "p") F T) 236 | 237 | testModule :: Module 238 | testModule = Module [("tru", T), ("not", notT), ("main", (App (Var "not") (Var "tru")))] 239 | 240 | -- A module that should not pass typechecking: 241 | testModule' :: Module 242 | testModule' = Module [("tru", T), ("not", notT), ("main", (App (Var "not") Unit))] 243 | 244 | main :: IO () 245 | main = 246 | case execModule testModule of 247 | Left e -> print e 248 | Right t -> print t 249 | -------------------------------------------------------------------------------- /main/old/SimplyTypedNBE.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE StrictData #-} 8 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 9 | 10 | module Main where 11 | 12 | -------------------------------------------------------------------------------- 13 | 14 | import Data.Functor (($>)) 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Utils 18 | 19 | data SnocList a 20 | = Snoc (SnocList a) a 21 | | Nil 22 | deriving (Show, Eq, Ord, Functor, Foldable) 23 | 24 | nth :: SnocList a -> Int -> Maybe a 25 | nth xs i 26 | | i < 0 = Nothing 27 | | otherwise = 28 | let go = \case 29 | (Nil, _) -> Nothing 30 | (Snoc _ x, 0) -> Just x 31 | (Snoc ys _, j) -> go (ys, j - 1) 32 | in go (xs, i) 33 | 34 | -------------------------------------------------------------------------------- 35 | -- Terms 36 | 37 | data Type = Type :-> Type | UnitT | BoolT 38 | deriving stock (Show, Eq, Ord) 39 | 40 | newtype Env val 41 | = Env (SnocList val) 42 | deriving stock (Show, Eq, Ord, Functor) 43 | 44 | initEnv :: Env val 45 | initEnv = Env Nil 46 | 47 | type Gamma = Env Type 48 | 49 | initCtx :: Gamma 50 | initCtx = initEnv 51 | 52 | data Syntax 53 | = Var Ix 54 | | Abs Name Syntax 55 | | App Syntax Syntax 56 | | Unit 57 | | T 58 | | F 59 | | If Syntax Syntax Syntax 60 | | Anno Syntax Type 61 | deriving stock (Show, Eq, Ord) 62 | 63 | data Value 64 | = VNeutral Type Neutral 65 | | VLam Name Closure 66 | | VTrue 67 | | VFalse 68 | | VUnit 69 | deriving stock (Show, Eq, Ord) 70 | 71 | data Neutral = Neutral {head :: Head, spine :: SnocList Frame} 72 | deriving stock (Show, Eq, Ord) 73 | 74 | newtype Head 75 | = VVar Lvl 76 | deriving (Show, Eq, Ord) 77 | 78 | data Frame = VApp {ty :: Type, arg :: Value} 79 | deriving stock (Show, Eq, Ord) 80 | 81 | pushFrame :: Neutral -> Frame -> Neutral 82 | pushFrame Neutral {..} frame = Neutral {head = head, spine = Snoc spine frame} 83 | 84 | data Closure = Closure {env :: Env Value, body :: Syntax} 85 | deriving stock (Show, Eq, Ord) 86 | 87 | -- | Debruijn Indices 88 | -- 89 | -- λ.λ.λ.2 90 | -- ^-----^ 91 | newtype Ix 92 | = Ix Int 93 | deriving newtype (Show, Eq, Ord) 94 | 95 | -- | Debruijn Levels 96 | -- 97 | -- λ.λ.λ.0 98 | -- ^-----^ 99 | newtype Lvl 100 | = Lvl Int 101 | deriving newtype (Show, Eq, Ord) 102 | 103 | incLevel :: Lvl -> Lvl 104 | incLevel (Lvl n) = Lvl (1 + n) 105 | 106 | newtype Name 107 | = Name String 108 | deriving newtype (Show, Eq, Ord) 109 | 110 | data Error 111 | = NotFound 112 | | TypeError String 113 | deriving (Show) 114 | 115 | lookupVar :: Env val -> Ix -> Either Error val 116 | lookupVar (Env env) (Ix i) = maybe (Left NotFound) Right $ env `nth` i 117 | 118 | extend :: Env val -> val -> Env val 119 | extend (Env env) val = Env (Snoc env val) 120 | 121 | -------------------------------------------------------------------------------- 122 | -- Typechecking 123 | 124 | synth :: Gamma -> Syntax -> Either Error Type 125 | synth ctx = \case 126 | Var ix -> lookupVar ctx ix 127 | App t1 t2 -> 128 | synth ctx t1 >>= \case 129 | tyA :-> tyB -> do 130 | check ctx t2 tyA 131 | pure tyB 132 | ty -> Left (TypeError $ "Not a function type: " ++ show ty) 133 | T -> pure BoolT 134 | F -> pure BoolT 135 | Unit -> pure UnitT 136 | If t1 t2 t3 -> do 137 | check ctx t1 BoolT 138 | ty2 <- synth ctx t2 139 | ty3 <- synth ctx t3 140 | if ty2 == ty3 141 | then pure ty2 142 | else Left $ TypeError $ "Type mismatch: " <> show ty2 <> " /= " <> show ty3 143 | Anno t1 ty -> check ctx t1 ty $> ty 144 | _ -> Left $ TypeError "cannot synthesize type." 145 | 146 | check :: Gamma -> Syntax -> Type -> Either Error () 147 | check ctx (Abs _bndr body) ty = 148 | case ty of 149 | tyA :-> tyB -> check (extend ctx tyA) body tyB 150 | ty' -> Left $ TypeError $ "Abs requires a function type, but got a: " <> show ty' 151 | check ctx t1 ty = do 152 | ty' <- synth ctx t1 153 | if ty' == ty 154 | then pure () 155 | else Left $ TypeError $ "Expected type " <> show ty <> " but got " <> show ty' 156 | 157 | -------------------------------------------------------------------------------- 158 | -- Evaluation 159 | 160 | eval :: Env Value -> Syntax -> Value 161 | eval env = \case 162 | Var ix -> either (error "internal error") id $ lookupVar env ix 163 | Abs bndr body -> VLam bndr (Closure env body) 164 | App t1 t2 -> 165 | let fun = eval env t1 166 | arg = eval env t2 167 | in doApply fun arg 168 | T -> VTrue 169 | F -> VFalse 170 | Unit -> VUnit 171 | If t1 t2 t3 -> doIf (eval env t1) (eval env t2) (eval env t3) 172 | Anno t1 _ty -> eval env t1 173 | 174 | doApply :: Value -> Value -> Value 175 | doApply (VLam _ clo) arg = 176 | instantiateClosure clo arg 177 | doApply (VNeutral (ty1 :-> ty2) neu) arg = 178 | VNeutral ty2 (pushFrame neu (VApp ty1 arg)) 179 | doApply _ _ = error "impossible case in doApply" 180 | 181 | instantiateClosure :: Closure -> Value -> Value 182 | instantiateClosure (Closure env body) v = eval (extend env v) body 183 | 184 | doIf :: Value -> Value -> Value -> Value 185 | doIf VTrue t2 _t3 = t2 186 | doIf VFalse _t2 t3 = t3 187 | doIf _ _ _ = error "impossible case in doIf" 188 | 189 | quote :: Lvl -> Type -> Value -> Syntax 190 | quote _ UnitT _ = Unit 191 | quote _ BoolT VTrue = T 192 | quote _ BoolT VFalse = F 193 | quote l (tyA :-> tyB) (VLam bndr clo@(Closure _env _body)) = 194 | let body = bindVar tyA l $ \v l' -> 195 | quote l' tyB $ instantiateClosure clo v 196 | in Abs bndr body 197 | quote l (tyA :-> tyB) f = 198 | let body = bindVar tyA l $ \v l' -> 199 | quote l' tyB (doApply f v) 200 | in Abs (Name "_") body 201 | quote l ty1 (VNeutral ty2 neu) = 202 | if ty1 == ty2 203 | then quoteNeutral l neu 204 | else error "Internal error while quoting" 205 | quote _ _ _ = error "impossible case in quote" 206 | 207 | bindVar :: Type -> Lvl -> (Value -> Lvl -> a) -> a 208 | bindVar ty lvl f = 209 | let v = VNeutral ty $ Neutral (VVar lvl) Nil 210 | in f v $ incLevel lvl 211 | 212 | quoteLevel :: Lvl -> Lvl -> Ix 213 | quoteLevel (Lvl l) (Lvl x) = Ix (l - (x + 1)) 214 | 215 | quoteNeutral :: Lvl -> Neutral -> Syntax 216 | quoteNeutral l Neutral {..} = foldl (quoteFrame l) (quoteHead l head) spine 217 | 218 | quoteHead :: Lvl -> Head -> Syntax 219 | quoteHead l (VVar x) = Var (quoteLevel l x) 220 | 221 | quoteFrame :: Lvl -> Syntax -> Frame -> Syntax 222 | quoteFrame l t1 VApp {..} = App t1 (quote l ty arg) 223 | 224 | normalize :: Syntax -> Syntax 225 | normalize term = 226 | case synth initEnv term of 227 | Right ty -> 228 | let val = eval initEnv term 229 | in quote (Lvl 0) ty val 230 | Left err -> error $ show err 231 | 232 | -------------------------------------------------------------------------------- 233 | -- main 234 | 235 | -- λx. x 236 | idenT :: Syntax 237 | idenT = Anno (Abs (Name "x") (Var (Ix 0))) (UnitT :-> UnitT) 238 | 239 | -- λf. f 240 | identT' :: Syntax 241 | identT' = 242 | Anno 243 | (Abs (Name "f") (Var (Ix 0))) 244 | ((BoolT :-> BoolT) :-> (BoolT :-> BoolT)) 245 | 246 | -- λx. λy. x 247 | constT :: Syntax 248 | constT = Anno (Abs (Name "x") (Abs (Name "_") (Var (Ix 1)))) (BoolT :-> (UnitT :-> BoolT)) 249 | 250 | -- λf. λx. f x 251 | applyT :: Syntax 252 | applyT = 253 | Anno 254 | (Abs (Name "f") (Abs (Name "x") (App (Var (Ix 1)) (Var (Ix 0))))) 255 | ((BoolT :-> BoolT) :-> (BoolT :-> BoolT)) 256 | 257 | notT :: Syntax 258 | notT = 259 | Anno 260 | (Abs (Name "p") (If (Var (Ix 0)) T F)) 261 | (BoolT :-> BoolT) 262 | 263 | main :: IO () 264 | main = do 265 | let term = Anno (Abs (Name "f") (Var (Ix 0))) ((BoolT :-> BoolT) :-> (BoolT :-> BoolT)) 266 | case synth initCtx term of 267 | Left err -> print err 268 | Right ty -> do 269 | print ty 270 | print (normalize term) 271 | -------------------------------------------------------------------------------- /main/old/SimplyTypedPatterns.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | module Main where 9 | 10 | import Control.Lens hiding (Context) 11 | import Control.Monad 12 | import Control.Monad.Except 13 | import Control.Monad.Reader 14 | import Control.Monad.State 15 | import Data.List (find, foldl', sort, (\\)) 16 | import Data.List.NonEmpty (NonEmpty (..)) 17 | import Data.List.NonEmpty qualified as NEL 18 | import Data.Map (Map) 19 | import Data.Map.Strict qualified as M 20 | 21 | ------------- 22 | --- Terms --- 23 | ------------- 24 | 25 | type Tycon = String 26 | 27 | type Binding = String 28 | 29 | data Term 30 | = Var Binding 31 | | Abs Binding Type Term 32 | | App Term Term 33 | | Constructor String 34 | | Case Term [(NonEmpty String, Term)] 35 | deriving (Show) 36 | 37 | infixr 0 :-> 38 | 39 | data Type = Type :-> Type | TypeConstructor String 40 | deriving (Show, Eq) 41 | 42 | data DataConstructor = DataConstructor 43 | { _typeConstructorName :: String, 44 | _dataConstructors :: [(String, [Type])] 45 | } 46 | deriving (Show) 47 | 48 | makeLenses ''DataConstructor 49 | 50 | data Context = Context 51 | { _gamma :: Map Binding Type, 52 | _dataDeclarations :: Map Tycon DataConstructor 53 | } 54 | deriving (Show) 55 | 56 | makeLenses ''Context 57 | 58 | emptyContext :: Context 59 | emptyContext = Context M.empty M.empty 60 | 61 | data TypeErr = TypeError deriving (Show, Eq) 62 | 63 | ------------------------ 64 | --- Alpha Conversion --- 65 | ------------------------ 66 | 67 | data Stream a = Stream a (Stream a) 68 | 69 | data AlphaContext = AlphaContext {_names :: Stream String, _register :: Map String String} 70 | 71 | names :: [String] 72 | names = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 73 | 74 | stream :: [String] -> Stream String 75 | stream (x : xs) = Stream x (stream xs) 76 | 77 | alpha :: Term -> State AlphaContext Term 78 | alpha = \case 79 | Var x -> do 80 | mx <- gets (M.lookup x . _register) 81 | case mx of 82 | Just x' -> pure $ Var x' 83 | Nothing -> pure $ Var x 84 | App t1 t2 -> do 85 | t1' <- alpha t1 86 | t2' <- alpha t2 87 | pure $ App t1' t2' 88 | t@(Abs bndr ty term) -> do 89 | (Stream fresh rest) <- gets _names 90 | registry <- gets _register 91 | put $ AlphaContext rest (M.insert bndr fresh registry) 92 | term' <- alpha term 93 | pure $ Abs fresh ty term' 94 | Case t1 patterns -> do 95 | t1' <- alpha t1 96 | patterns' <- (traverse . traverse) alpha patterns 97 | pure $ Case t1' patterns' 98 | t -> pure t 99 | 100 | emptyAlphaContext :: AlphaContext 101 | emptyAlphaContext = AlphaContext (stream names) M.empty 102 | 103 | alphaconvert :: Term -> Term 104 | alphaconvert term = evalState (alpha term) emptyAlphaContext 105 | 106 | -------------------- 107 | --- Typechecking --- 108 | -------------------- 109 | 110 | newtype TypecheckM a = TypecheckM {unTypecheckM :: ExceptT TypeErr (Reader Context) a} 111 | deriving (Functor, Applicative, Monad, MonadReader Context, MonadError TypeErr) 112 | 113 | extendTypecheckM :: Context -> TypecheckM a -> Either TypeErr a 114 | extendTypecheckM gamma = flip runReader gamma . runExceptT . unTypecheckM 115 | 116 | runTypecheckM :: TypecheckM a -> Either TypeErr a 117 | runTypecheckM = flip runReader emptyContext . runExceptT . unTypecheckM 118 | 119 | typecheck :: Term -> TypecheckM Type 120 | typecheck = \case 121 | Var x -> do 122 | ty <- view (gamma . at x) 123 | maybe (throwError TypeError) pure ty 124 | Abs bndr ty1 trm -> do 125 | ty2 <- local (gamma %~ M.insert bndr ty1) (typecheck trm) 126 | pure $ ty1 :-> ty2 127 | App t1 t2 -> do 128 | ty1 <- typecheck t1 129 | case ty1 of 130 | tyA :-> tyB -> do 131 | ty2 <- typecheck t2 132 | if tyA == ty2 then pure tyB else throwError TypeError 133 | _ -> throwError TypeError 134 | Constructor cnstr -> do 135 | tycon <- view (gamma . at cnstr) 136 | g <- view gamma 137 | maybe (throwError TypeError) pure tycon 138 | Case t1 patterns -> do 139 | typecheck t1 >>= \case 140 | TypeConstructor tycon -> do 141 | view (dataDeclarations . at tycon) >>= \case 142 | Just decl -> do 143 | let consTags = sort $ decl ^.. dataConstructors . folded . _1 144 | pattTags = sort $ NEL.head <$> patterns ^.. folded . _1 145 | if consTags == pattTags 146 | then checkPatterns decl patterns 147 | else throwError TypeError 148 | Nothing -> throwError TypeError 149 | _ -> throwError TypeError 150 | 151 | checkPattern :: DataConstructor -> (NonEmpty String, Term) -> TypecheckM Type 152 | checkPattern decl (cnstr :| xs, term) = do 153 | let cnstrs = decl ^. dataConstructors 154 | case lookup cnstr cnstrs of 155 | Just ys -> 156 | if length xs == length ys 157 | then local (gamma <>~ (M.fromList (zip xs ys))) (typecheck term) 158 | else throwError TypeError 159 | Nothing -> throwError TypeError 160 | 161 | checkPatterns :: DataConstructor -> [(NonEmpty String, Term)] -> TypecheckM Type 162 | checkPatterns decl patterns = do 163 | traverse (checkPattern decl) patterns >>= \case 164 | [] -> throwError TypeError 165 | (x : xs) -> 166 | if all (== x) xs 167 | then pure x 168 | else throwError TypeError 169 | 170 | -------------------- 171 | --- Substitution --- 172 | -------------------- 173 | 174 | subst :: String -> Term -> Term -> Term 175 | subst x s = \case 176 | (Var x') | x == x' -> s 177 | (Var y) -> Var y 178 | (Abs y ty t1) 179 | | x /= y && y `notElem` freevars s -> Abs y ty (subst x s t1) 180 | | otherwise -> error "oops name collision" 181 | (App t1 t2) -> App (subst x s t1) (subst x s t2) 182 | Constructor cstr -> Constructor cstr 183 | Case t1 pattrns -> Case (subst x s t1) (fmap (subst x s) <$> pattrns) 184 | 185 | substs :: [String] -> [Term] -> Term -> Term 186 | substs bndrs ts t = 187 | let fs = zipWith subst bndrs ts 188 | in foldl' (&) t fs 189 | 190 | freevars :: Term -> [String] 191 | freevars = \case 192 | Var x -> [x] 193 | Abs x ty t -> freevars t \\ [x] 194 | App t1 t2 -> freevars t1 ++ freevars t2 195 | Constructor x -> [x] 196 | Case t1 pattrns -> freevars t1 ++ concatMapOf (folded . _2) freevars pattrns 197 | 198 | ------------------ 199 | --- Evaluation --- 200 | ------------------ 201 | 202 | isVal :: Term -> Bool 203 | isVal = \case 204 | Abs {} -> True 205 | Constructor x -> True 206 | _ -> False 207 | 208 | singleEval :: Term -> Maybe Term 209 | singleEval = \case 210 | App (Abs x ty t12) v2 | isVal v2 -> Just $ subst x v2 t12 211 | App v1@Abs {} t2 -> App v1 <$> singleEval t2 212 | App t1 t2 -> flip App t2 <$> singleEval t1 213 | Case v1 pattrns | isVal v1 -> match v1 pattrns 214 | Case t1 pattrns -> flip Case pattrns <$> singleEval t1 215 | _ -> Nothing 216 | 217 | match :: Term -> [(NonEmpty String, Term)] -> Maybe Term 218 | match (Constructor cnstr) pattrns = 219 | let xs = map (\(x :| xs, y) -> (x, y)) pattrns 220 | in lookup cnstr xs 221 | match _ pattrns = Nothing 222 | 223 | multiStepEval :: Term -> Term 224 | multiStepEval t = maybe t multiStepEval (singleEval t) 225 | 226 | eval :: Term -> Term 227 | eval = \case 228 | App t1 t2 -> 229 | let v2 = eval t2 230 | in case eval t1 of 231 | Abs x _ t12 -> eval (subst x v2 t12) 232 | v1 -> App v1 v2 233 | Case t1 pattrns -> 234 | let v1 = eval t1 235 | in case normalizePats v1 pattrns of 236 | Just t -> t 237 | Nothing -> undefined 238 | t -> t 239 | 240 | unpackCnstr :: Term -> Maybe (String, [Term]) 241 | unpackCnstr (App t1 t2) = do 242 | (x, ts) <- unpackCnstr t1 243 | pure (x, ts <> [t2]) 244 | unpackCnstr (Constructor x) = Just (x, []) 245 | unpackCnstr _ = Nothing 246 | 247 | normalizePats :: Term -> [(NonEmpty String, Term)] -> Maybe Term 248 | normalizePats t pattrns = do 249 | (cnstr, ts) <- unpackCnstr t 250 | (_ :| bndrs, t') <- find ((== cnstr) . NEL.head . fst) pattrns 251 | pure $ substs bndrs ts t' 252 | 253 | ------------ 254 | --- Main --- 255 | ------------ 256 | 257 | boolT :: Type 258 | boolT = TypeConstructor "Boolean" 259 | 260 | tru :: Term 261 | tru = Constructor "True" 262 | 263 | fls :: Term 264 | fls = Constructor "False" 265 | 266 | pairT :: Type 267 | pairT = TypeConstructor "PairT" 268 | 269 | pair :: Term 270 | pair = App (App (Constructor "Pair") tru) fls 271 | 272 | testContext :: Context 273 | testContext = Context g d 274 | where 275 | g = 276 | M.fromList 277 | [ ("Id", (boolT :-> TypeConstructor "IdT")), 278 | ("True", boolT), 279 | ("False", boolT), 280 | ("Pair", (boolT :-> boolT :-> TypeConstructor "PairT")), 281 | ("Left", (boolT :-> TypeConstructor "EitherT")), 282 | ("Right", (boolT :-> TypeConstructor "EitherT")) 283 | ] 284 | d = 285 | M.fromList 286 | [ ("Boolean", (DataConstructor "Boolean" [("True", []), ("False", [])])), 287 | ("IdT", (DataConstructor "IdT" [("Id", [boolT])])), 288 | ("PairT", (DataConstructor "PairT" [("Pair", [boolT, boolT])])), 289 | ( "EitherT", 290 | ( DataConstructor 291 | "EitherT" 292 | [ ("Left", [boolT]), 293 | ("Right", [boolT]) 294 | ] 295 | ) 296 | ) 297 | ] 298 | 299 | notT :: Term 300 | notT = 301 | Abs "p" boolT $ 302 | Case 303 | (Var "p") 304 | [ ("True" :| [], fls), 305 | ("False" :| [], tru) 306 | ] 307 | 308 | first :: Term 309 | first = 310 | Abs "p" pairT $ 311 | Case (Var "p") [("Pair" :| ["x", "y"], Var "x")] 312 | 313 | caseTest :: Term 314 | caseTest = 315 | Abs "x" (TypeConstructor "IdT") $ 316 | Case (Var "x") [("Id" :| ["y"], Var "y")] 317 | 318 | main :: IO () 319 | main = do 320 | let term = App first pair 321 | print $ extendTypecheckM testContext (typecheck term) 322 | print $ eval term 323 | -------------------------------------------------------------------------------- /main/old/SystemF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Main where 8 | 9 | import Control.Lens 10 | import Control.Monad.Except 11 | import Control.Monad.Reader 12 | import Control.Monad.State 13 | import Data.List ((\\)) 14 | import Data.Map (Map) 15 | import Data.Map.Strict qualified as M 16 | 17 | ------------- 18 | --- Terms --- 19 | ------------- 20 | 21 | data Term 22 | = Var String 23 | | Abs String Type Term 24 | | App Term Term 25 | | TAbs String Term 26 | | TApp Term Type 27 | | Unit 28 | | T 29 | | F 30 | | If Term Term Term 31 | deriving (Show) 32 | 33 | infixr 0 :-> 34 | 35 | data Type = Type :-> Type | TVar String | Forall String Type | UnitT | BoolT 36 | deriving (Show, Eq) 37 | 38 | data Gamma = Gamma {_context :: Map String Type, _contextT :: [String]} 39 | 40 | makeLenses ''Gamma 41 | 42 | data TypeErr = TypeError deriving (Show, Eq) 43 | 44 | ---------------------- 45 | --- Pretty Printer --- 46 | ---------------------- 47 | 48 | class Show a => Pretty a where 49 | pretty :: a -> String 50 | pretty = show 51 | 52 | instance Pretty Term where 53 | pretty = \case 54 | Var x -> x 55 | Abs bndr ty t0 -> "(λ" ++ bndr ++ " : " ++ pretty ty ++ ". " ++ pretty t0 ++ ")" 56 | App t1 t2 -> pretty t1 ++ " " ++ pretty t2 57 | TAbs bndr t0 -> "(Λ" ++ bndr ++ ". " ++ pretty t0 ++ ")" 58 | TApp t0 ty -> pretty t0 ++ " " ++ "[" ++ pretty ty ++ "]" 59 | Unit -> "Unit" 60 | T -> "True" 61 | F -> "False" 62 | If t0 t1 t2 -> "If " ++ pretty t0 ++ " then " ++ pretty t1 ++ " else " ++ pretty t2 63 | 64 | instance Pretty Type where 65 | pretty = \case 66 | UnitT -> "Unit" 67 | BoolT -> "Bool" 68 | Forall x ty -> "∀" ++ x ++ " . " ++ pretty ty 69 | TVar x -> x 70 | ty0 :-> ty1 -> pretty ty0 ++ " -> " ++ pretty ty1 71 | 72 | ------------------------ 73 | --- Alpha Conversion --- 74 | ------------------------ 75 | 76 | data Stream a = Stream a (Stream a) 77 | 78 | data AlphaContext = AlphaContext 79 | { _names :: Stream String, 80 | _namesT :: Stream String, 81 | _register :: Map String String 82 | } 83 | 84 | makeLenses ''AlphaContext 85 | 86 | namesStream :: [String] 87 | namesStream = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 88 | 89 | typeNamesStream :: [String] 90 | typeNamesStream = (pure <$> ['A' .. 'Z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['A' .. 'Z']) 91 | 92 | stream :: [String] -> Stream String 93 | stream (x : xs) = Stream x (stream xs) 94 | 95 | alphaT :: Type -> State AlphaContext Type 96 | alphaT = \case 97 | TVar bndr -> 98 | use (register . at bndr) >>= \case 99 | Just bndr' -> pure $ TVar bndr' 100 | Nothing -> error "Something impossible happened" 101 | Forall bndr ty -> do 102 | use (register . at bndr) >>= \case 103 | Just bndr' -> Forall bndr' <$> alphaT ty 104 | Nothing -> do 105 | Stream fresh rest <- use namesT 106 | regstry <- use register 107 | namesT .= rest 108 | register %= M.insert bndr fresh 109 | ty' <- alphaT ty 110 | pure $ Forall fresh ty' 111 | ty1 :-> ty2 -> do 112 | ty1' <- alphaT ty1 113 | ty2' <- alphaT ty2 114 | pure $ ty1' :-> ty2' 115 | t -> pure t 116 | 117 | alpha :: Term -> State AlphaContext Term 118 | alpha = \case 119 | Var x -> 120 | use (register . at x) >>= \case 121 | Just x' -> pure $ Var x' 122 | Nothing -> error "Something impossible happened" 123 | App t1 t2 -> do 124 | t1' <- alpha t1 125 | t2' <- alpha t2 126 | pure $ App t1' t2' 127 | Abs bndr ty term -> do 128 | Stream fresh rest <- use names 129 | registry <- use register 130 | names .= rest 131 | register %= M.insert bndr fresh 132 | term' <- alpha term 133 | ty' <- alphaT ty 134 | pure $ Abs fresh ty' term' 135 | TApp t tyBndr -> do 136 | t' <- alpha t 137 | tyBndr' <- alphaT tyBndr 138 | pure $ TApp t' tyBndr' 139 | TAbs tyBndr term -> do 140 | Stream fresh' rest' <- use namesT 141 | regstry <- use register 142 | namesT .= rest' 143 | register %= M.insert tyBndr fresh' 144 | term' <- alpha term 145 | pure $ TAbs fresh' term' 146 | If t1 t2 t3 -> do 147 | t1' <- alpha t1 148 | t2' <- alpha t2 149 | t3' <- alpha t3 150 | pure (If t1' t2' t3') 151 | t -> pure t 152 | 153 | emptyAlphaContext :: AlphaContext 154 | emptyAlphaContext = AlphaContext (stream namesStream) (stream typeNamesStream) M.empty 155 | 156 | alphaconvert :: Term -> Term 157 | alphaconvert term = evalState (alpha term) emptyAlphaContext 158 | 159 | -------------------- 160 | --- Typechecking --- 161 | -------------------- 162 | 163 | newtype TypecheckM a = TypecheckM {unTypecheckM :: ExceptT TypeErr (Reader Gamma) a} 164 | deriving (Functor, Applicative, Monad, MonadReader Gamma, MonadError TypeErr) 165 | 166 | emptyGamma :: Gamma 167 | emptyGamma = Gamma mempty mempty 168 | 169 | runTypecheckM :: TypecheckM Type -> Either TypeErr Type 170 | runTypecheckM = flip runReader emptyGamma . runExceptT . unTypecheckM 171 | 172 | typecheck :: Term -> TypecheckM Type 173 | typecheck = \case 174 | Var x -> do 175 | ty <- view (context . at x) 176 | maybe (throwError TypeError) pure ty 177 | Abs bndr ty1 trm -> do 178 | ty2 <- local (context %~ M.insert bndr ty1) (typecheck trm) 179 | pure $ ty1 :-> ty2 180 | App t1 t2 -> 181 | typecheck t1 >>= \case 182 | tyA :-> tyB -> do 183 | ty2 <- typecheck t2 184 | if unify [] tyA ty2 then pure tyB else throwError TypeError 185 | _ -> throwError TypeError 186 | TAbs x t2 -> Forall x <$> typecheck t2 187 | TApp t1 ty2 -> 188 | typecheck t1 >>= \case 189 | Forall x ty12 -> pure $ substT x ty2 ty12 -- [x -> ty2]ty12 190 | _ -> throwError TypeError 191 | Unit -> pure UnitT 192 | T -> pure BoolT 193 | F -> pure BoolT 194 | If t0 t1 t2 -> do 195 | ty0 <- typecheck t0 196 | ty1 <- typecheck t1 197 | ty2 <- typecheck t2 198 | if ty0 == BoolT && ty1 == ty2 199 | then pure ty1 200 | else throwError TypeError 201 | 202 | unify :: [(String, String)] -> Type -> Type -> Bool 203 | unify names (TVar a) (TVar b) = 204 | if a `elem` (fmap fst names) || b `elem` (fmap snd names) 205 | then (a, b) `elem` names 206 | else a == b 207 | unify names (Forall x tyA) (Forall y tyB) = unify ((x, y) : names) tyA tyB 208 | unify names (tyA :-> tyB) (tyA' :-> tyB') = unify names tyA tyA' && unify names tyB tyB' 209 | unify names tyA tyB = tyA == tyB 210 | 211 | -------------------- 212 | --- Substitution --- 213 | -------------------- 214 | 215 | substTyTm :: String -> Type -> Term -> Term 216 | substTyTm x s = \case 217 | Abs y ty t1 -> Abs y (substT x s ty) t1 218 | App t1 t2 -> App (substTyTm x s t1) (substTyTm x s t2) 219 | If t0 t1 t2 -> If (substTyTm x s t0) (substTyTm x s t1) (substTyTm x s t2) 220 | t -> t 221 | 222 | substT :: String -> Type -> Type -> Type 223 | substT x s = \case 224 | TVar x' | x == x' -> s 225 | TVar y -> TVar y 226 | Forall y ty | x /= y -> Forall y (substT x s ty) 227 | ty1 :-> ty2 -> substT x s ty1 :-> substT x s ty2 228 | ty -> ty 229 | 230 | subst :: String -> Term -> Term -> Term 231 | subst x s = \case 232 | Var x' | x == x' -> s 233 | Var y -> Var y 234 | Abs y ty t1 235 | | x /= y && y `notElem` freevars s -> Abs y ty (subst x s t1) 236 | | otherwise -> error "oops name collision" 237 | App t1 t2 -> App (subst x s t1) (subst x s t2) 238 | If t0 t1 t2 -> If (subst x s t0) (subst x s t1) (subst x s t2) 239 | TApp t0 ty -> TApp (subst x s t0) ty 240 | TAbs bndr t0 -> TAbs bndr (subst x s t0) 241 | t -> t 242 | 243 | freevars :: Term -> [String] 244 | freevars = \case 245 | Var x -> [x] 246 | Abs x ty t -> freevars t \\ [x] 247 | App t1 t2 -> freevars t1 ++ freevars t2 248 | If t0 t1 t2 -> freevars t0 ++ freevars t1 ++ freevars t2 249 | TAbs x t0 -> freevars t0 250 | TApp t0 ty -> freevars t0 251 | _ -> [] 252 | 253 | ------------------ 254 | --- Evaluation --- 255 | ------------------ 256 | 257 | isVal :: Term -> Bool 258 | isVal = \case 259 | Abs {} -> True 260 | TAbs {} -> True 261 | T -> True 262 | F -> True 263 | Unit -> True 264 | _ -> False 265 | 266 | singleEval :: Term -> Maybe Term 267 | singleEval = \case 268 | App (Abs x ty t12) v2 | isVal v2 -> Just $ subst x v2 t12 269 | App v1@Abs {} t2 -> App v1 <$> singleEval t2 270 | App t1 t2 -> flip App t2 <$> singleEval t1 271 | TApp (TAbs x t12) ty2 -> Just (substTyTm x ty2 t12) 272 | TApp t1 ty2 -> flip TApp ty2 <$> singleEval t1 273 | If T t2 t3 -> pure t2 274 | If F t2 t3 -> pure t3 275 | _ -> Nothing 276 | 277 | multiStepEval :: Term -> Term 278 | multiStepEval t = maybe t multiStepEval (singleEval t) 279 | 280 | ------------ 281 | --- Main --- 282 | ------------ 283 | 284 | identA :: Term 285 | identA = TAbs "A" (Abs "a" (TVar "A") (Var "a")) 286 | 287 | cbool :: Type 288 | cbool = Forall "A" $ TVar "A" :-> TVar "A" :-> TVar "A" 289 | 290 | cbool' :: Type 291 | cbool' = Forall "B" $ TVar "B" :-> TVar "B" :-> TVar "B" 292 | 293 | truC :: Term 294 | truC = TAbs "A" . Abs "t" (TVar "A") . Abs "f" (TVar "A") $ Var "t" 295 | 296 | flsC :: Term 297 | flsC = TAbs "X" . Abs "t" (TVar "X") . Abs "f" (TVar "X") $ Var "f" 298 | 299 | notC :: Term 300 | notC = 301 | Abs "b" cbool . TAbs "X" . Abs "t" (TVar "X") . Abs "f" (TVar "X") $ 302 | App (App (TApp (Var "b") (TVar "X")) (Var "f")) (Var "t") 303 | 304 | main :: IO () 305 | main = 306 | let term = alphaconvert ((App (TApp (App notC truC) BoolT) T)) 307 | in case runTypecheckM $ typecheck term of 308 | Left e -> do 309 | putStrLn $ pretty term 310 | print e 311 | Right ty -> do 312 | putStrLn $ pretty term 313 | putStrLn $ pretty (multiStepEval term) ++ " as " ++ pretty ty 314 | -------------------------------------------------------------------------------- /main/old/SystemFOmega.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Main where 8 | 9 | import Control.Lens 10 | import Control.Monad.Except 11 | import Control.Monad.Reader 12 | import Control.Monad.State 13 | import Data.List ((\\)) 14 | import Data.Map (Map) 15 | import Data.Map.Strict qualified as M 16 | 17 | ------------- 18 | --- Terms --- 19 | ------------- 20 | 21 | data Term 22 | = Var String 23 | | Abs String Type Term 24 | | App Term Term 25 | | TAbs String Kind Term 26 | | TApp Term Type 27 | | Unit 28 | | T 29 | | F 30 | | If Term Term Term 31 | deriving (Show) 32 | 33 | infixr 0 :-> 34 | 35 | data Type 36 | = Type :-> Type 37 | | TVar String 38 | | Forall String Kind Type 39 | | TyAbs String Kind Type 40 | | TyApp Type Type 41 | | UnitT 42 | | BoolT 43 | deriving (Show, Eq) 44 | 45 | infixr 0 :=> 46 | 47 | data Kind = Star | Kind :=> Kind 48 | deriving (Show, Eq) 49 | 50 | data Gamma = Gamma 51 | { _context :: Map String Type, 52 | _contextT :: Map String Kind 53 | } 54 | 55 | makeLenses ''Gamma 56 | 57 | data TypeErr = TypeError | KindError deriving (Show, Eq) 58 | 59 | ---------------------- 60 | --- Pretty Printer --- 61 | ---------------------- 62 | 63 | class Show a => Pretty a where 64 | pretty :: a -> String 65 | pretty = show 66 | 67 | instance Pretty Term where 68 | pretty = \case 69 | Var x -> x 70 | Abs bndr ty t0 -> "(λ" ++ bndr ++ " : " ++ pretty ty ++ " . " ++ pretty t0 ++ ")" 71 | App t1 t2 -> pretty t1 ++ " " ++ pretty t2 72 | TAbs bndr k t0 -> "(Λ" ++ bndr ++ " :: " ++ pretty k ++ " . " ++ pretty t0 ++ ")" 73 | TApp t0 ty -> pretty t0 ++ " " ++ "[" ++ pretty ty ++ "]" 74 | Unit -> "Unit" 75 | T -> "True" 76 | F -> "False" 77 | If t0 t1 t2 -> "If " ++ pretty t0 ++ " then " ++ pretty t1 ++ " else " ++ pretty t2 78 | 79 | instance Pretty Type where 80 | pretty = \case 81 | TVar x -> x 82 | TyAbs b k ty -> "(" ++ b ++ " :: " ++ pretty k ++ " . " ++ pretty ty ++ ")" 83 | TyApp ty1 ty2 -> pretty ty1 ++ " " ++ pretty ty2 84 | ty0 :-> ty1 -> pretty ty0 ++ " -> " ++ pretty ty1 85 | Forall x k ty -> "∀" ++ x ++ " :: " ++ pretty k ++ " . " ++ pretty ty 86 | UnitT -> "Unit" 87 | BoolT -> "Bool" 88 | 89 | instance Pretty Kind where 90 | pretty = \case 91 | Star -> "*" -- "★" 92 | k1 :=> k2 -> "(" ++ pretty k1 ++ " -> " ++ pretty k2 ++ ")" 93 | 94 | ------------------------ 95 | --- Alpha Conversion --- 96 | ------------------------ 97 | 98 | data Stream a = Stream a (Stream a) 99 | 100 | data AlphaContext = AlphaContext 101 | { _names :: Stream String, 102 | _namesT :: Stream String, 103 | _register :: Map String String 104 | } 105 | 106 | makeLenses ''AlphaContext 107 | 108 | namesStream :: [String] 109 | namesStream = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 110 | 111 | typeNamesStream :: [String] 112 | typeNamesStream = (pure <$> ['A' .. 'Z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['A' .. 'Z']) 113 | 114 | stream :: [String] -> Stream String 115 | stream (x : xs) = Stream x (stream xs) 116 | 117 | alphaT :: Type -> State AlphaContext Type 118 | alphaT = \case 119 | TVar bndr -> 120 | use (register . at bndr) >>= \case 121 | Just bndr' -> pure $ TVar bndr' 122 | Nothing -> error "Something impossible happened" 123 | Forall bndr k ty -> 124 | use (register . at bndr) >>= \case 125 | Just bndr' -> Forall bndr' k <$> alphaT ty 126 | Nothing -> do 127 | Stream fresh rest <- use namesT 128 | namesT .= rest 129 | register %= M.insert bndr fresh 130 | ty' <- alphaT ty 131 | pure $ Forall fresh k ty' 132 | ty1 :-> ty2 -> do 133 | ty1' <- alphaT ty1 134 | ty2' <- alphaT ty2 135 | pure $ ty1' :-> ty2' 136 | -- TyAbs bndr k ty -> do 137 | -- TyApp ty1 ty2 -> do 138 | -- ty1' <- alphaT ty1 139 | -- ty2' <- alphaT ty2 140 | -- pure $ TyApp ty1' ty2' 141 | t -> pure t 142 | 143 | alpha :: Term -> State AlphaContext Term 144 | alpha = \case 145 | Var x -> do 146 | mx <- gets (M.lookup x . _register) 147 | case mx of 148 | Just x' -> pure $ Var x' 149 | Nothing -> error "Something impossible happened" 150 | App t1 t2 -> do 151 | t1' <- alpha t1 152 | t2' <- alpha t2 153 | pure $ App t1' t2' 154 | Abs bndr ty term -> do 155 | (Stream fresh rest) <- gets _names 156 | names .= rest 157 | register %= M.insert bndr fresh 158 | term' <- alpha term 159 | pure $ Abs fresh ty term' 160 | TApp t tyBndr -> do 161 | t' <- alpha t 162 | tyBndr' <- alphaT tyBndr 163 | pure $ TApp t' tyBndr' 164 | TAbs tyBndr k term -> do 165 | Stream fresh' rest' <- use namesT 166 | regstry <- use register 167 | namesT .= rest' 168 | register %= M.insert tyBndr fresh' 169 | term' <- alpha term 170 | pure $ TAbs fresh' k term' 171 | If t1 t2 t3 -> do 172 | t1' <- alpha t1 173 | t2' <- alpha t2 174 | t3' <- alpha t3 175 | pure (If t1' t2' t3') 176 | t -> pure t 177 | 178 | emptyAlphaContext :: AlphaContext 179 | emptyAlphaContext = AlphaContext (stream namesStream) (stream typeNamesStream) M.empty 180 | 181 | alphaconvert :: Term -> Term 182 | alphaconvert term = evalState (alpha term) emptyAlphaContext 183 | 184 | -------------------- 185 | --- Kindchecking --- 186 | -------------------- 187 | 188 | kindcheck :: Type -> TypecheckM Kind 189 | kindcheck (TVar bndr) = do 190 | k1 <- view (contextT . at bndr) 191 | maybe (throwError KindError) pure k1 192 | kindcheck (TyAbs bndr k1 ty) = do 193 | k2 <- local (contextT %~ M.insert bndr k1) (kindcheck ty) 194 | pure $ k1 :=> k2 195 | kindcheck (TyApp ty1 ty2) = 196 | kindcheck ty1 >>= \case 197 | k11 :=> k12 -> 198 | kindcheck ty2 >>= \k2 -> 199 | if k2 == k11 then pure k12 else throwError KindError 200 | _ -> throwError KindError 201 | kindcheck (ty1 :-> ty2) = do 202 | k1 <- kindcheck ty1 203 | k2 <- kindcheck ty2 204 | if (k1, k2) == (Star, Star) then pure Star else throwError KindError 205 | kindcheck ty = pure Star 206 | 207 | ------------------------ 208 | --- Type Equivalence --- 209 | ------------------------ 210 | 211 | tyeq :: Type -> Type -> Bool 212 | tyeq (s1 :-> s2) (t1 :-> t2) = tyeq s1 t1 && tyeq s2 t2 213 | tyeq (TyAbs b1 k1 s2) (TyAbs b2 k2 t2) = k1 == k2 && tyeq s2 t2 214 | tyeq (TyApp (TyAbs b1 k11 s12) s2) t1 = 215 | tyeq (substT b1 s2 s12) t1 216 | tyeq s1 (TyApp (TyAbs b2 k11 t12) t2) = 217 | tyeq s1 (substT b2 t2 t12) 218 | tyeq (TyApp s1 s2) (TyApp t1 t2) = s1 == t1 && s2 == t2 219 | tyeq (Forall b1 k1 ty1) (Forall b2 k2 ty2) = k1 == k2 && tyeq ty1 ty2 220 | tyeq s1 t1 = s1 == t1 221 | 222 | unify :: [(String, String)] -> Type -> Type -> Bool 223 | unify names (TVar a) (TVar b) = 224 | if a `elem` fmap fst names || b `elem` fmap snd names 225 | then (a, b) `elem` names 226 | else tyeq (TVar a) (TVar b) 227 | unify names (TyAbs b1 k1 tyA) (TyAbs b2 k2 tyB) = unify ((b1, b2) : names) tyA tyB 228 | unify names (TyApp s1 s2) (TyApp t1 t2) = unify names s1 t1 && unify names s2 t2 229 | unify names (tyA :-> tyB) (tyA' :-> tyB') = unify names tyA tyA' && unify names tyB tyB' 230 | unify names tyA tyB = tyeq tyA tyB 231 | 232 | -------------------- 233 | --- Typechecking --- 234 | -------------------- 235 | 236 | newtype TypecheckM a = TypecheckM {unTypecheckM :: ExceptT TypeErr (Reader Gamma) a} 237 | deriving (Functor, Applicative, Monad, MonadReader Gamma, MonadError TypeErr) 238 | 239 | emptyGamma :: Gamma 240 | emptyGamma = Gamma mempty mempty 241 | 242 | runTypecheckM :: TypecheckM a -> Either TypeErr a 243 | runTypecheckM = flip runReader emptyGamma . runExceptT . unTypecheckM 244 | 245 | testTypecheckM :: Gamma -> TypecheckM a -> Either TypeErr a 246 | testTypecheckM gamma = flip runReader gamma . runExceptT . unTypecheckM 247 | 248 | typecheck :: Term -> TypecheckM Type 249 | typecheck = \case 250 | Var x -> do 251 | ty <- view (context . at x) 252 | maybe (throwError TypeError) pure ty 253 | Abs bndr ty1 trm -> 254 | kindcheck ty1 >>= \case 255 | Star -> do 256 | ty2 <- local (context %~ M.insert bndr ty1) (typecheck trm) 257 | pure $ ty1 :-> ty2 258 | _ -> throwError KindError 259 | App t1 t2 -> do 260 | ty1 <- typecheck t1 261 | case ty1 of 262 | tyA :-> tyB -> do 263 | ty2 <- typecheck t2 264 | if unify [] tyA ty2 then pure tyB else throwError TypeError 265 | _ -> throwError TypeError 266 | TAbs x k t2 -> do 267 | ty2 <- local (contextT %~ M.insert x k) (typecheck t2) 268 | pure $ Forall x k ty2 269 | TApp t1 ty2 -> 270 | typecheck t1 >>= \case 271 | Forall x k1 ty12 -> 272 | kindcheck ty2 >>= \k2 -> 273 | if k1 == k2 then pure $ substT x ty2 ty12 else throwError TypeError 274 | _ -> throwError TypeError 275 | Unit -> pure UnitT 276 | T -> pure BoolT 277 | F -> pure BoolT 278 | If t0 t1 t2 -> do 279 | ty0 <- typecheck t0 280 | ty1 <- typecheck t1 281 | ty2 <- typecheck t2 282 | if ty0 == BoolT && ty1 == ty2 283 | then pure ty1 284 | else throwError TypeError 285 | 286 | -------------------- 287 | --- Substitution --- 288 | -------------------- 289 | 290 | substTyTm :: String -> Type -> Term -> Term 291 | substTyTm x s = \case 292 | Abs y ty t1 -> Abs y (substT x s ty) t1 293 | App t1 t2 -> App (substTyTm x s t1) (substTyTm x s t2) 294 | If t0 t1 t2 -> If (substTyTm x s t0) (substTyTm x s t1) (substTyTm x s t2) 295 | t -> t 296 | 297 | substT :: String -> Type -> Type -> Type 298 | substT x s = \case 299 | TVar x' | x == x' -> s 300 | TVar y -> TVar y 301 | TyAbs y k ty | x /= y -> TyAbs y k (substT x s ty) 302 | TyAbs y k ty -> error "substT: oops name collision" 303 | TyApp ty1 ty2 -> TyApp (substT x s ty1) (substT x s ty2) 304 | Forall y k ty | x /= y -> Forall y k (substT x s ty) 305 | ty1 :-> ty2 -> substT x s ty1 :-> substT x s ty2 306 | ty -> ty 307 | 308 | subst :: String -> Term -> Term -> Term 309 | subst x s = \case 310 | Var x' | x == x' -> s 311 | Var y -> Var y 312 | Abs y ty t1 313 | | x /= y && y `notElem` freevars s -> Abs y ty (subst x s t1) 314 | | otherwise -> error "subst: oops name collision" 315 | App t1 t2 -> App (subst x s t1) (subst x s t2) 316 | TApp t0 ty -> TApp (subst x s t0) ty 317 | TAbs bndr k t0 -> TAbs bndr k (subst x s t0) 318 | If t0 t1 t2 -> If (subst x s t0) (subst x s t1) (subst x s t2) 319 | T -> T 320 | F -> F 321 | Unit -> Unit 322 | 323 | freevars :: Term -> [String] 324 | freevars = \case 325 | Var x -> [x] 326 | Abs x ty t -> freevars t \\ [x] 327 | App t1 t2 -> freevars t1 ++ freevars t2 328 | If t0 t1 t2 -> freevars t0 ++ freevars t1 ++ freevars t2 329 | TAbs x k t0 -> freevars t0 330 | TApp t0 ty -> freevars t0 331 | _ -> [] 332 | 333 | ------------------ 334 | --- Evaluation --- 335 | ------------------ 336 | 337 | isVal :: Term -> Bool 338 | isVal = \case 339 | Abs {} -> True 340 | TAbs {} -> True 341 | T -> True 342 | F -> True 343 | Unit -> True 344 | _ -> False 345 | 346 | singleEval :: Term -> Maybe Term 347 | singleEval = \case 348 | App (Abs x ty t12) v2 | isVal v2 -> Just $ subst x v2 t12 349 | App v1@Abs {} t2 -> App v1 <$> singleEval t2 350 | App t1 t2 -> flip App t2 <$> singleEval t1 351 | TApp (TAbs x k t12) ty2 -> Just (substTyTm x ty2 t12) 352 | TApp t1 ty2 -> flip TApp ty2 <$> singleEval t1 353 | If T t2 t3 -> pure t2 354 | If F t2 t3 -> pure t3 355 | _ -> Nothing 356 | 357 | multiStepEval :: Term -> Term 358 | multiStepEval t = maybe t multiStepEval (singleEval t) 359 | 360 | ------------ 361 | --- Main --- 362 | ------------ 363 | 364 | -- Type Operators 365 | idT :: Type 366 | idT = TyAbs "A" Star $ Forall "Id" Star $ TVar "A" :-> TVar "X" 367 | 368 | constT :: Type 369 | constT = TyAbs "A" Star $ TyAbs "B" Star $ Forall "Const" Star $ TVar "A" :-> TVar "X" 370 | 371 | pairT :: Type 372 | pairT = TyAbs "A" Star $ TyAbs "B" Star $ Forall "C" Star $ (TVar "A" :-> TVar "B" :-> TVar "C") :-> TVar "C" 373 | 374 | churchT :: Type 375 | churchT = Forall "A" Star $ (TVar "A" :-> TVar "A") :-> TVar "A" :-> TVar "A" 376 | 377 | -- Terms 378 | -- mkId :: Term 379 | -- mkId = TAbs "A" Star $ Abs "a" k 380 | 381 | -- pair = ΛA::*.ΛB::*.λx:A.λy:B.ΛC::*.λk:(A -> B -> C).k x y; 382 | pair :: Term 383 | pair = 384 | TAbs "A" Star $ 385 | TAbs "B" Star $ 386 | Abs "x" (TVar "A") $ 387 | Abs "y" (TVar "B") $ 388 | TAbs "C" Star $ 389 | Abs "k" (TVar "A" :-> TVar "B" :-> TVar "C") $ 390 | App (App (Var "k") (Var "x")) (Var "y") 391 | 392 | -- fst = ΛA::*.ΛB::*.λp:Pair A B.p [A] (λx:A.λy:B.x); 393 | fst' = 394 | TAbs "A" Star $ 395 | TAbs "B" Star $ 396 | Abs "p" (TyApp (TyApp pairT (TVar "A")) (TVar "B")) $ 397 | App (TApp (Var "p") (TVar "A")) (Abs "x" (TVar "A") $ Abs "y" (TVar "B") (Var "x")) 398 | 399 | zeroT :: Term 400 | zeroT = 401 | TAbs "F" Star $ 402 | Abs "f" (TVar "F") $ 403 | TAbs "X" Star $ 404 | Abs "x" (TVar "X") $ 405 | App (TApp (Var "f") (TVar "X")) (App (Var "f") (Var "x")) 406 | 407 | main :: IO () 408 | main = 409 | let term = fst' -- alphaconvert $ (TApp (App pair T) BoolT)-- (App notT T) 410 | in case runTypecheckM $ typecheck term of 411 | Left e -> print e 412 | Right _ -> print (multiStepEval term) 413 | -------------------------------------------------------------------------------- /main/old/SystemOmega.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Main where 8 | 9 | import Control.Lens 10 | import Control.Monad.Except 11 | import Control.Monad.Reader 12 | import Control.Monad.State 13 | import Data.List ((\\)) 14 | import Data.Map (Map) 15 | import Data.Map.Strict qualified as M 16 | 17 | ------------- 18 | --- Terms --- 19 | ------------- 20 | 21 | data Term 22 | = Var String 23 | | Abs String Type Term 24 | | App Term Term 25 | | Unit 26 | | T 27 | | F 28 | | If Term Term Term 29 | deriving (Show) 30 | 31 | infixr 0 :-> 32 | 33 | data Type 34 | = Type :-> Type 35 | | TVar String 36 | | TyAbs String Kind Type 37 | | TyApp Type Type 38 | | UnitT 39 | | BoolT 40 | deriving (Show, Eq) 41 | 42 | infixr 0 :=> 43 | 44 | data Kind = Star | Kind :=> Kind 45 | deriving (Show, Eq) 46 | 47 | data Gamma = Gamma 48 | { _context :: Map String Type, 49 | _contextT :: Map String Kind 50 | } 51 | 52 | makeLenses ''Gamma 53 | 54 | data TypeErr = TypeError | KindError deriving (Show, Eq) 55 | 56 | ---------------------- 57 | --- Pretty Printer --- 58 | ---------------------- 59 | 60 | class Show a => Pretty a where 61 | pretty :: a -> String 62 | pretty = show 63 | 64 | instance Pretty Term where 65 | pretty = \case 66 | Var x -> x 67 | Abs bndr ty t0 -> "(λ" ++ bndr ++ " : " ++ pretty ty ++ " . " ++ pretty t0 ++ ")" 68 | App t1 t2 -> pretty t1 ++ " " ++ pretty t2 69 | Unit -> "Unit" 70 | T -> "True" 71 | F -> "False" 72 | If t0 t1 t2 -> "If " ++ pretty t0 ++ " then " ++ pretty t1 ++ " else " ++ pretty t2 73 | 74 | instance Pretty Type where 75 | pretty = \case 76 | TVar x -> x 77 | TyAbs b k ty -> "(" ++ b ++ " :: " ++ pretty k ++ " . " ++ pretty ty ++ ")" 78 | TyApp ty1 ty2 -> pretty ty1 ++ " " ++ pretty ty2 79 | ty0 :-> ty1 -> pretty ty0 ++ " -> " ++ pretty ty1 80 | UnitT -> "Unit" 81 | BoolT -> "Bool" 82 | 83 | instance Pretty Kind where 84 | pretty = \case 85 | Star -> "*" -- "★" 86 | k1 :=> k2 -> "(" ++ pretty k1 ++ " -> " ++ pretty k2 ++ ")" 87 | 88 | ------------------------ 89 | --- Alpha Conversion --- 90 | ------------------------ 91 | 92 | data Stream a = Stream a (Stream a) 93 | 94 | data AlphaContext = AlphaContext {_names :: Stream String, _register :: Map String String} 95 | 96 | makeLenses ''AlphaContext 97 | 98 | namesStream :: [String] 99 | namesStream = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 100 | 101 | stream :: [String] -> Stream String 102 | stream (x : xs) = Stream x (stream xs) 103 | 104 | alpha :: Term -> State AlphaContext Term 105 | alpha = \case 106 | Var bndr -> 107 | use (register . at bndr) >>= \case 108 | Just bndr' -> pure $ Var bndr' 109 | Nothing -> error "Something impossible happened" 110 | App t1 t2 -> do 111 | t1' <- alpha t1 112 | t2' <- alpha t2 113 | pure $ App t1' t2' 114 | Abs bndr ty term -> do 115 | Stream fresh rest <- use names 116 | names .= rest 117 | register %= M.insert bndr fresh 118 | term' <- alpha term 119 | pure $ Abs fresh ty term' 120 | If t1 t2 t3 -> do 121 | t1' <- alpha t1 122 | t2' <- alpha t2 123 | t3' <- alpha t3 124 | pure (If t1' t2' t3') 125 | t -> pure t 126 | 127 | emptyContext :: AlphaContext 128 | emptyContext = AlphaContext (stream namesStream) M.empty 129 | 130 | alphaconvert :: Term -> Term 131 | alphaconvert term = evalState (alpha term) emptyContext 132 | 133 | -------------------- 134 | --- Kindchecking --- 135 | -------------------- 136 | 137 | kindcheck :: Type -> TypecheckM Kind 138 | kindcheck (TVar bndr) = do 139 | k1 <- view (contextT . at bndr) 140 | maybe (throwError KindError) pure k1 141 | kindcheck (TyAbs bndr k1 ty) = do 142 | k2 <- local (contextT %~ M.insert bndr k1) (kindcheck ty) 143 | pure $ k1 :=> k2 144 | kindcheck (TyApp ty1 ty2) = 145 | kindcheck ty1 >>= \case 146 | k11 :=> k12 -> 147 | kindcheck ty2 >>= \k2 -> 148 | if k2 == k11 then pure k12 else throwError KindError 149 | _ -> throwError KindError 150 | kindcheck (ty1 :-> ty2) = do 151 | k1 <- kindcheck ty1 152 | k2 <- kindcheck ty2 153 | if (k1, k2) == (Star, Star) then pure Star else throwError KindError 154 | kindcheck ty = pure Star 155 | 156 | ------------------------ 157 | --- Type Equivalence --- 158 | ------------------------ 159 | 160 | tyeq :: Type -> Type -> Bool 161 | tyeq (s1 :-> s2) (t1 :-> t2) = tyeq s1 t1 && tyeq s2 t2 162 | tyeq (TyAbs b1 k1 s2) (TyAbs b2 k2 t2) = k1 == k2 && tyeq s2 t2 163 | tyeq (TyApp (TyAbs b1 k11 s12) s2) t1 = 164 | tyeq (substT b1 s2 s12) t1 165 | tyeq s1 (TyApp (TyAbs b2 k11 t12) t2) = 166 | tyeq s1 (substT b2 t2 t12) 167 | tyeq (TyApp s1 s2) (TyApp t1 t2) = s1 == t1 && s2 == t2 168 | tyeq s1 t1 = s1 == t1 169 | 170 | unify :: [(String, String)] -> Type -> Type -> Bool 171 | unify names (TVar a) (TVar b) = 172 | if a `elem` fmap fst names || b `elem` fmap snd names 173 | then (a, b) `elem` names 174 | else tyeq (TVar a) (TVar b) 175 | unify names (TyAbs b1 k1 tyA) (TyAbs b2 k2 tyB) = unify ((b1, b2) : names) tyA tyB 176 | unify names (TyApp s1 s2) (TyApp t1 t2) = unify names s1 t1 && unify names s2 t2 177 | unify names (tyA :-> tyB) (tyA' :-> tyB') = unify names tyA tyA' && unify names tyB tyB' 178 | unify names tyA tyB = tyeq tyA tyB 179 | 180 | -------------------- 181 | --- Typechecking --- 182 | -------------------- 183 | 184 | newtype TypecheckM a = TypecheckM {unTypecheckM :: ExceptT TypeErr (Reader Gamma) a} 185 | deriving (Functor, Applicative, Monad, MonadReader Gamma, MonadError TypeErr) 186 | 187 | emptyGamma :: Gamma 188 | emptyGamma = Gamma mempty mempty 189 | 190 | runTypecheckM :: TypecheckM a -> Either TypeErr a 191 | runTypecheckM = flip runReader emptyGamma . runExceptT . unTypecheckM 192 | 193 | typecheck :: Term -> TypecheckM Type 194 | typecheck = \case 195 | Var x -> do 196 | ty <- view (context . at x) 197 | maybe (throwError TypeError) pure ty 198 | Abs bndr ty1 trm -> 199 | kindcheck ty1 >>= \case 200 | Star -> do 201 | ty2 <- local (context %~ M.insert bndr ty1) (typecheck trm) 202 | pure $ ty1 :-> ty2 203 | _ -> throwError KindError 204 | App t1 t2 -> do 205 | ty1 <- typecheck t1 206 | case ty1 of 207 | tyA :-> tyB -> do 208 | ty2 <- typecheck t2 209 | if unify [] tyA ty2 then pure ty1 else throwError TypeError 210 | _ -> throwError TypeError 211 | Unit -> pure UnitT 212 | T -> pure BoolT 213 | F -> pure BoolT 214 | If t0 t1 t2 -> do 215 | ty0 <- typecheck t0 216 | ty1 <- typecheck t1 217 | ty2 <- typecheck t2 218 | if ty0 == BoolT && ty1 == ty2 219 | then pure ty1 220 | else throwError TypeError 221 | 222 | -------------------- 223 | --- Substitution --- 224 | -------------------- 225 | 226 | substT :: String -> Type -> Type -> Type 227 | substT x s = \case 228 | TVar x' | x == x' -> s 229 | TVar y -> TVar y 230 | TyAbs y k ty | x /= y -> TyAbs y k (substT x s ty) 231 | TyAbs y k ty -> error "substT: oops name collision" 232 | TyApp ty1 ty2 -> TyApp (substT x s ty1) (substT x s ty2) 233 | ty1 :-> ty2 -> substT x s ty1 :-> substT x s ty2 234 | ty -> ty 235 | 236 | subst :: String -> Term -> Term -> Term 237 | subst x s = \case 238 | (Var x') | x == x' -> s 239 | (Var y) -> Var y 240 | (Abs y ty t1) 241 | | x /= y && y `notElem` freevars s -> Abs y ty (subst x s t1) 242 | | otherwise -> error "subst: oops name collision" 243 | (App t1 t2) -> App (subst x s t1) (subst x s t2) 244 | (If t0 t1 t2) -> If (subst x s t0) (subst x s t1) (subst x s t2) 245 | T -> T 246 | F -> F 247 | Unit -> Unit 248 | 249 | freevars :: Term -> [String] 250 | freevars = \case 251 | (Var x) -> [x] 252 | (Abs x ty t) -> freevars t \\ [x] 253 | (App t1 t2) -> freevars t1 ++ freevars t2 254 | (If t0 t1 t2) -> freevars t0 ++ freevars t1 ++ freevars t2 255 | 256 | ------------------ 257 | --- Evaluation --- 258 | ------------------ 259 | 260 | isVal :: Term -> Bool 261 | isVal = \case 262 | Abs {} -> True 263 | T -> True 264 | F -> True 265 | Unit -> True 266 | _ -> False 267 | 268 | singleEval :: Term -> Maybe Term 269 | singleEval = \case 270 | (App (Abs x ty t12) v2) | isVal v2 -> Just $ subst x v2 t12 271 | (App v1@Abs {} t2) -> App v1 <$> singleEval t2 272 | (App t1 t2) -> flip App t2 <$> singleEval t1 273 | (If T t2 t3) -> pure t2 274 | (If F t2 t3) -> pure t3 275 | _ -> Nothing 276 | 277 | multiStepEval :: Term -> Term 278 | multiStepEval t = maybe t multiStepEval (singleEval t) 279 | 280 | ------------ 281 | --- Main --- 282 | ------------ 283 | 284 | idT :: Type 285 | idT = TyAbs "X" Star (TVar "X") 286 | 287 | idT' :: Type 288 | idT' = TyAbs "Y" Star (TVar "Y") 289 | 290 | notT :: Term 291 | notT = Abs "p" BoolT (If (Var "p") F T) 292 | 293 | main :: IO () 294 | main = 295 | let term = alphaconvert (App notT T) 296 | in case runTypecheckM $ typecheck term of 297 | Left e -> print e 298 | Right _ -> print (multiStepEval term) 299 | -------------------------------------------------------------------------------- /main/old/SystemT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | 6 | module Main where 7 | 8 | import Control.Monad.Except 9 | import Control.Monad.Reader 10 | import Control.Monad.State 11 | import Data.List 12 | import Data.Map (Map) 13 | import qualified Data.Map.Strict as M 14 | 15 | data Term 16 | = Var String 17 | | Abs String Type Term 18 | | App Term Term 19 | | Unit 20 | | T 21 | | F 22 | | If Term Term Term 23 | | Z 24 | | S Term 25 | | Rec Term Term 26 | deriving (Show, Eq) 27 | 28 | data Type = Type :-> Type | UnitT | BoolT | NatT 29 | deriving (Show, Eq) 30 | 31 | type Gamma = [(String, Type)] 32 | 33 | data TypeErr = TypeError deriving (Show, Eq) 34 | 35 | ------------------------ 36 | --- Alpha Conversion --- 37 | ------------------------ 38 | 39 | data Stream a = Stream a (Stream a) 40 | 41 | data AlphaContext = AlphaContext {_names :: Stream String, _register :: Map String String} 42 | 43 | names :: [String] 44 | names = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 45 | 46 | stream :: [String] -> Stream String 47 | stream (x : xs) = Stream x (stream xs) 48 | 49 | alpha :: Term -> State AlphaContext Term 50 | alpha = \case 51 | (Var x) -> do 52 | mx <- gets (M.lookup x . _register) 53 | case mx of 54 | Just x' -> pure $ Var x' 55 | Nothing -> error "Something impossible happened" 56 | (App t1 t2) -> do 57 | t1' <- alpha t1 58 | t2' <- alpha t2 59 | pure $ App t1' t2' 60 | t@(Abs bndr ty term) -> do 61 | (Stream fresh rest) <- gets _names 62 | registry <- gets _register 63 | put $ AlphaContext rest (M.insert bndr fresh registry) 64 | term' <- alpha term 65 | pure $ Abs fresh ty term' 66 | (If t1 t2 t3) -> do 67 | t1' <- alpha t1 68 | t2' <- alpha t2 69 | t3' <- alpha t3 70 | pure (If t1' t2' t3') 71 | (S t1) -> S <$> alpha t1 72 | (Rec t1 t2) -> do 73 | t1' <- alpha t1 74 | t2' <- alpha t2 75 | pure (Rec t1' t2') 76 | t -> pure t 77 | 78 | emptyContext :: AlphaContext 79 | emptyContext = AlphaContext (stream names) (M.empty) 80 | 81 | alphaconvert :: Term -> Term 82 | alphaconvert term = evalState (alpha term) emptyContext 83 | 84 | -------------------- 85 | --- Typechecking --- 86 | -------------------- 87 | 88 | newtype TypecheckM a = TypecheckM {unTypecheckM :: ExceptT TypeErr (Reader Gamma) a} 89 | deriving (Functor, Applicative, Monad, MonadReader Gamma, MonadError TypeErr) 90 | 91 | runTypecheckM :: TypecheckM Type -> Either TypeErr Type 92 | runTypecheckM = flip runReader [] . runExceptT . unTypecheckM 93 | 94 | typecheck :: Term -> TypecheckM Type 95 | typecheck = \case 96 | Var x -> do 97 | ty <- asks $ lookup x 98 | maybe (throwError TypeError) pure ty 99 | Abs bndr ty1 trm -> do 100 | ty2 <- local ((:) (bndr, ty1)) (typecheck trm) 101 | pure $ ty1 :-> ty2 102 | App t1 t2 -> do 103 | ty1 <- typecheck t1 104 | case ty1 of 105 | tyA :-> tyB -> do 106 | ty2 <- typecheck t2 107 | if tyA == ty2 then pure ty1 else throwError TypeError 108 | _ -> throwError TypeError 109 | Z -> pure NatT 110 | S n -> do 111 | ty <- typecheck n 112 | if ty == NatT then pure NatT else throwError TypeError 113 | T -> pure BoolT 114 | F -> pure BoolT 115 | If t0 t1 t2 -> do 116 | ty0 <- typecheck t0 117 | ty1 <- typecheck t1 118 | ty2 <- typecheck t2 119 | if ty0 == BoolT && ty1 == ty2 120 | then pure ty1 121 | else throwError TypeError 122 | Rec base step -> do 123 | ty0 <- typecheck base 124 | ty1 <- typecheck step 125 | case ty1 of 126 | NatT :-> (ty :-> ty') | ty == ty' -> pure (NatT :-> ty) 127 | ty -> throwError TypeError 128 | 129 | -------------------- 130 | --- Substitution --- 131 | -------------------- 132 | 133 | subst :: String -> Term -> Term -> Term 134 | subst x v1 = \case 135 | (Var y) | x == y -> v1 136 | (Var y) -> Var y 137 | (Abs y ty t1) 138 | | x == y -> Abs y ty t1 139 | | y `notElem` freevars v1 -> Abs y ty (subst x v1 t1) 140 | | otherwise -> error "oops name collision" 141 | (App t1 t2) -> App (subst x v1 t1) (subst x v1 t2) 142 | Z -> Z 143 | (S t) -> S (subst x v1 t) 144 | T -> T 145 | F -> F 146 | (If t0 t1 t2) -> If (subst x v1 t0) (subst x v1 t1) (subst x v1 t2) 147 | (Rec base step) -> Rec (subst x v1 base) (subst x v1 step) 148 | 149 | freevars :: Term -> [String] 150 | freevars = \case 151 | (Var x) -> [x] 152 | (Abs x _ t) -> freevars t \\ [x] 153 | (App t1 t2) -> freevars t1 ++ freevars t2 154 | (S t) -> freevars t 155 | (If t0 t1 t2) -> freevars t0 ++ freevars t1 ++ freevars t2 156 | (Rec t0 t1) -> freevars t0 ++ freevars t1 157 | _ -> [] 158 | 159 | ------------------ 160 | --- Evaluation --- 161 | ------------------ 162 | 163 | isVal :: Term -> Bool 164 | isVal = \case 165 | Abs {} -> True 166 | T -> True 167 | F -> True 168 | Unit -> True 169 | Z -> True 170 | (S t) -> isVal t 171 | _ -> False 172 | 173 | singleEval :: Term -> Maybe Term 174 | singleEval = \case 175 | (App (Abs x ty t12) v2) | isVal v2 -> Just $ subst x v2 t12 176 | (App v1@Abs {} t2) -> App v1 <$> singleEval t2 177 | (App (Rec base step) Z) -> pure base 178 | (App (Rec base step) (S n)) -> pure $ App (App step n) (App (Rec base step) n) 179 | (App t1 t2) -> flip App t2 <$> singleEval t1 180 | (S t) | not (isVal t) -> S <$> singleEval t 181 | (If T t2 t3) -> pure t2 182 | (If F t2 t3) -> pure t3 183 | _ -> Nothing 184 | 185 | multiStepEval :: Term -> Term 186 | multiStepEval t = maybe t multiStepEval (singleEval t) 187 | 188 | ------------ 189 | --- Main --- 190 | ------------ 191 | 192 | iden :: Term 193 | iden = Abs "n" NatT (Var "n") 194 | 195 | add1 :: Term 196 | add1 = Abs "step" NatT (Abs "n" NatT (S (Var "n"))) 197 | 198 | add :: Term 199 | add = Abs "base" NatT (Rec (Var "base") add1) 200 | 201 | main :: IO () 202 | main = 203 | let term = alphaconvert $ App (App add (S $ S Z)) (S $ S Z) 204 | in case runTypecheckM $ typecheck term of 205 | Left e -> print e 206 | Right _ -> print (multiStepEval term) 207 | -------------------------------------------------------------------------------- /main/old/Untyped.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.State 6 | import Data.List ((\\)) 7 | import Data.Map (Map) 8 | import Data.Map.Strict qualified as M 9 | 10 | ------------- 11 | --- Terms --- 12 | ------------- 13 | 14 | data Term 15 | = Var String 16 | | Abs String Term 17 | | App Term Term 18 | deriving (Show) 19 | 20 | ------------------------ 21 | --- Alpha Conversion --- 22 | ------------------------ 23 | 24 | data Stream a = Stream a (Stream a) 25 | 26 | data AlphaContext = AlphaContext {_names :: Stream String, _register :: Map String String} 27 | 28 | names :: [String] 29 | names = (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 30 | 31 | stream :: [String] -> Stream String 32 | stream (x : xs) = Stream x (stream xs) 33 | 34 | alpha :: Term -> State AlphaContext Term 35 | alpha = \case 36 | (Var x) -> do 37 | mx <- gets (M.lookup x . _register) 38 | case mx of 39 | Just x' -> pure $ Var x' 40 | Nothing -> error "Something impossible happened" 41 | (App t1 t2) -> do 42 | t1' <- alpha t1 43 | t2' <- alpha t2 44 | pure $ App t1' t2' 45 | t@(Abs bndr term) -> do 46 | (Stream fresh rest) <- gets _names 47 | registry <- gets _register 48 | put $ AlphaContext rest (M.insert bndr fresh registry) 49 | term' <- alpha term 50 | pure $ Abs fresh term' 51 | 52 | emptyContext :: AlphaContext 53 | emptyContext = AlphaContext (stream names) (M.empty) 54 | 55 | alphaconvert :: Term -> Term 56 | alphaconvert term = evalState (alpha term) emptyContext 57 | 58 | -------------------- 59 | --- Substitution --- 60 | -------------------- 61 | 62 | subst :: String -> Term -> Term -> Term 63 | subst x s = \case 64 | (Var x') | x == x' -> s 65 | (Var y) -> Var y 66 | (Abs y t1) 67 | | x /= y && y `notElem` freevars s -> Abs y (subst x s t1) 68 | | otherwise -> error "oops name collision" 69 | (App t1 t2) -> App (subst x s t1) (subst x s t2) 70 | 71 | freevars :: Term -> [String] 72 | freevars = \case 73 | (Var x) -> [x] 74 | (Abs x t) -> freevars t \\ [x] 75 | (App t1 t2) -> freevars t1 ++ freevars t2 76 | 77 | ------------------ 78 | --- Evaluation --- 79 | ------------------ 80 | 81 | isVal :: Term -> Bool 82 | isVal = \case 83 | Abs {} -> True 84 | _ -> False 85 | 86 | singleEval :: Term -> Maybe Term 87 | singleEval = \case 88 | (App (Abs x t12) v2) | isVal v2 -> Just $ subst x v2 t12 89 | (App v1@Abs {} t2) -> App v1 <$> singleEval t2 90 | (App t1 t2) -> flip App t2 <$> singleEval t1 91 | _ -> Nothing 92 | 93 | multiStepEval :: Term -> Term 94 | multiStepEval t = maybe t multiStepEval (singleEval t) 95 | 96 | ------------ 97 | --- Main --- 98 | ------------ 99 | 100 | idenT :: Term 101 | idenT = Abs "x" (Var "x") 102 | 103 | trueT :: Term 104 | trueT = Abs "p" (Abs "a" (Var "p")) 105 | 106 | falseT :: Term 107 | falseT = Abs "p" (Abs "q" (Var "q")) 108 | 109 | notT :: Term 110 | notT = Abs "p" (App (App (Var "p") falseT) trueT) 111 | 112 | main :: IO () 113 | main = do 114 | let term = alphaconvert (App notT trueT) 115 | print (multiStepEval term) 116 | -------------------------------------------------------------------------------- /main/old/UntypedNBE.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | 6 | module Main where 7 | 8 | -------------------------------------------------------------------------------- 9 | 10 | import Control.Monad.State 11 | import Data.List ((\\)) 12 | import Data.Map (Map) 13 | import Data.Map.Strict qualified as M 14 | 15 | -------------------------------------------------------------------------------- 16 | -- Terms 17 | 18 | data Term 19 | = Var Name 20 | | Abs Name Term 21 | | App Term Term 22 | deriving (Show) 23 | 24 | data Value 25 | = VClosure (Env Value) Name Term 26 | | VNeutral Neutral 27 | deriving (Show) 28 | 29 | data Neutral 30 | = NVar Name 31 | | NApp Neutral Value 32 | deriving (Show) 33 | 34 | newtype Name = Name String 35 | deriving newtype (Show, Eq, Ord) 36 | 37 | newtype Env val = Env [(Name, val)] 38 | deriving stock (Show, Functor) 39 | 40 | initEnv :: Env val 41 | initEnv = Env [] 42 | 43 | newtype Error = NotFound Name 44 | deriving (Show) 45 | 46 | lookupVar :: Env val -> Name -> Either Error val 47 | lookupVar (Env env) var = maybe (Left $ NotFound var) Right $ lookup var env 48 | 49 | extend :: Env val -> Name -> val -> Env val 50 | extend (Env env) var val = Env ((var, val) : env) 51 | 52 | -------------------------------------------------------------------------------- 53 | -- Alpha Conversion 54 | 55 | data Stream a = Stream a (Stream a) 56 | 57 | data AlphaContext = AlphaContext {_names :: Stream Name, _register :: Map Name Name} 58 | 59 | names :: [Name] 60 | names = fmap Name $ (pure <$> ['a' .. 'z']) ++ (flip (:) <$> (show <$> [1 ..]) <*> ['a' .. 'z']) 61 | 62 | stream :: [Name] -> Stream Name 63 | stream (x : xs) = Stream x (stream xs) 64 | 65 | alpha :: Term -> State AlphaContext Term 66 | alpha = \case 67 | (Var x) -> do 68 | mx <- gets (M.lookup x . _register) 69 | case mx of 70 | Just x' -> pure $ Var x' 71 | Nothing -> error "Something impossible happened" 72 | (App t1 t2) -> do 73 | t1' <- alpha t1 74 | t2' <- alpha t2 75 | pure $ App t1' t2' 76 | t@(Abs bndr term) -> do 77 | (Stream fresh rest) <- gets _names 78 | registry <- gets _register 79 | put $ AlphaContext rest (M.insert bndr fresh registry) 80 | term' <- alpha term 81 | pure $ Abs fresh term' 82 | 83 | emptyContext :: AlphaContext 84 | emptyContext = AlphaContext (stream names) M.empty 85 | 86 | alphaconvert :: Term -> Term 87 | alphaconvert term = evalState (alpha term) emptyContext 88 | 89 | -------------------------------------------------------------------------------- 90 | -- Evaluation 91 | 92 | eval :: Env Value -> Term -> Either Error Value 93 | eval env = \case 94 | Var x -> lookupVar env x 95 | Abs x body -> pure (VClosure env x body) 96 | App t1 t2 -> do 97 | fun <- eval env t1 98 | arg <- eval env t2 99 | doApply fun arg 100 | 101 | doApply :: Value -> Value -> Either Error Value 102 | doApply (VClosure env x body) arg = 103 | eval (extend env x arg) body 104 | doApply (VNeutral neu) arg = 105 | Right (VNeutral (NApp neu arg)) 106 | 107 | quote :: [Name] -> Value -> Either Error Term 108 | quote used = \case 109 | VNeutral (NVar x) -> pure (Var x) 110 | VNeutral (NApp fun arg) -> do 111 | t1 <- quote used (VNeutral fun) 112 | t2 <- quote used arg 113 | pure (App t1 t2) 114 | fun@(VClosure _ x _) -> do 115 | bodyVal <- doApply fun (VNeutral (NVar x)) 116 | bodyTerm <- quote (x : used) bodyVal 117 | pure (Abs x bodyTerm) 118 | 119 | normalize :: Term -> Either Error Term 120 | normalize term = do 121 | val <- eval initEnv term 122 | quote [] val 123 | 124 | -------------------------------------------------------------------------------- 125 | -- main 126 | 127 | idenT :: Term 128 | idenT = Abs (Name "x") (Var (Name "x")) 129 | 130 | trueT :: Term 131 | trueT = Abs (Name "p") (Abs (Name "a") (Var (Name "p"))) 132 | 133 | falseT :: Term 134 | falseT = Abs (Name "p") (Abs (Name "q") (Var (Name "q"))) 135 | 136 | notT :: Term 137 | notT = Abs (Name "p") (App (App (Var (Name "p")) falseT) trueT) 138 | 139 | main :: IO () 140 | main = do 141 | let term = alphaconvert (App notT trueT) 142 | print (normalize term) 143 | -------------------------------------------------------------------------------- /scripts.nix: -------------------------------------------------------------------------------- 1 | { s }: rec 2 | { 3 | ghcidScript = s "dev" "ghcid --command 'cabal new-repl' --allow-eval --warnings"; 4 | allScripts = [ ghcidScript ]; 5 | } 6 | --------------------------------------------------------------------------------