├── .envrc ├── .github ├── dependabot.yaml └── workflows │ └── ocaml.yml ├── .gitignore ├── CONTRIBUTING.md ├── CONTRIBUTORS.md ├── LICENSE ├── Makefile ├── README.md ├── cooltt.opam ├── doc ├── .gitignore ├── jmsdelim.sty ├── jon-note.sty ├── jon-todo.sty ├── kan.tex └── refs.bib ├── dune-project ├── emacs └── cooltt.el ├── flake.lock ├── flake.nix ├── format.sh ├── src ├── basis │ ├── LexingUtil.ml │ ├── LexingUtil.mli │ ├── ListUtil.ml │ ├── ListUtil.mli │ ├── Monad.ml │ ├── Monad.mli │ ├── PersistentTable.ml │ ├── PersistentTable.mli │ ├── Pp.ml │ ├── Pp.mli │ ├── PpExn.ml │ ├── PpExn.mli │ ├── Symbol.ml │ ├── Symbol.mli │ ├── SymbolMap.ml │ ├── SymbolMap.mli │ ├── Void.ml │ ├── Void.mli │ └── dune ├── bin │ ├── dune │ └── main.ml ├── core │ ├── CodeUnit.ml │ ├── CodeUnit.mli │ ├── CofBuilder.ml │ ├── CofThy.ml │ ├── CofVar.ml │ ├── CofVar.mli │ ├── Conversion.ml │ ├── Conversion.mli │ ├── Debug.ml │ ├── Debug.mli │ ├── Dim.ml │ ├── Dim.mli │ ├── DimProbe.ml │ ├── DimProbe.mli │ ├── Domain.ml │ ├── Domain.mli │ ├── DomainData.ml │ ├── Ident.ml │ ├── Ident.mli │ ├── Log.ml │ ├── Log.mli │ ├── Monads.ml │ ├── Monads.mli │ ├── Namespace.ml │ ├── Namespace.mli │ ├── Quote.ml │ ├── Quote.mli │ ├── RefineEnv.ml │ ├── RefineEnv.mli │ ├── RefineError.ml │ ├── RefineError.mli │ ├── RefineErrorData.ml │ ├── RefineMonad.ml │ ├── RefineMonad.mli │ ├── RefineState.ml │ ├── RefineState.mli │ ├── Refiner.ml │ ├── Refiner.mli │ ├── Scope.ml │ ├── Scope.mli │ ├── Scopes.ml │ ├── Scopes.mli │ ├── Semantics.ml │ ├── Semantics.mli │ ├── Splice.ml │ ├── Splice.mli │ ├── Syntax.ml │ ├── Syntax.mli │ ├── SyntaxData.ml │ ├── SyntaxPrecedence.ml │ ├── SyntaxPrecedence.mli │ ├── Tactic.ml │ ├── Tactic.mli │ ├── TermBuilder.ml │ ├── TermBuilder.mli │ └── dune └── frontend │ ├── ConcreteSyntax.ml │ ├── ConcreteSyntax.mli │ ├── ConcreteSyntaxData.ml │ ├── Driver.ml │ ├── Driver.mli │ ├── DriverMessage.ml │ ├── DriverMessage.mli │ ├── ElabError.ml │ ├── ElabError.mli │ ├── Elaborator.ml │ ├── Elaborator.mli │ ├── Grammar.mly │ ├── Lex.mll │ ├── Load.ml │ ├── Load.mli │ ├── Server.ml │ ├── Server.mli │ ├── Tactics.ml │ ├── Tactics.mli │ └── dune ├── test ├── README.md ├── Test.ml ├── abstract.cooltt ├── algebra.cooltt ├── base-types.cooltt ├── bruno.cooltt ├── circle.cooltt ├── coercion.cooltt ├── com.cooltt ├── cool-total-space.cooltt ├── cooltt-lib ├── dune ├── elab.cooltt ├── equation.cooltt ├── evan.cooltt ├── export.cooltt ├── groupoid-laws.cooltt ├── hcom-type.cooltt ├── hlevel.cooltt ├── holes.cooltt ├── import.cooltt ├── inequality.cooltt ├── isos.cooltt ├── names.cooltt ├── nat-path.cooltt ├── nat.cooltt ├── patch.cooltt ├── path-types.cooltt ├── prelude.cooltt ├── record.cooltt ├── repack.cooltt ├── section.cooltt ├── selfification.cooltt ├── test.expected ├── typeclass.cooltt ├── v.cooltt └── view.cooltt ├── vim ├── README.md ├── ftdetect │ └── cooltt.vim ├── ftplugin │ └── cooltt.vim ├── install.sh └── syntax │ └── cooltt.vim └── zsh ├── README.md └── _cooltt /.envrc: -------------------------------------------------------------------------------- 1 | # this line sources your `.envrc.local` file 2 | source_env_if_exists .envrc.local 3 | -------------------------------------------------------------------------------- /.github/dependabot.yaml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "daily" 7 | -------------------------------------------------------------------------------- /.github/workflows/ocaml.yml: -------------------------------------------------------------------------------- 1 | name: Build, test, and doc update 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | jobs: 8 | run: 9 | strategy: 10 | matrix: 11 | include: 12 | - ocaml-compiler: "5.0" 13 | with-doc: true 14 | runs-on: ubuntu-latest 15 | steps: 16 | - uses: actions/checkout@v4 17 | - uses: RedPRL/actions-ocaml@v2 18 | with: 19 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 20 | with-doc: ${{ matrix.with-doc }} 21 | publish-doc-if-built: ${{ github.ref == 'refs/heads/main' }} 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | 3 | # -*- mode: gitignore; -*- 4 | *.install 5 | *~ 6 | \#*\# 7 | /.emacs.desktop 8 | /.emacs.desktop.lock 9 | *.elc 10 | auto-save-list 11 | tramp 12 | .\#* 13 | 14 | # Org-mode 15 | .org-id-locations 16 | *_archive 17 | 18 | # flymake-mode 19 | *_flymake.* 20 | 21 | # eshell files 22 | /eshell/history 23 | /eshell/lastdir 24 | 25 | # elpa packages 26 | /elpa/ 27 | 28 | # reftex files 29 | *.rel 30 | 31 | # AUCTeX auto folder 32 | auto/ 33 | 34 | # cask packages 35 | .cask/ 36 | dist/ 37 | 38 | # Flycheck 39 | flycheck_*.el 40 | 41 | # server auth directory 42 | /server/ 43 | 44 | # projectiles files 45 | .projectile 46 | 47 | # directory configuration 48 | .dir-locals.el 49 | 50 | 51 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Linux.gitignore 52 | 53 | *~ 54 | 55 | # temporary files which can be created if a process still has a handle open of a deleted file 56 | .fuse_hidden* 57 | 58 | # KDE directory preferences 59 | .directory 60 | 61 | # Linux trash folder which might appear on any partition or disk 62 | .Trash-* 63 | 64 | # .nfs files are created when an open file is removed but is still being accessed 65 | .nfs* 66 | 67 | 68 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/macOS.gitignore 69 | 70 | # General 71 | .DS_Store 72 | .AppleDouble 73 | .LSOverride 74 | 75 | # Icon must end with two \r 76 | Icon 77 | 78 | 79 | # Thumbnails 80 | ._* 81 | 82 | # Files that might appear in the root of a volume 83 | .DocumentRevisions-V100 84 | .fseventsd 85 | .Spotlight-V100 86 | .TemporaryItems 87 | .Trashes 88 | .VolumeIcon.icns 89 | .com.apple.timemachine.donotpresent 90 | 91 | # Directories potentially created on remote AFP share 92 | .AppleDB 93 | .AppleDesktop 94 | Network Trash Folder 95 | Temporary Items 96 | .apdisk 97 | 98 | 99 | ### https://raw.githubusercontent.com/github/gitignore/main/OCaml.gitignore 100 | 101 | *.annot 102 | *.cmo 103 | *.cma 104 | *.cmi 105 | *.a 106 | *.o 107 | *.cmx 108 | *.cmxs 109 | *.cmxa 110 | 111 | # ocamlbuild working directory 112 | _build/ 113 | 114 | # ocamlbuild targets 115 | *.byte 116 | *.native 117 | 118 | # oasis generated files 119 | setup.data 120 | setup.log 121 | 122 | # Merlin configuring file for Vim and Emacs 123 | .merlin 124 | 125 | # Dune generated files 126 | *.install 127 | 128 | # Local OPAM switch 129 | _opam/ 130 | 131 | # for Nix 132 | result 133 | 134 | # for Direnv 135 | /.envrc.local 136 | /.direnv/ 137 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Copyright Assignment 2 | 3 | Thank you for your contribution. Here is some important legal stuff. 4 | 5 | By submitting a pull request for this project, unless explicitly stated otherwise, you agree to assign your copyright of the contribution to **The RedPRL Development Team** when it is accepted (merged with or without minor changes). You assert that you have full power to assign the copyright, and that any copyright owned by or shared with a third party has been clearly marked with appropriate copyright notices. If you are employed, please check with your employer about the owernership of your contribution. 6 | 7 | This would allow us to, for example, change the license of the codebase to Apache 2.0 or transfer the ownership of the project to someone else *without your further consent*. We demand this assignment so that we do not have to ask *everyone* who has ever contributed for these activities. This requires trust, and if you feel uncomfortable about this assignment, please make an explicit note. 8 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | # Contributors 2 | 3 | - Carlo Angiuli 4 | - Solomon Bothwell 5 | - Evan Cavallo 6 | - Jt Gleason 7 | - Daniel Gratzer 8 | - Alex Gryzlov 9 | - Favonia 10 | - Matthew McQuaid 11 | - Reed Mullanix 12 | - Jonathan Sterling 13 | - Ian Voysey 14 | 15 | ## External Copyrighted Materials 16 | 17 | Here is the list of materials whose copyright was not assigned to **The RedPRL Development Team.** 18 | 19 | - Code originating from [blott](https://github.com/jozefg/blott/) (see below). 20 | - Before we imposed the the CLA (see [Copyright Assignment](CONTRIBUTING.md)), Jt Gleason (`@EntropyFails`) made a [pull request](https://github.com/RedPRL/cooltt/pull/166) that improves error messages and the PR was merged. According to the GitHub’s term of service, Jt Cleason implicitly agreed that the contribution can be licensed under the same license cooltt used, which was Apache 2.0. 21 | 22 | ## History and Original License 23 | 24 | This project historically began from the source code of 25 | [blott](https://github.com/jozefg/blott/), a companion implementation for a 26 | paper written by Daniel Gratzer, Jonathan Sterling, and Lars Birkedal. cooltt 27 | also incorporates code from redtt, developed by Sterling and Favonia. 28 | 29 | blott is distributed under the MIT License; cooltt is distributed under the 30 | Apache License. As required, we reproduce the original license below. 31 | 32 | ``` 33 | Copyright 2019 Daniel Gratzer, Jonathan Sterling, Lars Birkedal 34 | 35 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and 36 | associated documentation files (the "Software"), to deal in the Software without restriction, 37 | including without limitation the rights to use, copy, modify, merge, publish, distribute, 38 | sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is 39 | furnished to do so, subject to the following conditions: 40 | 41 | The above copyright notice and this permission notice shall be included in all copies or substantial 42 | portions of the Software. 43 | 44 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT 45 | NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 46 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES 47 | OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 48 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 49 | ``` 50 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OPAM=opam 2 | EXEC=${OPAM} exec 3 | DUNE=${EXEC} dune -- 4 | PIN_DEPENDS=bantorra 5 | 6 | .PHONY: all build clean doc install test snapshot format 7 | 8 | all: build 9 | 10 | upgrade-pins: 11 | ${OPAM} update --upgrade --quiet ${PIN_DEPENDS} 12 | 13 | build: 14 | @${DUNE} build @install 15 | 16 | clean: 17 | @${DUNE} clean 18 | 19 | doc: 20 | @${DUNE} build @doc 21 | 22 | install: 23 | ${OPAM} reinstall cooltt 24 | 25 | test: 26 | @${DUNE} build --display=quiet @runtest @test-display 27 | 28 | # Here we want full reproducible behavior, ideally, we build all the 29 | # dependencies of the tests before actually running them, as to avoid 30 | # interference. This is possible to do cleanly in Dune 3.0 as `alias` 31 | # got the right semantics, so you can collect all of your tests deps 32 | # in an alias and use `dune build @test-deps` instead of the 33 | # hand-setup below. 34 | TEST_FILE=test/test.exe 35 | test-timings: 36 | @${DUNE} clean --display=quiet 37 | @${DUNE} build --display=quiet $(TEST_FILE) $(shell ls test/*.cooltt test/cooltt-lib) 38 | @${DUNE} build --display=quiet --cache=disabled @runtest @test-display 39 | 40 | snapshot: 41 | @${DUNE} promote 42 | 43 | format: 44 | ./format.sh 45 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## cooltt 2 | 3 | A cool implementation of normalization by evaluation (NbE) & elaboration for 4 | Cartesian cubical type theory. 5 | 6 | For examples, see the `test/` directory. 7 | 8 | This implementation is forked from `blott`, the implementation artifact of 9 | [Implementing a Modal Dependent Type Theory](https://doi.acm.org/10.1145/3341711) 10 | by Gratzer, Sterling, and Birkedal. Code has been incorporated from 11 | [redtt](https://www.github.com/RedPRL/redtt), implemented by Sterling and 12 | Favonia. 13 | 14 | A small collection of example programs is contained in the `test/` directory. 15 | See `test/README.md` for a brief description of each program's purpose. 16 | 17 | ## Building 18 | 19 | cooltt has been built with OCaml 5.0 with [opam 2.0.8](https://opam.ocaml.org/). 20 | 21 | ### With OPAM 22 | 23 | If you are running an older version of OCaml, try executing the following command: 24 | 25 | ``` 26 | $ opam switch create 5.0.0 27 | ``` 28 | 29 | Once these dependencies are installed cooltt can be built with the following set of commands. 30 | 31 | ``` 32 | $ opam update 33 | $ opam pin add -y cooltt . # first time 34 | $ opam upgrade # after packages change 35 | ``` 36 | 37 | After this, the executable `cooltt` should be available. The makefile can be 38 | used to rebuild the package for small tests. Locally, cooltt is built with 39 | [dune](https://dune.build); running the above commands will also install dune. 40 | Once dune is available the executable can be locally changed and run with the 41 | following: 42 | 43 | ``` 44 | $ make upgrade-pins # update and upgrade dependencies in active development 45 | $ dune exec cooltt # from the `cooltt` top-level directory 46 | ``` 47 | 48 | ### With Nix 49 | 50 | First, you'll need the [Nix package manager](https://nixos.org/download.html), and then 51 | you'll need to [install or enable flakes](https://nixos.wiki/wiki/Flakes). 52 | 53 | Then, cooltt can be built with the command 54 | 55 | ``` 56 | nix build 57 | ``` 58 | 59 | to put a binary `cooltt` in `result/bin/cooltt`. This is good for if you just want to build 60 | and play around with cooltt. 61 | 62 | If you're working on cooltt, you can enter a development shell with an OCaml compiler, dune, 63 | and other tools with 64 | 65 | ``` 66 | nix develop 67 | ``` 68 | 69 | and then build as in the [with OPAM](https://github.com/RedPRL/cooltt/#with-opam=) section 70 | above. 71 | 72 | ## Acknowledgments 73 | 74 | This research was supported by the Air Force Office of Scientific Research under MURI grants FA9550-15-1-0053, FA9550-19-1-0216, and FA9550-21-1-0009. Any opinions, findings and conclusions or recommendations expressed in this material are those of the authors and do not necessarily reflect the views of any sponsoring institution, government or any other entity. 75 | -------------------------------------------------------------------------------- /cooltt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "cooltt" 3 | version: "0.0" 4 | maintainer: "Jonathan Sterling " 5 | authors: ["The RedPRL Development Team"] 6 | homepage: "https://github.com/RedPRL/cooltt" 7 | bug-reports: "https://github.com/RedPRL/cooltt/issues" 8 | dev-repo: "git+https://github.com/RedPRL/cooltt.git" 9 | synopsis: "Experimental implementation of Cartesian cubical type theory" 10 | license: "Apache-2.0" 11 | depends: [ 12 | "dune" {>= "2.0"} 13 | "ocaml" {>= "5.0"} 14 | "ppx_deriving" {>= "4.4.1"} 15 | "bantorra" {>= "0.1" & < "0.2"} 16 | "bwd" {>= "2.2"} 17 | "cmdliner" {>= "1.1"} 18 | "containers" {>= "3.4"} 19 | "ezjsonm" {>= "1.2.0"} 20 | "menhir" {>= "20180703"} 21 | "uuseg" {>= "12.0.0"} 22 | "uutf" {>= "1.0.2"} 23 | "yuujinchou" {>= "5.0"} 24 | "odoc" {with-doc} 25 | "kado" 26 | ] 27 | pin-depends: [ 28 | [ "kado.~dev" "git+https://github.com/RedPRL/kado#65573a1c0f14f6b09836f8ae317fda17f5900968" ] 29 | [ "bantorra.0.1.0" "git+https://github.com/RedPRL/bantorra#1e78633d9a2ef7104552a24585bb8bea36d4117b" ] 30 | ] 31 | build: [ 32 | ["dune" "build" "-p" name "-j" jobs] 33 | ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} 34 | ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} 35 | ] 36 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | *.pdf 2 | 3 | ## Core latex/pdflatex auxiliary files: 4 | *.aux 5 | *.lof 6 | *.log 7 | *.lot 8 | *.fls 9 | *.out 10 | *.toc 11 | *.fmt 12 | *.fot 13 | *.cb 14 | *.cb2 15 | .*.lb 16 | 17 | ## Intermediate documents: 18 | *.dvi 19 | *.xdv 20 | *-converted-to.* 21 | # these rules might exclude image files for figures etc. 22 | # *.ps 23 | # *.eps 24 | # *.pdf 25 | 26 | ## Generated if empty string is given at "Please type another file name for output:" 27 | .pdf 28 | 29 | ## Bibliography auxiliary files (bibtex/biblatex/biber): 30 | *.bbl 31 | *.bcf 32 | *.blg 33 | *-blx.aux 34 | *-blx.bib 35 | *.run.xml 36 | 37 | ## Build tool auxiliary files: 38 | *.fdb_latexmk 39 | *.synctex 40 | *.synctex(busy) 41 | *.synctex.gz 42 | *.synctex.gz(busy) 43 | *.pdfsync 44 | 45 | ## Build tool directories for auxiliary files 46 | # latexrun 47 | latex.out/ 48 | 49 | ## Auxiliary and intermediate files from other packages: 50 | # algorithms 51 | *.alg 52 | *.loa 53 | 54 | # achemso 55 | acs-*.bib 56 | 57 | # amsthm 58 | *.thm 59 | 60 | # beamer 61 | *.nav 62 | *.pre 63 | *.snm 64 | *.vrb 65 | 66 | # changes 67 | *.soc 68 | 69 | # comment 70 | *.cut 71 | 72 | # cprotect 73 | *.cpt 74 | 75 | # elsarticle (documentclass of Elsevier journals) 76 | *.spl 77 | 78 | # endnotes 79 | *.ent 80 | 81 | # fixme 82 | *.lox 83 | 84 | # feynmf/feynmp 85 | *.mf 86 | *.mp 87 | *.t[1-9] 88 | *.t[1-9][0-9] 89 | *.tfm 90 | 91 | #(r)(e)ledmac/(r)(e)ledpar 92 | *.end 93 | *.?end 94 | *.[1-9] 95 | *.[1-9][0-9] 96 | *.[1-9][0-9][0-9] 97 | *.[1-9]R 98 | *.[1-9][0-9]R 99 | *.[1-9][0-9][0-9]R 100 | *.eledsec[1-9] 101 | *.eledsec[1-9]R 102 | *.eledsec[1-9][0-9] 103 | *.eledsec[1-9][0-9]R 104 | *.eledsec[1-9][0-9][0-9] 105 | *.eledsec[1-9][0-9][0-9]R 106 | 107 | # glossaries 108 | *.acn 109 | *.acr 110 | *.glg 111 | *.glo 112 | *.gls 113 | *.glsdefs 114 | *.lzo 115 | *.lzs 116 | 117 | # uncomment this for glossaries-extra (will ignore makeindex's style files!) 118 | # *.ist 119 | 120 | # gnuplottex 121 | *-gnuplottex-* 122 | 123 | # gregoriotex 124 | *.gaux 125 | *.gtex 126 | 127 | # htlatex 128 | *.4ct 129 | *.4tc 130 | *.idv 131 | *.lg 132 | *.trc 133 | *.xref 134 | 135 | # hyperref 136 | *.brf 137 | 138 | # knitr 139 | *-concordance.tex 140 | # TODO Comment the next line if you want to keep your tikz graphics files 141 | *.tikz 142 | *-tikzDictionary 143 | 144 | # listings 145 | *.lol 146 | 147 | # luatexja-ruby 148 | *.ltjruby 149 | 150 | # makeidx 151 | *.idx 152 | *.ilg 153 | *.ind 154 | 155 | # minitoc 156 | *.maf 157 | *.mlf 158 | *.mlt 159 | *.mtc[0-9]* 160 | *.slf[0-9]* 161 | *.slt[0-9]* 162 | *.stc[0-9]* 163 | 164 | # minted 165 | _minted* 166 | *.pyg 167 | 168 | # morewrites 169 | *.mw 170 | 171 | # nomencl 172 | *.nlg 173 | *.nlo 174 | *.nls 175 | 176 | # pax 177 | *.pax 178 | 179 | # pdfpcnotes 180 | *.pdfpc 181 | 182 | # sagetex 183 | *.sagetex.sage 184 | *.sagetex.py 185 | *.sagetex.scmd 186 | 187 | # scrwfile 188 | *.wrt 189 | 190 | # sympy 191 | *.sout 192 | *.sympy 193 | sympy-plots-for-*.tex/ 194 | 195 | # pdfcomment 196 | *.upa 197 | *.upb 198 | 199 | # pythontex 200 | *.pytxcode 201 | pythontex-files-*/ 202 | 203 | # tcolorbox 204 | *.listing 205 | 206 | # thmtools 207 | *.loe 208 | 209 | # TikZ & PGF 210 | *.dpth 211 | *.md5 212 | *.auxlock 213 | 214 | # todonotes 215 | *.tdo 216 | 217 | # vhistory 218 | *.hst 219 | *.ver 220 | 221 | # easy-todo 222 | *.lod 223 | 224 | # xcolor 225 | *.xcp 226 | 227 | # xmpincl 228 | *.xmpi 229 | 230 | # xindy 231 | *.xdy 232 | 233 | # xypic precompiled matrices and outlines 234 | *.xyc 235 | *.xyd 236 | 237 | # endfloat 238 | *.ttt 239 | *.fff 240 | 241 | # Latexian 242 | TSWLatexianTemp* 243 | 244 | ## Editors: 245 | # WinEdt 246 | *.bak 247 | *.sav 248 | 249 | # Texpad 250 | .texpadtmp 251 | 252 | # LyX 253 | *.lyx~ 254 | 255 | # Kile 256 | *.backup 257 | 258 | # gummi 259 | .*.swp 260 | 261 | # KBibTeX 262 | *~[0-9]* 263 | 264 | # TeXnicCenter 265 | *.tps 266 | 267 | # auto folder when using emacs and auctex 268 | ./auto/* 269 | *.el 270 | 271 | # expex forward references with \gathertags 272 | *-tags.tex 273 | 274 | # standalone packages 275 | *.sta 276 | 277 | # Makeindex log files 278 | *.lpz 279 | -------------------------------------------------------------------------------- /doc/jon-todo.sty: -------------------------------------------------------------------------------- 1 | \RequirePackage{xcolor} 2 | \RequirePackage{ifdraft} 3 | 4 | \definecolor{todo-color}{gray}{0.3} 5 | \definecolor{todo-red}{RGB}{134,1,17} 6 | \definecolor{todo-blue}{RGB}{3,69,117} 7 | 8 | \ExplSyntaxOn 9 | \NewDocumentCommand\todo{om}{ 10 | \ifdraft{ 11 | \noindent 12 | \marginpar[\smash{\llap{$\color{todo-red}\bullet$}}]{\smash{\rlap{$\color{todo-red}\bullet$}}} 13 | \group_begin: 14 | \sffamily 15 | \textcolor{todo-color}{ 16 | $\langle$ 17 | \textcolor{todo-red}{ 18 | \IfValueTF{#1}{Assigned~to~\textbf{#1}}{\textbf{todo}} 19 | }~|~ 20 | #2 21 | $\rangle$ 22 | } 23 | \group_end: 24 | }{} 25 | } 26 | 27 | \NewDocumentCommand\thought{m}{ 28 | \ifdraft{ 29 | \noindent 30 | \marginpar[\smash{\llap{$\color{todo-blue}\bullet$}}]{\smash{\rlap{$\color{todo-blue}\bullet$}}} 31 | \group_begin: 32 | \sffamily 33 | \textcolor{todo-color}{ 34 | $\langle$ 35 | \textcolor{todo-blue}{ 36 | \textbf{thought} 37 | }~|~ 38 | #1 39 | $\rangle$ 40 | } 41 | \group_end: 42 | }{} 43 | } 44 | 45 | \ExplSyntaxOff 46 | 47 | -------------------------------------------------------------------------------- /doc/refs.bib: -------------------------------------------------------------------------------- 1 | @phdthesis{angiuli:2019, 2 | author = {Angiuli, Carlo}, 3 | institution = {Carnegie Mellon University}, 4 | date = {2019}, 5 | title = {Computational Semantics of Cartesian Cubical Type Theory}, 6 | } 7 | 8 | @online{abcfhl:2019, 9 | author = {Angiuli, Carlo and Brunerie, Guillaume and Coquand, Thierry and {Hou (Favonia)}, Kuen-Bang and Harper, Robert and Licata, Daniel R.}, 10 | url = {https://github.com/dlicata335/cart-cube}, 11 | date = {2019-02}, 12 | note = {Preprint}, 13 | title = {Syntax and Models of Cartesian Cubical Type Theory}, 14 | } 15 | 16 | @inproceedings{orton-pitts:2016, 17 | author = {Orton, Ian and Pitts, Andrew M.}, 18 | booktitle = {25th {EACSL} Annual Conference on Computer Science Logic, {CSL} 2016, August 29 - September 1, 2016, Marseille, France}, 19 | date = {2016}, 20 | pages = {24:1--24:19}, 21 | title = {Axioms for Modelling Cubical Type Theory in a Topos}, 22 | } 23 | 24 | @misc{cooltt:2020, 25 | author = {The {RedPRL Development Team}}, 26 | url = {http://www.github.com/RedPRL/cooltt}, 27 | date = {2020}, 28 | title = {\texttt{cooltt}}, 29 | } 30 | 31 | @online{angiuli-favonia-harper:2017, 32 | author = {Angiuli, Carlo and {Hou (Favonia)}, Kuen-Bang and Harper, Robert}, 33 | url = {https://arxiv.org/abs/1712.01800}, 34 | date = {2017}, 35 | eprint = {1712.01800}, 36 | eprinttype = {arXiv}, 37 | title = {Computational Higher Type Theory {III}: Univalent Universes and Exact Equality}, 38 | shorthand = {AFH17}, 39 | } 40 | 41 | 42 | 43 | @inproceedings{vezzosi-mortberg-abel:2019, 44 | author = {Vezzosi, Andrea and M\"{o}rtberg, Anders and Abel, Andreas}, 45 | location = {Boston, Massachusetts, USA}, 46 | publisher = {ACM}, 47 | url = {http://www.cs.cmu.edu/~amoertbe/papers/cubicalagda.pdf}, 48 | booktitle = {Proceedings of the 24th ACM SIGPLAN International Conference on Functional Programming}, 49 | date = {2019}, 50 | doi = {10.1145/3341691}, 51 | series = {ICFP '19}, 52 | title = {{Cubical Agda: A Dependently Typed Programming Language with Univalence and Higher Inductive Types}}, 53 | } 54 | 55 | 56 | @misc{redtt:2018, 57 | author = {{RedPRL Development Team}, The}, 58 | url = {http://www.github.com/RedPRL/redtt}, 59 | date = {2018}, 60 | title = {\texttt{\textcolor[rgb]{.91,.31,.27}{red}tt}}, 61 | } 62 | 63 | @misc{redprl:2018, 64 | author = {{RedPRL Development Team}, The}, 65 | url = {http://www.redprl.org/}, 66 | date = {2018}, 67 | title = {\textsf{\textcolor[rgb]{.91,.31,.27}{Red}PRL} -- the {P}eople's {R}efinement {L}ogic}, 68 | } 69 | 70 | 71 | 72 | @article{cchm:2017, 73 | author = {Cohen, Cyril and Coquand, Thierry and Huber, Simon and M\"{o}rtberg, Anders}, 74 | url = {http://www.collegepublications.co.uk/journals/ifcolog/?00019}, 75 | date = {2017-11}, 76 | journaltitle = {IfCoLog Journal of Logics and their Applications}, 77 | number = {10}, 78 | pages = {3127--3169}, 79 | title = {{Cubical Type Theory: a constructive interpretation of the univalence axiom}}, 80 | volume = {4}, 81 | shorthand = {CCHM17}, 82 | } 83 | 84 | 85 | @misc{cchm:cubicaltt, 86 | author = {Cohen, Cyril and Coquand, Thierry and Huber, Simon and M{\"{o}}rtberg, Anders}, 87 | url = {https://github.com/mortberg/cubicaltt}, 88 | date = {2018}, 89 | title = {\texttt{cubicaltt}: Experimental implementation of {Cubical Type Theory}}, 90 | } 91 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (using menhir 1.0) 3 | (formatting disabled) 4 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-compat": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1627913399, 7 | "narHash": "sha256-hY8g6H2KFL8ownSiFeMOjwPC8P0ueXpCVEbxgda3pko=", 8 | "owner": "edolstra", 9 | "repo": "flake-compat", 10 | "rev": "12c64ca55c1014cdc1b16ed5a804aa8576601ff2", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "edolstra", 15 | "repo": "flake-compat", 16 | "type": "github" 17 | } 18 | }, 19 | "flake-utils": { 20 | "inputs": { 21 | "systems": "systems" 22 | }, 23 | "locked": { 24 | "lastModified": 1692799911, 25 | "narHash": "sha256-3eihraek4qL744EvQXsK1Ha6C3CR7nnT8X2qWap4RNk=", 26 | "owner": "numtide", 27 | "repo": "flake-utils", 28 | "rev": "f9e7cf818399d17d347f847525c5a5a8032e4e44", 29 | "type": "github" 30 | }, 31 | "original": { 32 | "owner": "numtide", 33 | "repo": "flake-utils", 34 | "type": "github" 35 | } 36 | }, 37 | "flake-utils_2": { 38 | "locked": { 39 | "lastModified": 1638122382, 40 | "narHash": "sha256-sQzZzAbvKEqN9s0bzWuYmRaA03v40gaJ4+iL1LXjaeI=", 41 | "owner": "numtide", 42 | "repo": "flake-utils", 43 | "rev": "74f7e4319258e287b0f9cb95426c9853b282730b", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "numtide", 48 | "repo": "flake-utils", 49 | "type": "github" 50 | } 51 | }, 52 | "mirage-opam-overlays": { 53 | "flake": false, 54 | "locked": { 55 | "lastModified": 1661959605, 56 | "narHash": "sha256-CPTuhYML3F4J58flfp3ZbMNhkRkVFKmBEYBZY5tnQwA=", 57 | "owner": "dune-universe", 58 | "repo": "mirage-opam-overlays", 59 | "rev": "05f1c1823d891ce4d8adab91f5db3ac51d86dc0b", 60 | "type": "github" 61 | }, 62 | "original": { 63 | "owner": "dune-universe", 64 | "repo": "mirage-opam-overlays", 65 | "type": "github" 66 | } 67 | }, 68 | "nixpkgs": { 69 | "locked": { 70 | "lastModified": 1682362401, 71 | "narHash": "sha256-/UMUHtF2CyYNl4b60Z2y4wwTTdIWGKhj9H301EDcT9M=", 72 | "owner": "nixos", 73 | "repo": "nixpkgs", 74 | "rev": "884ac294018409e0d1adc0cae185439a44bd6b0b", 75 | "type": "github" 76 | }, 77 | "original": { 78 | "owner": "nixos", 79 | "ref": "nixos-unstable", 80 | "repo": "nixpkgs", 81 | "type": "github" 82 | } 83 | }, 84 | "opam-nix": { 85 | "inputs": { 86 | "flake-compat": "flake-compat", 87 | "flake-utils": "flake-utils_2", 88 | "mirage-opam-overlays": "mirage-opam-overlays", 89 | "nixpkgs": "nixpkgs", 90 | "opam-overlays": "opam-overlays", 91 | "opam-repository": [ 92 | "opam-repository" 93 | ], 94 | "opam2json": "opam2json" 95 | }, 96 | "locked": { 97 | "lastModified": 1692284409, 98 | "narHash": "sha256-Cql9CKy/k+LmSab3Rd2ZkuoEpmWVDb5oRhE/UHM4fT8=", 99 | "owner": "tweag", 100 | "repo": "opam-nix", 101 | "rev": "e83bd1d949c5e330a49f89d394b51b744248e3ca", 102 | "type": "github" 103 | }, 104 | "original": { 105 | "owner": "tweag", 106 | "repo": "opam-nix", 107 | "type": "github" 108 | } 109 | }, 110 | "opam-overlays": { 111 | "flake": false, 112 | "locked": { 113 | "lastModified": 1654162756, 114 | "narHash": "sha256-RV68fUK+O3zTx61iiHIoS0LvIk0E4voMp+0SwRg6G6c=", 115 | "owner": "dune-universe", 116 | "repo": "opam-overlays", 117 | "rev": "c8f6ef0fc5272f254df4a971a47de7848cc1c8a4", 118 | "type": "github" 119 | }, 120 | "original": { 121 | "owner": "dune-universe", 122 | "repo": "opam-overlays", 123 | "type": "github" 124 | } 125 | }, 126 | "opam-repository": { 127 | "flake": false, 128 | "locked": { 129 | "lastModified": 1693414331, 130 | "narHash": "sha256-4lcerZ9XBJ5nMGw+cxYrIcvxNQzuKu7ZPiE4R7PUJ3w=", 131 | "owner": "ocaml", 132 | "repo": "opam-repository", 133 | "rev": "aa09a2fd2386ae30b729a2ee438e7698c011e69c", 134 | "type": "github" 135 | }, 136 | "original": { 137 | "owner": "ocaml", 138 | "repo": "opam-repository", 139 | "type": "github" 140 | } 141 | }, 142 | "opam2json": { 143 | "inputs": { 144 | "nixpkgs": [ 145 | "opam-nix", 146 | "nixpkgs" 147 | ] 148 | }, 149 | "locked": { 150 | "lastModified": 1671540003, 151 | "narHash": "sha256-5pXfbUfpVABtKbii6aaI2EdAZTjHJ2QntEf0QD2O5AM=", 152 | "owner": "tweag", 153 | "repo": "opam2json", 154 | "rev": "819d291ea95e271b0e6027679de6abb4d4f7f680", 155 | "type": "github" 156 | }, 157 | "original": { 158 | "owner": "tweag", 159 | "repo": "opam2json", 160 | "type": "github" 161 | } 162 | }, 163 | "root": { 164 | "inputs": { 165 | "flake-utils": "flake-utils", 166 | "nixpkgs": [ 167 | "opam-nix", 168 | "nixpkgs" 169 | ], 170 | "opam-nix": "opam-nix", 171 | "opam-repository": "opam-repository" 172 | } 173 | }, 174 | "systems": { 175 | "locked": { 176 | "lastModified": 1681028828, 177 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 178 | "owner": "nix-systems", 179 | "repo": "default", 180 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 181 | "type": "github" 182 | }, 183 | "original": { 184 | "owner": "nix-systems", 185 | "repo": "default", 186 | "type": "github" 187 | } 188 | } 189 | }, 190 | "root": "root", 191 | "version": 7 192 | } 193 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Experimental implementation of Cartesian cubical type theory"; 3 | 4 | inputs = { 5 | opam-repository = { 6 | url = "github:ocaml/opam-repository"; 7 | flake = false; 8 | }; 9 | opam-nix.url = "github:tweag/opam-nix"; 10 | opam-nix.inputs.opam-repository.follows = "opam-repository"; 11 | flake-utils.url = "github:numtide/flake-utils"; 12 | nixpkgs.follows = "opam-nix/nixpkgs"; 13 | }; 14 | 15 | outputs = { self, flake-utils, opam-nix, opam-repository, nixpkgs }@inputs: 16 | flake-utils.lib.eachDefaultSystem (system: 17 | let 18 | pkgs = nixpkgs.legacyPackages.${system}; 19 | on = opam-nix.lib.${system}; 20 | localPackagesQuery = builtins.mapAttrs (_: pkgs.lib.last) 21 | (on.listRepo (on.makeOpamRepo ./.)); 22 | devPackagesQuery = { 23 | ocaml-lsp-server = "*"; 24 | ocp-indent = "*"; 25 | merlin = "*"; 26 | }; 27 | query = devPackagesQuery // { 28 | ocaml-base-compiler = "*"; 29 | }; 30 | scope = on.buildDuneProject { } "cooltt" ./. query; 31 | devPackages = builtins.attrValues 32 | (pkgs.lib.getAttrs (builtins.attrNames devPackagesQuery) scope); 33 | packages = 34 | pkgs.lib.getAttrs (builtins.attrNames localPackagesQuery) scope; 35 | in 36 | { 37 | legacyPackages = scope; 38 | 39 | packages = packages // { default = packages.cooltt; }; 40 | 41 | devShells.default = pkgs.mkShell { 42 | inputsFrom = builtins.attrValues packages; 43 | buildInputs = devPackages ++ [ 44 | pkgs.fd 45 | pkgs.nixpkgs-fmt 46 | pkgs.pkg-config 47 | pkgs.shellcheck 48 | ]; 49 | }; 50 | }); 51 | } 52 | -------------------------------------------------------------------------------- /format.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | git --no-pager diff origin/main --name-only | grep -E ".*\.ml(i)?$" | xargs -I% ocp-indent -i % 3 | -------------------------------------------------------------------------------- /src/basis/LexingUtil.ml: -------------------------------------------------------------------------------- 1 | include Lexing 2 | 3 | type span = 4 | {start : Lexing.position; 5 | stop : Lexing.position} 6 | 7 | let pp_span : span Pp.printer = 8 | fun fmt span -> 9 | Format.fprintf fmt "%a:%i.%i-%i.%i" 10 | (* HACK: We use the basename, rather than the full path here 11 | to avoid issues with the test suite. This is bad, and should 12 | be changed once more thought is put into how we want to 13 | handle fancier imports/project structures. *) 14 | Uuseg_string.pp_utf_8 (Filename.basename span.start.pos_fname) 15 | span.start.pos_lnum 16 | (span.start.pos_cnum - span.start.pos_bol) 17 | span.stop.pos_lnum 18 | (span.stop.pos_cnum - span.stop.pos_bol) 19 | 20 | let last_token lexbuf = 21 | let tok = lexeme lexbuf in 22 | if tok = "" then None else Some tok 23 | 24 | let current_span lexbuf = 25 | {start = lexbuf.lex_start_p; stop = lexbuf.lex_curr_p} 26 | -------------------------------------------------------------------------------- /src/basis/LexingUtil.mli: -------------------------------------------------------------------------------- 1 | include (module type of Lexing) 2 | 3 | type span = 4 | {start : Lexing.position; 5 | stop : Lexing.position} 6 | 7 | val pp_span : span Pp.printer 8 | 9 | val last_token : lexbuf -> string option 10 | val current_span : lexbuf -> span -------------------------------------------------------------------------------- /src/basis/ListUtil.ml: -------------------------------------------------------------------------------- 1 | open Bwd 2 | 3 | let rec zip xs ys = 4 | match xs, ys with 5 | | (x :: xs, y :: ys) -> (x, y) :: zip xs ys 6 | | _, _ -> [] 7 | 8 | let rec unzip = 9 | function 10 | | [] -> ([], []) 11 | | ((x, y) :: xs) -> 12 | let (xs, ys) = unzip xs in 13 | (x :: xs, y :: ys) 14 | 15 | let zip_with f xs ys = 16 | let rec go acc xs ys = 17 | match xs, ys with 18 | | x :: xs, y :: ys -> go (Snoc (acc, f x y)) xs ys 19 | | _, _ -> BwdLabels.to_list acc 20 | in go Emp xs ys 21 | 22 | 23 | let rec map_opt f = function 24 | | [] -> Some [] 25 | | (x :: xs) -> 26 | match f x with 27 | | Some y -> Option.map (fun ys -> y :: ys) (map_opt f xs) 28 | | None -> None 29 | 30 | let map_accum_left (f : 'a -> 'b -> 'a * 'c) (e : 'a) (xs : ' b list) : 'a * 'c list = 31 | let rec go e ys = 32 | function 33 | | [] -> (e, BwdLabels.to_list ys) 34 | | (x :: xs) -> 35 | let (e, y) = f e x in 36 | (go[@tailcall]) e (Snoc (ys, y)) xs 37 | in go e Emp xs 38 | -------------------------------------------------------------------------------- /src/basis/ListUtil.mli: -------------------------------------------------------------------------------- 1 | val zip : 'a list -> 'b list -> ('a * 'b) list 2 | val unzip : ('a * 'b) list -> 'a list * 'b list 3 | val zip_with : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 4 | val map_opt : ('a -> 'b option) -> 'a list -> 'b list option 5 | val map_accum_left : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list 6 | -------------------------------------------------------------------------------- /src/basis/Monad.ml: -------------------------------------------------------------------------------- 1 | open Bwd 2 | 3 | module type S = sig 4 | type 'a m 5 | 6 | val ret : 'a -> 'a m 7 | 8 | val bind : 'a m -> ('a -> 'b m) -> 'b m 9 | end 10 | 11 | module type Notation = sig 12 | type 'a m 13 | 14 | val (let*) : 'a m -> ('a -> 'b m) -> 'b m 15 | val (and*) : 'a m -> 'b m -> ('a * 'b) m 16 | val (let+) : 'a m -> ('a -> 'b) -> 'b m 17 | val (and+) : 'a m -> 'b m -> ('a * 'b) m 18 | val (<@>) : ('a -> 'b) -> 'a m -> 'b m 19 | val (|>>) : 'a m -> ('a -> 'b m) -> 'b m 20 | val (@<<) : ('a -> 'b m) -> 'a m -> 'b m 21 | val (<&>) : 'a m -> 'b m -> ('a * 'b) m 22 | end 23 | 24 | module Notation (M : S) : Notation with type 'a m = 'a M.m = struct 25 | type 'a m = 'a M.m 26 | 27 | let (let*) = M.bind 28 | 29 | let (and*) m n = 30 | let* x = m in 31 | let* y = n in 32 | M.ret (x, y) 33 | 34 | let (let+) m f = M.bind m (fun x -> M.ret (f x)) 35 | 36 | let (and+) m n = (and*) m n 37 | 38 | let (<@>) f m = (let+) m f 39 | let (|>>) = (let*) 40 | let (@<<) f m = m |>> f 41 | let (<&>) = (and+) 42 | end 43 | 44 | module Util (M : S) = 45 | struct 46 | open Notation (M) 47 | 48 | let rec commute_list = 49 | function 50 | | [] -> M.ret [] 51 | | m :: ms -> 52 | let+ x = m 53 | and+ xs = commute_list ms in 54 | x :: xs 55 | 56 | let rec map f = 57 | function 58 | | [] -> M.ret [] 59 | | (x :: xs) -> 60 | let+ y = f x 61 | and+ ys = map f xs in 62 | y :: ys 63 | 64 | let rec filter_map f = 65 | function 66 | | [] -> M.ret [] 67 | | (x :: xs) -> 68 | let+ oy = f x 69 | and+ ys = filter_map f xs in 70 | match oy with 71 | | None -> ys 72 | | Some y -> y :: ys 73 | 74 | let rec map_bwd f = 75 | function 76 | | Emp -> M.ret Emp 77 | | Snoc (xs, x) -> 78 | let+ xs = map_bwd f xs 79 | and+ x = f x in 80 | Snoc (xs, x) 81 | 82 | let rec iter f = 83 | function 84 | | [] -> M.ret () 85 | | x :: xs -> let* () = f x in iter f xs 86 | 87 | let rec filter_map f = 88 | function 89 | | [] -> M.ret [] 90 | | (x :: xs) -> 91 | let+ y = f x 92 | and+ ys = filter_map f xs in 93 | match y with 94 | | None -> ys 95 | | Some y -> y :: ys 96 | 97 | let ignore m = 98 | let+ _ = m in () 99 | 100 | let rec fold_left_m f b = 101 | function 102 | | [] -> M.ret b 103 | | (x :: xs) -> M.bind (f x b) (fun b' -> fold_left_m f b' xs) 104 | 105 | let guard b action = 106 | if b then 107 | action () 108 | else 109 | M.ret () 110 | 111 | let first f (a, b) = 112 | let+ c = f a in 113 | (c, b) 114 | 115 | let second f (a, b) = 116 | let+ c = f b in 117 | (a, c) 118 | 119 | let map_accum_left_m f xs = 120 | let rec go acc = 121 | function 122 | | [] -> M.ret [] 123 | | (x :: xs) -> 124 | let+ y = f acc x 125 | and+ ys = go (acc @ [x]) xs in 126 | y :: ys 127 | in 128 | go [] xs 129 | end 130 | 131 | module type MonadReaderResult = sig 132 | include S 133 | type local 134 | val read : local m 135 | val scope : (local -> local) -> 'a m -> 'a m 136 | val run : local -> 'a m -> ('a, exn) result 137 | val run_exn : local -> 'a m -> 'a 138 | val throw : exn -> 'a m 139 | val trap : 'a m -> ('a, exn) result m 140 | end 141 | 142 | module type MonadReaderStateResult = sig 143 | include S 144 | type global 145 | type local 146 | 147 | val read : local m 148 | val scope : (local -> local) -> 'a m -> 'a m 149 | val get : global m 150 | val set : global -> unit m 151 | val modify : (global -> global) -> unit m 152 | 153 | val run : global -> local -> 'a m -> ('a, exn) result 154 | val run_exn : global -> local -> 'a m -> 'a 155 | val throw : exn -> 'a m 156 | val trap : 'a m -> ('a, exn) result m 157 | end 158 | 159 | 160 | 161 | module MonadReaderResult (X : sig type local end) = 162 | struct 163 | type 'a m = X.local -> ('a, exn) result 164 | 165 | let ret a _ = Ok a 166 | 167 | let bind m k env = 168 | match m env with 169 | | Ok a -> k a env 170 | | Error exn -> Error exn 171 | 172 | let throw exn _ = Error exn 173 | 174 | let trap (m : 'a m) : ('a, exn) result m = 175 | fun env -> 176 | Ok (m env) 177 | 178 | let read env = Ok env 179 | let scope f m env = m @@ f env 180 | 181 | let run env m = m env 182 | 183 | let run_exn env m = 184 | match run env m with 185 | | Ok a -> a 186 | | Error exn -> raise exn 187 | 188 | end 189 | 190 | module MonadReaderStateResult (X : sig type global type local end) = 191 | struct 192 | type 'a m = X.global * X.local -> ('a, exn) result * X.global 193 | 194 | let ret a (st, _) = Ok a, st 195 | 196 | let bind m k (st, env) = 197 | match m (st, env) with 198 | | Ok a, st' -> k a (st', env) 199 | | Error exn, st' -> Error exn, st' 200 | 201 | let throw exn (st, _) = Error exn, st 202 | 203 | 204 | let trap (m : 'a m) : ('a, exn) result m = 205 | fun env -> 206 | match m env with 207 | | Ok a, st -> Ok (Ok a), st 208 | | Error exn, st -> Ok (Error exn), st 209 | 210 | let read (st, env) = Ok env, st 211 | let scope f m (st, env) = m (st, f env) 212 | 213 | let get (st, _) = Ok st, st 214 | let set st (_, _) = Ok (), st 215 | let modify f (st, _) = Ok (), f st 216 | 217 | let run st env m = 218 | let a, _ = m (st, env) in 219 | a 220 | 221 | let run_exn st env m = 222 | match run st env m with 223 | | Ok a -> a 224 | | Error exn -> raise exn 225 | end 226 | -------------------------------------------------------------------------------- /src/basis/Monad.mli: -------------------------------------------------------------------------------- 1 | open Bwd 2 | 3 | module type S = sig 4 | type 'a m 5 | 6 | val ret : 'a -> 'a m 7 | val bind : 'a m -> ('a -> 'b m) -> 'b m 8 | end 9 | 10 | module type Notation = sig 11 | type 'a m 12 | 13 | val (let*) : 'a m -> ('a -> 'b m) -> 'b m 14 | val (and*) : 'a m -> 'b m -> ('a * 'b) m 15 | val (let+) : 'a m -> ('a -> 'b) -> 'b m 16 | val (and+) : 'a m -> 'b m -> ('a * 'b) m 17 | 18 | val (<@>) : ('a -> 'b) -> 'a m -> 'b m 19 | val (|>>) : 'a m -> ('a -> 'b m) -> 'b m 20 | val (@<<) : ('a -> 'b m) -> 'a m -> 'b m 21 | val (<&>) : 'a m -> 'b m -> ('a * 'b) m 22 | end 23 | 24 | module Notation (M : S) : Notation with type 'a m = 'a M.m 25 | 26 | module Util (M : S) : sig 27 | val commute_list : 'a M.m list -> 'a list M.m 28 | val map : ('a -> 'b M.m) -> 'a list -> 'b list M.m 29 | val filter_map : ('a -> 'b option M.m) -> 'a list -> 'b list M.m 30 | val map_bwd : ('a -> 'b M.m) -> 'a bwd -> 'b bwd M.m 31 | val iter : ('a -> unit M.m) -> 'a list -> unit M.m 32 | val ignore : 'a M.m -> unit M.m 33 | val fold_left_m : ('a -> 'b ->'b M.m) -> 'b -> 'a list -> 'b M.m 34 | val guard : bool -> (unit -> unit M.m) -> unit M.m 35 | val first : ('a -> 'b M.m) -> ('a * 'c) -> ('b * 'c) M.m 36 | val second : ('b -> 'c M.m) -> ('a * 'b) -> ('a * 'c) M.m 37 | val map_accum_left_m : ('a list -> 'a -> 'b M.m) -> 'a list -> ('b list) M.m 38 | end 39 | 40 | module type MonadReaderResult = sig 41 | include S 42 | type local 43 | val read : local m 44 | val scope : (local -> local) -> 'a m -> 'a m 45 | val run : local -> 'a m -> ('a, exn) result 46 | val run_exn : local -> 'a m -> 'a 47 | val throw : exn -> 'a m 48 | 49 | val trap : 'a m -> ('a, exn) result m 50 | end 51 | 52 | module type MonadReaderStateResult = sig 53 | include S 54 | type global 55 | type local 56 | 57 | val read : local m 58 | val scope : (local -> local) -> 'a m -> 'a m 59 | val get : global m 60 | val set : global -> unit m 61 | val modify : (global -> global) -> unit m 62 | 63 | val run : global -> local -> 'a m -> ('a, exn) result 64 | val run_exn : global -> local -> 'a m -> 'a 65 | val throw : exn -> 'a m 66 | val trap : 'a m -> ('a, exn) result m 67 | end 68 | 69 | module MonadReaderResult (X : sig type local end) : sig 70 | include MonadReaderResult 71 | with type 'a m = X.local -> ('a, exn) result 72 | with type local := X.local 73 | end 74 | 75 | module MonadReaderStateResult (X : sig type global type local end) : sig 76 | include MonadReaderStateResult 77 | with type 'a m = X.global * X.local -> ('a, exn) result * X.global 78 | with type global := X.global 79 | with type local := X.local 80 | end 81 | -------------------------------------------------------------------------------- /src/basis/PersistentTable.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type key 4 | type 'a t 5 | 6 | val empty : 'a t 7 | val size : 'a t -> int 8 | val get : key -> 'a t -> 'a 9 | val get_opt : key -> 'a t -> 'a option 10 | val set : key -> 'a -> 'a t -> 'a t 11 | val mem : key -> 'a t -> bool 12 | val remove : key -> 'a t -> 'a t 13 | val set_opt : key -> 'a option -> 'a t -> 'a t 14 | val find : key -> 'a t -> 'a option 15 | val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 16 | 17 | (** entries from the first argument overwrite the ones from the second. *) 18 | val merge : 'a t -> 'a t -> 'a t 19 | 20 | val to_list : 'a t -> (key * 'a) list 21 | val to_list_keys : 'a t -> key list 22 | val to_list_values : 'a t -> 'a list 23 | end 24 | 25 | module type MAKER = functor (O : Map.OrderedType) -> S with type key = O.t 26 | 27 | module M (O : Map.OrderedType) = 28 | struct 29 | 30 | type key = O.t 31 | 32 | module M = Map.Make (O) 33 | 34 | type 'a t = 'a M.t 35 | 36 | let empty = M.empty 37 | 38 | let size t = M.cardinal t 39 | 40 | let get k t = M.find k t 41 | 42 | let get_opt k t = M.find_opt k t 43 | 44 | let mem k t = M.mem k t 45 | 46 | let find k t = M.find_opt k t 47 | 48 | let set k v t = M.add k v t 49 | 50 | let remove k t = M.remove k t 51 | 52 | let set_opt k ov t = M.update k (fun _ -> ov) t 53 | 54 | let fold f t e = M.fold f t e 55 | 56 | let merge t0 t1 = fold set t0 t1 57 | 58 | let to_list t = M.bindings t 59 | 60 | let to_list_keys t = List.map (fun (k, _) -> k) @@ to_list t 61 | 62 | let to_list_values t = List.map (fun (_, v) -> v) @@ to_list t 63 | 64 | end 65 | -------------------------------------------------------------------------------- /src/basis/PersistentTable.mli: -------------------------------------------------------------------------------- 1 | (* Originally due to Conchon & Filliatre, but then redone using Map.Make *) 2 | 3 | module type S = 4 | sig 5 | type key 6 | type 'a t 7 | 8 | val empty : 'a t 9 | val size : 'a t -> int 10 | val get : key -> 'a t -> 'a 11 | val get_opt : key -> 'a t -> 'a option 12 | val set : key -> 'a -> 'a t -> 'a t 13 | val mem : key -> 'a t -> bool 14 | val remove : key -> 'a t -> 'a t 15 | val set_opt : key -> 'a option -> 'a t -> 'a t 16 | val find : key -> 'a t -> 'a option 17 | val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 18 | 19 | (** entries from the first argument overwrite the ones from the second. *) 20 | val merge : 'a t -> 'a t -> 'a t 21 | 22 | val to_list : 'a t -> (key * 'a) list 23 | val to_list_keys : 'a t -> key list 24 | val to_list_values : 'a t -> 'a list 25 | end 26 | 27 | module type MAKER = functor (O : Map.OrderedType) -> S with type key = O.t 28 | 29 | module M : MAKER 30 | -------------------------------------------------------------------------------- /src/basis/Pp.ml: -------------------------------------------------------------------------------- 1 | type 'a printer = Format.formatter -> 'a -> unit 2 | 3 | open Bwd 4 | open Bwd.Infix 5 | 6 | module Env = 7 | struct 8 | type t = string bwd 9 | 10 | let emp = Emp 11 | 12 | let nat_to_suffix n = 13 | let formatted = string_of_int n in 14 | let lookup : int -> string = Array.get [|"₀";"₁";"₂";"₃";"₄";"₅";"₆";"₇";"₈";"₉"|] in 15 | String.concat "" @@ 16 | List.init (String.length formatted) @@ 17 | fun n -> lookup (Char.code (String.get formatted n) - Char.code '0') 18 | 19 | let rec rename xs x i = 20 | let suffix = nat_to_suffix i in 21 | let new_x = x ^ suffix in 22 | if BwdLabels.mem new_x ~set:xs then (rename [@tailcall]) xs x (i + 1) else new_x 23 | 24 | let choose_name (env : t) (x : string) = 25 | if BwdLabels.mem x ~set:env then rename env x 1 else x 26 | 27 | let var i env = 28 | match BwdLabels.nth_opt env i with 29 | | Some v -> v 30 | | None -> failwith "Pp printer: tried to resolve bound variable out of range" 31 | 32 | let proj xs = 33 | match xs with 34 | | Emp -> failwith "ppenv/proj" 35 | | Snoc (xs, _) -> xs 36 | 37 | let bind (env : t) (nm : string option) : string * t = 38 | let x = 39 | match nm with 40 | | None -> choose_name env "_x" 41 | | Some x -> choose_name env x 42 | in 43 | x, env <: x 44 | 45 | let bind_underscore (env : t) : string * t = 46 | "_", env <: "_" 47 | 48 | let rec bindn (env : t) (nms : string option list) : string list * t = 49 | match nms with 50 | | [] -> 51 | [], env 52 | | nm :: nms -> 53 | let x, env' = bind env nm in 54 | let xs, env'' = bindn env' nms in 55 | (x :: xs), env'' 56 | 57 | let names (env : t) : string list = 58 | Bwd.to_list env 59 | end 60 | 61 | let pp_sep_list ?(sep = ", ") pp_elem fmt xs = 62 | Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_string fmt sep) pp_elem fmt xs 63 | 64 | type env = Env.t 65 | -------------------------------------------------------------------------------- /src/basis/Pp.mli: -------------------------------------------------------------------------------- 1 | type 'a printer = Format.formatter -> 'a -> unit 2 | 3 | module Env : 4 | sig 5 | type t 6 | val emp : t 7 | val var : int -> t -> string 8 | val bind : t -> string option -> string * t 9 | val bindn : t -> string option list -> string list * t 10 | val bind_underscore : t -> string * t 11 | 12 | val proj : t -> t 13 | val names : t -> string list 14 | end 15 | 16 | val pp_sep_list : ?sep:string -> 'a printer -> ('a list) printer 17 | 18 | type env = Env.t 19 | -------------------------------------------------------------------------------- /src/basis/PpExn.ml: -------------------------------------------------------------------------------- 1 | exception Unrecognized 2 | 3 | let printers = Stack.create () 4 | 5 | let install_printer printer = 6 | Stack.push printer printers; 7 | Printexc.register_printer @@ fun exn -> 8 | try 9 | printer Format.str_formatter exn; 10 | Some (Format.flush_str_formatter ()) 11 | with 12 | | Unrecognized -> 13 | None 14 | 15 | let pp fmt exn = 16 | let exception Break in 17 | let go printer = 18 | try 19 | printer fmt exn; 20 | raise Break 21 | with 22 | | Unrecognized -> () 23 | in 24 | try 25 | Stack.iter go printers; 26 | Format.fprintf fmt "%s" @@ Printexc.to_string exn 27 | with 28 | | Break -> () -------------------------------------------------------------------------------- /src/basis/PpExn.mli: -------------------------------------------------------------------------------- 1 | exception Unrecognized 2 | 3 | val pp : exn Pp.printer 4 | val install_printer : exn Pp.printer -> unit -------------------------------------------------------------------------------- /src/basis/Symbol.ml: -------------------------------------------------------------------------------- 1 | module J = Ezjsonm 2 | 3 | module type S = sig 4 | type t 5 | 6 | val compare : t -> t -> int 7 | val equal : t -> t -> bool 8 | 9 | val pp : t Pp.printer 10 | val show : t -> string 11 | 12 | val serialize : t -> J.value 13 | val deserialize : J.value -> t 14 | end 15 | -------------------------------------------------------------------------------- /src/basis/Symbol.mli: -------------------------------------------------------------------------------- 1 | module J = Ezjsonm 2 | 3 | module type S = sig 4 | type t 5 | 6 | val compare : t -> t -> int 7 | val equal : t -> t -> bool 8 | 9 | val pp : t Pp.printer 10 | val show : t -> string 11 | 12 | val serialize : t -> J.value 13 | val deserialize : J.value -> t 14 | end 15 | -------------------------------------------------------------------------------- /src/basis/SymbolMap.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | include Map.S 4 | 5 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 6 | end 7 | 8 | module Make (S : Symbol.S) = 9 | struct 10 | include Map.Make (S) 11 | 12 | let pp _ih fmt _table = 13 | Format.fprintf fmt "" 14 | end 15 | -------------------------------------------------------------------------------- /src/basis/SymbolMap.mli: -------------------------------------------------------------------------------- 1 | 2 | module type S = 3 | sig 4 | include Map.S 5 | 6 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 7 | end 8 | 9 | module Make (Sym : Symbol.S) : S with type key = Sym.t 10 | -------------------------------------------------------------------------------- /src/basis/Void.ml: -------------------------------------------------------------------------------- 1 | type t = | 2 | 3 | let abort : t -> 'a = function _ -> . 4 | -------------------------------------------------------------------------------- /src/basis/Void.mli: -------------------------------------------------------------------------------- 1 | type t = | 2 | 3 | val abort : t -> 'a 4 | -------------------------------------------------------------------------------- /src/basis/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Basis) 3 | (flags 4 | (:standard -w -32-38 -warn-error -a+31)) 5 | (preprocess 6 | (pps ppx_deriving.std)) 7 | (libraries ezjsonm uuseg uuseg.string uutf containers bwd) 8 | (public_name cooltt.basis)) 9 | -------------------------------------------------------------------------------- /src/bin/dune: -------------------------------------------------------------------------------- 1 | (env (static (flags (:standard -ccopt "-static -s")))) 2 | 3 | (executables 4 | (names main) 5 | (libraries cooltt.frontend cmdliner)) 6 | 7 | (install 8 | (section bin) 9 | (package cooltt) 10 | (files 11 | (main.exe as cooltt))) 12 | -------------------------------------------------------------------------------- /src/bin/main.ml: -------------------------------------------------------------------------------- 1 | open Frontend 2 | open Cmdliner 3 | 4 | let _ = 5 | Printexc.record_backtrace false; 6 | () 7 | 8 | type mode = 9 | [ `Interactive 10 | | `Scripting of [`Stdin | `File of string] 11 | ] 12 | 13 | type options = 14 | { mode : mode; 15 | as_file : string option; 16 | width : int; 17 | debug_mode : bool; 18 | server_info : (string * int) option; 19 | } 20 | 21 | let options mode as_file width debug_mode server_info = 22 | { mode; as_file; width; debug_mode; server_info } 23 | 24 | let main {mode; as_file; width; debug_mode; server_info} = 25 | Format.set_margin width; 26 | match 27 | match mode with 28 | | `Interactive -> Driver.do_repl {as_file; debug_mode; server_info} 29 | | `Scripting input -> Driver.load_file {as_file; debug_mode; server_info} input 30 | with 31 | | Ok () -> `Ok () 32 | | Error () -> `Error (false, "encountered one or more errors") 33 | 34 | let opt_mode = 35 | let doc = 36 | "Set the interaction mode. "^ 37 | "The value $(docv) must be one of "^ 38 | "$(b,scripting) (default) or $(b,interactive)." in 39 | Arg.(value & opt (some string) None & info ["m"; "mode"] ~doc ~docv:"MODE") 40 | 41 | let opt_interactive = 42 | let doc = "An abbreviation of $(b,--mode interactive)." in 43 | Arg.(value & flag & info ["i"; "interactive"] ~doc) 44 | 45 | let opt_width = 46 | let default_width = Format.get_margin () in 47 | let doc = "Set the maximum output width to $(docv) columns." in 48 | Arg.(value & opt int default_width & info ["w"; "width"] ~doc ~docv:"NUM") 49 | 50 | let opt_input_file = 51 | let doc = "The file to typecheck. When $(docv) is -, read standard input." in 52 | let parse_dash = Term.(app @@ const @@ Option.map @@ fun str -> if str = "-" then `Stdin else `File str) in 53 | Arg.(parse_dash & value & pos ~rev:true 0 (some string) None & info [] ~doc ~docv:"FILE") 54 | 55 | let opt_as_file = 56 | let doc = "Pretend the input was located at $(docv) when searching for the project root. \ 57 | This is mainly useful when reading from stdin." 58 | in 59 | Arg.(value & opt (some string) None & info ["as-file"] ~doc ~docv:"FILE") 60 | 61 | let opt_debug = 62 | let doc = "Enable debug mode. This will print out a bunch of information pertaining to the internal operations of cooltt." 63 | in 64 | Arg.(value & flag & info ["debug"] ~doc) 65 | 66 | let opt_server = 67 | let doc = "Enable the cooltt hole server." 68 | in 69 | Arg.(value & flag & info ["server"] ~doc) 70 | 71 | let opt_server_hostname = 72 | let doc = "The cooltt hole server hostname. If --server is not enabled, this does nothing." 73 | in 74 | Arg.(value & opt string "localhost" & info ["server-hostname"] ~doc ~docv:"HOSTNAME") 75 | 76 | let opt_server_port = 77 | let doc = "The cooltt hole server port. If --server is not enabled, this does nothing." 78 | in 79 | Arg.(value & opt int 3001 & info ["server-port"] ~doc ~docv:"PORT") 80 | 81 | let myinfo = 82 | let doc = "elaborate and normalize terms in Cartesian cubical type theory" in 83 | let err_exit = Cmd.Exit.info ~doc:"on ill-formed types or terms." 1 in 84 | Cmd.info "cooltt" ~version:"0.0" ~doc 85 | ~exits:(err_exit :: Cmd.Exit.defaults) 86 | 87 | let parse_mode = 88 | function 89 | | "interactive" -> `Interactive 90 | | "scripting" -> `Scripting 91 | | s -> `Nonexistent s 92 | 93 | let quote s = "`" ^ s ^ "'" 94 | 95 | let consolidate_input_options mode interactive input_file : (mode, [`Msg of string]) result = 96 | match Option.map parse_mode mode, interactive, input_file with 97 | | (Some `Scripting | None), false, Some input_file -> 98 | Ok (`Scripting input_file) 99 | | (Some `Scripting | None), false, None -> 100 | Error (`Msg "scripting mode expects an input file") 101 | | Some `Interactive, _, None | None, true, None -> 102 | Ok `Interactive 103 | | Some `Interactive, _, Some _ | None, true, _ -> 104 | Error (`Msg "interactive mode expects no input files") 105 | | Some `Scripting, true, _ -> 106 | Error (`Msg "inconsistent mode assignment") 107 | | Some (`Nonexistent s), _, _ -> 108 | Error (`Msg ("no mode named " ^ quote s)) 109 | 110 | let consolidate_server_options server_enabled server_host server_port = 111 | if server_enabled 112 | then Some (server_host, server_port) 113 | else None 114 | 115 | let () = 116 | let opts_input = Term.(term_result ~usage:true (const consolidate_input_options $ opt_mode $ opt_interactive $ opt_input_file)) in 117 | let opts_server = Term.(const consolidate_server_options $ opt_server $ opt_server_hostname $ opt_server_port) in 118 | let options : options Term.t = Term.(const options $ opts_input $ opt_as_file $ opt_width $ opt_debug $ opts_server) in 119 | let t = Term.ret @@ Term.(const main $ options) in 120 | exit (Cmd.eval ~catch:true ~err:Format.std_formatter @@ Cmd.v myinfo t) 121 | -------------------------------------------------------------------------------- /src/core/CodeUnit.ml: -------------------------------------------------------------------------------- 1 | open ContainersLabels 2 | 3 | module J = Ezjsonm 4 | 5 | module CodeUnitID = 6 | struct 7 | type t = string option 8 | let compare = Option.compare String.compare 9 | let pp fmt id = Format.pp_print_string fmt (Option.value ~default:"" id) 10 | let top_level : t = None 11 | let file s : t = Some s 12 | end 13 | type id = CodeUnitID.t 14 | 15 | module Global = 16 | struct 17 | type t = 18 | { origin : CodeUnitID.t; 19 | index : int; 20 | name : string option; 21 | unfolder : t option} 22 | [@@deriving show] 23 | 24 | let unfolder s = 25 | s.unfolder 26 | 27 | let compare s1 s2 = 28 | match CodeUnitID.compare s1.origin s2.origin with 29 | | 0 -> Int.compare s1.index s2.index 30 | | c -> c 31 | 32 | let equal s1 s2 = 33 | Int.equal (compare s1 s2) 0 34 | 35 | let pp fmt sym = 36 | match sym.name with 37 | | Some nm -> 38 | Format.fprintf fmt "%a" Uuseg_string.pp_utf_8 nm 39 | | None -> 40 | Format.fprintf fmt "#%i" sym.index 41 | 42 | let rec serialize sym = 43 | `O [("origin", J.option J.string @@ sym.origin); 44 | ("index", `String (Int.to_string sym.index)); 45 | ("unfolder", J.option serialize sym.unfolder); 46 | ("name", J.option J.string @@ sym.name) ] 47 | 48 | let rec deserialize : J.value -> t = 49 | function 50 | | `O [("origin", j_origin); ("index", j_index); ("unfolder", j_unfolder); ("name", j_name)] -> 51 | { origin = J.get_option J.get_string j_origin; 52 | unfolder = J.get_option deserialize j_unfolder; 53 | index = int_of_string @@ J.get_string j_index; 54 | name = J.get_option J.get_string j_name } 55 | | j -> J.parse_error j "Global.deserialize" 56 | end 57 | 58 | module Domain = Domain.Make (Global) 59 | module Syntax = Syntax.Make (Global) 60 | module CofVar = CofVar.Make (Global) 61 | module Dim = Dim.Make (Global) 62 | module CofBuilder = CofBuilder.Make (Global) 63 | module CofThy = CofThy.Make (Global) 64 | 65 | module CodeUnit = 66 | struct 67 | type t = 68 | { (* The name of the code unit. *) 69 | id : id; 70 | (* All the top-level bindings for this code unit. *) 71 | symbol_table : Domain.tp Vector.vector } 72 | 73 | let origin (sym : Global.t) = sym.origin 74 | 75 | let id code_unit = code_unit.id 76 | 77 | let create id = 78 | { id = id; 79 | symbol_table = Vector.create () } 80 | 81 | let add_global ~unfolder ident tp code_unit = 82 | let index = Vector.length code_unit.symbol_table in 83 | let _ = Vector.push code_unit.symbol_table tp in 84 | let sym = { Global.origin = code_unit.id; unfolder; index; name = Ident.to_string_opt ident } in 85 | (sym, code_unit) 86 | 87 | let get_global (sym : Global.t) code_unit = 88 | Vector.get code_unit.symbol_table sym.index 89 | end 90 | -------------------------------------------------------------------------------- /src/core/CodeUnit.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module J = Ezjsonm 4 | 5 | module CodeUnitID : 6 | sig 7 | type t 8 | val compare : t -> t -> int 9 | val pp : t Pp.printer 10 | val top_level : t 11 | val file : string -> t 12 | end 13 | type id = CodeUnitID.t 14 | 15 | module Global : 16 | sig 17 | include Symbol.S 18 | 19 | (** The global variable representing the 'unfolding dimension' of a global variable. *) 20 | val unfolder : t -> t option 21 | end 22 | 23 | module Domain : module type of Domain.Make(Global) 24 | module Syntax : module type of Syntax.Make(Global) 25 | module CofVar : module type of CofVar.Make(Global) 26 | module Dim : module type of Dim.Make(Global) 27 | module CofBuilder : module type of CofBuilder.Make(Global) 28 | module CofThy : module type of CofThy.Make(Global) 29 | 30 | module CodeUnit : sig 31 | 32 | (** Some metadata about a given code unit. *) 33 | type t 34 | 35 | (** Return the name of the code unit that a symbol originated from. *) 36 | val origin : Global.t -> id 37 | 38 | (** The name of a given code unit *) 39 | val id : t -> id 40 | 41 | (** Create a code unit. *) 42 | val create : id -> t 43 | 44 | (** Add a binding to a given code unit. *) 45 | val add_global : unfolder:Global.t option -> Ident.t -> Domain.tp -> t -> (Global.t * t) 46 | 47 | (** Get the binding associated with a symbol. *) 48 | val get_global : Global.t -> t -> Domain.tp 49 | end 50 | -------------------------------------------------------------------------------- /src/core/CofBuilder.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module Make (Symbol : Symbol.S) = 4 | struct 5 | module CofVar = CofVar.Make(Symbol) 6 | module Dim = Dim.Make(Symbol) 7 | 8 | include Kado.Builder.Free.Make 9 | (struct 10 | type dim = Dim.t 11 | type var = CofVar.t 12 | let dim0 = Dim.dim0 13 | let dim1 = Dim.dim1 14 | let equal_dim = Dim.equal 15 | end) 16 | end 17 | -------------------------------------------------------------------------------- /src/core/CofThy.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module Make (Symbol : Symbol.S) = 4 | struct 5 | module CofVar = CofVar.Make(Symbol) 6 | module Dim = Dim.Make(Symbol) 7 | 8 | include Kado.Theory.Make 9 | (struct 10 | type dim = Dim.t 11 | type var = CofVar.t 12 | let dim0 = Dim.dim0 13 | let dim1 = Dim.dim1 14 | let compare_dim = Dim.compare 15 | let compare_var = CofVar.compare 16 | end) 17 | end 18 | -------------------------------------------------------------------------------- /src/core/CofVar.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module Make (Symbol : Symbol.S) = 4 | struct 5 | 6 | type t = 7 | | Local of int 8 | | Axiom of Symbol.t 9 | 10 | let compare v0 v1 = 11 | match v0, v1 with 12 | | Local lvl0, Local lvl1 -> Int.compare lvl0 lvl1 13 | | Axiom sym0, Axiom sym1 -> Symbol.compare sym0 sym1 14 | | Local _, Axiom _ -> -1 15 | | Axiom _, Local _ -> 1 16 | 17 | let dump fmt = 18 | function 19 | | Local lvl -> Format.pp_print_int fmt lvl 20 | | Axiom sym -> Symbol.pp fmt sym 21 | end 22 | -------------------------------------------------------------------------------- /src/core/CofVar.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module Make : functor (Symbol : Symbol.S) -> sig 4 | type t = 5 | | Local of int 6 | | Axiom of Symbol.t 7 | 8 | val compare : t -> t -> int 9 | val dump : Format.formatter -> t -> unit 10 | end 11 | -------------------------------------------------------------------------------- /src/core/Conversion.mli: -------------------------------------------------------------------------------- 1 | (** The purpose of this module is to check whether two {i well-typed} objects are equal or not. The semantics are that all definitions are unfolded. *) 2 | 3 | open Basis 4 | open Monads 5 | 6 | open CodeUnit 7 | 8 | module D = Domain 9 | 10 | (** {1 Assertions} *) 11 | 12 | (** Assert that two {i well-formed} semantic types are equal. *) 13 | val equate_tp : D.tp -> D.tp -> unit conversion 14 | 15 | (** Assert that two {i well-typed} semantic elements of a {i well-formed} semantic type are equal. *) 16 | val equate_con : D.tp -> D.con -> D.con -> unit conversion 17 | 18 | (** {1 Error handling} *) 19 | 20 | module Error : 21 | sig 22 | type t 23 | val pp : t Pp.printer 24 | end 25 | 26 | exception ConversionError of Error.t 27 | -------------------------------------------------------------------------------- /src/core/Debug.ml: -------------------------------------------------------------------------------- 1 | let debug_enabled = ref false 2 | 3 | let debug_mode is_debug = 4 | debug_enabled := is_debug 5 | 6 | let is_debug_mode () = 7 | !debug_enabled 8 | 9 | let debug_formatter = 10 | let out buf pos len = 11 | if !debug_enabled then 12 | Stdlib.output_substring Stdlib.stderr buf pos len 13 | else 14 | () 15 | in 16 | let flush () = Stdlib.flush Stdlib.stderr in 17 | Format.make_formatter out flush 18 | 19 | let print (fmt : ('a, Format.formatter, unit) format) = 20 | Format.fprintf debug_formatter "[DEBUG] "; 21 | Format.fprintf debug_formatter fmt 22 | -------------------------------------------------------------------------------- /src/core/Debug.mli: -------------------------------------------------------------------------------- 1 | val debug_mode : bool -> unit 2 | val is_debug_mode : unit -> bool 3 | val print : ('a, Format.formatter, unit) format -> 'a 4 | -------------------------------------------------------------------------------- /src/core/Dim.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module Make (Symbol : Symbol.S) = 4 | struct 5 | module CofVar = CofVar.Make (Symbol) 6 | type t = 7 | | Dim0 8 | | Dim1 9 | | DimVar of CofVar.t 10 | | DimProbe of DimProbe.t 11 | 12 | let equal d1 d2 = 13 | match d1, d2 with 14 | | Dim0, Dim0 -> true 15 | | Dim1, Dim1 -> true 16 | | DimVar v1, DimVar v2 -> Int.equal (CofVar.compare v1 v2) 0 17 | | DimProbe p1, DimProbe p2 -> DimProbe.equal p1 p2 18 | | _ -> false 19 | 20 | let compare d1 d2 = 21 | match d1, d2 with 22 | | Dim0, Dim0 -> 0 23 | | Dim0, _ -> -1 24 | | Dim1, Dim0 -> 1 25 | | Dim1, Dim1 -> 0 26 | | Dim1, _ -> -1 27 | | DimVar _, (Dim0 | Dim1) -> 1 28 | | DimVar v1, DimVar v2 -> CofVar.compare v1 v2 29 | | DimVar _, _ -> -1 30 | | DimProbe _, (Dim0 | Dim1 | DimVar _) -> 1 31 | | DimProbe p1, DimProbe p2 -> DimProbe.compare p1 p2 32 | 33 | let dim0 = Dim0 34 | let dim1 = Dim1 35 | let var lvl = DimVar (CofVar.Local lvl) 36 | let axiom sym = DimVar (CofVar.Axiom sym) 37 | 38 | let dump fmt = 39 | function 40 | | Dim0 -> Format.fprintf fmt "dim0" 41 | | Dim1 -> Format.fprintf fmt "dim1" 42 | | DimVar v -> Format.fprintf fmt "dim#var[%a]" CofVar.dump v 43 | | DimProbe sym -> Format.fprintf fmt "dim#probe[%a]" DimProbe.pp sym 44 | end 45 | -------------------------------------------------------------------------------- /src/core/Dim.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module Make : functor (Symbol : Symbol.S) -> sig 4 | module CofVar := CofVar.Make(Symbol) 5 | type t = 6 | | Dim0 7 | (** The left endpoint of the abstract interval. *) 8 | 9 | | Dim1 10 | (** The right endpoint of the abstract interval. *) 11 | 12 | | DimVar of CofVar.t 13 | (** In [cooltt], most dimension variables are represented as natural numbers (pointers into the context). *) 14 | 15 | | DimProbe of DimProbe.t 16 | (** Some dimension variables must be generated to probe underneath a binder. Subject to substitution. *) 17 | 18 | val dim0 : t 19 | val dim1 : t 20 | val var : int -> t 21 | val axiom : Symbol.t -> t 22 | 23 | val equal : t -> t -> bool 24 | val compare : t -> t -> int 25 | 26 | val dump : t Pp.printer 27 | end 28 | -------------------------------------------------------------------------------- /src/core/DimProbe.ml: -------------------------------------------------------------------------------- 1 | module J = Ezjsonm 2 | 3 | type t = int 4 | 5 | let global = ref 0 6 | 7 | let compare p1 p2 = Int.compare p1 p2 8 | 9 | let equal p1 p2 = p1 = p2 10 | 11 | let pp fmt p = 12 | Format.fprintf fmt "#%i" p 13 | 14 | let show p = Int.to_string p 15 | 16 | let serialize (p : t) : J.value = 17 | `String (Int.to_string p) 18 | 19 | let deserialize : J.value -> t = 20 | function 21 | | `String p -> int_of_string p 22 | | j -> J.parse_error j "DimProbe.deserialize" 23 | 24 | 25 | 26 | let fresh () = 27 | let i = !global in 28 | global := i + 1; 29 | i 30 | -------------------------------------------------------------------------------- /src/core/DimProbe.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | include Symbol.S 4 | 5 | val fresh : unit -> t 6 | -------------------------------------------------------------------------------- /src/core/Domain.mli: -------------------------------------------------------------------------------- 1 | (** {1 Types} *) 2 | 3 | open Basis 4 | 5 | module Make : functor (Symbol : Symbol.S) -> sig 6 | 7 | include module type of DomainData.Make(Symbol) 8 | 9 | (** {1 Convenience constructors} *) 10 | 11 | val dim_to_con : dim -> con 12 | val cof_to_con : cof -> con 13 | val mk_var : tp -> int -> con 14 | val push : frm -> cut -> cut 15 | 16 | val const_tm_clo : con -> tm_clo 17 | val const_tp_clo : tp -> tp_clo 18 | 19 | val un_lam : con -> tm_clo 20 | val compose : con -> con -> con 21 | val apply_to : con -> tm_clo 22 | 23 | val fst : con 24 | val snd : con 25 | val proj : Ident.t -> int -> con 26 | val el_out : con 27 | 28 | val tm_abort : con 29 | val tp_abort : tp 30 | 31 | val tele_lbls : tele -> Ident.t list 32 | val kan_tele_lbls : kan_tele -> Ident.t list 33 | 34 | val empty_env : env 35 | val extend_env : env -> con -> env 36 | 37 | (** {1 Pretty-printers } 38 | 39 | These are only for debugging. *) 40 | 41 | val pp_dim : dim Pp.printer 42 | val pp_clo : tm_clo Pp.printer 43 | val pp_cof : cof Pp.printer 44 | val pp_tp : tp Pp.printer 45 | val pp_con : con Pp.printer 46 | val pp_cut : cut Pp.printer 47 | val pp_hd : hd Pp.printer 48 | val pp_frame : frm Pp.printer 49 | val pp_spine : frm list Pp.printer 50 | val pp_tele : tele Pp.printer 51 | val pp_kan_tele : kan_tele Pp.printer 52 | end 53 | -------------------------------------------------------------------------------- /src/core/DomainData.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Bwd 3 | 4 | module Make (Symbol : Symbol.S) = 5 | struct 6 | module S = Syntax.Make(Symbol) 7 | module CofVar = CofVar.Make(Symbol) 8 | module Dim = Dim.Make(Symbol) 9 | module Cof = CofBuilder.Make(Symbol) 10 | 11 | type dim = Dim.t 12 | type cof_var = CofVar.t 13 | type cof = Cof.t 14 | 15 | (** A type code whose head constructor is stable under dimension substitution. *) 16 | type 'a stable_code = 17 | [ `Pi of 'a * 'a 18 | (** Dependent product type *) 19 | 20 | | `Sg of 'a * 'a 21 | (** Dependent sum type *) 22 | 23 | | `Signature of kan_tele 24 | (** First-Class Record types *) 25 | 26 | | `Ext of int * 'a * [`Global of 'a] * 'a 27 | (** Extension type *) 28 | 29 | | `Nat 30 | (** Natural numbers type *) 31 | 32 | | `Circle 33 | (** The circle [S1]. *) 34 | 35 | | `Univ 36 | (** A code for the universe (antinomous for now). *) 37 | ] 38 | 39 | (** A type code which {i may or may not} be stable under dimension substitution. That is, 40 | type codes with these constructors may or may not remain in normal forms under substitution. *) 41 | and 'a unstable_code = 42 | [ `HCom of dim * dim * cof * 'a 43 | (** Formal composite types *) 44 | 45 | | `V of dim * 'a * 'a * 'a 46 | (** V types, for univalence *) 47 | ] 48 | 49 | and env = {tpenv : tp bwd; conenv: con bwd} 50 | 51 | (** A {i closure} combines a semantic environment with a syntactic object binding an additional variable. *) 52 | and 'a clo = Clo of 'a * env 53 | and tp_clo = S.tp clo 54 | and tm_clo = S.t clo 55 | and tele_clo = S.tele clo 56 | and kan_tele_clo = S.kan_tele clo 57 | 58 | (** Value constructors are governed by {!type:con}; we do not maintain in the datatype {i a priori} any invariant that these represent whnfs (weak head normal forms). Whether a value constructor is a whnf is contingent on the ambient local state, such as the cofibration theory. *) 59 | and con = 60 | | Lam of Ident.t * tm_clo 61 | 62 | | BindSym of DimProbe.t * con 63 | (** A nominal binder of a dimension; these are used during the execution of coercion, which must probe a line of type codes with a fresh dimension. *) 64 | 65 | | LetSym of dim * DimProbe.t * con 66 | (** An explicit substitution of a dimension for a symbol. *) 67 | 68 | | Cut of {tp : tp; cut : cut} 69 | (** Our notion of {i neutral} value, a type annotated {!type:cut}. *) 70 | 71 | | Zero 72 | | Suc of con 73 | | Base 74 | | Loop of dim 75 | | Pair of con * con 76 | | Struct of fields 77 | | SubIn of con 78 | 79 | | ElIn of con 80 | (** The introduction form for the extension of a {i stable} type code only (see {!constructor:ElStable} and {!constructor:ElUnstable}). *) 81 | 82 | | Dim0 83 | | Dim1 84 | | DimProbe of DimProbe.t 85 | 86 | | Cof of (con, con) Kado.Syntax.endo 87 | (** A mixin of the language of cofibrations (as described in {!module:CofBuilder}), with dimensions and indeterminates in {!type:con}. *) 88 | 89 | | Prf 90 | 91 | | FHCom of [`Nat | `Circle] * dim * dim * cof * con 92 | 93 | | StableCode of con stable_code 94 | | UnstableCode of con unstable_code 95 | 96 | | Box of dim * dim * cof * con * con 97 | | VIn of dim * con * con * con 98 | 99 | | Split of (cof * tm_clo) list 100 | 101 | and tp = 102 | | Sub of tp * cof * tm_clo 103 | | Univ 104 | | ElCut of cut 105 | | ElStable of con stable_code 106 | | ElUnstable of con unstable_code 107 | | TpDim 108 | | TpCof 109 | | TpPrf of cof 110 | | TpSplit of (cof * tp_clo) list 111 | | Pi of tp * Ident.t * tp_clo 112 | | Sg of tp * Ident.t * tp_clo 113 | | Signature of tele 114 | | Nat 115 | | Circle 116 | 117 | and tele = 118 | | Cell of Ident.t * tp * S.tele clo 119 | | Empty 120 | 121 | and kan_tele = 122 | | KCell of Ident.t * con * S.kan_tele clo 123 | | KEmpty 124 | 125 | and fields = 126 | | Fields of (Ident.t * con) list 127 | 128 | (** A head is a variable (e.g. {!constructor:Global}, {!constructor:Var}), or it is some kind of unstable elimination form ({!constructor:Coe}, {!constructor:UnstableCut}). The geometry of {!type:cut}, {!type:hd}, {!type:unstable_frm} enables a very direct way to re-reduce a complex cut to whnf by following the unstable nodes to the root. *) 129 | and hd = 130 | | Global of Symbol.t 131 | (** A top-level declaration*) 132 | 133 | | Var of int 134 | (** De Bruijn level *) 135 | 136 | | Coe of con * dim * dim * con 137 | | UnstableCut of cut * unstable_frm 138 | 139 | (** A {!type:cut} is a value that is blocked on the computation of a {!type:hd} ("head"); when the head is computed, the list of stack frames ({!type:frm}) carried by the cut will be enacted. *) 140 | and cut = hd * frm list 141 | 142 | (** A {i stable} frame is a {i dimension substitution-stable} elimination form with a hole in place of its principal argument. Unstable elimination forms are governed by {!type:hd} to ease the "re-reduction" of a value to whnf under a stronger cofibration theory. *) 143 | and frm = 144 | | KAp of tp * con 145 | | KFst 146 | | KSnd 147 | | KProj of Ident.t * int 148 | | KNatElim of con * con * con 149 | | KCircleElim of con * con * con 150 | 151 | | KElOut 152 | (** The elimination form for the extension of a {i stable} type code only (see {!constructor:ElStable}). *) 153 | 154 | 155 | (** An {i unstable} frame is a {i dimension substitution-unstable} elimination form with a hole in place of its principal argument. *) 156 | and unstable_frm = 157 | | KHCom of dim * dim * cof * con 158 | | KCap of dim * dim * cof * con 159 | | KVProj of dim * con * con * con 160 | | KSubOut of cof * tm_clo 161 | 162 | module CofBuilder = Kado.Builder.Endo.Make 163 | (struct 164 | type dim = con 165 | type cof = con 166 | let dim0 = Dim0 167 | let dim1 = Dim1 168 | let equal_dim = (=) 169 | let cof phi = Cof phi 170 | let uncof = function Cof phi -> Some phi | _ -> None 171 | end) 172 | end 173 | -------------------------------------------------------------------------------- /src/core/Ident.ml: -------------------------------------------------------------------------------- 1 | type t = [`Anon | `User of string list | `Machine of string | `Unfolder of t | `Blocked of t list] 2 | type 'a some = 'a constraint 'a = [< t ] 3 | type user = [ `User of string list ] 4 | 5 | module J = Ezjsonm 6 | 7 | 8 | let user parts = `User parts 9 | let machine str = `Machine str 10 | let unfolder i = `Unfolder i 11 | let anon = `Anon 12 | let blocked ts = `Blocked ts 13 | 14 | let qual_to_string = 15 | function 16 | | [] -> "∷" 17 | | parts -> String.concat "∷" parts 18 | 19 | let pp_user fmt = 20 | function 21 | | `User parts -> Uuseg_string.pp_utf_8 fmt (qual_to_string parts) 22 | 23 | let rec pp fmt = 24 | function 25 | | `Anon -> Format.fprintf fmt "" 26 | | `User _ as u -> pp_user fmt u 27 | | `Machine str -> Uuseg_string.pp_utf_8 fmt str 28 | | `Unfolder t -> Format.fprintf fmt "unfold[%a]" pp t 29 | | `Blocked ts -> 30 | let comma fmt () = Format.fprintf fmt "," in 31 | Format.fprintf fmt "blocked[%a]" (Format.pp_print_list ~pp_sep:comma pp) ts 32 | 33 | let to_string i = 34 | let _ = Format.flush_str_formatter () in 35 | Format.fprintf Format.str_formatter "%a" pp i ; 36 | Format.flush_str_formatter () 37 | 38 | let to_string_opt : t -> string option = 39 | function 40 | | `Anon -> None 41 | | i -> Some (to_string i) 42 | 43 | let user_to_string_opt = 44 | function 45 | | `User [] -> None 46 | | `User parts -> Some (String.concat "∷" parts) 47 | 48 | let json_of_user : [`User of string list ] -> [> `A of J.value list ] = 49 | function 50 | | `User path -> `A (List.map J.string path) 51 | 52 | let json_to_user : J.value -> [> `User of string list] = 53 | function 54 | | `A path -> `User (List.map J.get_string path) 55 | | j -> J.parse_error j "json_to_path" 56 | 57 | 58 | let rec json_of_ident : t -> J.value = 59 | function 60 | | `Anon -> `String "anon" 61 | | `User _ as u -> `O [("user", json_of_user u)] 62 | | `Machine str -> `O [("machine", `String str)] 63 | | `Unfolder i -> `O [("unfolder", json_of_ident i)] 64 | | `Blocked ts -> `O [("blocked", J.list json_of_ident ts)] 65 | 66 | let rec json_to_ident : J.value -> t = 67 | function 68 | | `String "anon" -> `Anon 69 | | `O [("user", parts)] -> json_to_user parts 70 | | `O [("machine", `String str)] -> machine str 71 | | `O [("unfolder", i)] -> unfolder @@ json_to_ident i 72 | | `O [("blocked", ts)] -> blocked @@ J.get_list json_to_ident ts 73 | | j -> J.parse_error j "json_to_ident" 74 | 75 | let rec equal i0 i1 = 76 | match (i0, i1) with 77 | | `Anon, `Anon -> true 78 | | `User p0, `User p1 -> List.equal String.equal p0 p1 79 | | `Machine s0, `Machine s1 -> String.equal s0 s1 80 | | `Unfolder u0, `Unfolder u1 -> equal u0 u1 81 | | `Blocked b0, `Blocked b1 -> List.equal equal b0 b1 82 | | _, _ -> false 83 | -------------------------------------------------------------------------------- /src/core/Ident.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module J = Ezjsonm 4 | 5 | type t = [`Anon | `User of string list | `Machine of string | `Unfolder of t | `Blocked of t list] 6 | 7 | (* Jon says: I do not like this type! *) 8 | type 'a some = 'a constraint 'a = [< t ] 9 | type user = [ `User of string list ] 10 | 11 | val user : string list -> t 12 | val machine : string -> t 13 | val unfolder : t -> t 14 | val blocked : t list -> t 15 | val anon : t 16 | 17 | val pp : t Pp.printer 18 | val pp_user : user Pp.printer 19 | val to_string : t -> string 20 | val to_string_opt : t -> string option 21 | 22 | val user_to_string_opt : user -> string option 23 | 24 | val json_of_ident : t -> J.value 25 | val json_to_ident : J.value -> t 26 | val json_of_user : [`User of string list ] -> [> `A of J.value list ] 27 | val json_to_user : J.value -> [`User of string list] 28 | 29 | val equal : t -> t -> bool 30 | -------------------------------------------------------------------------------- /src/core/Log.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | type level = [`Info | `Error | `Warn] 4 | 5 | let pp_lvl fmt = 6 | function 7 | | `Info -> 8 | Format.fprintf fmt "Info" 9 | | `Error -> 10 | Format.fprintf fmt "Error" 11 | | `Warn -> 12 | Format.fprintf fmt "Warn" 13 | 14 | (* 15 | We have 2 types of messages. Errors from the driver load_file and runtime messages 16 | which may be output or errors. Messages may or may not have a span. 17 | 18 | *) 19 | let pp_runtime_message ~loc ~lvl pp data = 20 | match loc with 21 | | None -> 22 | Format.printf "@[[%a]:@, @[%a@]@]@.@." 23 | pp_lvl lvl 24 | pp data 25 | | Some span -> 26 | Format.printf "@[%a [%a]:@, @[%a@]@]@.@." 27 | LexingUtil.pp_span span 28 | pp_lvl lvl 29 | pp data 30 | 31 | 32 | let pp_error_message ~loc ~lvl pp data = 33 | match loc with 34 | | None -> 35 | Format.printf "@[[%a]:@, @[%a@]@]@.@." 36 | pp_lvl lvl 37 | pp data 38 | | Some span -> 39 | Format.printf "@[%a [%a]:@, @[%a@]@]@.@." 40 | LexingUtil.pp_span span 41 | pp_lvl lvl 42 | pp data 43 | -------------------------------------------------------------------------------- /src/core/Log.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | type level = [`Info | `Error | `Warn] 4 | 5 | (* We are always using stdout (not stderr) to prevent interleaving *) 6 | val pp_error_message 7 | : loc:LexingUtil.span option 8 | -> lvl:level 9 | -> 'a Pp.printer 10 | -> 'a 11 | -> unit 12 | 13 | val pp_runtime_message 14 | : loc:LexingUtil.span option 15 | -> lvl:level 16 | -> 'a Pp.printer 17 | -> 'a 18 | -> unit 19 | -------------------------------------------------------------------------------- /src/core/Monads.mli: -------------------------------------------------------------------------------- 1 | (** All the monads in this file keep track of a cofibration theory. *) 2 | open Basis 3 | 4 | open CodeUnit 5 | 6 | module D := Domain 7 | module S := Syntax 8 | module St := RefineState 9 | 10 | 11 | type 'a compute 12 | type 'a evaluate 13 | type 'a conversion 14 | type 'a quote 15 | 16 | (** The "computation" monad; contains enough state to run computations in the semantic domain, 17 | does not contain a variable environment or anything that would be needed for evaluation. *) 18 | module CmpM : sig 19 | include Monad.MonadReaderResult 20 | with type 'a m = 'a compute 21 | 22 | val read_global : RefineState.t m 23 | 24 | val lift_ev : D.env -> 'a evaluate -> 'a m 25 | val test_sequent : D.cof list -> D.cof -> bool m 26 | val simplify_cof : D.cof -> D.cof m 27 | val forall_cof : D.dim * D.cof -> D.cof m 28 | 29 | val restore_cof_thy : CofThy.Disj.t -> 'a m -> 'a m 30 | 31 | val abort_if_inconsistent : 'a m -> 'a m -> 'a m 32 | end 33 | 34 | (** The "evaluation" monad; like the computation monad but keeps a variable environment. *) 35 | module EvM : sig 36 | include Monad.MonadReaderResult 37 | with type 'a m = 'a evaluate 38 | 39 | val lift_cmp : 'a compute -> 'a m 40 | 41 | val read_global : RefineState.t m 42 | val read_local : D.env m 43 | 44 | val append : D.con list -> 'a m -> 'a m 45 | val drop_con : 'a m -> 'a m 46 | val drop_all_cons : 'a m -> 'a m 47 | 48 | val abort_if_inconsistent : 'a m -> 'a m -> 'a m 49 | end 50 | 51 | 52 | (** The conversion environment keeps track of De Bruijn indices for use in conversion checking. *) 53 | module ConvM : sig 54 | include Monad.MonadReaderResult 55 | with type 'a m = 'a conversion 56 | 57 | val lift_cmp : 'a compute -> 'a m 58 | 59 | val restrict_ : D.cof list -> unit m -> unit m 60 | val bind_var_ : D.tp -> (D.con -> unit m) -> unit m 61 | 62 | val globally : 'a m -> 'a m 63 | 64 | val abort_if_inconsistent : 'a m -> 'a m -> 'a m 65 | end 66 | 67 | (** The quotation environment keeps track of De Bruijn indices for quotation. *) 68 | module QuM : sig 69 | include Monad.MonadReaderResult 70 | with type 'a m = 'a quote 71 | 72 | val lift_cmp : 'a compute -> 'a m 73 | 74 | val should_normalize : bool m 75 | val with_normalization : bool -> 'a m -> 'a m 76 | 77 | val read_global : RefineState.t m 78 | val read_local : int m 79 | 80 | val globally : 'a m -> 'a m 81 | 82 | val binder : int -> 'a m -> 'a m 83 | val bind_var : D.tp -> (D.con -> 'a m) -> 'a m 84 | 85 | val abort_if_inconsistent : 'a m -> 'a m -> 'a m 86 | end 87 | 88 | (** The elaboration monad is the "maximal" monad that can run code from any of the other monads. *) 89 | module RefineM : sig 90 | include Monad.MonadReaderStateResult 91 | with type global := St.t 92 | with type local := RefineEnv.t 93 | 94 | val lift_qu : 'a quote -> 'a m 95 | val lift_conv_ : unit conversion -> unit m 96 | 97 | val lift_ev : 'a evaluate -> 'a m 98 | val lift_cmp : 'a compute -> 'a m 99 | 100 | val restrict : D.cof list -> 'a m -> 'a m 101 | 102 | val globally : 'a m -> 'a m 103 | val emit : ?lvl:Log.level -> LexingUtil.span option -> (Format.formatter -> 'a -> unit) -> 'a -> unit m 104 | 105 | val abort_if_inconsistent : 'a m -> 'a m -> 'a m 106 | end 107 | -------------------------------------------------------------------------------- /src/core/Namespace.ml: -------------------------------------------------------------------------------- 1 | open Bwd 2 | open Yuujinchou 3 | 4 | type path = Yuujinchou.Trie.path 5 | 6 | module Param = struct 7 | type data = CodeUnit.Global.t 8 | type tag = unit 9 | type hook = [`Print of string option] 10 | type context = | 11 | end 12 | module M = Modifier.Make(Param) 13 | 14 | type t = CodeUnit.Global.t Trie.Untagged.t 15 | type pattern = [`Print of string option ] Yuujinchou.Language.t 16 | 17 | exception BindingNotFound of path 18 | exception Shadowing of path 19 | type ('a, 'error) result = ('a, [> `BindingNotFound of path | `Shadowing of path ] as 'error) Stdlib.result 20 | 21 | let empty = Trie.empty 22 | 23 | let prefix = Trie.prefix 24 | 25 | let merge ~shadowing path _ x = 26 | if shadowing then x else raise @@ Shadowing (Bwd.to_list path) 27 | 28 | let transform ~shadowing ~pp pat ns = 29 | let not_found _ path = raise @@ BindingNotFound (Bwd.to_list path) in 30 | let hook _ path (`Print lbl) t = 31 | let lbl = Option.fold ~none:"?" ~some:(fun lbl -> "?" ^ lbl) lbl in 32 | Format.printf "@[Emitted namespace under %a@,%s = @[{ " 33 | Ident.pp (`User (Bwd.to_list path)) lbl; 34 | let first = ref true in (* XXX NON-functional programming! *) 35 | Trie.Untagged.iter (fun path sym -> 36 | if not !first then Format.printf "@,; "; 37 | first := false; (* XXX there are 100 ways to avoid references *) 38 | Format.printf "@[%a =>@ %a@]" Ident.pp (`User (Bwd.to_list path)) pp sym) t; 39 | Format.printf "@ }@]@]@.@."; 40 | t 41 | in 42 | try Result.ok @@ M.run ~not_found ~shadow:(fun _ctx -> merge ~shadowing) ~hook @@ fun () -> M.modify pat ns with 43 | | BindingNotFound p -> Result.error @@ `BindingNotFound p 44 | | Shadowing p -> Result.error @@ `Shadowing p 45 | 46 | let union ~shadowing ns1 ns2 = 47 | try Result.ok @@ Trie.Untagged.union (merge ~shadowing) ns1 ns2 with 48 | | Shadowing p -> Result.error @@ `Shadowing p 49 | 50 | let merge1 ~shadowing path x old_x = 51 | if Option.is_none old_x || shadowing 52 | then Some x 53 | else raise @@ Shadowing (Bwd.to_list path) 54 | 55 | let add ~shadowing ident sym ns = 56 | match ident with 57 | | `User path -> 58 | begin 59 | try Result.ok @@ Trie.Untagged.update_singleton path (merge1 ~shadowing (Bwd.of_list path) sym) ns with 60 | | Shadowing p -> Result.error @@ `Shadowing p 61 | end 62 | | _ -> Result.ok ns 63 | 64 | let find (ident : Ident.t) ns = 65 | match ident with 66 | | `User path -> Trie.Untagged.find_singleton path ns 67 | | _ -> None 68 | -------------------------------------------------------------------------------- /src/core/Namespace.mli: -------------------------------------------------------------------------------- 1 | type path = Yuujinchou.Trie.path 2 | 3 | type t 4 | type pattern = [`Print of string option ] Yuujinchou.Language.t 5 | type ('a, 'error) result = ('a, [> `BindingNotFound of path | `Shadowing of path ] as 'error) Stdlib.result 6 | 7 | val empty : t 8 | 9 | val prefix : path -> t -> t 10 | 11 | val transform : shadowing:bool 12 | -> pp:(Format.formatter -> CodeUnit.Global.t -> unit) 13 | -> pattern 14 | -> t 15 | -> (t, 'error) result 16 | 17 | val union : shadowing:bool -> t -> t -> (t, 'error) result 18 | 19 | val add : shadowing:bool -> Ident.t -> CodeUnit.Global.t -> t -> (t, 'error) result 20 | 21 | val find : Ident.t -> t -> CodeUnit.Global.t option 22 | -------------------------------------------------------------------------------- /src/core/Quote.mli: -------------------------------------------------------------------------------- 1 | (** The purpose of this module is to transform semantic objects into syntactic objects as efficiently as possible. *) 2 | open Monads 3 | open CodeUnit 4 | 5 | module D := Domain 6 | module S := Syntax 7 | 8 | val quote_con : D.tp -> D.con -> S.t quote 9 | val quote_tp : D.tp -> S.tp quote 10 | val quote_tele : D.tele -> S.tele quote 11 | val quote_kan_tele : D.kan_tele -> S.kan_tele quote 12 | val quote_cut : D.cut -> S.t quote 13 | val quote_cof : D.cof -> S.t quote 14 | val quote_dim : D.dim -> S.t quote 15 | -------------------------------------------------------------------------------- /src/core/RefineEnv.ml: -------------------------------------------------------------------------------- 1 | open ContainersLabels 2 | open Basis 3 | open Bwd 4 | open Bwd.Infix 5 | 6 | open CodeUnit 7 | 8 | module StringMap = Map.Make (String) 9 | module D = Domain 10 | module S = Syntax 11 | 12 | 13 | module Cell = 14 | struct 15 | type 'a t = 16 | {contents : 'a; 17 | ident : Ident.t} 18 | 19 | let make nm c = {contents = c; ident = nm} 20 | let ident cell = cell.ident 21 | let contents cell = cell.contents 22 | end 23 | 24 | type cell = (D.tp * D.con) Cell.t 25 | 26 | type t = 27 | { 28 | (* local assumptions *) 29 | locals : cell bwd; 30 | cof_thy : CofThy.Disj.t; 31 | pp : Pp.env; 32 | 33 | (* location *) 34 | location : LexingUtil.span option; 35 | } 36 | 37 | let init = 38 | { locals = Emp; 39 | cof_thy = CofThy.Disj.empty; 40 | pp = Pp.Env.emp; 41 | location = None } 42 | 43 | let globally env = 44 | { locals = Emp; 45 | cof_thy = CofThy.Disj.empty; 46 | pp = Pp.Env.emp; 47 | location = env.location } 48 | 49 | 50 | (* local assumptions *) 51 | let locals env = env.locals 52 | let size env = BwdLabels.length env.locals 53 | let get_local_tp ix env = 54 | let cell = BwdLabels.nth env.locals ix in 55 | let tp, _ = Cell.contents cell in 56 | tp 57 | let get_local ix env = 58 | let cell = BwdLabels.nth env.locals ix in 59 | let _, con = Cell.contents cell in 60 | con 61 | let resolve_local (ident : Ident.t) env = 62 | let exception E in 63 | let rec go i = function 64 | | Emp -> raise E 65 | | Snoc (xs, cell) -> 66 | begin 67 | match ident, Cell.ident cell with 68 | | `User parts_x, `User parts_y when List.equal String.equal parts_x parts_y -> i 69 | | _ -> go (i + 1) xs 70 | end 71 | in 72 | match go 0 @@ env.locals with 73 | | i -> Some i 74 | | exception E -> None 75 | let rec dump_locals fmt : (D.tp * D.con) Cell.t list -> unit = 76 | function 77 | | [] -> () 78 | | (cell :: cells) -> 79 | Format.fprintf fmt "%a : %a := @[%a@]@;%a" Ident.pp cell.ident D.pp_tp (fst cell.contents) D.pp_con (snd cell.contents) dump_locals cells 80 | 81 | (* cofibrations and others *) 82 | let local_cof_thy env = env.cof_thy 83 | let pp_env env = env.pp 84 | let sem_env (env : t) : D.env = 85 | {tpenv = Emp; 86 | conenv = 87 | BwdLabels.map env.locals 88 | ~f:(fun cell -> 89 | let _, con = Cell.contents cell in 90 | con)} 91 | let restrict phis env = 92 | {env with 93 | cof_thy = CofThy.Disj.assume env.cof_thy phis} 94 | let append_con ident con tp env = 95 | {env with 96 | pp = snd @@ Pp.Env.bind env.pp (Ident.to_string_opt ident); 97 | locals = env.locals <: Cell.make ident (tp, con); 98 | cof_thy = 99 | match tp with 100 | | D.TpPrf phi -> CofThy.Disj.assume env.cof_thy [phi] 101 | | _ -> env.cof_thy} 102 | 103 | (* locations *) 104 | let location env = env.location 105 | let set_location loc env = 106 | match loc with 107 | | Some _ -> {env with location = loc} 108 | | _ -> env 109 | 110 | let dump fmt : t -> unit = 111 | fun env -> 112 | Format.fprintf fmt "Locals: @[%a@]" dump_locals (BwdLabels.to_list env.locals) 113 | -------------------------------------------------------------------------------- /src/core/RefineEnv.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Bwd 3 | 4 | open CodeUnit 5 | 6 | module D := Domain 7 | 8 | module Cell : sig 9 | type 'a t 10 | 11 | val contents : 'a t -> 'a 12 | val ident : 'a t -> Ident.t 13 | end 14 | 15 | type cell = (D.tp * D.con) Cell.t 16 | 17 | type t 18 | val init : t 19 | val globally : t -> t 20 | 21 | val locals : t -> cell bwd 22 | val size : t -> int 23 | val get_local_tp : int -> t -> D.tp 24 | val get_local : int -> t -> D.con 25 | val resolve_local : Ident.t -> t -> int option 26 | 27 | val local_cof_thy : t -> CofThy.Disj.t 28 | val pp_env : t -> Pp.env 29 | val sem_env : t -> D.env 30 | val restrict : CofThy.cof list -> t -> t 31 | val append_con : Ident.t -> D.con -> D.tp -> t -> t 32 | 33 | val location : t -> LexingUtil.span option 34 | val set_location : LexingUtil.span option -> t -> t 35 | 36 | val dump : t Pp.printer 37 | -------------------------------------------------------------------------------- /src/core/RefineError.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open CodeUnit 3 | 4 | module D = Domain 5 | module S = Syntax 6 | 7 | include RefineErrorData.Data 8 | 9 | module Fmt = Format 10 | 11 | let pp_connective fmt = 12 | function 13 | | `Cof -> 14 | Format.fprintf fmt "cof" 15 | | `Dim -> 16 | Format.fprintf fmt "dim" 17 | | `Pi -> 18 | Format.fprintf fmt "pi" 19 | | `Sg -> 20 | Format.fprintf fmt "sg" 21 | | `Signature -> 22 | Format.fprintf fmt "sig" 23 | | `Univ -> 24 | Format.fprintf fmt "univ" 25 | | `Nat -> 26 | Format.fprintf fmt "nat" 27 | | `Circle -> 28 | Format.fprintf fmt "circle" 29 | | `Sub -> 30 | Format.fprintf fmt "sub" 31 | | `Prf -> 32 | Format.fprintf fmt "prf" 33 | | `El -> 34 | Format.fprintf fmt "el" 35 | | `ElV -> 36 | Format.fprintf fmt "V" 37 | | `ElHCom -> 38 | Format.fprintf fmt "hcom" 39 | | `ElExt -> 40 | Format.fprintf fmt "ext" 41 | 42 | let pp fmt = 43 | function 44 | | UnboundVariable id -> 45 | Fmt.fprintf fmt "Unbound variable %a" Ident.pp id 46 | | ExpectedEqual (ppenv, tp, tm0, tm1, _) -> 47 | Fmt.fprintf fmt 48 | "Expected @[%a =@;%a@;: %a@]" 49 | (S.pp ppenv) tm0 50 | (S.pp ppenv) tm1 51 | (S.pp_tp ppenv) tp 52 | | ExpectedEqualTypes (ppenv, tp0, tp1, _) -> 53 | Fmt.fprintf fmt 54 | "Expected @[%a =@;%a@]" 55 | (S.pp_tp ppenv) tp0 56 | (S.pp_tp ppenv) tp1 57 | | ExpectedConnective (conn, ppenv, tp) -> 58 | Fmt.fprintf fmt 59 | "Head connective mismatch, expected %a but got %a" 60 | pp_connective conn 61 | (S.pp_tp ppenv) tp 62 | | ExpectedDimensionLiteral n -> 63 | Fmt.fprintf fmt 64 | "Expected dimension literal 0 or 1, but got %i" n 65 | | ExpectedTrue (ppenv, cof) -> 66 | Fmt.fprintf fmt 67 | "Expected true cofibration: %a" 68 | (S.pp ppenv) cof 69 | | ExpectedField (ppenv, sign, tm, lbl) -> 70 | Fmt.fprintf fmt "Expected (%a : sig %a) to have field %a" (S.pp ppenv) tm (S.pp_tele ppenv) sign Ident.pp lbl 71 | | FieldNameMismatches (expected, actual) -> 72 | Fmt.fprintf fmt "Field names mismatch, expected [%a] but got [%a]" (Pp.pp_sep_list Ident.pp_user) expected (Pp.pp_sep_list Ident.pp_user) actual 73 | | VirtualType -> 74 | Fmt.fprintf fmt "Virtual type (dim, cof, etc.) cannot appear in this position" 75 | | HoleNotPermitted (ppenv, tp) -> 76 | Fmt.fprintf fmt 77 | "Holes of type %a are not permitted" 78 | (S.pp_tp ppenv) tp 79 | | BindingNotFound (`User []) -> 80 | Fmt.fprintf fmt 81 | "No bindings" 82 | | BindingNotFound id -> 83 | Fmt.fprintf fmt 84 | "No bindings with the prefix %a" Ident.pp_user id 85 | | UnexpectedShadowing id -> 86 | Fmt.fprintf fmt 87 | "Unexpected shadowing of %a" Ident.pp_user id 88 | | CyclicImport id -> 89 | Fmt.fprintf fmt 90 | "Cyclic import of %a" CodeUnitID.pp id 91 | | RefineErrorData.Data.ErrorsInSection -> (* qualified names to check spellings *) 92 | Fmt.fprintf fmt 93 | "Unexpected errors in sections" 94 | | UnsolvedHoles 1 -> 95 | Fmt.fprintf fmt 96 | "There is 1 unsolved hole" 97 | | UnsolvedHoles n -> 98 | Fmt.fprintf fmt 99 | "There are %i unsolved holes" n 100 | | ExpectedSignature (ppenv, tm) -> 101 | Fmt.fprintf fmt 102 | "Expected signature but got %a" (S.pp_tp ppenv) tm 103 | | ExpectedKanSignature (ppenv, tm) -> 104 | Fmt.fprintf fmt 105 | "Expected kan signature but got %a" (S.pp ppenv) tm 106 | | ExpectedStructure (ppenv, tm) -> 107 | Fmt.fprintf fmt 108 | "Expected structure but got %a" (S.pp ppenv) tm 109 | 110 | 111 | 112 | 113 | exception RefineError of t * LexingUtil.span option 114 | 115 | let _ = 116 | PpExn.install_printer @@ fun fmt -> 117 | function 118 | | RefineError (err, _loc) -> 119 | pp fmt err 120 | | _ -> 121 | raise PpExn.Unrecognized 122 | -------------------------------------------------------------------------------- /src/core/RefineError.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | include module type of RefineErrorData.Data 4 | val pp : Format.formatter -> t -> unit 5 | 6 | exception RefineError of t * LexingUtil.span option 7 | -------------------------------------------------------------------------------- /src/core/RefineErrorData.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | open CodeUnit 4 | 5 | module S = Syntax 6 | module D = Domain 7 | 8 | module Data = 9 | struct 10 | type connective = 11 | [ `Pi 12 | | `Sg 13 | | `Signature 14 | | `Nat 15 | | `Circle 16 | | `Univ 17 | | `Dim 18 | | `Cof 19 | | `Sub 20 | | `Prf 21 | | `El 22 | | `ElV 23 | | `ElHCom 24 | | `ElExt 25 | ] 26 | 27 | type t = 28 | | UnboundVariable of Ident.t 29 | | FieldNameMismatches of Ident.user list * Ident.user list 30 | | ExpectedField of Pp.env * S.tele * S.t * Ident.t 31 | | ExpectedEqual of Pp.env * S.tp * S.t * S.t * Conversion.Error.t 32 | | ExpectedEqualTypes of Pp.env * S.tp * S.tp * Conversion.Error.t 33 | | ExpectedConnective of connective * Pp.env * S.tp 34 | | ExpectedDimensionLiteral of int 35 | | ExpectedTrue of Pp.env * S.t 36 | | VirtualType 37 | | HoleNotPermitted of Pp.env * S.tp 38 | | BindingNotFound of Ident.user 39 | | UnexpectedShadowing of Ident.user 40 | | CyclicImport of CodeUnitID.t 41 | | ErrorsInSection 42 | | UnsolvedHoles of int 43 | | ExpectedSignature of Pp.env * S.tp 44 | | ExpectedKanSignature of Pp.env * S.t 45 | | ExpectedStructure of Pp.env * S.t 46 | end 47 | -------------------------------------------------------------------------------- /src/core/RefineMonad.mli: -------------------------------------------------------------------------------- 1 | open CodeUnit 2 | module D = Domain 3 | module S = Syntax 4 | module Env = RefineEnv 5 | 6 | open Basis 7 | open Bwd 8 | 9 | include module type of Monads.RefineM 10 | 11 | val refine_err : RefineError.t -> 'a m 12 | 13 | val update_span : LexingUtil.span option -> 'a m -> 'a m 14 | val abstract : Ident.t -> D.tp -> (D.con -> 'a m) -> 'a m 15 | 16 | val add_global : unfolder:Global.t option -> shadowing:bool -> Ident.t -> D.tp -> Global.t m 17 | val get_global : Global.t -> D.tp m 18 | val resolve : Ident.t -> [`Local of int | `Global of Global.t | `Unbound] m 19 | val resolve_unfolder_syms : Ident.t list -> Global.t list m 20 | 21 | val add_hole : (D.tp * D.cof * D.tm_clo) -> unit m 22 | val get_holes : (D.tp * D.cof * D.tm_clo) list m 23 | 24 | val get_local_tp : int -> D.tp m 25 | val get_local : int -> D.con m 26 | 27 | val get_lib : Bantorra.Manager.library m 28 | val with_unit : Bantorra.Manager.library -> id -> 'a m -> 'a m 29 | 30 | val import : shadowing:bool -> Namespace.pattern -> id -> unit m 31 | val loading_status : CodeUnitID.t -> [ `Loaded | `Loading | `Unloaded ] m 32 | 33 | val view : shadowing:bool -> Namespace.pattern -> unit m 34 | val export : shadowing:bool -> Namespace.pattern -> unit m 35 | val repack : shadowing:bool -> Namespace.pattern -> unit m 36 | val with_section : shadowing:bool -> prefix:Namespace.path option -> 'a m -> 'a m 37 | 38 | val eval : S.t -> D.con m 39 | val eval_tp : S.tp -> D.tp m 40 | 41 | val quote_con : D.tp -> D.con -> S.t m 42 | val quote_tp : D.tp -> S.tp m 43 | val quote_cut : D.cut -> S.t m 44 | val quote_cof : D.cof -> S.t m 45 | val quote_dim : D.dim -> S.t m 46 | 47 | val equate_tp : D.tp -> D.tp -> unit m 48 | val equate : D.tp -> D.con -> D.con -> unit m 49 | 50 | val with_pp : (Pp.env -> 'a m) -> 'a m 51 | 52 | val expected_connective : RefineError.connective -> D.tp -> 'a m 53 | val expected_field : D.tele -> S.t -> Ident.t -> 'a m 54 | val field_names_mismatch : expected:Ident.user list -> actual:Ident.user list -> 'a m 55 | 56 | (* [HACK: Hazel; 2022-06-24] FKA GlobalUtil, maybe this shouldn't go here *) 57 | val destruct_cells : Env.cell list -> (Ident.t * S.tp) list m 58 | val multi_pi : Env.cell list -> S.tp m -> S.tp m 59 | val multi_ap : Env.cell bwd -> D.cut -> D.cut 60 | 61 | val print_state : string option -> (Ident.t * S.tp) list -> S.tp -> unit m 62 | val print_boundary : S.t -> D.tp -> D.cof -> D.tm_clo -> unit m 63 | val boundary_satisfied : S.t -> D.tp -> D.cof -> D.tm_clo -> [> `BdrySat | `BdryUnsat ] m 64 | -------------------------------------------------------------------------------- /src/core/RefineState.ml: -------------------------------------------------------------------------------- 1 | open ContainersLabels 2 | open CodeUnit 3 | 4 | module IDMap = Map.Make (CodeUnitID) 5 | module D = Domain 6 | 7 | type t = 8 | { 9 | (** current library manager *) 10 | lib : Bantorra.Manager.library; 11 | (** current unit ID *) 12 | unit_id : CodeUnitID.t; 13 | (** current nested scopes *) 14 | scopes : Scopes.t; 15 | (** numbers of holes in the current unit *) 16 | holes : (D.tp * D.cof * D.tm_clo) list; 17 | 18 | (** global cofibration theory *) 19 | cof_thy : CofThy.Disj.t; 20 | 21 | (** all known units (including the ones that are being processed), which keep the data associated with global symbols *) 22 | units : CodeUnit.t IDMap.t; 23 | (** all global cofibrations and namespaces exported by processed units (not including the ones in proccessing) *) 24 | exports : (Namespace.t * CofThy.Disj.t) IDMap.t; 25 | } 26 | 27 | let init lib = 28 | let unit_id = CodeUnitID.top_level in 29 | { lib; 30 | unit_id; 31 | scopes = Scopes.init Scope.empty; 32 | holes = []; 33 | cof_thy = CofThy.Disj.empty; 34 | units = IDMap.singleton unit_id (CodeUnit.create unit_id); 35 | exports = IDMap.empty; 36 | } 37 | 38 | (* lib *) 39 | let get_lib st = st.lib 40 | 41 | (* holes *) 42 | let get_holes st = st.holes 43 | let add_hole hole st = {st with holes = hole :: st.holes } 44 | 45 | (* scopes *) 46 | let modify_scopes f st = { st with scopes = f st.scopes } 47 | let begin_section st = modify_scopes Scopes.begin_ st 48 | 49 | let modify_scopes f st = 50 | let open Result in 51 | let+ scopes = f st.scopes in 52 | { st with scopes } 53 | let transform_view ~shadowing pattern = 54 | modify_scopes (Scopes.transform_view ~shadowing ~pp:Global.pp pattern) 55 | let transform_export ~shadowing pattern = 56 | modify_scopes (Scopes.transform_export ~shadowing ~pp:Global.pp pattern) 57 | let export_view ~shadowing pattern = 58 | modify_scopes (Scopes.export_view ~shadowing ~pp:Global.pp pattern) 59 | let end_section ~shadowing ~prefix = modify_scopes (Scopes.end_ ~shadowing ~prefix) 60 | 61 | (* unit *) 62 | let get_unit id st = IDMap.find id st.units 63 | 64 | let resolve_global id st = Scopes.resolve id st.scopes 65 | let add_global ~unfolder ~shadowing ident tp st = 66 | let open Result in 67 | let unit = get_unit st.unit_id st in 68 | let (sym, unit) = CodeUnit.add_global ~unfolder ident tp unit in 69 | let cof_thy = 70 | match tp with 71 | | D.TpPrf phi -> CofThy.Disj.assume st.cof_thy [phi] 72 | | _ -> st.cof_thy 73 | in 74 | let+ scopes = Scopes.add ~shadowing ident sym st.scopes in 75 | sym, { st with cof_thy; scopes; units = IDMap.add st.unit_id unit st.units } 76 | 77 | let get_global sym st = 78 | CodeUnit.get_global sym @@ get_unit (CodeUnit.origin sym) st 79 | 80 | let get_global_cof_thy st = st.cof_thy 81 | 82 | let begin_unit lib unit_id st = 83 | { lib; unit_id; 84 | scopes = Scopes.init Scope.empty; 85 | holes = []; 86 | cof_thy = CofThy.Disj.empty; 87 | units = IDMap.add unit_id (CodeUnit.create unit_id) st.units; 88 | exports = st.exports; 89 | } 90 | 91 | let end_unit ~parent ~child = 92 | { lib = parent.lib; 93 | unit_id = parent.unit_id; 94 | holes = parent.holes; 95 | scopes = parent.scopes; 96 | cof_thy = parent.cof_thy; 97 | units = child.units; 98 | exports = IDMap.add child.unit_id (Scopes.export_top child.scopes, child.cof_thy) child.exports; 99 | } 100 | 101 | let import ~shadowing pat unit_id st = 102 | let open Result in 103 | let ns, cof_thy = IDMap.find unit_id st.exports in 104 | let* ns = Namespace.transform ~shadowing ~pp:Global.pp pat ns in 105 | let cof_thy = CofThy.Disj.meet2 st.cof_thy cof_thy in 106 | let+ scopes = Scopes.import ~shadowing ns st.scopes in 107 | { st with scopes; cof_thy } 108 | 109 | let loading_status unit_id st = 110 | if IDMap.mem unit_id st.exports then 111 | `Loaded 112 | else if IDMap.mem unit_id st.exports then 113 | `Loading 114 | else 115 | `Unloaded 116 | -------------------------------------------------------------------------------- /src/core/RefineState.mli: -------------------------------------------------------------------------------- 1 | open CodeUnit 2 | module D = Domain 3 | 4 | type t 5 | 6 | val init : Bantorra.Manager.library -> t 7 | 8 | val get_lib : t -> Bantorra.Manager.library 9 | 10 | val get_holes : t -> (D.tp * D.cof * D.tm_clo) list 11 | val add_hole : (D.tp * D.cof * D.tm_clo) -> t -> t 12 | 13 | (* Manipulate of scopes *) 14 | val transform_view : shadowing:bool -> Namespace.pattern -> t -> (t, 'error) Namespace.result 15 | val transform_export : shadowing:bool -> Namespace.pattern -> t -> (t, 'error) Namespace.result 16 | val export_view : shadowing:bool -> Namespace.pattern -> t -> (t, 'error) Namespace.result 17 | val import : shadowing:bool -> Namespace.pattern -> CodeUnitID.t -> t -> (t, 'error) Namespace.result 18 | 19 | val begin_section : t -> t 20 | val end_section : shadowing:bool -> prefix:Namespace.path option -> t -> (t, 'error) Namespace.result 21 | 22 | val add_global : unfolder:Global.t option -> shadowing:bool -> Ident.t -> D.tp -> t -> (Global.t * t, 'error) Namespace.result 23 | val get_global : Global.t -> t -> D.tp 24 | val resolve_global : Ident.t -> t -> Global.t option 25 | val get_global_cof_thy : t -> CofThy.Disj.t 26 | 27 | (** Create and add a new code unit. *) 28 | val begin_unit : Bantorra.Manager.library -> id -> t -> t 29 | val end_unit : parent:t -> child:t -> t 30 | 31 | (** Add a code unit as an import. *) 32 | val loading_status : CodeUnitID.t -> t -> [ `Loaded | `Loading | `Unloaded ] 33 | -------------------------------------------------------------------------------- /src/core/Refiner.mli: -------------------------------------------------------------------------------- 1 | (** This is the basis of trusted inference rules for cooltt. This module also contains 2 | some auxiliary tactics, but these don't need to be trusted so they should be moved elsewhere. *) 3 | 4 | open CodeUnit 5 | 6 | module D := Domain 7 | module S := Syntax 8 | module RM := Monads.RefineM 9 | 10 | open Tactic 11 | 12 | type ('a, 'b) quantifier = 'a -> Ident.t * (var -> 'b) -> 'b 13 | 14 | module Hole : sig 15 | val silent_hole : string option -> Chk.tac 16 | val unleash_hole : string option -> Chk.tac 17 | val silent_syn_hole : string option -> Syn.tac 18 | val unleash_syn_hole : string option -> Syn.tac 19 | end 20 | 21 | module Probe : sig 22 | val probe_chk : string option -> Chk.tac -> Chk.tac 23 | val probe_boundary : Chk.tac -> Chk.tac -> Chk.tac 24 | val probe_syn : string option -> Syn.tac -> Syn.tac 25 | 26 | val probe_goal_chk : ((Ident.t * S.tp) list -> S.tp -> unit RM.m) -> Chk.tac -> Chk.tac 27 | val probe_goal_syn : ((Ident.t * S.tp) list -> S.tp -> unit RM.m) -> Syn.tac -> Syn.tac 28 | 29 | val try_with_boundary : Chk.tac -> (S.t -> Chk.tac) -> Chk.tac 30 | end 31 | 32 | module Dim : sig 33 | val formation : Tp.tac 34 | val dim0 : Chk.tac 35 | val dim1 : Chk.tac 36 | val literal : int -> Chk.tac 37 | end 38 | 39 | module Cof : sig 40 | val formation : Tp.tac 41 | val eq : Chk.tac -> Chk.tac -> Chk.tac 42 | val le : Chk.tac -> Chk.tac -> Chk.tac 43 | val join : Chk.tac list -> Chk.tac 44 | val meet : Chk.tac list -> Chk.tac 45 | val boundary : Chk.tac -> Chk.tac 46 | 47 | type branch_tac = {cof : Chk.tac; bdy : var -> Chk.tac} 48 | val split : branch_tac list -> Chk.tac 49 | end 50 | 51 | module Prf : sig 52 | val formation : Chk.tac -> Tp.tac 53 | val intro : Chk.tac 54 | end 55 | 56 | module Univ : sig 57 | val formation : Tp.tac 58 | val univ : Chk.tac 59 | val nat : Chk.tac 60 | val circle : Chk.tac 61 | val pi : Chk.tac -> Chk.tac -> Chk.tac 62 | val sg : Chk.tac -> Chk.tac -> Chk.tac 63 | val signature : KanTele.tac -> Chk.tac 64 | val patch : Chk.tac -> (Ident.t -> [`Patch of Chk.tac | `Subst of Chk.tac] option) -> Chk.tac 65 | val total : D.kan_tele -> D.con -> Chk.tac 66 | val ext : int -> Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac 67 | val infer_nullary_ext : Chk.tac 68 | val code_v : Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac 69 | val coe : Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Syn.tac 70 | val hcom : Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Syn.tac 71 | val hcom_chk : Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac 72 | val com : Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Syn.tac 73 | end 74 | 75 | module El : sig 76 | val formation : Chk.tac -> Tp.tac 77 | val intro : Chk.tac -> Chk.tac 78 | val elim : Syn.tac -> Syn.tac 79 | end 80 | 81 | module ElV : sig 82 | val intro : Chk.tac -> Chk.tac -> Chk.tac 83 | val elim : Syn.tac -> Syn.tac 84 | end 85 | 86 | module ElHCom : sig 87 | val intro : Chk.tac -> Chk.tac -> Chk.tac 88 | val elim : Syn.tac -> Syn.tac 89 | end 90 | 91 | module Pi : sig 92 | val formation : (Tp.tac, Tp.tac) quantifier 93 | val intro : ?ident:Ident.t -> (var -> Chk.tac) -> Chk.tac 94 | val apply : Syn.tac -> Chk.tac -> Syn.tac 95 | end 96 | 97 | module Sg : sig 98 | val formation : (Tp.tac, Tp.tac) quantifier 99 | val intro : Chk.tac -> Chk.tac -> Chk.tac 100 | 101 | val pi1 : Syn.tac -> Syn.tac 102 | val pi2 : Syn.tac -> Syn.tac 103 | end 104 | 105 | module Telescope : sig 106 | val empty : Tele.tac 107 | val cell : (Tp.tac, Tele.tac) quantifier 108 | val include_ : (Ident.t -> Ident.t option) -> Tele.tac -> (Var.tac list -> Tele.tac) -> Tele.tac 109 | val el : KanTele.tac -> Tele.tac 110 | end 111 | 112 | module KanTelescope : sig 113 | val empty : KanTele.tac 114 | val cell : (Chk.tac, KanTele.tac) quantifier 115 | val include_ : (Ident.t -> Ident.t option) -> KanTele.tac -> (Var.tac list -> KanTele.tac) -> KanTele.tac 116 | end 117 | 118 | module Signature : sig 119 | val formation : Tele.tac -> Tp.tac 120 | val intro : [`Field of Ident.t * Chk.tac |`Include of Syn.tac * (Ident.t -> Ident.t option)] list -> Chk.tac 121 | val proj : Syn.tac -> Ident.t -> Syn.tac 122 | end 123 | 124 | module Sub : sig 125 | val formation : Tp.tac -> Chk.tac -> (var -> Chk.tac) -> Tp.tac 126 | val intro : Chk.tac -> Chk.tac 127 | val elim : Syn.tac -> Syn.tac 128 | end 129 | 130 | module Nat : sig 131 | val formation : Tp.tac 132 | val literal : int -> Chk.tac 133 | val suc : Chk.tac -> Chk.tac 134 | val elim 135 | : Chk.tac 136 | -> Chk.tac 137 | -> Chk.tac 138 | -> Syn.tac 139 | -> Syn.tac 140 | end 141 | 142 | module Circle : sig 143 | val formation : Tp.tac 144 | val base : Chk.tac 145 | val loop : Chk.tac -> Chk.tac 146 | val elim 147 | : Chk.tac 148 | -> Chk.tac 149 | -> Chk.tac 150 | -> Syn.tac 151 | -> Syn.tac 152 | end 153 | 154 | module Structural : sig 155 | val let_ : ?ident:Ident.t -> Syn.tac -> (var -> Chk.tac) -> Chk.tac 156 | val let_syn : ?ident:Ident.t -> Syn.tac -> (var -> Syn.tac) -> Syn.tac 157 | val lookup_var : Ident.t -> Syn.tac 158 | val level : int -> Syn.tac 159 | val generalize : Ident.t -> Chk.tac -> Chk.tac 160 | val unfold : Ident.t list -> Chk.tac -> Chk.tac 161 | val abstract : name:Ident.t option -> Chk.tac -> Chk.tac 162 | end 163 | -------------------------------------------------------------------------------- /src/core/Scope.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { view : Namespace.t 3 | ; export : Namespace.t 4 | } 5 | 6 | let empty = {view = Namespace.empty; export = Namespace.empty} 7 | let inherit_view s = {s with export = Namespace.empty} 8 | let get_export ~prefix s = 9 | match prefix with 10 | | None -> s.export 11 | | Some prefix -> Namespace.prefix prefix s.export 12 | let resolve id s = Namespace.find id s.view 13 | 14 | let (let*) = Result.bind 15 | let (let+) x f = Result.map f x 16 | 17 | let transform_view ~shadowing ~pp pattern s = 18 | let+ view = Namespace.transform ~shadowing ~pp pattern s.view in {s with view} 19 | let transform_export ~shadowing ~pp pattern s = 20 | let+ export = Namespace.transform ~shadowing ~pp pattern s.export in {s with export} 21 | let export_view ~shadowing ~pp pattern s = 22 | let* to_export = Namespace.transform ~shadowing ~pp pattern s.view in 23 | let+ export = Namespace.union ~shadowing s.export to_export in 24 | {s with export} 25 | let add ~shadowing id sym s = 26 | let* view = Namespace.add ~shadowing id sym s.view in 27 | let+ export = Namespace.add ~shadowing id sym s.export in 28 | {view; export} 29 | let include_ ~shadowing ns s = 30 | let* view = Namespace.union ~shadowing s.view ns in 31 | let+ export = Namespace.union ~shadowing s.export ns in 32 | {view; export} 33 | let import ~shadowing ns s = 34 | let+ view = Namespace.union ~shadowing s.view ns in 35 | {s with view} 36 | -------------------------------------------------------------------------------- /src/core/Scope.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val empty : t 4 | val inherit_view : t -> t 5 | val get_export : prefix:Namespace.path option -> t -> Namespace.t 6 | val resolve : Ident.t -> t -> CodeUnit.Global.t option 7 | 8 | val transform_view : 9 | shadowing:bool -> 10 | pp:(Format.formatter -> CodeUnit.Global.t -> unit) -> 11 | Namespace.pattern -> 12 | t -> (t, 'error) Namespace.result 13 | 14 | val transform_export : 15 | shadowing:bool -> 16 | pp:(Format.formatter -> CodeUnit.Global.t -> unit) -> 17 | Namespace.pattern -> 18 | t -> (t, 'error) Namespace.result 19 | 20 | val export_view : 21 | shadowing:bool -> 22 | pp:(Format.formatter -> CodeUnit.Global.t -> unit) -> 23 | Namespace.pattern -> 24 | t -> (t, 'error) Namespace.result 25 | 26 | val add : shadowing:bool -> Ident.t -> CodeUnit.Global.t -> t -> (t, 'error) Namespace.result 27 | 28 | val include_ : shadowing:bool -> Namespace.t -> t -> (t, 'error) Namespace.result 29 | 30 | val import : shadowing:bool -> Namespace.t -> t -> (t, 'error) Namespace.result 31 | -------------------------------------------------------------------------------- /src/core/Scopes.ml: -------------------------------------------------------------------------------- 1 | open Bwd 2 | 3 | type t = Scope.t bwd 4 | 5 | let init s = Snoc (Emp, s) 6 | 7 | let push s ss = Snoc (ss, s) 8 | 9 | let pop = 10 | function 11 | | Emp -> invalid_arg "Scopes.pop" 12 | | Snoc (ss, s) -> s, ss 13 | 14 | let map_current ~f ss = 15 | let s, ss = pop ss in 16 | Result.bind (f s) @@ fun s -> 17 | Result.ok (push s ss) 18 | 19 | let transform_view ~shadowing ~pp pattern ss = 20 | map_current ss ~f:(Scope.transform_view ~shadowing ~pp pattern) 21 | let transform_export ~shadowing ~pp pattern ss = 22 | map_current ss ~f:(Scope.transform_export ~shadowing ~pp pattern) 23 | let export_view ~shadowing ~pp pattern ss = 24 | map_current ss ~f:(Scope.export_view ~shadowing ~pp pattern) 25 | let add ~shadowing id sym ss = 26 | map_current ss ~f:(Scope.add ~shadowing id sym) 27 | let import ~shadowing ns ss = 28 | map_current ss ~f:(Scope.import ~shadowing ns) 29 | 30 | let begin_ ss = 31 | let last, _ = pop ss in 32 | push (Scope.inherit_view last) ss 33 | let end_ ~shadowing ~prefix ss = 34 | let (s, ss) = pop ss in 35 | map_current ss ~f:Scope.(include_ ~shadowing @@ get_export ~prefix s) 36 | 37 | let rec resolve id = 38 | function 39 | | Emp -> None 40 | | Snoc (ss, s) -> 41 | match Scope.resolve id s with 42 | | Some x -> Some x 43 | | None -> resolve id ss 44 | let export_top = 45 | function 46 | | Snoc (Emp, s) -> Scope.get_export ~prefix:None s 47 | | _ -> invalid_arg "Scopes.export_top" 48 | -------------------------------------------------------------------------------- /src/core/Scopes.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val init : Scope.t -> t 4 | 5 | val transform_view : 6 | shadowing:bool -> 7 | pp:(Format.formatter -> CodeUnit.Global.t -> unit) -> 8 | Namespace.pattern -> 9 | t -> (t, 'error) Namespace.result 10 | 11 | val transform_export : 12 | shadowing:bool -> 13 | pp:(Format.formatter -> CodeUnit.Global.t -> unit) -> 14 | Namespace.pattern -> 15 | t -> (t, 'error) Namespace.result 16 | 17 | val export_view : 18 | shadowing:bool -> 19 | pp:(Format.formatter -> CodeUnit.Global.t -> unit) -> 20 | Namespace.pattern -> 21 | t -> (t, 'error) Namespace.result 22 | 23 | val add : shadowing:bool -> Ident.t -> CodeUnit.Global.t -> t -> (t, 'error) Namespace.result 24 | val import : shadowing:bool -> Namespace.t -> t -> (t, 'error) Namespace.result 25 | 26 | val begin_ : t -> t 27 | val end_ : shadowing:bool -> prefix:Namespace.path option -> t -> (t, 'error) Namespace.result 28 | 29 | val resolve : Ident.t -> t -> CodeUnit.Global.t option 30 | val export_top : t -> Namespace.t 31 | -------------------------------------------------------------------------------- /src/core/Semantics.mli: -------------------------------------------------------------------------------- 1 | open Monads 2 | 3 | open CodeUnit 4 | 5 | module S := Syntax 6 | module D := Domain 7 | 8 | val eval : S.t -> D.con evaluate 9 | val eval_cof : S.t -> D.cof evaluate 10 | val eval_tp : S.tp -> D.tp evaluate 11 | val eval_tele : S.tele -> D.tele evaluate 12 | val eval_kan_tele : S.kan_tele -> D.kan_tele evaluate 13 | 14 | type 'a whnf = [`Done | `Reduce of 'a] 15 | val whnf_con : D.con -> D.con whnf compute 16 | val whnf_cut : D.cut -> D.con whnf compute 17 | val whnf_hd : D.hd -> D.con whnf compute 18 | val whnf_con_branches : (D.cof * D.tm_clo) list -> D.con whnf compute 19 | val whnf_tp : D.tp -> D.tp whnf compute 20 | val whnf_tp_branches : (D.cof * D.tp_clo) list -> D.tp whnf compute 21 | 22 | 23 | val whnf_tp_ : D.tp -> D.tp compute 24 | val whnf_con_ : D.con -> D.con compute 25 | 26 | val inst_tp_clo : D.tp_clo -> D.con -> D.tp compute 27 | val inst_tm_clo : D.tm_clo -> D.con -> D.con compute 28 | val inst_tele_clo : D.tele_clo -> D.con -> D.tele compute 29 | val inst_kan_tele_clo : D.kan_tele_clo -> D.con -> D.kan_tele compute 30 | val inst_tele : D.tele -> D.con -> D.tele compute 31 | val inst_kan_tele : D.kan_tele -> D.con -> D.kan_tele compute 32 | 33 | 34 | val do_ap : D.con -> D.con -> D.con compute 35 | val do_ap2 : D.con -> D.con -> D.con -> D.con compute 36 | val do_aps : D.con -> D.con list -> D.con compute 37 | val do_fst : D.con -> D.con compute 38 | val do_snd : D.con -> D.con compute 39 | val do_proj : D.con -> Ident.t -> int -> D.con compute 40 | val do_sub_out : D.con -> D.con compute 41 | val do_el_out : D.con -> D.con compute 42 | val unfold_el : D.con D.stable_code -> D.tp compute 43 | val do_el : D.con -> D.tp compute 44 | val do_spine : D.con -> D.frm list -> D.con compute 45 | 46 | val con_to_dim : D.con -> D.dim compute 47 | val con_to_cof : D.con -> D.cof compute 48 | val cof_con_to_cof : (D.con, D.con) Kado.Syntax.endo -> D.cof compute 49 | 50 | val do_rigid_cap : D.dim -> D.dim -> D.cof -> D.con -> D.con -> D.con compute 51 | val do_rigid_vproj : D.dim -> D.con -> D.con -> D.con -> D.con -> D.con compute 52 | 53 | (** Unpack a struct into a list of fields, potentially performing eta-expansion. *) 54 | val do_unpack : Ident.t list -> D.con -> D.fields compute 55 | 56 | val splice_tm : S.t Splice.t -> D.con compute 57 | val splice_tp : S.tp Splice.t -> D.tp compute 58 | 59 | val subst_con : D.dim -> DimProbe.t -> D.con -> D.con compute 60 | val push_subst_con : D.dim -> DimProbe.t -> D.con -> D.con compute 61 | -------------------------------------------------------------------------------- /src/core/Splice.ml: -------------------------------------------------------------------------------- 1 | open Bwd 2 | open Bwd.Infix 3 | 4 | open CodeUnit 5 | 6 | module S = Syntax 7 | module D = Domain 8 | module TB = TermBuilder 9 | 10 | type 'a t = D.env -> 'a TB.m * D.env 11 | 12 | let foreign con k : _ t = 13 | fun env -> 14 | let env' = {env with conenv = env.conenv <: con} in 15 | let var = TB.lvl @@ BwdLabels.length env.conenv in 16 | k var env' 17 | 18 | let foreign_cof phi = foreign @@ D.cof_to_con phi 19 | let foreign_dim r = foreign @@ D.dim_to_con r 20 | let foreign_clo clo = foreign @@ D.Lam (Ident.anon, clo) 21 | 22 | let foreign_tp tp k : _ t = 23 | fun env -> 24 | let env' = {env with tpenv = env.tpenv <: tp} in 25 | let var = TB.tplvl @@ BwdLabels.length env.tpenv in 26 | k var env' 27 | 28 | let foreign_list (cons : D.con list) k : _ t = 29 | let rec go cons k = 30 | match cons with 31 | | [] -> k [] 32 | | con :: cons -> 33 | foreign con @@ fun tm -> 34 | go cons @@ fun tms -> 35 | k @@ tm :: tms 36 | in 37 | go cons k 38 | 39 | let compile (t : 'a t) : D.env * 'a = 40 | let m, env = t {tpenv = Emp; conenv = Emp} in 41 | let tplen = BwdLabels.length env.tpenv in 42 | let conlen = BwdLabels.length env.conenv in 43 | env, TB.run ~tplen ~conlen m 44 | 45 | let term (m : 'a TB.m) : 'a t = 46 | fun env -> 47 | m, env 48 | 49 | module F = 50 | struct 51 | let con = foreign 52 | let tp = foreign_tp 53 | let cons = foreign_list 54 | let dim = foreign_dim 55 | let cof = foreign_cof 56 | let clo = foreign_clo 57 | end 58 | 59 | module Macro = 60 | struct 61 | let commute_split (self : D.con) (phis : D.cof list) (action : 'a TB.m -> 'b TB.m) = 62 | let phis = List.map D.cof_to_con phis in 63 | F.con self @@ fun self -> 64 | F.cons phis @@ fun phis -> 65 | term @@ TB.cof_split @@ List.map (fun phi -> phi, action self) phis 66 | 67 | let tp_pequiv_in_v ~r ~pcode ~code = 68 | F.dim r @@ fun r -> 69 | F.con pcode @@ fun pcode -> 70 | F.con code @@ fun code -> 71 | term @@ 72 | TB.pi (TB.tp_prf (TB.eq r TB.dim0)) @@ fun _ -> 73 | TB.el @@ TB.Equiv.code_equiv (TB.ap pcode [TB.prf]) code 74 | end 75 | 76 | module Bdry = 77 | struct 78 | module CB = CofBuilder 79 | 80 | let cap ~r ~r' ~phi ~code ~box = 81 | CB.join [CB.eq r r'; phi], 82 | F.dim r @@ fun r -> 83 | F.dim r' @@ fun r' -> 84 | F.cof phi @@ fun phi -> 85 | foreign code @@ fun code -> 86 | foreign box @@ fun box -> 87 | term @@ 88 | TB.cof_split 89 | [TB.eq r r', box; 90 | phi, TB.coe code r' r box] 91 | 92 | let vproj ~r ~pcode ~code ~pequiv ~v = 93 | CB.boundary r, 94 | F.dim r @@ fun r -> 95 | F.con pcode @@ fun _pcode -> 96 | F.con code @@ fun _code -> 97 | F.con pequiv @@ fun pequiv -> 98 | F.con v @@ fun v -> 99 | term @@ 100 | TB.cof_split 101 | [TB.eq r TB.dim0, TB.ap (TB.Equiv.equiv_fwd (TB.ap pequiv [TB.prf])) [v]; 102 | TB.eq r TB.dim1, v] 103 | 104 | let vin ~r ~pivot ~base = 105 | CB.boundary r, 106 | F.dim r @@ fun r -> 107 | F.con pivot @@ fun pivot -> 108 | F.con base @@ fun base -> 109 | term @@ 110 | TB.cof_split 111 | [TB.eq r TB.dim0, TB.ap pivot [TB.prf]; 112 | TB.eq r TB.dim1, base] 113 | 114 | let box ~r ~r' ~phi ~sides ~cap = 115 | CB.join [CB.eq r r'; phi], 116 | F.dim r @@ fun r -> 117 | F.dim r' @@ fun r' -> 118 | F.cof phi @@ fun phi -> 119 | F.con cap @@ fun cap -> 120 | F.con sides @@ fun sides -> 121 | term @@ 122 | TB.cof_split 123 | [TB.eq r r', cap; 124 | phi, TB.ap sides [TB.prf]] 125 | 126 | let hcom ~r ~r' ~phi ~bdy = 127 | CB.join [CB.eq r r'; phi], 128 | F.dim r' @@ fun r' -> 129 | F.con bdy @@ fun bdy -> 130 | term @@ TB.ap bdy [r'; TB.prf] 131 | 132 | let com = hcom 133 | 134 | let coe ~r ~r' ~bdy = 135 | CB.eq r r', 136 | F.con bdy term 137 | 138 | let unstable_code = 139 | function 140 | | `HCom (r, s, phi, bdy) -> 141 | CB.join [CB.eq r s; phi], 142 | F.dim s @@ fun s -> 143 | F.con bdy @@ fun bdy -> 144 | term @@ TB.ap bdy [s; TB.prf] 145 | | `V (r, pcode, code, _) -> 146 | CB.boundary r, 147 | F.dim r @@ fun r -> 148 | F.con pcode @@ fun pcode -> 149 | F.con code @@ fun code -> 150 | term @@ 151 | TB.cof_split 152 | [TB.eq r TB.dim0, TB.ap pcode [TB.prf]; 153 | TB.eq r TB.dim1, code] 154 | 155 | let unstable_frm cut ufrm = 156 | match ufrm with 157 | | D.KHCom (r, s, phi, bdy) -> 158 | CB.join [CB.eq r s; phi], 159 | F.dim s @@ fun s -> 160 | F.con bdy @@ fun bdy -> 161 | term @@ TB.ap bdy [s; TB.prf] 162 | | D.KSubOut (phi, clo) -> 163 | phi, 164 | foreign_clo clo @@ fun clo -> 165 | term @@ TB.ap clo [TB.prf] 166 | | D.KVProj (r, pcode, code, pequiv) -> 167 | let v = D.Cut {cut; tp = D.ElUnstable (`V (r, pcode, code, pequiv))} in 168 | vproj ~r ~pcode ~code ~pequiv ~v 169 | | D.KCap (r, r', phi, code) -> 170 | let box = D.Cut {cut; tp = D.ElUnstable (`HCom (r, r', phi, code))} in 171 | cap ~r ~r' ~phi ~code ~box 172 | end 173 | 174 | include F 175 | -------------------------------------------------------------------------------- /src/core/Splice.mli: -------------------------------------------------------------------------------- 1 | (** Constructing values in the semantic domain that go underneath binders is 2 | very difficult! In general you need to be able to form exactly the right 3 | closure for each binder, and it is usually not obvious how to do this, 4 | and it usually involves some awful De Bruijn arithmetic. 5 | 6 | An alternative is to create a term in an extended context, and then 7 | evaluate that in an environment that contains the values you want to 8 | "splice" into it; then, the resulting value will have the desired behavior. 9 | This module, which is called [Splice] for lack of a better name, 10 | achieves this in an automatic way, avoiding all De Bruijn arithmetic. *) 11 | open CodeUnit 12 | 13 | module S := Syntax 14 | module D := Domain 15 | module TB := TermBuilder 16 | 17 | type 'a t 18 | 19 | val con : D.con -> (S.t TB.m -> 'a t) -> 'a t 20 | val cons : D.con list -> (S.t TB.m list -> 'a t) -> 'a t 21 | val dim : D.dim -> (S.t TB.m -> 'a t) -> 'a t 22 | val cof : D.cof -> (S.t TB.m -> 'a t) -> 'a t 23 | val clo : D.tm_clo -> (S.t TB.m -> 'a t) -> 'a t 24 | val tp : D.tp -> (S.tp TB.m -> 'a t) -> 'a t 25 | val compile : 'a t -> D.env * 'a 26 | val term : 'a TB.m -> 'a t 27 | 28 | module Macro : 29 | sig 30 | val tp_pequiv_in_v : r:D.dim -> pcode:D.con -> code:D.con -> S.tp t 31 | val commute_split : D.con -> D.cof list -> (S.t TB.m -> S.t TB.m) -> S.t t 32 | end 33 | 34 | module Bdry : 35 | sig 36 | type bdry := D.cof * S.t t 37 | val box : r:D.dim -> r':D.dim -> phi:D.cof -> sides:D.con -> cap:D.con -> bdry 38 | val cap : r:D.dim -> r':D.dim -> phi:D.cof -> code:D.con -> box:D.con -> bdry 39 | 40 | val vin : r:D.dim -> pivot:D.con -> base:D.con -> bdry 41 | val vproj : r:D.dim -> pcode:D.con -> code:D.con -> pequiv:D.con -> v:D.con -> bdry 42 | 43 | val hcom : r:D.dim -> r':D.dim -> phi:D.cof -> bdy:D.con -> bdry 44 | val com : r:D.dim -> r':D.dim -> phi:D.cof -> bdy:D.con -> bdry 45 | val coe : r:D.dim -> r':D.dim -> bdy:D.con -> bdry 46 | 47 | val unstable_code : D.con D.unstable_code -> bdry 48 | val unstable_frm : D.cut -> D.unstable_frm -> bdry 49 | end 50 | -------------------------------------------------------------------------------- /src/core/Syntax.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | (** {1 Types} *) 4 | 5 | module Make : functor (Symbol : Symbol.S) -> sig 6 | include module type of SyntaxData.Make(Symbol) 7 | 8 | (** {1 Convenience constructors} *) 9 | val tm_abort : t 10 | val tp_abort : tp 11 | 12 | val tele_lbls : tele -> Ident.t list 13 | val kan_tele_lbls : kan_tele -> Ident.t list 14 | 15 | val rename_tele : (Ident.t -> Ident.t option) -> tele -> tele 16 | val rename_kan_tele : (Ident.t -> Ident.t option) -> kan_tele -> kan_tele 17 | 18 | (** Append two kan telescopes together. 19 | INVARIANT: The second telescope is well-scoped with regard to the first. *) 20 | val append_tele : tele -> tele -> tele 21 | 22 | (** Append two kan telescopes together. 23 | INVARIANT: The second telescope is well-scoped with regard to the first. *) 24 | val append_kan_tele : kan_tele -> kan_tele -> kan_tele 25 | 26 | (** {1 Pretty printers} *) 27 | 28 | (** {2 For display} 29 | These pretty printers are context sensitive, in order to recall user-specified names for binders. *) 30 | 31 | (** Print a core language term. *) 32 | val pp : Pp.env -> t Pp.printer 33 | 34 | (** Print a signature. *) 35 | val pp_tele : Pp.env -> tele Pp.printer 36 | 37 | (** Print a core language type. *) 38 | val pp_tp : Pp.env -> tp Pp.printer 39 | 40 | (** Vertically print an iterated dependent product type as if it were a sequent, for display of goals. *) 41 | val pp_sequent : lbl:string option -> (Ident.t * tp) list -> tp Pp.printer 42 | 43 | (** Vertically print an iterated dependent product type as if it were a sequent, for display of goals. 44 | This variant will also print out a partially constructed terms, as well as display if the boundary 45 | conditions are met. *) 46 | val pp_partial_sequent : [< `BdrySat | `BdryUnsat ] -> (Ident.t * tp) list -> (t * tp) Pp.printer 47 | 48 | (** {2 For debugging} 49 | When debugging, we are not likely to have enough context to use the nice pretty printers above; as a last resort, {!val:dump} and {!val:dump_tp} may be used. *) 50 | 51 | val dump : t Pp.printer 52 | val dump_tele : tele Pp.printer 53 | val dump_kan_tele : kan_tele Pp.printer 54 | val dump_tp : tp Pp.printer 55 | end 56 | -------------------------------------------------------------------------------- /src/core/SyntaxData.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | module Make (Symbol : Symbol.S) = 4 | struct 5 | module Cof = Kado.Syntax.Endo 6 | 7 | type t = 8 | | Var of int 9 | | Global of Symbol.t 10 | | Let of t * Ident.t * t 11 | | Ann of t * tp 12 | 13 | | Zero 14 | | Suc of t 15 | | NatElim of t * t * t * t 16 | 17 | | Base 18 | | Loop of t 19 | | CircleElim of t * t * t * t 20 | 21 | | Lam of Ident.t * t 22 | | Ap of t * t 23 | 24 | | Pair of t * t 25 | | Fst of t 26 | | Snd of t 27 | 28 | | Struct of fields 29 | | Proj of t * Ident.t * int 30 | 31 | | Coe of t * t * t * t 32 | | HCom of t * t * t * t * t 33 | | Com of t * t * t * t * t 34 | 35 | | SubIn of t 36 | | SubOut of t 37 | 38 | | Dim0 39 | | Dim1 40 | | Cof of (t, t) Cof.t 41 | | ForallCof of t 42 | | CofSplit of (t * t) list 43 | | Prf 44 | 45 | | ElIn of t 46 | | ElOut of t 47 | 48 | | Box of t * t * t * t * t 49 | | Cap of t * t * t * t * t 50 | 51 | | VIn of t * t * t * t 52 | | VProj of t * t * t * t * t 53 | 54 | | CodeExt of int * t * [`Global of t] * t 55 | | CodePi of t * t 56 | | CodeSg of t * t 57 | | CodeSignature of kan_tele 58 | | CodeNat 59 | | CodeUniv 60 | | CodeV of t * t * t * t 61 | | CodeCircle 62 | 63 | | ESub of sub * t 64 | (** Explicit substition *) 65 | 66 | and tp = 67 | | Univ 68 | | El of t 69 | | TpVar of int 70 | | TpDim 71 | | TpCof 72 | | TpPrf of t 73 | | TpCofSplit of (t * tp) list 74 | | Sub of tp * t * t 75 | | Pi of tp * Ident.t * tp 76 | | Sg of tp * Ident.t * tp 77 | | Signature of tele 78 | | Nat 79 | | Circle 80 | | TpESub of sub * tp 81 | 82 | and tele = 83 | | ElTele of kan_tele 84 | | Cell of Ident.t * tp * tele 85 | | Empty 86 | 87 | and kan_tele = 88 | | KCell of Ident.t * t * kan_tele 89 | | KEmpty 90 | 91 | and fields = 92 | | Fields of (Ident.t * t) list 93 | | Unpack of Ident.t list * t 94 | (** Unpack a {!val:Struct} into its list of fields. *) 95 | | MCoe of Ident.t * kan_tele * t * t * fields 96 | (** Coercion along a line in a telescope. 97 | The {i kan_tele} has a free variable for a dimension variable. *) 98 | | MCom of kan_tele * t * t * t * fields 99 | (** Composition in a telescope, provided a list of systems. *) 100 | 101 | (** The language of substitions from {{:https://arxiv.org/abs/1102.2405} Abel, Coquand, and Pagano}. *) 102 | and sub = 103 | | SbI 104 | (** The identity substitution [Γ → Γ]. *) 105 | 106 | | SbC of sub * sub 107 | (** The composition of substitutions [δ ∘ γ]. *) 108 | 109 | | Sb1 110 | (** The terminal substitution [Γ → 1]. *) 111 | 112 | | SbE of sub * t 113 | (** The universal substitution into an extended context [<γ, a>]. *) 114 | 115 | | SbP 116 | (** The projection from a extended context [Γ.A → Γ]. *) 117 | 118 | module CofBuilder = Kado.Builder.Endo.Make 119 | (struct 120 | type dim = t 121 | type cof = t 122 | let dim0 = Dim0 123 | let dim1 = Dim1 124 | let equal_dim = (=) 125 | let cof phi = Cof phi 126 | let uncof = function Cof phi -> Some phi | _ -> None 127 | end) 128 | end 129 | -------------------------------------------------------------------------------- /src/core/SyntaxPrecedence.ml: -------------------------------------------------------------------------------- 1 | type t = int * int 2 | 3 | let nonassoc n = 2*n, 2*n 4 | let left n = 2*n, 2*n+1 5 | let right n = 2*n+1, 2*n 6 | let prefix n = Int.max_int, 2*n 7 | let postfix n = 2*n, Int.max_int 8 | 9 | let dual (l, _) (_, r) = l, r 10 | 11 | let pp fmt (l, r) = Format.fprintf fmt "<%i-%i>" l r 12 | 13 | type env = int * int 14 | let left_of (l, _) = Int.min_int, l 15 | let right_of (_, r) = r, Int.min_int 16 | let surrounded_by (l, r) = r, l 17 | let isolated = Int.min_int, Int.min_int 18 | let isolate_left (_, r) = Int.min_int, r 19 | let isolate_right (l, _) = l, Int.min_int 20 | 21 | let pp_env fmt (l,r) = 22 | match l = Int.min_int, r = Int.min_int with 23 | | true, true -> Format.fprintf fmt "" 24 | | false, true -> Format.fprintf fmt "" l 25 | | true, false -> Format.fprintf fmt "" r 26 | | false, false -> Format.fprintf fmt "" l r 27 | 28 | let parens (l', r') (l, r) = l' >= l || r' >= r 29 | -------------------------------------------------------------------------------- /src/core/SyntaxPrecedence.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val nonassoc : int -> t 4 | val left : int -> t 5 | val right : int -> t 6 | val prefix : int -> t 7 | val postfix : int -> t 8 | val dual : t -> t -> t 9 | 10 | type env 11 | val left_of : t -> env 12 | val right_of : t -> env 13 | val surrounded_by : t -> env 14 | val isolated : env 15 | val isolate_right : env -> env 16 | val isolate_left : env -> env 17 | 18 | val parens : env -> t -> bool 19 | 20 | val pp : Format.formatter -> t -> unit 21 | val pp_env : Format.formatter -> env -> unit 22 | -------------------------------------------------------------------------------- /src/core/Tactic.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | open CodeUnit 3 | 4 | module S := Syntax 5 | module D := Domain 6 | module RM := RefineMonad 7 | 8 | module type Tactic = 9 | sig 10 | type tac 11 | val update_span : LexingUtil.span option -> tac -> tac 12 | val whnf : tac -> tac 13 | end 14 | 15 | 16 | (* general types *) 17 | module Tp : 18 | sig 19 | include Tactic 20 | 21 | val rule : ?name:string -> S.tp RM.m -> tac 22 | 23 | (** A "virtual type" is one that is only permitted to appear as the domain of a pi type *) 24 | val virtual_rule : ?name:string -> S.tp RM.m -> tac 25 | 26 | (** Only succeeds for non-virtual types *) 27 | val run : tac -> S.tp RM.m 28 | 29 | (** Virtual types allowed *) 30 | val run_virtual : tac -> S.tp RM.m 31 | 32 | val map : (S.tp RM.m -> S.tp RM.m) -> tac -> tac 33 | end 34 | 35 | module rec Chk : 36 | sig 37 | include Tactic 38 | 39 | val rule : ?name:string -> (D.tp -> S.t RM.m) -> tac 40 | val brule : ?name:string -> (D.tp * D.cof * D.tm_clo -> S.t RM.m) -> tac 41 | val run : tac -> D.tp -> S.t RM.m 42 | val brun : tac -> D.tp * D.cof * D.tm_clo -> S.t RM.m 43 | 44 | val syn : Syn.tac -> tac 45 | 46 | val catch : Chk.tac -> (exn -> Chk.tac) -> Chk.tac 47 | end 48 | and Syn : 49 | sig 50 | include Tactic 51 | val rule : ?name:string -> (S.t * D.tp) RM.m -> tac 52 | val run : tac -> (S.t * D.tp) RM.m 53 | val ann : Chk.tac -> Tp.tac -> tac 54 | 55 | val catch : Syn.tac -> (exn -> Syn.tac) -> Syn.tac 56 | end 57 | 58 | module Tele : 59 | sig 60 | include Tactic 61 | 62 | val rule : ?name:string -> S.tele RM.m -> tac 63 | val run : tac -> S.tele RM.m 64 | end 65 | 66 | module KanTele : 67 | sig 68 | include Tactic 69 | 70 | val rule : ?name:string -> (D.tp -> S.kan_tele RM.m) -> tac 71 | val run : tac -> D.tp -> S.kan_tele RM.m 72 | end 73 | 74 | module Var : 75 | sig 76 | type tac 77 | 78 | val prf : D.cof -> tac 79 | val con : tac -> D.con 80 | val syn : tac -> Syn.tac 81 | end 82 | 83 | type var = Var.tac 84 | 85 | val abstract : ?ident:Ident.t -> D.tp -> (var -> 'a RM.m) -> 'a RM.m 86 | val abstract_tele : D.tele -> (var list -> 'a RM.m) -> 'a RM.m 87 | val abstract_kan_tele : D.kan_tele -> (var list -> 'a RM.m) -> 'a RM.m 88 | -------------------------------------------------------------------------------- /src/core/TermBuilder.mli: -------------------------------------------------------------------------------- 1 | (** A language for building terms without doing De Bruijn arithmetic. This module contains constructors 2 | * not only for the primitives of cubical type theory, but also for the more complex derived forms -- 3 | * for instance, the algorithm of coercion and composition in various type connectives. *) 4 | 5 | open Basis 6 | open CodeUnit 7 | 8 | include Monad.S 9 | 10 | module S := Syntax 11 | 12 | type t := S.t 13 | type tp := S.tp 14 | type tele := S.tele 15 | 16 | type 'a b = t m -> 'a m 17 | val scope : 'a b -> 'a m 18 | val run : tplen:int -> conlen:int -> 'a m -> 'a 19 | val lvl : int -> t m 20 | val tplvl : int -> tp m 21 | 22 | val lam : ?ident:Ident.t -> t b -> t m 23 | val ap : t m -> t m list -> t m 24 | val coe : t m -> t m -> t m -> t m -> t m 25 | val hcom : t m -> t m -> t m -> t m -> t m -> t m 26 | val com : t m -> t m -> t m -> t m -> t m -> t m 27 | val let_ : ?ident:Ident.t -> t m -> t b -> t m 28 | val pair : t m -> t m -> t m 29 | val fst : t m -> t m 30 | val snd : t m -> t m 31 | 32 | val lams : Ident.t list -> (t m list -> t m) -> t m 33 | 34 | val struct_ : S.fields m -> t m 35 | val proj : t m -> Ident.t -> int -> t m 36 | 37 | val zero : t m 38 | val suc : t m -> t m 39 | 40 | val base : t m 41 | val loop : t m -> t m 42 | 43 | val prf : t m 44 | 45 | val cap : t m -> t m -> t m -> t m -> t m -> t m 46 | val box : t m -> t m -> t m -> t m -> t m -> t m 47 | 48 | val cof_split : (t m * t m) list -> t m 49 | val tp_cof_split : (t m * tp m) list -> tp m 50 | val tm_abort : t m 51 | val sub_out : t m -> t m 52 | val sub_in : t m -> t m 53 | 54 | val el_in : t m -> t m 55 | val el_out : t m -> t m 56 | 57 | val univ : tp m 58 | val nat : tp m 59 | val code_nat : t m 60 | val nat_elim : t m -> t m -> t m -> t m -> t m 61 | 62 | val circle : tp m 63 | val code_circle : t m 64 | val circle_elim : t m -> t m -> t m -> t m -> t m 65 | 66 | val pi : ?ident:Ident.t -> tp m -> tp b -> tp m 67 | val sg : ?ident:Ident.t -> tp m -> tp b -> tp m 68 | val signature : tele m -> tp m 69 | val sub : tp m -> t m -> t b -> tp m 70 | val tp_prf : t m -> tp m 71 | val tp_dim : tp m 72 | val tp_cof : tp m 73 | val el : t m -> tp m 74 | 75 | val pis: ?idents:Ident.t list -> t m list -> (t m list -> tp m) -> tp m 76 | 77 | val cube : int -> (t m list -> tp m) -> tp m 78 | 79 | val code_pi : t m -> t m -> t m 80 | val code_sg : t m -> t m -> t m 81 | val code_path : t m -> t m -> t m 82 | (** A specialization of {!val:code_path} that performs a {!val:cof_split}. *) 83 | val code_path' : t m -> t m -> t m -> t m 84 | val code_v : t m -> t m -> t m -> t m -> t m 85 | val code_ext : int -> t m -> t m -> t m -> t m 86 | val vproj : t m -> t m -> t m -> t m -> t m -> t m 87 | 88 | val code_pis : t m list -> (t m list -> t m) -> t m 89 | 90 | val dim0 : t m 91 | val dim1 : t m 92 | val eq : t m -> t m -> t m 93 | val join : t m list -> t m 94 | val meet : t m list -> t m 95 | val top : t m 96 | val bot : t m 97 | val boundary : t m -> t m 98 | val forall : t b -> t m 99 | 100 | 101 | module Equiv : sig 102 | val code_is_contr : t m -> t m 103 | val code_fiber : t m -> t m -> t m -> t m -> t m 104 | val code_equiv : t m -> t m -> t m 105 | val equiv_fwd : t m -> t m 106 | val equiv_inv : t m -> t m -> t m 107 | val equiv_inv_path : t m -> t m -> t m -> t m 108 | end 109 | 110 | 111 | module Kan : sig 112 | type coe = r:t m -> r':t m -> bdy:t m -> t m 113 | type hcom = r:t m -> r':t m -> phi:t m -> bdy:t m -> t m 114 | 115 | val coe_pi : base_line:t m -> fam_line:t m -> coe 116 | val hcom_pi : fam:t m -> hcom 117 | 118 | val coe_sg : base_line:t m -> fam_line:t m -> coe 119 | val hcom_sg : base:t m -> fam:t m -> hcom 120 | 121 | val hcom_ext : n:int -> cof:t m -> fam:t m -> bdry:t m -> hcom 122 | val coe_ext : n:int -> cof:t m -> fam_line:t m -> bdry_line:t m -> coe 123 | 124 | module V : sig 125 | type vcode = {r : t m; pcode : t m; code : t m; pequiv : t m} 126 | val hcom_v : v:vcode -> r:t m -> r':t m -> phi:t m -> bdy:t m -> t m 127 | val coe_v : v:vcode -> r:t m -> r':t m -> bdy:t m -> t m 128 | end 129 | 130 | module FHCom : sig 131 | type fhcom_u = {r : t m; r' : t m; phi : t m; bdy : t m} 132 | val hcom_fhcom : fhcom:fhcom_u -> r:t m -> r':t m -> phi:t m -> bdy:t m -> t m 133 | val coe_fhcom : fhcom:fhcom_u -> r:t m -> r':t m -> bdy:t m -> t m 134 | end 135 | end 136 | 137 | module Test : sig 138 | val print_example : unit -> unit 139 | end 140 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Core) 3 | (libraries kado bantorra cooltt.basis ezjsonm yuujinchou bwd) 4 | (preprocess 5 | (pps ppx_deriving.std)) 6 | (flags 7 | (:standard -w -32-37-38 -warn-error -a+31)) 8 | (public_name cooltt.core)) 9 | -------------------------------------------------------------------------------- /src/frontend/ConcreteSyntax.ml: -------------------------------------------------------------------------------- 1 | include ConcreteSyntaxData 2 | -------------------------------------------------------------------------------- /src/frontend/ConcreteSyntax.mli: -------------------------------------------------------------------------------- 1 | include module type of ConcreteSyntaxData 2 | 3 | val show_con : con -> string 4 | val pp_con : Format.formatter -> con -> unit 5 | -------------------------------------------------------------------------------- /src/frontend/ConcreteSyntaxData.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Core 3 | 4 | type info = LexingUtil.span option 5 | 6 | let pp_info fmt = 7 | function 8 | | None -> Format.fprintf fmt "Unknown location" 9 | | Some span -> 10 | LexingUtil.pp_span fmt span 11 | 12 | type 'a node = 13 | {node : 'a; 14 | info : info} 15 | [@@deriving show] 16 | 17 | type hole = {name: string option; silent: bool} 18 | [@@deriving show] 19 | 20 | let map_node ~f n = {n with node = f n.node} 21 | let get_info n = n.info 22 | 23 | type cell = Cell of {names : Ident.t list; tp : con} 24 | and con = con_ node 25 | and con_ = 26 | | Var of Ident.t 27 | | DeBruijnLevel of int 28 | | Let of con * Ident.t * con 29 | | Ann of {term : con; tp : con} 30 | | Nat 31 | | Suc of con 32 | | Lit of int 33 | | Circle 34 | | Base 35 | | Loop of con 36 | | Pi of cell list * con 37 | | Lam of Ident.t list * con 38 | | Ap of con * con list 39 | | Sg of cell list * con 40 | | Signature of field list 41 | | Struct of field list 42 | | Proj of con * Ident.t 43 | | Patch of con * patch_field list 44 | | Open of con * (Ident.user * Ident.user) list * con 45 | | Sub of con * con * con 46 | | Pair of con * con 47 | | Fst of con 48 | | Snd of con 49 | | Type 50 | | Hole of hole * con option 51 | | BoundaryHole of con option 52 | | Visualize 53 | | Underscore 54 | | Generalize of Ident.t * con 55 | | Unfold of Ident.t list * con 56 | | Abstract of Ident.t option * con 57 | | Elim of {mot : con; cases : case list; scrut : con} 58 | | Rec of {mot : con; cases : case list; scrut : con} 59 | | LamElim of case list 60 | | Equations of { code : con; eqns : eqns step } 61 | | Dim 62 | | Cof 63 | | CofEq of con * con 64 | | CofLe of con * con 65 | | Join of con list 66 | | Meet of con list 67 | | CofBoundary of con 68 | | Prf of con 69 | | CofSplit of (con * con) list 70 | | Ext of Ident.t list * con * (con * con) list 71 | | Coe of con * con * con * con 72 | | TopC 73 | | BotC 74 | | HCom of con * con * con * con * con 75 | | HComChk of con * con * con 76 | | HFill of con * con * con * con 77 | | HFillChk of con * con 78 | | Com of con * con * con * con * con 79 | | V of con * con * con * con 80 | | VProj of con 81 | | Cap of con 82 | | ModAll 83 | | ModOnly of string list 84 | | ModRename of string list * string list 85 | | ModNone 86 | | ModExcept of string list 87 | | ModSeq of con list 88 | | ModUnion of con list 89 | | ModInSubtree of string list * con 90 | | ModPrint of hole 91 | [@@deriving show] 92 | 93 | and case = pat * con 94 | [@@deriving show] 95 | 96 | and field = [`Field of Ident.user * con | `Include of con * (Ident.user * Ident.user) list] 97 | [@@deriving show] 98 | 99 | and patch_field = [`Patch of Ident.user * con | `Subst of Ident.user * con] 100 | [@@deriving show] 101 | 102 | and pat = Pat of {lbl : string list; args : pat_arg list} 103 | [@@deriving show] 104 | 105 | and pat_arg = [`Simple of Ident.t | `Inductive of Ident.t * Ident.t] 106 | [@@deriving show] 107 | 108 | and 'a step = 109 | | Equals of con * con * 'a 110 | | Trivial of con * 'a 111 | 112 | and eqns = 113 | | Step of eqns step 114 | | Qed of con 115 | 116 | type decl = decl_ node 117 | and decl_ = 118 | | Def of {abstract : bool; shadowing : bool; name : Ident.t; args : cell list; def : con; tp : con; unfolding : Ident.t list} 119 | | Axiom of {shadowing : bool; name : Ident.t; args : cell list; tp : con} 120 | | Print of {unfolding : Ident.t list; name : Ident.t node} 121 | | Import of {shadowing : bool; unitpath : string list; modifier : con option} 122 | | NormalizeTerm of {unfolding : Ident.t list; con : con} 123 | | Fail of decl 124 | | Debug of bool 125 | | Quit 126 | | View of {shadowing : bool; modifier : con} 127 | | Export of {shadowing : bool; modifier : con} 128 | | Repack of {shadowing : bool; modifier : con} 129 | | Section of {shadowing : bool; prefix : string list option; decls : signature; modifier : con option} 130 | [@@deriving show] 131 | 132 | and signature = decl list 133 | 134 | type repl_command = repl_command_ node 135 | and repl_command_ = 136 | | NoOp 137 | | EndOfFile 138 | | Decl of decl 139 | -------------------------------------------------------------------------------- /src/frontend/Driver.mli: -------------------------------------------------------------------------------- 1 | (* This is the top-level driver for the proof assistant. *) 2 | 3 | type options = 4 | { as_file : string option; 5 | debug_mode : bool; 6 | server_info : (string * int) option } 7 | 8 | val load_file : options -> [`Stdin | `File of string] -> (unit, unit) result 9 | val do_repl : options -> (unit, unit) result 10 | -------------------------------------------------------------------------------- /src/frontend/DriverMessage.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Core 3 | 4 | open CodeUnit 5 | 6 | module S = Syntax 7 | 8 | type output_message = 9 | | NormalizedTerm of {orig : Syntax.t; nf : Syntax.t} 10 | | Definition of {ident : Ident.t; tp : Syntax.tp; ptm : (Syntax.t * Syntax.t) option} 11 | 12 | type warning_message = | 13 | 14 | type error_message = 15 | | LexingError 16 | | ParseError 17 | | UnboundIdent of Ident.t 18 | | InvalidLibrary of string 19 | | UnitNotFound of string 20 | 21 | type message = 22 | | OutputMessage of output_message 23 | | WarningMessage of warning_message 24 | | ErrorMessage of {error : error_message; last_token : string option} 25 | 26 | 27 | (* 28 | TODO: This is the start of better messaging, still needs work 29 | 30 | During Emit, we often don't have a last_token as the parser is happy and we just 31 | have an unbound identifier or a hole or things like that. In those cases, we don't print the 32 | last_token as it would contain nothing. 33 | 34 | *) 35 | 36 | let pp_message fmt = 37 | function 38 | | ErrorMessage {error = ParseError; last_token = None} -> 39 | Format.fprintf fmt "Parse error" 40 | 41 | | ErrorMessage {error = ParseError; last_token = Some last_token} -> 42 | Format.fprintf fmt "Parse error near %s" last_token 43 | 44 | | ErrorMessage {error = LexingError; last_token = None} -> 45 | Format.fprintf fmt "Lexing error" 46 | 47 | | ErrorMessage {error = LexingError; last_token = Some last_token} -> 48 | Format.fprintf fmt "Lexing error near %s" last_token 49 | 50 | | ErrorMessage {error = UnboundIdent ident; _} -> 51 | Format.fprintf fmt 52 | "@[Unbound identifier %a@]" 53 | Ident.pp ident 54 | 55 | | ErrorMessage {error = InvalidLibrary msg; _} -> 56 | Format.fprintf fmt 57 | "@[Could not load the library.@ %a@]" BantorraBasis.Error.pp_lines msg 58 | 59 | | ErrorMessage {error = UnitNotFound msg; _} -> 60 | Format.fprintf fmt 61 | "@[Could not find the unit.@ %a@]" BantorraBasis.Error.pp_lines msg 62 | 63 | | WarningMessage _ -> . 64 | 65 | | OutputMessage (NormalizedTerm {orig; nf}) -> 66 | let env = Pp.Env.emp in 67 | Format.fprintf fmt 68 | "@[Computed normal form of@ @[%a@] as@,@[ %a@]@]" 69 | (Syntax.pp env) orig 70 | (Syntax.pp env) nf 71 | 72 | | OutputMessage (Definition {ident; tp; ptm = Some (_cof, tm)}) -> 73 | let env = Pp.Env.emp in 74 | let _, env' = Pp.Env.bind env None in 75 | Format.fprintf fmt 76 | "@[def %a :@;@[%a@]@;:=@;%a@]" 77 | Ident.pp ident 78 | (Syntax.pp_tp env) tp 79 | (Syntax.pp env') tm 80 | 81 | | OutputMessage (Definition {ident; tp; ptm = None}) -> 82 | let env = Pp.Env.emp in 83 | Format.fprintf fmt 84 | "@[%a : %a@]" 85 | Ident.pp ident 86 | (Syntax.pp_tp env) tp 87 | -------------------------------------------------------------------------------- /src/frontend/DriverMessage.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | open CodeUnit 3 | 4 | type output_message = 5 | | NormalizedTerm of {orig : Syntax.t; nf : Syntax.t} 6 | | Definition of {ident : Ident.t; tp : Syntax.tp; ptm : (Syntax.t * Syntax.t) option} 7 | 8 | type warning_message = | 9 | 10 | type error_message = 11 | | LexingError 12 | | ParseError 13 | | UnboundIdent of Ident.t 14 | | InvalidLibrary of string 15 | | UnitNotFound of string 16 | 17 | type message = 18 | | OutputMessage of output_message 19 | | WarningMessage of warning_message 20 | | ErrorMessage of {error : error_message; last_token : string option} 21 | 22 | val pp_message : Format.formatter -> message -> unit 23 | -------------------------------------------------------------------------------- /src/frontend/ElabError.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Core 3 | 4 | open CodeUnit 5 | 6 | module CS = ConcreteSyntax 7 | module S = Syntax 8 | 9 | type t = 10 | | MalformedCase 11 | | InvalidTypeExpression of CS.con 12 | | ExpectedSynthesizableTerm of CS.con_ 13 | | CannotEliminate of Pp.env * S.tp 14 | | ExpectedSimpleInductive of Pp.env * S.tp 15 | | InvalidModifier of CS.con 16 | | ExpectedFailure of CS.decl 17 | 18 | let pp fmt = 19 | function 20 | | ExpectedSynthesizableTerm orig -> 21 | Format.fprintf fmt 22 | "@[Type annotation required for@,@[ %a@]@]" 23 | CS.pp_con_ orig 24 | | InvalidTypeExpression cs -> 25 | Format.fprintf fmt 26 | "Invalid type expression: %a" 27 | CS.pp_con cs 28 | | MalformedCase -> 29 | Format.fprintf fmt "Malformed case" 30 | | CannotEliminate (ppenv, tp) -> 31 | Format.fprintf fmt 32 | "Cannot eliminate element of type %a" 33 | (S.pp_tp ppenv) tp 34 | | ExpectedSimpleInductive (ppenv, tp) -> 35 | Format.fprintf fmt 36 | "Expected simple inductive type but found %a" 37 | (S.pp_tp ppenv) tp 38 | | InvalidModifier cs -> 39 | Format.fprintf fmt 40 | "Invalid modifier: %a" 41 | CS.pp_con cs 42 | | ExpectedFailure decl -> 43 | Format.fprintf fmt 44 | "Expected command to fail: %a" 45 | CS.pp_decl decl 46 | 47 | exception ElabError of t * LexingUtil.span option 48 | 49 | let _ = 50 | PpExn.install_printer @@ fun fmt -> 51 | function 52 | | ElabError (err, _loc) -> 53 | pp fmt err 54 | | _ -> 55 | raise PpExn.Unrecognized 56 | -------------------------------------------------------------------------------- /src/frontend/ElabError.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Core 3 | 4 | open CodeUnit 5 | 6 | module CS := ConcreteSyntax 7 | module S := Syntax 8 | 9 | type t = 10 | | MalformedCase 11 | | InvalidTypeExpression of CS.con 12 | | ExpectedSynthesizableTerm of CS.con_ 13 | | CannotEliminate of Pp.env * S.tp 14 | | ExpectedSimpleInductive of Pp.env * S.tp 15 | | InvalidModifier of CS.con 16 | | ExpectedFailure of CS.decl 17 | 18 | val pp : Format.formatter -> t -> unit 19 | 20 | exception ElabError of t * LexingUtil.span option 21 | -------------------------------------------------------------------------------- /src/frontend/Elaborator.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | module CS := ConcreteSyntax 3 | module S := Syntax 4 | module RM := Monads.RefineM 5 | module D := Domain 6 | 7 | open Tactic 8 | 9 | val chk_tp : CS.con -> Tp.tac 10 | val chk_tp_in_tele : CS.cell list -> CS.con -> Tp.tac 11 | val chk_tm : CS.con -> Chk.tac 12 | val chk_tm_in_tele : CS.cell list -> CS.con -> Chk.tac 13 | val syn_tm : ?elim_total:bool -> CS.con -> Syn.tac 14 | val modifier : CS.con -> Namespace.pattern RM.m 15 | -------------------------------------------------------------------------------- /src/frontend/Load.ml: -------------------------------------------------------------------------------- 1 | open Lex 2 | open Basis 3 | 4 | type error = 5 | | LexingError of {span : LexingUtil.span; last_token : string option} 6 | | ParseError of {span : LexingUtil.span; last_token : string option} 7 | 8 | exception ParseError of string * LexingUtil.span 9 | 10 | let parse_with_error parser lexbuf = 11 | try Ok (parser Lex.token lexbuf) with 12 | | SyntaxError _msg -> 13 | let span = LexingUtil.current_span lexbuf in 14 | let last_token = LexingUtil.last_token lexbuf in 15 | Error (LexingError {span; last_token}) 16 | | Grammar.Error -> 17 | let span = LexingUtil.current_span lexbuf in 18 | let last_token = LexingUtil.last_token lexbuf in 19 | Error (ParseError {span; last_token}) 20 | 21 | let create_lexbuf input = 22 | let ch, filename = 23 | match input with 24 | | `Stdin -> stdin, "[stdin]" 25 | | `File filename -> open_in filename, filename 26 | in 27 | let lexbuf = Lexing.from_channel ch in 28 | lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = filename}; 29 | ch, lexbuf 30 | 31 | let load_file input = 32 | let ch, lexbuf = create_lexbuf input in 33 | let sign = parse_with_error Grammar.sign lexbuf in 34 | close_in ch; 35 | sign 36 | 37 | let prepare_repl () = create_lexbuf `Stdin 38 | 39 | (* Favonia: still thinking about the line numbers. *) 40 | let reset_pos _lexbuf = () 41 | 42 | let load_cmd lexbuf = 43 | reset_pos lexbuf; 44 | parse_with_error Grammar.repl_command lexbuf 45 | -------------------------------------------------------------------------------- /src/frontend/Load.mli: -------------------------------------------------------------------------------- 1 | open Basis 2 | 3 | type error = 4 | | LexingError of {span : LexingUtil.span; last_token: string option} 5 | | ParseError of {span : LexingUtil.span; last_token: string option} 6 | 7 | (* Load and parse a file or stdin *) 8 | val load_file : [`Stdin | `File of string] -> (ConcreteSyntax.signature, error) result 9 | 10 | val prepare_repl : unit -> in_channel * Lexing.lexbuf 11 | val load_cmd : Lexing.lexbuf -> (ConcreteSyntax.repl_command, error) result 12 | -------------------------------------------------------------------------------- /src/frontend/Server.ml: -------------------------------------------------------------------------------- 1 | open Basis 2 | open Bwd 3 | 4 | module K = Kado.Syntax 5 | 6 | open Core 7 | open CodeUnit 8 | 9 | module S = Syntax 10 | 11 | module J = Ezjsonm 12 | 13 | (* [NOTE: Cooltt Server] 14 | We use a 'ref' here to prevent having to thread down a server handle 15 | deep into the guts of the elaborator. *) 16 | let server : Unix.file_descr option ref = 17 | ref None 18 | 19 | let init host_name port = 20 | try 21 | Format.eprintf "Initializing cooltt server connection on port %n...@." port; 22 | let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 23 | let host_entry = Unix.gethostbyname host_name in 24 | begin 25 | match CCArray.get_safe host_entry.h_addr_list 0 with 26 | | Some addr -> 27 | let () = Unix.connect socket (Unix.ADDR_INET (addr, port)) in 28 | Format.eprintf "Cooltt server connection initialized@."; 29 | server := Some socket 30 | | None -> Format.eprintf "Error: Could not initialize cooltt server connection.@." 31 | end 32 | with Unix.Unix_error _ -> 33 | Format.eprintf "Error: Could not initialize cooltt server connection.@." 34 | 35 | let close () = 36 | match !server with 37 | | Some socket -> 38 | Unix.close socket; 39 | server := None 40 | | None -> () 41 | 42 | let ppenv_bind env ident = 43 | Pp.Env.bind env @@ Ident.to_string_opt ident 44 | 45 | let serialize_label (str : string) (pos : (string * float) list) : J.value = 46 | `O [("position", `O (List.map (fun (nm, d) -> (nm, J.float d)) pos)); ("txt", `String str)] 47 | 48 | let dim_tm : S.t -> float = 49 | function 50 | | S.Dim0 -> -. 1.0 51 | | S.Dim1 -> 1.0 52 | | _ -> failwith "dim_tm: bad dim" 53 | 54 | (* Fetch a list of label positions from a cofibration. *) 55 | let rec dim_from_cof (dims : (string option) bwd) (cof : S.t) : (string * float) list list = 56 | match cof with 57 | | S.Cof (K.Le (S.Var v, r)) 58 | | S.Cof (K.Le (r, S.Var v)) -> 59 | let axis = Option.get @@ BwdLabels.nth dims v in 60 | let d = dim_tm r in 61 | [[(axis, d)]] 62 | | S.Cof (K.Join cofs) -> List.concat_map (dim_from_cof dims) cofs 63 | | S.Cof (K.Meet cofs) -> [List.concat @@ List.concat_map (dim_from_cof dims) cofs] 64 | | cof -> 65 | failwith @@ Format.asprintf "dim_from_cof: bad cof '%a'" S.dump cof 66 | 67 | (* Create our list of labels from a boundary constraint. *) 68 | let boundary_labels (dims : (string option) bwd) (env : Pp.env) (tm : S.t) : J.value list = 69 | let rec go env dims (bdry, cons) = 70 | match cons with 71 | | S.CofSplit branches -> 72 | let (_x, envx) = ppenv_bind env `Anon in 73 | List.concat_map (go envx (Snoc (dims, None))) branches 74 | | _ -> 75 | let (_x, envx) = ppenv_bind env `Anon in 76 | let lbl = Format.asprintf "%a" (S.pp envx) cons in 77 | List.map (serialize_label lbl) @@ dim_from_cof (Snoc (dims, None)) bdry 78 | in 79 | match tm with 80 | | S.CofSplit branches -> 81 | let (_x, envx) = ppenv_bind env `Anon in 82 | List.concat_map (go envx dims) branches 83 | | _ -> [] 84 | 85 | let serialize_boundary (ctx : (Ident.t * S.tp) list) (goal : S.tp) : J.t option = 86 | let rec go dims env = 87 | function 88 | | [] -> 89 | begin 90 | match goal with 91 | | S.Sub (_, _, bdry) -> 92 | let dim_names = BwdLabels.to_list @@ BwdLabels.filter_map ~f:Fun.id dims in 93 | let labels = boundary_labels dims env bdry in 94 | let context = Format.asprintf "%a" (S.pp_sequent ~lbl:None ctx) goal in 95 | let msg = `O [ 96 | ("dims", `A (List.map J.string dim_names)); 97 | ("labels", `A labels); 98 | ("context", `String context) 99 | ] in 100 | Some (`O [("DisplayGoal", msg)]) 101 | | _ -> None 102 | end 103 | | (var, var_tp) :: ctx -> 104 | let (dim_name, envx) = ppenv_bind env var in 105 | match var_tp with 106 | | S.TpDim -> go (Snoc (dims, Some dim_name)) envx ctx 107 | | _ -> go (Snoc (dims, None)) envx ctx 108 | in go Emp Pp.Env.emp ctx 109 | 110 | let dispatch_goal ctx goal = 111 | match !server, serialize_boundary ctx goal with 112 | | Some socket, Some msg -> 113 | begin 114 | try 115 | let buf = Buffer.create 65536 in 116 | J.to_buffer ~minify:true buf msg; 117 | let nbytes = Unix.send socket (Buffer.to_bytes buf) 0 (Buffer.length buf) [] in 118 | Debug.print "Sent %n bytes to Server.@." nbytes; 119 | () 120 | with Unix.Unix_error _ -> 121 | Format.eprintf "Cooltt server connection lost.@."; 122 | close () 123 | end 124 | | _, _ -> () 125 | -------------------------------------------------------------------------------- /src/frontend/Server.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | open CodeUnit 3 | 4 | val init : string -> int -> unit 5 | val close : unit -> unit 6 | 7 | val dispatch_goal : (Ident.t * Syntax.tp) list -> Syntax.tp -> unit 8 | -------------------------------------------------------------------------------- /src/frontend/Tactics.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | open CodeUnit 4 | 5 | module D := Domain 6 | module S := Syntax 7 | module RM := Monads.RefineM 8 | module CS := ConcreteSyntax 9 | module R := Refiner 10 | 11 | open Tactic 12 | 13 | (** Determines whether a signature is: 14 | `TotalAll : A total space created by the `total` tactic, where all fields but `fib` are patched 15 | `TotalSome : A total space created by the `total` tactic, where at least one non-`fib` field is *not* patched 16 | `NotTotal : Not a total space created by the `total` tactic 17 | *) 18 | val is_total : D.tele -> [`TotalAll | `TotalSome | `NotTotal] RM.m 19 | 20 | val intro_subtypes_and_total : Chk.tac -> Chk.tac 21 | val intro_implicit_connectives : Chk.tac -> Chk.tac 22 | val elim_implicit_connectives : Syn.tac -> Syn.tac 23 | val elim_implicit_connectives_and_total : Syn.tac -> Syn.tac 24 | val intro_conversions : Syn.tac -> Chk.tac 25 | 26 | (** Brings all fields of a struct into scope, potentially applying a renaming. *) 27 | val open_ : Syn.tac -> (Ident.t -> Ident.t option) -> (var list -> Chk.tac) -> Chk.tac 28 | 29 | (** Brings all fields of a struct into scope, potentially applying a renaming. *) 30 | val open_syn : Syn.tac -> (Ident.t -> Ident.t option) -> (var list -> Syn.tac) -> Syn.tac 31 | 32 | (** Attempt to extract a telescope from a signature. *) 33 | val tele_of_sign : Tp.tac -> Tele.tac 34 | 35 | (** Attempt to extract a kan telescope from a signature code. *) 36 | val kan_tele_of_sign : Chk.tac -> KanTele.tac 37 | 38 | val tac_nary_quantifier : ('a, 'b) R.quantifier -> (Ident.t * 'a) list -> 'b -> 'b 39 | 40 | val match_goal : (D.tp * D.cof * D.tm_clo -> Chk.tac RM.m) -> Chk.tac 41 | 42 | val refine : ((D.tp * D.cof * D.tm_clo) list -> exn option -> Chk.tac) -> Chk.tac 43 | 44 | module Elim : sig 45 | type case_tac = CS.pat * Chk.tac 46 | 47 | val elim 48 | : Chk.tac 49 | -> case_tac list 50 | -> Syn.tac 51 | -> Syn.tac 52 | 53 | val lam_elim 54 | : case_tac list 55 | -> Chk.tac 56 | end 57 | 58 | module Equations : sig 59 | val step : Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Chk.tac -> Syn.tac 60 | val qed : Chk.tac -> Chk.tac -> Syn.tac 61 | end 62 | -------------------------------------------------------------------------------- /src/frontend/dune: -------------------------------------------------------------------------------- 1 | (menhir 2 | (flags --strict --explain --table) 3 | (modules Grammar)) 4 | 5 | (ocamllex Lex) 6 | 7 | (library 8 | (name Frontend) 9 | (libraries kado bantorra cooltt.basis cooltt.core ezjsonm menhirLib) 10 | (preprocess 11 | (pps ppx_deriving.std)) 12 | (flags 13 | (:standard -w -32-37-38 -warn-error -a+31)) 14 | (public_name cooltt.frontend)) 15 | -------------------------------------------------------------------------------- /test/README.md: -------------------------------------------------------------------------------- 1 | ## tests 2 | 3 | There are a handful of examples showing how `cooltt` may be used. 4 | 5 | To run the test suite, simply run 6 | ``` 7 | make test 8 | ``` 9 | 10 | If any of the output has changed, you can update our testing snapshots by using 11 | ``` 12 | make snapshot 13 | ``` 14 | -------------------------------------------------------------------------------- /test/Test.ml: -------------------------------------------------------------------------------- 1 | open Frontend 2 | open Driver 3 | 4 | let header fname = 5 | String.make 20 '-' ^ "[" ^ fname ^ "]" ^ String.make 20 '-' ^ "\n" 6 | 7 | let execute_file fname = 8 | if String.equal (Filename.extension fname) ".cooltt" then 9 | try 10 | let _ = print_string (header fname) in 11 | let opts = { as_file = None; debug_mode = false; server_info = None } in 12 | ignore @@ Driver.load_file opts (`File fname) 13 | with 14 | e -> 15 | Format.eprintf "Could not load file %s@." fname; 16 | raise e 17 | 18 | let () = 19 | let cooltt_files = Sys.readdir "." in 20 | Array.sort String.compare cooltt_files; 21 | Array.iter execute_file cooltt_files 22 | -------------------------------------------------------------------------------- /test/abstract.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | import hlevel 3 | 4 | 5 | abstract 6 | def + : nat → nat → nat := 7 | elim [ 8 | | zero => n => n 9 | | suc {_ => ih} => n => suc {ih n} 10 | ] 11 | 12 | unfold + 13 | abstract 14 | def +0L : (x : nat) → path nat {+ 0 x} x := 15 | x _ => x 16 | 17 | 18 | unfold + 19 | abstract def +SL : (x y : nat) → path nat {+ {suc x} y} {suc {+ x y}} := 20 | x y _ => suc {+ x y} 21 | 22 | abstract 23 | def +0R : (x : nat) → path nat {+ x 0} x := 24 | elim [ 25 | | zero => +0L 0 26 | | suc {x => ih} => 27 | equation nat begin 28 | + {suc x} 0 =[ +SL x 0 ] 29 | suc {+ x 0} =[ i => suc {ih i} ] 30 | suc x 31 | end 32 | ] 33 | 34 | abstract 35 | def +SR : (x y : nat) → path nat {+ x {suc y}} {suc {+ x y}} := 36 | elim [ 37 | | zero => 38 | y => 39 | equation nat begin 40 | + 0 {suc y} =[ +0L {suc y} ] 41 | suc y =[ i => suc {symm nat {+0L y} i} ] 42 | suc {+ 0 y} 43 | end 44 | | suc {x => ih} => 45 | y => 46 | equation nat begin 47 | + {suc x} {suc y} =[ +SL x {suc y} ] 48 | suc {+ x {suc y}} =[ i => suc {ih y i} ] 49 | suc {suc {+ x y}} =[ i => suc {symm nat {+SL x y} i} ] 50 | suc {+ {suc x} y} 51 | end 52 | ] 53 | 54 | abstract 55 | def +A : (x y z : nat) → path nat {+ {+ x y} z} {+ x {+ y z}} := 56 | elim [ 57 | | zero => 58 | y z => 59 | equation nat begin 60 | + {+ 0 y} z =[ i => + {+0L y i} z ] 61 | + y z =[ symm nat {+0L {+ y z}} ] 62 | + 0 {+ y z} 63 | end 64 | | suc {x => ih} => 65 | y z => 66 | equation nat begin 67 | + {+ {suc x} y} z =[ i => + {+SL x y i} z ] 68 | + {suc {+ x y}} z =[ +SL {+ x y} z ] 69 | suc {+ {+ x y} z} =[ i => suc {ih y z i} ] 70 | suc {+ x {+ y z}} =[ symm nat {+SL x {+ y z}} ] 71 | + {suc x} {+ y z} 72 | end 73 | ] 74 | 75 | 76 | /- next we demonstrate unfolding in the *types* of declarations 77 | -/ 78 | 79 | axiom nat∷set : set # [tp := nat] 80 | 81 | def foo (p : path nat {+ 0 0} 0) : unfold + in path {path nat {+ 0 0} 0} p {_ => 0} := 82 | unfold + has-hlevel in 83 | nat∷set 0 0 p {_ => 0} 84 | 85 | -- A simple example for Daniel G. 86 | 87 | def two : nat := + 1 1 88 | 89 | def test : path nat two 2 := 90 | unfold two + in 91 | i => 2 92 | 93 | 94 | def test2 : path-p {i => path nat two {test i}} {_ => two} test := 95 | i j => 96 | unfold two + in 97 | 2 98 | 99 | 100 | 101 | def abs-test : nat := 102 | suc {abstract abs-test::foo ← 41} 103 | 104 | #print abs-test 105 | 106 | unfold abs-test::foo 107 | #print abs-test 108 | 109 | 110 | -------------------------------------------------------------------------------- /test/algebra.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | import nat 3 | 4 | 5 | def monoid : type := 6 | sig 7 | def t : type 8 | def op : t → t → t 9 | def emp : t 10 | def opL : (u : t) → path t {op emp u} u 11 | def opR : (u : t) → path t {op u emp} u 12 | def opA : (u v w : t) → path t {op {op u v} w} {op u {op v w}} 13 | end 14 | 15 | 16 | def commutative-monoid : type := 17 | sig 18 | include monoid 19 | def opC : (u v : t) → path t {op u v} {op v u} 20 | end 21 | 22 | def multiplicative-monoid : type := 23 | sig 24 | include monoid 25 | renaming [op → mul; emp → one; opL → mulL; opR → mulR; opA → mulA] 26 | end 27 | 28 | def additive-monoid : type := 29 | sig 30 | include monoid 31 | renaming [op → add; emp → zer; opL → addL; opR → addR; opA → addA] 32 | end 33 | 34 | def abelian-group : type := 35 | sig 36 | include additive-monoid 37 | def neg : t → t 38 | def addC : (u v : t) → path t {add u v} {add v u} 39 | def add-neg : (u : t) → path t {add {neg u} u} zer 40 | end 41 | 42 | def ring : type := 43 | sig 44 | def t : type 45 | include abelian-group # [ t ::= t ] 46 | include multiplicative-monoid # [ t ::= t ] 47 | end 48 | 49 | def monoid/nat : monoid # [t := nat] := 50 | struct 51 | def op := + 52 | def emp := 0 53 | def opL := +-left-unit 54 | def opR := +-right-unit 55 | def opA := +-assoc 56 | end 57 | 58 | #print monoid/nat 59 | 60 | def monoid/nat/+ : monoid # [t := nat, op := +] := 61 | struct 62 | def emp := 0 63 | def opL := +-left-unit 64 | def opR := +-right-unit 65 | def opA := +-assoc 66 | end 67 | 68 | def additive-monoid/nat : additive-monoid # [ t := nat ] := 69 | struct 70 | include monoid/nat 71 | renaming [op → add; emp → zer; opL → addL; opR → addR; opA → addA] 72 | end 73 | 74 | #print additive-monoid/nat 75 | 76 | def monoid/unit : monoid # [t := unit] := 77 | struct 78 | def op := _ _ => 0 79 | def emp := 0 80 | def opL := _ _ => 0 81 | def opR := _ _ => 0 82 | def opA := _ _ _ _ => 0 83 | end 84 | 85 | def abelian-group/unit : abelian-group # [t := unit] := 86 | struct 87 | include monoid/unit 88 | renaming [op → add; emp → zer; opL → addL; opR → addR; opA → addA] 89 | def neg := _ => 0 90 | def addC := _ _ _ => 0 91 | def add-neg := _ _ => 0 92 | end 93 | 94 | def ring/unit : ring # [t := unit] := 95 | struct 96 | include abelian-group/unit 97 | include monoid/unit 98 | renaming [op → mul; emp → one; opL → mulL; opR → mulR; opA → mulA] 99 | end -------------------------------------------------------------------------------- /test/base-types.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | abstract 4 | def empty : type := path nat 0 1 5 | 6 | abstract 7 | def abort (P : empty -> type) (e : empty) : P e := 8 | unfold empty in 9 | let myelim : nat -> type := elim [ zero => unit | suc _ => P e ] in 10 | coe {i => myelim {e i}} 0 1 ⋆ 11 | 12 | abstract 13 | def sum (A B : type) : type := 14 | let fam∷shifted : nat -> type := elim [ zero => B | suc _ => empty ] in 15 | let fam : nat -> type := elim [ zero => A | suc n => fam∷shifted n ] in 16 | (n : nat) * fam n 17 | 18 | unfold sum 19 | def inl (A B : type) (x : A) : sum A B := 20 | [ 0 , x ] 21 | 22 | unfold sum 23 | def inr (A B : type) (y : B) : sum A B := 24 | [ 1 , y ] 25 | 26 | def case (A B : type) (P : sum A B -> type) 27 | (P/inl : (a : A) -> P {inl A B a}) 28 | (P/inr : (b : B) -> P {inr A B b}) 29 | (s : sum A B) : P s 30 | := 31 | let fam/shifted : nat -> type := elim [ zero => B | suc _ => empty ] in 32 | let curried/shifted : (n : nat) (e : fam/shifted n) -> unfold sum in P [ suc n , e ] := 33 | unfold inr in 34 | elim [ zero => P/inr | suc n => e => abort {_ => P [ suc {suc n} , e ]} e ] 35 | in 36 | let fam : nat -> type := elim [ zero => A | suc n => fam/shifted n ] in 37 | let curried : (n : nat) (e : fam n) -> unfold sum in P [ n , e ] := 38 | unfold sum inl in 39 | elim [ zero => P/inl | suc n => curried/shifted n ] 40 | in 41 | unfold sum in 42 | curried {fst s} {snd s} 43 | 44 | #print case 45 | -------------------------------------------------------------------------------- /test/circle.cooltt: -------------------------------------------------------------------------------- 1 | def path (A : type) (a b : A) : type := 2 | ext i => A with [i=0 => a | i=1 => b] 3 | 4 | def Ω1s1 : type := 5 | path circle base base 6 | 7 | def loopn : nat -> Ω1s1 := 8 | elim [ 9 | | zero => _ => base 10 | | suc {n => loopn} => 11 | i => 12 | hcom circle 0 1 {∂ i} {k => 13 | [ k=0 => loopn i 14 | | i=0 => base 15 | | i=1 => loop k 16 | ] 17 | } 18 | ] 19 | 20 | #normalize {loopn 100} 21 | -------------------------------------------------------------------------------- /test/coercion.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | -- This is the Cartesian coercion operator. 4 | def _ (A : 𝕀 → type) (src : 𝕀) (trg : 𝕀) (x : A src) : sub {A trg} {src=trg} x := 5 | coe A src trg x 6 | 7 | -- A special case of coercion is that if we have a path of types A0 = A1, we can 8 | -- cast/coerce (x : A0) to an element of A1. 9 | def coe/fwd (A : 𝕀 → type) (x : A 0) : A 1 := 10 | coe A 0 1 x 11 | 12 | -- ...and conversely. 13 | def coe/bwd (A : 𝕀 → type) (x : A 1) : A 0 := 14 | coe A 1 0 x 15 | 16 | -- By combining coe with ap (the fact that functions respect paths), we can show 17 | -- that if we have a path (a0 = a1 : A) and an A-indexed family B of types, then 18 | -- we can transport (x : B a0) to an element of (B a1). 19 | def transport/fwd (A : type) (B : A → type) (p : 𝕀 → A) (x : B {p 0}) : B {p 1} := 20 | coe/fwd {i => B {p i}} x 21 | 22 | -- If we coerce (x : A0) to an interval variable, we get a dependent path from x 23 | -- to the coercion of x. That's because of the side condition that coe is the 24 | -- identity function when src=trg. 25 | def _ (A : 𝕀 → type) (x : A 0) : path-p A x {coe/fwd A x} := 26 | i => coe A 0 i x 27 | 28 | -- Here's another use of coercing to an interval variable. If we have a 29 | -- homogeneous path in A0, we can turn it into a heterogeneous path in A from 30 | -- its left endpoint to the coercion of its right endpoint. 31 | def heterogenize (A : 𝕀 → type) (p : 𝕀 → A 0) : path-p A {p 0} {coe/fwd A {p 1}} := 32 | i => coe A 0 i {p i} 33 | 34 | -- Dually, we can coerce *from* an interval variable to turn a heterogeneous 35 | -- path into a homogeneous one. 36 | def homogenize (A : 𝕀 → type) (p : (i : 𝕀) → A i) : path {A 1} {coe/fwd A {p 0}} {p 1} := 37 | i => coe A i 1 {p i} 38 | -------------------------------------------------------------------------------- /test/com.cooltt: -------------------------------------------------------------------------------- 1 | def mycoe/fun 2 | (A : (i : 𝕀) → type) (B : (i: 𝕀) → type) 3 | (coe/A : (r : 𝕀) (x : A r) (i : 𝕀) → sub {A i} {i=r} x) 4 | (coe/B : (r : 𝕀) (x : B r) (i : 𝕀) → sub {B i} {i=r} x) 5 | (r : 𝕀) (f : (_ : A r) → B r) (i : 𝕀) 6 | : sub {(_ : A i) → B i} {i=r} f 7 | := 8 | x => 9 | coe/B r {f {coe/A i x r}} i 10 | 11 | def mycom/fun 12 | (A B : 𝕀 → type) 13 | (com/A : (r : 𝕀) (φ : 𝔽) (p : (i : 𝕀) → [i=r ∨ φ] → A i) (i : 𝕀) → sub {A i} {i=r ∨ φ} {p i}) 14 | (com/B : (r : 𝕀) (φ : 𝔽) (p : (i : 𝕀) → [i=r ∨ φ] → B i) (i : 𝕀) → sub {B i} {i=r ∨ φ} {p i}) 15 | (r : 𝕀) (φ : 𝔽) (p : (i : 𝕀) → [i=r ∨ φ] → A i → B i) (i : 𝕀) 16 | : sub {(_ : A i) → B i} {i=r ∨ φ} {p i} 17 | := 18 | x => 19 | com/B r φ {j => p j {com/A i ⊥ {_ => x} j}} i 20 | 21 | #normalize mycom/fun 22 | 23 | def coe/intro (A : 𝕀 → type) (r r' : 𝕀) (x : A r) : sub {A r'} {r=r'} x := 24 | coe A r r' x 25 | 26 | def coe/pi 27 | (A : 𝕀 → type) (B : (i : 𝕀) → A i → type) 28 | (r r' : 𝕀) 29 | (f : (x : A r) → B r x) 30 | : sub {(x : A r') → B r' x} ⊤ {x => coe {i => B i {coe A r' i x}} r r' {f {coe A r' r x}}} 31 | := 32 | coe {i => (x : A i) → B i x} r r' f 33 | 34 | #normalize coe/pi 35 | 36 | def coe/sigma 37 | (A : 𝕀 → type) (B : (i : 𝕀) → A i → type) 38 | (r r' : 𝕀) 39 | (p : (x : A r) × B r x) 40 | : sub {(x : A r') × B r' x} ⊤ [coe A r r' {fst p}, coe {i => B i {coe A r i {fst p}}} r r' {snd p}] 41 | := 42 | coe {i => (x : A i) × B i x} r r' p 43 | 44 | #normalize coe/sigma 45 | 46 | def pathd (A : 𝕀 → type) (a : A 0) (b : A 1) : type := 47 | ext i => A i with [i=0 => a | i=1 => b] 48 | 49 | 50 | def coe/pathd 51 | (A : 𝕀 -> 𝕀 -> type) 52 | (r r' : 𝕀) 53 | (a : (i : 𝕀) -> A i 0) 54 | (b : (i : 𝕀) -> A i 1) 55 | (m : pathd {A r} {a r} {b r}) 56 | : sub {pathd {A r'} {a r'} {b r'}} ⊤ {j => 57 | com {i => A i j} r r' {∂ j} {i => 58 | [j=0 => a i | j=1 => b i | i=r => m j] 59 | } 60 | } 61 | := 62 | coe {i => pathd {A i} {a i} {b i}} r r' m 63 | 64 | #normalize coe/pathd 65 | 66 | def hcom/intro 67 | (A : type) (r r' : 𝕀) (φ : 𝔽) 68 | (p : (i : 𝕀) → [i=r ∨ φ] → A) 69 | : sub A {r=r' ∨ φ} {p r'} 70 | := 71 | hcom A r r' φ p 72 | 73 | def hcom/fun 74 | (A B : type) (r r' : 𝕀) (φ : 𝔽) 75 | (p : (i : 𝕀) → [i=r ∨ φ] → A → B) 76 | : sub {A → B} ⊤ {x => hcom B r r' φ {j => p j x}} 77 | := 78 | hcom {A → B} r r' φ p 79 | 80 | #normalize hcom/fun 81 | 82 | def com/intro 83 | (A : 𝕀 → type) (r r' : 𝕀) (φ : 𝔽) 84 | (p : (i : 𝕀) → [i=r ∨ φ] → A i) 85 | : sub {A r'} {r=r' ∨ φ} {p r'} 86 | := 87 | com A r r' φ p 88 | 89 | #normalize com/intro 90 | 91 | def com/decomposition 92 | (A : 𝕀 → type) (r r' : 𝕀) (φ : 𝔽) 93 | (p : (i : 𝕀) → [i=r ∨ φ] → A i) 94 | : sub {A r'} ⊤ {hcom {A r'} r r' φ {j => coe A j r' {p j}}} 95 | := 96 | com A r r' φ p 97 | -------------------------------------------------------------------------------- /test/cool-total-space.cooltt: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | def fully-patched (fam : sig [x : nat] -> type) (fib : fam {struct [x := 0]}) : fam # [x := 0] := 5 | fib 6 | #print fully-patched 7 | 8 | def not-fully-patched (fam : sig [x : nat] -> type) (fib : fam {struct [x := 0]}) : fam := 9 | struct [x := 0, fib := fib] 10 | #print not-fully-patched 11 | 12 | def no-insert-fib (fam : sig [x : nat] -> type) (total : fam) : nat := 13 | total.x 14 | #print no-insert-fib 15 | 16 | def insert-fib-plain (fam : sig [x : nat] -> type) (total : fam) : fam {struct [x := total.x]} := 17 | total 18 | #print insert-fib-plain 19 | 20 | def insert-fib-pi : sig [fam : sig [x : nat] -> type, test : fam -> nat] := 21 | struct 22 | def fam := _ => nat -> nat 23 | def test := total => total 0 24 | end 25 | #print insert-fib-pi 26 | 27 | def insert-fib-sg : sig [fam : sig [x : nat] -> type, test : fam -> nat] := 28 | struct 29 | def fam := _ => nat * nat 30 | def test := total => fst total 31 | end 32 | #print insert-fib-sg 33 | 34 | def no-insert-fib-record : sig [fam : sig [x : nat] -> type, test : fam -> nat] := 35 | struct 36 | def fam := _ => sig [y : nat] 37 | def test := total => total.fib.y 38 | end 39 | 40 | #print no-insert-fib-record 41 | 42 | def test-hole (fam : sig [x : nat] -> type) : fam # [x := 0] := ? 43 | -------------------------------------------------------------------------------- /test/cooltt-lib: -------------------------------------------------------------------------------- 1 | { "format": "1.0.0" } 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names test) 3 | (libraries cooltt.frontend)) 4 | 5 | (rule 6 | (target test.output) 7 | (deps 8 | (glob_files ./*.cooltt) 9 | (glob_files ./cooltt-lib)) 10 | (action (with-stdout-to %{target} (run ./test.exe)))) 11 | 12 | (rule 13 | (alias runtest) 14 | (action 15 | (diff test.expected test.output))) 16 | 17 | (rule 18 | (alias test-display) 19 | (deps (universe)) 20 | (action (cat test.output))) 21 | -------------------------------------------------------------------------------- /test/elab.cooltt: -------------------------------------------------------------------------------- 1 | def boundary-test : (i : 𝕀) → [∂ i] → nat := 2 | i => 3 | [ i=1 => 5 4 | | i=0 => 19 5 | ] 6 | 7 | #normalize boundary-test 8 | 9 | def reflexivity : (A : type) (a : A) (i : 𝕀) → A := 10 | A a _ => a 11 | 12 | 13 | def pi-code-test : type := (x : nat) → nat 14 | 15 | def foo : pi-code-test := 16 | x => x 17 | 18 | #normalize pi-code-test 19 | 20 | 21 | def simple-let : 22 | (A : type) (a : A) -> A 23 | := 24 | A a => 25 | let b : A := a in 26 | b 27 | 28 | #normalize simple-let 29 | 30 | 31 | def hole-in-type : 32 | (x y z : nat) 33 | → ?tyhole 34 | := 35 | y z => ?tmhole 36 | 37 | def path (A : type) (a b : A) : type := 38 | ext i => A with [i=0 => a | i=1 => b] 39 | 40 | def bar : (x : nat) → (y : nat) × path nat x y := 41 | x => 42 | [x, ?hole1] 43 | -------------------------------------------------------------------------------- /test/equation.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | def equational/trans (a : type) (x y z : a) (p : path a x y) (q : path a y z) : path a x z := 4 | equation a begin 5 | x =[ p ] 6 | y =[ q ] 7 | z 8 | end 9 | 10 | #print equational/trans 11 | 12 | def equational/refl/nat : path nat 4 4 := 13 | equation nat begin 14 | 4 =[] 15 | 4 16 | end 17 | 18 | #print equational/refl/nat 19 | -------------------------------------------------------------------------------- /test/evan.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | def refl2 (A : type) (p : (i : 𝕀) → A) : sub {path {path A {p 0} {p 1}} p p} ⊤ {_ => p} 4 | := 5 | _ => p 6 | 7 | def test (A : type) (p : (i : 𝕀) → A) : (j : 𝕀) → path A {p 0} {p 1} 8 | := 9 | j => refl2 A p j 10 | -------------------------------------------------------------------------------- /test/export.cooltt: -------------------------------------------------------------------------------- 1 | def a1 : nat := 0 2 | def a2 : nat := 10 3 | def a3 : nat := 20 4 | 5 | repack {} -- un-export all bindings 6 | 7 | -- export a from what's currently visible 8 | export a1 9 | repack [?] -- check all exported bindings 10 | 11 | -- export a2 and a3 12 | export { a2, a3 } 13 | repack [?] -- check all exported bindings 14 | 15 | -- export a1 again, but under the name b1 16 | export [ a1; a1 -> b1 ] 17 | repack [?] -- check all exported bindings 18 | 19 | -- export nothing 20 | export {} 21 | repack [?] -- check all exported bindings 22 | 23 | -- export a2 as a3, shadowing the existing a3 24 | !export [ a2; a2 -> a3 ] 25 | repack [?] -- check all exported bindings 26 | 27 | -- check all visible bindings 28 | view [?] 29 | -------------------------------------------------------------------------------- /test/groupoid-laws.cooltt: -------------------------------------------------------------------------------- 1 | -- J-like proofs without carrying around J-on-refl paths everywhere 2 | -- (by carrying around cofibrations everywhere instead) 3 | import prelude 4 | 5 | -- pretend we have CCHM Id-types 6 | abstract 7 | def special-j (A : type) (x : A) (B : (φ : 𝔽) → {(i : 𝕀) → sub A {i=0 ∨ φ} x} → type) 8 | (d : B ⊤ {_ => x}) 9 | (φ : 𝔽) (p : (i : 𝕀) → sub A {i=0 ∨ φ} x) 10 | : sub {B φ p} φ d 11 | := 12 | let filler : 𝕀 → 𝕀 → A := 13 | j i => 14 | hcom A 0 i {∂ j ∨ φ} {i => 15 | [ i=0 ∨ j=0 ∨ φ => p 0 16 | | j=1 => p i 17 | ] 18 | } 19 | in 20 | com {j => B {φ ∨ j=0} {filler j}} 0 1 {φ} {j => d} 21 | 22 | shadowing def trans (A : type) (p : (i : 𝕀) → A) 23 | : (φ : 𝔽) (q : (i : 𝕀) → sub A {i=0 ∨ φ} {p 1}) 24 | → sub {path A {p 0} {q 1}} φ p 25 | := 26 | special-j A {p 1} {_ q => path A {p 0} {q 1}} p 27 | 28 | abstract 29 | def assoc (A : type) 30 | (p : (i : 𝕀) → A) 31 | (φ : 𝔽) (q : (i : 𝕀) → sub A {i=0 ∨ φ} {p 1}) 32 | : (ψ : 𝔽) (r : (i : 𝕀) → sub A {i=0 ∨ ψ} {q 1}) 33 | → sub {path {path A {p 0} {r 1}} {trans A {trans A p φ q} ψ r} {trans A p {φ ∧ ψ} {trans A q ψ r}}} 34 | ψ {_ => trans A p φ q} 35 | := 36 | special-j A {q 1} 37 | {ψ r => path {path A {p 0} {r 1}} {trans A {trans A p φ q} ψ r} {trans A p {φ ∧ ψ} {trans A q ψ r}}} 38 | {_ => trans A p φ q} 39 | 40 | def pentagonType (A : type) 41 | (p : (i : 𝕀) → A) 42 | (φ : 𝔽) (q : (i : 𝕀) → sub A {i=0 ∨ φ} {p 1}) 43 | (ψ : 𝔽) (r : (i : 𝕀) → sub A {i=0 ∨ ψ} {q 1}) 44 | (χ : 𝔽) (s : (i : 𝕀) → sub A {i=0 ∨ χ} {r 1}) 45 | : type 46 | := 47 | path 48 | {path 49 | {path A {p 0} {s 1}} 50 | {trans A {trans A {trans A p φ q} ψ r} χ s} 51 | {trans A p {φ ∧ ψ ∧ χ} {trans A q {ψ ∧ χ} {trans A r χ s}}}} 52 | {trans {path A {p 0} {s 1}} 53 | {assoc A {trans A p φ q} ψ r χ s} 54 | {ψ ∧ χ} 55 | {assoc A p φ q {ψ ∧ χ} {trans A r χ s}}} 56 | {trans {path A {p 0} {s 1}} 57 | {j => trans A {assoc A p φ q ψ r j} χ s} 58 | {φ ∧ ψ ∧ χ} 59 | {trans {path A {p 0} {s 1}} 60 | {assoc A p {φ ∧ ψ} {trans A q ψ r} χ s} 61 | {φ ∧ ψ ∧ χ} 62 | {j => trans A p {φ ∧ ψ ∧ χ} {assoc A q ψ r χ s j}}}} 63 | 64 | def pentagon (A : type) 65 | (p : (i : 𝕀) → A) 66 | (φ : 𝔽) (q : (i : 𝕀) → sub A {i=0 ∨ φ} {p 1}) 67 | (ψ : 𝔽) (r : (i : 𝕀) → sub A {i=0 ∨ ψ} {q 1}) 68 | : (χ : 𝔽) (s : (i : 𝕀) → sub A {i=0 ∨ χ} {r 1}) 69 | → pentagonType A p φ q ψ r χ s 70 | := 71 | special-j A {r 1} 72 | {pentagonType A p φ q ψ r} 73 | {special-j A {q 1} 74 | {ψ r => pentagonType A p φ q ψ r ⊤ {_ => r 1}} 75 | {special-j A {p 1} 76 | {φ q => pentagonType A p φ q ⊤ {_ => q 1} ⊤ {_ => q 1}} 77 | {_ _ => p} 78 | φ q} 79 | ψ r} 80 | 81 | -- get the standard functions by instantiating at ⊥ everywhere 82 | 83 | def trans' (A : type) (p : (i : 𝕀) → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) 84 | : path A {p 0} {q 1} 85 | := 86 | trans A p ⊥ q 87 | 88 | abstract 89 | def assoc' (A : type) 90 | (p : (i : 𝕀) → A) 91 | (q : (i : 𝕀) → sub A {i=0} {p 1}) 92 | (r : (i : 𝕀) → sub A {i=0} {q 1}) 93 | : path {path A {p 0} {r 1}} {trans' A {trans' A p q} r} {trans' A p {trans' A q r}} 94 | := 95 | assoc A p ⊥ q ⊥ r 96 | 97 | unfold assoc' 98 | def pentagon' (A : type) 99 | (p : (i : 𝕀) → A) 100 | (q : (i : 𝕀) → sub A {i=0} {p 1}) 101 | (r : (i : 𝕀) → sub A {i=0} {q 1}) 102 | (s : (i : 𝕀) → sub A {i=0} {r 1}) 103 | : path 104 | {path 105 | {path A {p 0} {s 1}} 106 | {trans' A {trans' A {trans' A p q} r} s} 107 | {trans' A p {trans' A q {trans' A r s}}}} 108 | {trans' {path A {p 0} {s 1}} 109 | {assoc' A {trans' A p q} r s} 110 | {assoc' A p q {trans' A r s}}} 111 | {trans' {path A {p 0} {s 1}} 112 | {j => trans' A {assoc' A p q r j} s} 113 | {trans' {path A {p 0} {s 1}} 114 | {assoc' A p {trans' A q r} s} 115 | {j => trans' A p {assoc' A q r s j}}}} 116 | := 117 | pentagon A p ⊥ q ⊥ r ⊥ s 118 | 119 | def test (A : type) 120 | (p : (i : 𝕀) → A) 121 | (q : (i : 𝕀) → sub A {i=0} {p 1}) 122 | (r : (i : 𝕀) → sub A {i=0} {q 1}) 123 | (s : (i : 𝕀) → sub A {i=0} {r 1}) 124 | : (j : 𝕀) → path A {p 0} {r 1} 125 | := 126 | j => assoc A p ⊥ q ⊥ r j 127 | 128 | #print test 129 | -------------------------------------------------------------------------------- /test/hcom-type.cooltt: -------------------------------------------------------------------------------- 1 | def v-test (r : 𝕀) (A : type) : type := 2 | V r A A 3 | [ x => x 4 | , x => 5 | [ [x, _ => x] 6 | , p i => 7 | let aux := hfill A 1 {∂ i} {k => [ k=1 => x | i=1 => {snd p} k | i=0 => x ] } in 8 | [aux 0, aux] 9 | ] 10 | ] 11 | 12 | #print v-test 13 | 14 | def hcom-type (i : 𝕀) : type := 15 | hcom type 0 1 {∂ i} {j => [j=0 => v-test i nat | ∂ i => nat]} 16 | 17 | def hcom-box (i : 𝕀) : hcom-type i := 18 | [?asdf, [?,?]] 19 | 20 | 21 | -------------------------------------------------------------------------------- /test/hlevel.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | 4 | abstract 5 | def has-hlevel : nat → type → type := 6 | let aux : nat → type → type := 7 | elim [ 8 | | zero => A => (a a' : A) → path A a a' 9 | | suc {l => ih} => 10 | A => (a : A) (a' : A) → ih {path A a a'} 11 | ] 12 | in 13 | elim [ 14 | | zero => A => sig [pt : A, path : (pt' : A) → path A pt pt'] 15 | | suc l => aux l 16 | ] 17 | 18 | def htype : sig [lvl : nat, tp : type] → type := a => open a in has-hlevel lvl tp 19 | 20 | def contr : type := htype # [lvl := 0] 21 | def prop : type := htype # [lvl := 1] 22 | def set : type := htype # [lvl := 2] 23 | def groupoid : type := htype # [lvl := 3] 24 | 25 | #print prop 26 | #normalize prop 27 | 28 | abstract 29 | def contr-prop (A : contr) : prop # [tp := A.tp] := 30 | unfold has-hlevel in pt pt' => trans {A.tp} {symm {A.tp} {A.fib.path pt}} {A.fib.path pt'} 31 | 32 | abstract 33 | def prop-set (A : prop) : set # [tp := A.tp] := 34 | unfold has-hlevel in a b p q i j => 35 | hcom {A.tp} 0 1 {∂ i ∨ ∂ j} {k => 36 | [ k=0 ∨ ∂ j ∨ i=0 => A a {p j} k 37 | | i=1 => A a {q j} k 38 | ] 39 | } 40 | 41 | 42 | abstract 43 | def raise-hlevel (A : htype) : htype # [lvl := suc {A.lvl}, tp := A.tp] := 44 | let aux : (m : nat) (B : htype # [lvl := suc m]) → htype # [lvl := suc {suc m}, tp := B.tp] := 45 | elim [ 46 | | zero => prop-set 47 | | suc {l => ih} => B => 48 | unfold has-hlevel in 49 | b b' => {ih {struct [tp := path {B.tp} b b', fib := B b b']}} 50 | ] 51 | in 52 | let aux2 : (m : nat) (B : htype # [lvl := m]) → htype # [lvl := suc m, tp := B.tp] := 53 | elim [ 54 | | zero => contr-prop 55 | | suc l => aux l 56 | ] 57 | in 58 | aux2 {A.lvl} A 59 | 60 | 61 | abstract 62 | def prop-hlevel : (l : nat) (A : prop) → htype # [lvl := suc l, tp := A.tp] := 63 | elim [ 64 | | zero => A => A 65 | | suc {l => ih} => A => raise-hlevel {ih A} 66 | ] 67 | 68 | 69 | abstract 70 | def path-hlevel : (l : nat) (A : htype # [lvl := suc l]) (a a' : A.tp) → htype # [lvl := l, tp := path {A.tp} a a'] := 71 | elim [ 72 | | zero => A a a' => 73 | unfold has-hlevel in 74 | struct [pt := A a a', path := {prop-set A} a a' {A a a'}] 75 | 76 | | suc l => 77 | unfold has-hlevel in 78 | A => A 79 | ] 80 | 81 | abstract 82 | def path-based-contr (A : type) (a : A) : contr # [tp := (x : A) × path A a x] := 83 | unfold has-hlevel in 84 | struct 85 | def pt := [a, i => a] 86 | def path := x i => 87 | let aux : 𝕀 → A := j => 88 | hcom A 0 j {∂ i} {k => 89 | [ k=0 ∨ i=0 => a 90 | | i=1 => {snd x} k 91 | ] 92 | } 93 | in 94 | [aux 1, aux] 95 | end 96 | -------------------------------------------------------------------------------- /test/holes.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | -- Test that the cone of silence tactic works 4 | def incomplete-trans₁ (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) : path A {p 0} {q 1} := 5 | i => {! !} 6 | 7 | def incomplete-trans₂ (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) : path A {p 0} {q 1} := 8 | i => {! trans/filler A ? ? 1 i !} 9 | 10 | def incomplete-trans₃ (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) : path A {p 0} {q 1} := 11 | i => {! trans/filler A p q 0 i !} 12 | 13 | def incomplete-trans₄ (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) : path A {p 0} {q 1} := 14 | i => {! trans/filler A p q 1 i !} 15 | 16 | def incomplete-trans₅ (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) : path A {p 0} {q 1} := 17 | i => {! trans/filler A ?_h1 ?h2 1 i !} 18 | 19 | def incomplete-trans₆ (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) : path A {p 0} {q 1} := 20 | i => {! trans/filler A ?h3 ?_h4 1 i !} 21 | 22 | -- Test that the cone of silence tactic still triggers failures when it ought to 23 | #fail def cone-of-silence-hcom (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) : path A {p 0} {q 1} := 24 | i => hcom A 0 1 {∂ i} {!!} 25 | -------------------------------------------------------------------------------- /test/import.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | [ unit -> u -- rename unit to u 3 | ; {:: -> p1, -> p2} -- take the union of two prefix modifiers; u becomes p1::u and p2::u, for example 4 | ; p2::[⋆ -> q::t] -- rename p2::⋆ to p2::q::t 5 | ; [[[[[{[]};{[{[[];[]]}]}]]]]] -- no op 6 | ; p1::!u -- remove p1::u 7 | ; ! p2::path -- remove p2::path 8 | ; p2::?cool -- print out the bindings under p2 9 | ; ?all -- print all the bindings to be imported 10 | ] 11 | import prelude [unit; unit -> p1::u] -- re-introduce p1::u; would err if p1::u is already there 12 | import prelude -- comment here 13 | /- 14 | comment here 15 | -/ 16 | [] -- import everything, unqualified 17 | import prelude /- comment -/{} -- import nothing 18 | import prelude [ ! ] -- import nothing (the bang removes the entire tree) 19 | import /- comment -/prelude [ ! :: ] -- import nothing 20 | import /- comment -/ prelude [?; !] -- print out all the bindings but then import nothing 21 | 22 | import prelude [cong; cong -> cool::cong] 23 | 24 | def cool-tt : p1::u := p2::q::t 25 | #print cool-tt 26 | 27 | view [p2::?] -- check all visible bindings under p2 28 | -------------------------------------------------------------------------------- /test/inequality.cooltt: -------------------------------------------------------------------------------- 1 | axiom i : 𝕀 2 | axiom j : 𝕀 3 | axiom k : 𝕀 4 | 5 | axiom ij : [i <= j] 6 | axiom jk : [j <= k] 7 | 8 | axiom foo : ext => nat with [i <= k => zero ] 9 | def bar : ext => nat with [0=0 => zero] := foo 10 | 11 | #print bar 12 | -------------------------------------------------------------------------------- /test/isos.cooltt: -------------------------------------------------------------------------------- 1 | -- "stdlib" 2 | import prelude 3 | 4 | -- isomorphisms 5 | 6 | def iso : type := 7 | sig 8 | def A : type 9 | def B : type 10 | def fwd : A → B 11 | def bwd : B → A 12 | def fwd-bwd : (b : B) → path B {fwd {bwd b}} b 13 | def bwd-fwd : (a : A) → path A {bwd {fwd a}} a 14 | end 15 | 16 | 17 | abstract 18 | def iso/refl (A : type) : iso # [A := A, B := A] := 19 | struct 20 | def fwd := x => x 21 | def bwd := x => x 22 | def fwd-bwd := b i => b 23 | def bwd-fwd := a i => a 24 | end 25 | 26 | abstract 27 | def iso/symm (I : iso) : iso # [A := I.B, B := I.A] := 28 | open I in 29 | struct 30 | def fwd := bwd 31 | def bwd := fwd 32 | def fwd-bwd := bwd-fwd 33 | def bwd-fwd := fwd-bwd 34 | end 35 | 36 | 37 | abstract 38 | def iso/trans (I1 : iso) (I2 : iso # [ A := I1.B ]) : iso # [A := I1.A, B := I2.B] := 39 | struct 40 | def fwd := a => I2.fwd {I1.fwd a} 41 | def bwd := b => I1.bwd {I2.bwd b} 42 | def fwd-bwd := b => trans {I2.B} {j => I2.fwd {I1.fwd-bwd {I2.bwd b} j}} {I2.fwd-bwd b} 43 | def bwd-fwd := a => trans {I1.A} {j => I1.bwd {I2.bwd-fwd {I1.fwd a} j}} {I1.bwd-fwd a} 44 | end 45 | 46 | -- pair isos 47 | 48 | abstract 49 | def iso/pair/comm (X Y : type) : iso # [A := X × Y, B := Y × X] := 50 | struct 51 | def fwd := ab => [snd ab, fst ab] 52 | def bwd := ba => [snd ba, fst ba] 53 | def fwd-bwd := ba i => ba 54 | def bwd-fwd := ab i => ab 55 | end 56 | 57 | abstract 58 | def iso/pair/assoc (X Y Z : type) : iso # [A := {X × Y × Z}, B := {{X × Y} × Z}] := 59 | struct 60 | def fwd := a_bc => [[fst a_bc, fst {snd a_bc}], snd {snd a_bc}] 61 | def bwd := ab_c => [fst {fst ab_c}, [snd {fst ab_c}, snd ab_c]] 62 | def fwd-bwd := ab_c i => ab_c 63 | def bwd-fwd := a_bc i => a_bc 64 | end 65 | 66 | abstract 67 | def iso/pair/unit (X : type) : iso # [A := X × unit, B := X] := 68 | struct 69 | def fwd := au => fst au 70 | def bwd := a => [a, ⋆] 71 | def fwd-bwd := a i => a 72 | def bwd-fwd := au i => au 73 | end 74 | 75 | 76 | -- function isos 77 | 78 | def curry (A B C : type) : {{A × B} → C} → {A → B → C} := 79 | f a b => f [a , b] 80 | 81 | def uncurry (A B C : type) : {A → B → C} → {{A × B} → C} := 82 | f ab => f {fst ab} {snd ab} 83 | 84 | def iso/curry (X Y Z : type) : iso # [A := X → Y → Z, B := {X × Y} → Z] := 85 | struct 86 | def fwd := uncurry X Y Z 87 | def bwd := curry X Y Z 88 | def fwd-bwd := ab_c i => ab_c 89 | def bwd-fwd := a_b_c i => a_b_c 90 | end 91 | 92 | def iso/lhs (C : type) (I : iso) : iso # [A := {I.A} → C, B := {I.B} → C] := 93 | open I in 94 | struct 95 | def fwd := ac b => ac {bwd b} 96 | def bwd := bc a => bc {fwd a} 97 | def fwd-bwd := bc i b => bc {fwd-bwd b i} 98 | def bwd-fwd := ac i a => ac {bwd-fwd a i} 99 | end 100 | 101 | def iso/rhs (C : type) (I : iso) : iso # [A := C → {I.A}, B := C → {I.B} ] := 102 | open I in 103 | struct 104 | def fwd := ca c => fwd {ca c} 105 | def bwd := cb c => bwd {cb c} 106 | def fwd-bwd := cb i c => fwd-bwd {cb c} i 107 | def bwd-fwd := ca i c => bwd-fwd {ca c} i 108 | end 109 | 110 | def iso/flip (X Y Z : type) : iso # [A := X → Y → Z, B := Y → X → Z] := 111 | struct 112 | def fwd := abc b a => abc a b 113 | def bwd := bac a b => bac b a 114 | def fwd-bwd := bac i => bac 115 | def bwd-fwd := abc i => abc 116 | end 117 | -------------------------------------------------------------------------------- /test/names.cooltt: -------------------------------------------------------------------------------- 1 | def x::y : nat := 0 2 | def x (_ : nat) : nat := 0 3 | def y : nat := x x::y 4 | def x::y::z (u::v : nat) : nat := u::v 5 | #print x::y::z 6 | -------------------------------------------------------------------------------- /test/nat-path.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | import nat 3 | 4 | def evan-test (A : type) (φ : 𝔽) (a : A) 5 | (p : sub {path A a a} φ {_ => a}) 6 | : (j : 𝕀) → A 7 | := 8 | p 9 | 10 | abstract 11 | def J (A : type) (p : 𝕀 → A) (C : {(i : 𝕀) → sub A {i=0} {p 0}} → type) (d : C {_ => p 0}) : C p := 12 | coe {i => 13 | C {hfill A 0 {∂ i} {k => [k=0 ∨ i=0 => p 0 | i=1 => p k]}} 14 | } 0 1 d 15 | 16 | unfold J 17 | #normalize J 18 | 19 | 20 | abstract 21 | def J/eq (A : type) (p : 𝕀 → A) (C : {(i : 𝕀) → sub A {i=0} {p 0}} → type) (d : C {_ => p 0}) : path {C {_ => p 0}} {J A {_ => p 0} C d} d := 22 | let square : 𝕀 → 𝕀 → A := i => hfill A 0 {∂ i} {_ => p 0} in 23 | k => 24 | let mot : 𝕀 → type := 25 | i => C {hfill A 0 {∂ k ∨ ∂ i} {j => [k=0 => square i j | j=0 ∨ k=1 ∨ ∂ i => p 0]}} 26 | in 27 | unfold J in 28 | com mot 0 1 {∂ k} {i => [k=0 => coe {j => C {square j}} 0 i d | k=1 ∨ i=0 => d]} 29 | 30 | abstract 31 | def trans-left-unit (A : type) (p : 𝕀 → A) : path {path A {p 0} {p 1}} p {trans A {_ => p 0} p} := 32 | k i => 33 | unfold trans in 34 | hcom A 0 1 {k=0 ∨ ∂ i} {j => 35 | [ j=0 ∨ i=0 => p 0 36 | | i=1 => p j 37 | | k=0 => 38 | hcom A 0 1 {∂ i ∨ ∂ j} {l => 39 | let filler : 𝕀 → A := k => trans/filler A {_ => p 0} p k l in 40 | [ l=0 ∨ i=0 ∨ j=1 => filler i 41 | | i=1 ∨ j=0 => filler j 42 | ] 43 | } 44 | ] 45 | } 46 | 47 | def trans-right-unit (A : type) (p : 𝕀 → A) : path {path A {p 0} {p 1}} p {trans A p {_ => p 1}} := 48 | unfold trans in 49 | trans/filler A p {_ => p 1} 50 | 51 | 52 | def trans-symm-refl (A : type) (p : 𝕀 → A) : path {path A {p 0} {p 0}} {_ => p 0} {trans A p {symm A p}} := 53 | k i => 54 | unfold trans symm in 55 | hcom A 0 1 {k=0 ∨ ∂ i} {j => 56 | symm/filler A p j i 57 | } 58 | 59 | #normalize +-assoc 60 | 61 | unfold +-assoc +-left-unit +-suc-l + 62 | #normalize +-assoc 63 | 64 | #normalize trans-left-unit 65 | #normalize trans-right-unit 66 | #normalize trans-symm-refl 67 | 68 | def test (p : 𝕀 → nat) : (i : 𝕀) → nat := 69 | let fun : nat → nat := 70 | elim [ 71 | | zero => zero 72 | | suc _ => zero 73 | ] 74 | in 75 | i => fun {symm nat p i} 76 | 77 | 78 | def test2 : (i : 𝕀) → nat := 79 | let fun : nat → nat := 80 | elim [ 81 | | zero => zero 82 | | suc _ => zero 83 | ] 84 | in 85 | i => 86 | fun {symm nat {_ => zero} i} 87 | 88 | #normalize test 89 | 90 | #normalize test2 91 | 92 | -- The following illustrates that although cooltt's quasi-normal forms aren't as fully 93 | -- reduced as they could be, it is of no consequence for definitional 94 | -- equivalence. That is, we don't bother pushing eliminators through all the 95 | -- branches of a disjunction split, but our equational theory acts as if we do. 96 | def test2' : sub {𝕀 → nat} ⊤ {i => hcom nat 0 1 {∂ i} {_ => 0}} := unfold symm in test2 97 | -------------------------------------------------------------------------------- /test/nat.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | abstract 4 | def + : nat → nat → nat := 5 | elim [ 6 | | zero => n => n 7 | | suc {_ => ih} => n => suc {ih n} 8 | ] 9 | 10 | #print + 11 | 12 | #normalize + 2 3 13 | 14 | unfold + 15 | #normalize + 2 3 16 | 17 | abstract 18 | def pred : nat → nat := 19 | elim [ 20 | | zero => zero 21 | | suc {n => _} => n 22 | ] 23 | 24 | abstract 25 | def +-left-unit (x : nat) : path nat {+ 0 x} x := 26 | unfold + in 27 | _ => x 28 | 29 | abstract 30 | def +-suc-l (x y : nat) : path nat {+ {suc x} y} {suc {+ x y}} := 31 | unfold + in 32 | _ => suc {+ x y} 33 | 34 | 35 | abstract 36 | def +-right-unit : (x : nat) → path nat {+ x 0} x := 37 | elim [ 38 | | zero => 39 | +-left-unit 0 40 | | suc {y => ih} => 41 | equation nat begin 42 | + {suc y} 0 =[ +-suc-l y 0 ] 43 | suc {+ y 0} =[ i => suc {ih i} ] 44 | suc y 45 | end 46 | ] 47 | 48 | 49 | abstract 50 | def +-suc-r : (x y : nat) → path nat {+ x {suc y}} {suc {+ x y}} := 51 | elim [ 52 | | zero => x => 53 | equation nat begin 54 | + 0 {suc x} =[ +-left-unit {suc x} ] 55 | suc x =[ i => suc {symm nat {+-left-unit x} i} ] 56 | suc {+ 0 x} 57 | end 58 | | suc {x => ih} => y => 59 | equation nat begin 60 | + {suc x} {suc y} =[ +-suc-l x {suc y} ] 61 | suc {+ x {suc y}} =[ i => suc {ih y i} ] 62 | suc {suc {+ x y}} =[ i => suc {symm nat {+-suc-l x y} i} ] 63 | suc {+ {suc x} y} 64 | end 65 | ] 66 | 67 | abstract 68 | def +-comm : (x y : nat) → path nat {+ y x} {+ x y} := 69 | elim [ 70 | | zero => 71 | y => 72 | equation nat begin 73 | + y 0 =[ +-right-unit y ] 74 | y =[ symm nat {+-left-unit y} ] 75 | + 0 y 76 | end 77 | | suc {y => ih} => 78 | z => 79 | equation nat begin 80 | + z {suc y} =[ +-suc-r z y ] 81 | suc {+ z y} =[ i => suc {ih z i} ] 82 | suc {+ y z} =[ symm nat {+-suc-l y z} ] 83 | + {suc y} z 84 | end 85 | ] 86 | 87 | abstract 88 | def +-assoc : (x y z : nat) → path nat {+ {+ x y} z} {+ x {+ y z}} := 89 | elim [ 90 | | zero => y z => 91 | equation nat begin 92 | + {+ 0 y} z =[ i => + {+-left-unit y i} z ] 93 | + y z =[ symm nat {+-left-unit {+ y z}} ] 94 | + 0 {+ y z} 95 | end 96 | | suc {x => ih} => y z => 97 | equation nat begin 98 | + {+ {suc x} y} z =[ i => + {+-suc-l x y i} z ] 99 | + {suc {+ x y}} z =[ +-suc-l {+ x y} z ] 100 | suc {+ {+ x y} z} =[ i => suc {ih y z i} ] 101 | suc {+ x {+ y z}} =[ symm nat {+-suc-l x {+ y z}} ] 102 | + {suc x} {+ y z} 103 | end 104 | ] 105 | -------------------------------------------------------------------------------- /test/patch.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | def el : type := 4 | sig 5 | def A : type 6 | def a : A 7 | end 8 | 9 | def el-patch : type := el # [A := nat, a := 4] 10 | def el-patch-partial : type := el # [ A := nat ] 11 | 12 | def patch/inhabit : el-patch := 13 | struct 14 | def A := nat 15 | def a := 4 16 | end 17 | 18 | def patch-partial/inhabit/infer : el-patch-partial := struct def a := 4 end 19 | def patch/inhabit/infer : el-patch := struct end 20 | def patch/inhabit/hole : el-patch := struct def A := ? def a := ? end 21 | 22 | #print el-patch 23 | #print el-patch-partial 24 | #print patch/inhabit 25 | #print patch-partial/inhabit/infer 26 | #print patch/inhabit/infer 27 | 28 | def patch-depends : type := {sig [A : type, B : type]} # [A := nat, B := A] 29 | #print patch-depends 30 | def patch-depends/inhabit : patch-depends := struct def A := nat def B := nat end 31 | 32 | 33 | def testing (A Z : type) (B : A → type) (p : Z → sig [x : A, bx : B x]) (z : Z) : sig [x : A, bx : B x] # [x := p z.x, bx := p z.bx] := 34 | p z 35 | 36 | #print testing 37 | 38 | -- Record Patching + Total Space Conversion 39 | #fail def total-space/fail (fam : sig [A : type, a : A] → nat → type) : type := fam 40 | 41 | abstract 42 | def category : type := 43 | sig 44 | def ob : type 45 | def hom : sig [s : ob, t : ob] → type 46 | def idn : (x : ob) → hom # [s := x, t := x] 47 | def seq : (f : hom) → (g : hom # [s := f.t]) → hom # [s := f.s, t := g.t] 48 | 49 | def seqL : 50 | abstract seqL∷tp ← 51 | (f : hom) → path {hom # [s := f.s, t := f.t]} {seq {idn {f.s}} f} f 52 | 53 | def seqR : 54 | abstract seqR∷tp ← 55 | (f : hom) → path {hom # [s := f.s, t := f.t]} {seq f {idn {f.t}}} f 56 | 57 | def seqA : 58 | abstract seqA∷tp ← 59 | (f : hom) (g : hom # [s := f.t]) (h : hom # [s := g.t]) 60 | → path {hom # [s := f.s, t := h.t]} {seq f {seq g h}} {seq {seq f g} h} 61 | end 62 | 63 | def types : category := 64 | unfold category in 65 | struct 66 | def ob := type 67 | def hom := args => {args.s} → {args.t} 68 | def idn := _ x => x 69 | def seq := f g x => g {f x} 70 | def seqL := unfold seqL∷tp in f _ => f 71 | def seqR := unfold seqR∷tp in f _ => f 72 | def seqA := unfold seqA∷tp in f g h _ x => h {g {f x}} 73 | end 74 | 75 | def test-auto (fam : sig [x : nat] → type) : type := fam 76 | #print test-auto 77 | 78 | def test-auto-patch (fam : sig [x : nat] → type) : type := fam # [x := 0] 79 | #print test-auto-patch 80 | 81 | def U : type := type 82 | def test-unfold-total (fam : sig [x : nat] → U) : U := fam 83 | #print test-unfold-total 84 | 85 | 86 | -- Extra fields are ignored and elaborated away 87 | def test-extra-field : sub el true {struct [A := nat, a := 0]} := 88 | struct [B := 0, A := nat, x := 0, a := 0, y := 0] 89 | 90 | def test-extra-field-patch : sub {el # [A := nat]} true {struct [A := nat, a := 0]} := 91 | struct [B := 0, x := 0, a := 0, y := 0] 92 | 93 | def test-extra-field-include : sub el true {struct [A := nat, a := 0]} := 94 | unfold category in 95 | struct 96 | include types 97 | include test-extra-field 98 | include types 99 | end 100 | -------------------------------------------------------------------------------- /test/path-types.cooltt: -------------------------------------------------------------------------------- 1 | def formation : { 2 | (A : 𝕀 → type) (a : A 0) (b : A 1) → type 3 | } := { 4 | A a b => 5 | ext i => A i with [i=0 => a | i=1 => b] 6 | } 7 | 8 | #normalize formation 9 | 10 | def path (A : type) (a : A) (b : A) : type := 11 | ext i => A with [i=0 => a | i=1 => b] 12 | 13 | 14 | def myrefl : { 15 | (A : type) (a : A) → path A a a 16 | } := { 17 | A a i => a 18 | } 19 | 20 | 21 | #normalize myrefl 22 | 23 | def funext : { 24 | (A B : type) (f : (x : A) → B) (g : (x : A) → B) 25 | (h : (x : A) → path B {f x} {g x}) 26 | → path {(x : A) → B} f g 27 | } := { 28 | A B f g h i x => 29 | h x i 30 | } 31 | 32 | #normalize funext 33 | 34 | def funextdep : { 35 | (A : 𝕀 → type) (B : (i : 𝕀) → A i → type) 36 | (f : (i : 𝕀) → [∂ i] → (x : A i) → B i x) 37 | (h : (p : (i : 𝕀) → A i) → ext i => B i {p i} with [∂ i => f i {p i}]) 38 | → ext i => (x : A i) → B i x with [∂ i => f i] 39 | } := { 40 | A B f h i x => 41 | h {j => coe A i j x} i 42 | } 43 | 44 | def pairext : { 45 | (A B : type) (p : (x : A) × B) (q : (x : A) × B) 46 | (h : (x : path A {fst p} {fst q}) × path B {snd p} {snd q}) 47 | → path {(x : A) × B} p q 48 | } := { 49 | A B p q h i => 50 | [ {fst h} i 51 | , {snd h} i 52 | ] 53 | } 54 | 55 | #normalize pairext 56 | -------------------------------------------------------------------------------- /test/prelude.cooltt: -------------------------------------------------------------------------------- 1 | -- Path Types, and some common operations 2 | def path (A : type) (x y : A) : type := 3 | ext i => A with [i=0 => x | i=1 => y] 4 | 5 | 6 | def path-p (A : 𝕀 → type) (x : A 0) (y : A 1) : type := 7 | ext i => A i with [i=0 => x | i=1 => y] 8 | 9 | def refl (A : type) (x : A) : path A x x := 10 | i => x 11 | 12 | def symm/filler (A : type) (p : 𝕀 → A) (i : 𝕀) : (j : 𝕀) → sub A {∂ i} [ i=1 => p 0 | i=0 => p j ] := 13 | hfill 0 {j => 14 | [ j=0 ∨ i=1 => p 0 15 | | i=0 => p j 16 | ] 17 | } 18 | 19 | abstract 20 | def symm (A : type) (p : 𝕀 → A) : path A {p 1} {p 0} := 21 | i => symm/filler A p i 1 22 | 23 | def trans/filler (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) (j : 𝕀) (i : 𝕀) : A := 24 | hcom A 0 j {∂ i} {j => 25 | [ j=0 ∨ i=0 => p i 26 | | i=1 => q j 27 | ] 28 | } 29 | 30 | abstract 31 | def trans (A : type) (p : 𝕀 → A) (q : (i : 𝕀) → sub A {i=0} {p 1}) : path A {p 0} {q 1} := 32 | trans/filler A p q 1 33 | 34 | def cong (A : type) (B : A → type) (f : (a : A) → B a) (x y : A) (p : path A x y) : path-p {i => B {p i}} {f x} {f y} := 35 | i => f {p i} 36 | 37 | def funext (A : type) (B : type) (f : (x : A) → B) (g : (x : A) → B) (h : (x : A) → path B {f x} {g x}) : path {(x : A) → B} f g := 38 | i x => h x i 39 | 40 | def unit : type := ext => nat with [⊤ => 0] 41 | 42 | def ⋆ : unit := 0 43 | 44 | def unit/eta (x : unit) : path unit ⋆ x := 45 | _ => x 46 | -------------------------------------------------------------------------------- /test/record.cooltt: -------------------------------------------------------------------------------- 1 | -- Various tests for sig types + structs 2 | import prelude 3 | 4 | def test : type := 5 | sig 6 | def x : type 7 | def y : type 8 | def fn : x -> y 9 | end 10 | 11 | #print test 12 | 13 | def basic : type := 14 | sig 15 | def foo::x : nat 16 | def bar : nat → nat 17 | end 18 | 19 | def basic::inhabit : basic := struct [foo::x := 1, bar := x => suc x] 20 | 21 | #print basic 22 | #print basic::inhabit 23 | #normalize basic::inhabit 24 | #normalize basic::inhabit.foo::x 25 | #normalize basic::inhabit.bar 1 26 | 27 | def basic/ext 28 | (b0 : basic) (b1 : basic) 29 | (p : path nat {b0 . foo::x} {b1 . foo::x}) 30 | (q : path {nat → nat} {b0.bar} {b1.bar}) : path basic b0 b1 31 | := 32 | i => 33 | struct 34 | def foo::x := p i 35 | def bar := q i 36 | end 37 | 38 | def depend : type := 39 | sig 40 | def tp : type 41 | def fun : tp → tp 42 | end 43 | 44 | #print depend 45 | 46 | -- Make sure dependent paths work 47 | def depend/ext 48 | (d0 : depend) 49 | (d1 : depend) 50 | (p : path type {d0.tp} {d1.tp}) 51 | (q : path-p {i => p i → p i} {d0.fun} {d1.fun}) : path depend d0 d1 52 | := 53 | i => struct [tp := p i, fun := q i] 54 | 55 | 56 | -- Can we inhabit first class sigs? 57 | def sig/inhabit : 58 | sig 59 | def tp : type 60 | def fun : tp → tp → type 61 | def comp : (X : tp) (Y : tp) (Z : tp) (f : fun Y Z) → (g : fun X Y) → fun X Z 62 | end 63 | := 64 | struct [tp := nat, fun := x y => nat, comp := x y z f g => 1] 65 | 66 | -- Can we convert between equal representations of sig types? 67 | def sig/conv : path type depend {sig [tp : type, fun : tp → tp]} := 68 | i => depend 69 | 70 | -- Test that forming paths in first-class sigs works 71 | def sig/ext 72 | (b0 : sig [foo : nat]) 73 | (b1 : sig [foo : nat]) 74 | (p : path nat {b0.foo} {b1.foo}) 75 | : path {sig [foo : nat]} b0 b1 76 | := 77 | i => struct [foo := p i] 78 | 79 | 80 | -- Test that empty sigs/structs work 81 | def empty : type := sig [] 82 | def empty/inhabit : empty := struct [] 83 | -------------------------------------------------------------------------------- /test/repack.cooltt: -------------------------------------------------------------------------------- 1 | def a1 : nat := 0 2 | def a2 : nat := 10 3 | def a3 : nat := 20 4 | 5 | repack [?] -- check all exported bindings 6 | 7 | -- rename all exported a1 to b1 8 | repack [ a1 -> b1 ] 9 | repack [?] -- check all exported bindings 10 | 11 | -- rename all exported a2 to a1 12 | !repack [ a2 -> a1 ] 13 | repack [?] -- check all exported bindings 14 | 15 | view [?] -- check all visible bindings 16 | -------------------------------------------------------------------------------- /test/section.cooltt: -------------------------------------------------------------------------------- 1 | -- section with prefix 2 | section x1::y1 begin 3 | def a1 : nat := 0 4 | end 5 | #print x1::y1::a1 6 | 7 | -- section without prefix 8 | section begin 9 | def a2 : nat := 10 10 | end 11 | #print a2 12 | 13 | -- section with shadowing 14 | def a3 : nat := 20 15 | shadowing section begin 16 | shadowing def a3 : nat := 30 17 | end 18 | #print a3 19 | 20 | 21 | -- section with pattern 22 | section x4 begin 23 | def a4 : nat := 40 24 | end [ a4 -> b4 ] 25 | #print x4::b4 26 | 27 | -- empty sections 28 | section begin end 29 | 30 | -- empty sections 31 | section x begin end 32 | 33 | -- check all visible bindings 34 | view [?] 35 | -------------------------------------------------------------------------------- /test/selfification.cooltt: -------------------------------------------------------------------------------- 1 | def testing : { 2 | (Z A : type) (B : A → type) (p : Z → (x : A) × B x) → 3 | (z : Z) → {sub A ⊤ {fst {p z}}} × {sub {B {fst {p z}}} ⊤ {snd {p z}}} 4 | } := { 5 | _ _ _ p => p 6 | } 7 | 8 | #normalize testing 9 | -------------------------------------------------------------------------------- /test/typeclass.cooltt: -------------------------------------------------------------------------------- 1 | import prelude 2 | 3 | def functor : type := 4 | sig 5 | def F : type → type 6 | def map : (A B : type) → {A → B} → F A → F B 7 | end 8 | 9 | def applicative : type := 10 | sig 11 | include functor 12 | def pure : (A : type) → A → F A 13 | def ap : (A B : type) → F {A → B} → F A → F B 14 | end 15 | 16 | def monad : type := 17 | sig 18 | include applicative 19 | def bind : (A B : type) → F A → {A → F B} → F B 20 | end 21 | 22 | abstract 23 | def maybe (A : type) : type := 24 | (R : type) → {A → R} → R → R 25 | 26 | def some (A : type) (x : A) : maybe A := 27 | unfold maybe in 28 | R some none => some x 29 | 30 | def none (A : type) : maybe A := 31 | unfold maybe in 32 | R some none => none 33 | 34 | 35 | def functor/maybe : functor # [F := maybe] := 36 | struct 37 | def map := A B f opt => unfold maybe in R some none => opt R {x => some {f x}} none 38 | end 39 | 40 | def applicative/maybe : applicative # [F := maybe] := 41 | struct 42 | include functor/maybe 43 | def pure := some 44 | def ap := A B mf mx => 45 | unfold maybe in 46 | mf {maybe B} {f => mx {maybe B} {x => some B {f x}} {none B}} {none B} 47 | end 48 | 49 | def monad/maybe : monad # [F := maybe] := 50 | struct 51 | include applicative/maybe 52 | def bind := A B mx f => 53 | unfold maybe in 54 | mx {maybe B} f {none B} 55 | end 56 | 57 | def monad-prod (M : monad) (A B : type) (ma : M.F A) (mb : M.F B) : M.F {A * B} := 58 | open M renaming [bind -> bnd ; pure -> ret] in 59 | bnd A {A * B} ma {x => 60 | bnd B {A * B} mb {y => 61 | ret {A * B} [x,y] }} -------------------------------------------------------------------------------- /test/v.cooltt: -------------------------------------------------------------------------------- 1 | def v-test (r : 𝕀) (A : type) : type := 2 | V r A A 3 | [ x => x 4 | , x => 5 | [ [x, _ => x] 6 | , p i => 7 | let aux := hfill A 1 {∂ i} {k => [ k=1 => x | i=1 => {snd p} k | i=0 => x ] } in 8 | [aux 0, aux] 9 | ] 10 | ] 11 | 12 | #normalize v-test 13 | 14 | def cool (A : type) (a : A) : sub A ⊤ {coe {_ => A} 0 1 a} := 15 | coe {i => v-test i A} 0 1 a 16 | 17 | def cool2 (A : type) (a : A) (i : 𝕀) : A := 18 | coe {i => v-test i A} i 0 [a, a] 19 | 20 | #normalize cool 21 | #normalize cool2 22 | 23 | def cool3 (A : type) (a : A) (i : 𝕀) : sub A ⊤ a := 24 | let vin : v-test i A := [a, a] in 25 | vproj vin 26 | 27 | #normalize cool3 28 | -------------------------------------------------------------------------------- /test/view.cooltt: -------------------------------------------------------------------------------- 1 | def a1 : nat := 0 2 | #print a1 3 | 4 | -- rename a to b in what's currently visible 5 | view [ a1 -> b1 ] 6 | #print b1 7 | repack [?] -- check all exported bindings 8 | 9 | def m1::a2 : nat := 10 10 | def m1::a3 : nat := 20 11 | def m2::a3 : nat := 30 12 | def m2::a4 : nat := 40 13 | 14 | -- open everything under m1 while keeping m1 15 | view { [] , m1 -> } 16 | #print a2 17 | #print a3 18 | repack [?] -- check all exported bindings 19 | 20 | -- move everything under m2 to the root; shadow existing bindings 21 | shadowing view { !m2 , m2 -> } 22 | #print a2 23 | #print a3 24 | #print a4 25 | repack [?] -- check all exported bindings 26 | 27 | -- check all visible bindings 28 | view [?] 29 | -------------------------------------------------------------------------------- /vim/README.md: -------------------------------------------------------------------------------- 1 | # cooltt.vim 2 | 3 | This vim plugin requires Vim 8 (released September 2016). 4 | 5 | ## Use 6 | 7 | While editing a .cooltt file, run `:Cooltt` or `l` (`l` for `load`) 8 | in the command (normal) mode to check the current buffer and display the output 9 | in a separate buffer. Run `p` (`p` for `partial`) to check the 10 | current buffer, ignoring lines below the cursor's current position. From the 11 | output buffer, run `CTRL-]` to jump to the location of the message. 12 | 13 | ### Typing special characters 14 | 15 | `cooltt` uses several Unicode characters in its concrete notation; each of these 16 | can be typed easily in the Vim mode using the `digraph` feature; alternatively, 17 | there are ASCII equivalents. 18 | 19 | | Char | Digraph | ASCII | 20 | |------|-----------|-------| 21 | | 𝕀 | `C-k II` | `dim` | 22 | | 𝔽 | `C-k FF` | `cof` | 23 | | ∂ | `C-k dP` | | 24 | | ∧ | `C-k AN` | `/\` | 25 | | ∨ | `C-k OR` | `\/` | 26 | | × | `C-k *X` | `*` | 27 | | → | `C-k ->` | `->` | 28 | 29 | ## Setup 30 | 31 | This plugin is compatible with Vim 8's package system. You can (re)install it by 32 | running the following shell command from the current directory: 33 | 34 | ./install.sh 35 | 36 | If the `cooltt` binary is not in your `PATH`, add the following line to your 37 | `.vimrc`: 38 | 39 | let g:cooltt_path = '/path/to/the-cooltt-binary' 40 | -------------------------------------------------------------------------------- /vim/ftdetect/cooltt.vim: -------------------------------------------------------------------------------- 1 | " vim-cooltt ftdetect 2 | " Language: cooltt 3 | " Author: Carlo Angiuli 4 | " Last Change: 2020 May 6 5 | 6 | au BufNewFile,BufRead *.cooltt setf cooltt 7 | -------------------------------------------------------------------------------- /vim/ftplugin/cooltt.vim: -------------------------------------------------------------------------------- 1 | " vim-cooltt ftplugin 2 | " Language: cooltt 3 | " Author: Carlo Angiuli 4 | " Last Change: 2021 October 24 5 | 6 | if (exists("b:did_ftplugin") || !has('job')) 7 | finish 8 | endif 9 | 10 | if (!exists('g:cooltt_path')) 11 | let g:cooltt_path = 'cooltt' 12 | endif 13 | 14 | if (!exists('g:coolttviz_path')) 15 | let g:coolttviz_path = 'coolttviz-rs' 16 | endif 17 | 18 | command! Cooltt :call CheckBuffer() 19 | nnoremap l :call CheckBuffer() 20 | nnoremap p :call CheckBuffer(line('.')) 21 | autocmd QuitPre call s:CloseBuffer() 22 | 23 | digraph FF 120125 24 | digraph II 120128 25 | 26 | sign define coolttInfo text=» texthl=Identifier 27 | sign define coolttError text=✗ texthl=Error 28 | 29 | let s:regex = '^\[stdin\]:\(\d\+\).\(\d\+\)-\(\d\+\).\(\d\+\) \[\(\a\+\)\]' 30 | let s:options = '' 31 | 32 | if (executable(g:coolttviz_path)) 33 | if (!exists('s:vizjob') || job_status(s:vizjob) != 'run') 34 | let s:vizjob = job_start(g:coolttviz_path) 35 | let s:options = ' --server' 36 | endif 37 | endif 38 | 39 | " Optional argument: the last line to send to cooltt (default: all). 40 | function! CheckBuffer(...) 41 | if (exists('s:job')) 42 | call job_stop(s:job, 'int') 43 | endif 44 | 45 | let l:current = bufname('%') 46 | 47 | if (!bufexists('cooltt') || (winbufnr(bufwinnr('cooltt')) != bufnr('cooltt'))) 48 | belowright vsplit cooltt 49 | call s:InitBuffer() 50 | else 51 | execute bufwinnr('cooltt') . 'wincmd w' 52 | endif 53 | let b:active = l:current 54 | silent %d _ 55 | wincmd p 56 | 57 | execute 'sign unplace * file=' . l:current 58 | 59 | let s:job = job_start(g:cooltt_path . 60 | \' - -w ' . s:EditWidth() . s:options . ' --as-file ' . expand('%:p'), { 61 | \'in_io': 'buffer', 'in_buf': bufnr('%'), 62 | \'in_bot': exists('a:1') ? a:1 : line('$'), 63 | \'out_cb': 'ParseMessages', 64 | \'out_io': 'buffer', 'out_name': 'cooltt', 'out_msg': 0}) 65 | endfunction 66 | 67 | function! ParseMessages(ch, line) 68 | let matches = matchlist(a:line, s:regex) 69 | if (get(matches, 1) != 0 && (get(matches, 5) == 'Info' || get(matches, 5) == 'Error')) 70 | let line = matches[1] 71 | let type = matches[5] 72 | let buf = getbufvar('cooltt', 'active') 73 | execute 'sign place ' . line . ' line=' . line . ' name=cooltt' . type . ' file=' . buf 74 | endif 75 | endfunction 76 | 77 | " Call this only from cooltt output buffer. 78 | function! g:JumpFromOutputBuffer() 79 | let matches = matchlist(getline(search(s:regex, 'bcW')), s:regex) 80 | if (get(matches, 1) != 0 && bufexists(b:active) && 81 | \ (winbufnr(bufwinnr(b:active)) == bufnr(b:active))) 82 | execute 'sign jump ' . matches[1] . ' file=' . b:active 83 | endif 84 | endfunction 85 | 86 | " Call this only from cooltt output buffer. 87 | function! g:CheckFromOutputBuffer() 88 | if (bufexists(b:active) && (winbufnr(bufwinnr(b:active)) == bufnr(b:active))) 89 | execute bufwinnr(b:active) . 'wincmd w' 90 | call CheckBuffer() 91 | endif 92 | endfunction 93 | 94 | function! s:InitBuffer() 95 | set buftype=nofile 96 | set syntax=cooltt 97 | set noswapfile 98 | nnoremap l :call CheckFromOutputBuffer() 99 | nnoremap :call JumpFromOutputBuffer() 100 | endfunction 101 | 102 | function! s:EditWidth() 103 | execute bufwinnr('cooltt') . 'wincmd w' 104 | 105 | let l:width = winwidth(winnr()) 106 | if (has('linebreak') && (&number || &relativenumber)) 107 | let l:width -= &numberwidth 108 | endif 109 | if (has('folding')) 110 | let l:width -= &foldcolumn 111 | endif 112 | if (has('signs')) 113 | redir => l:signs 114 | silent execute 'sign place buffer=' . bufnr('%') 115 | redir END 116 | if (&signcolumn == "yes" || len(split(l:signs, "\n")) > 2) 117 | let l:width -= 2 118 | endif 119 | endif 120 | 121 | wincmd p 122 | return l:width 123 | endfunction 124 | 125 | function! s:CloseBuffer() 126 | if (bufexists('cooltt') && !getbufvar('cooltt', '&modified')) 127 | if (getbufvar('cooltt', 'active') == bufname('%')) 128 | bdelete cooltt 129 | endif 130 | endif 131 | endfunction 132 | 133 | let b:did_ftplugin = 1 134 | -------------------------------------------------------------------------------- /vim/install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | DEST=~/.vim/pack/redprl-org/start ; 4 | [ -d $DEST/vim-cooltt ] && rm -r $DEST/vim-cooltt ; 5 | mkdir -p $DEST && cp -r . $DEST/vim-cooltt 6 | -------------------------------------------------------------------------------- /vim/syntax/cooltt.vim: -------------------------------------------------------------------------------- 1 | " vim-cooltt syntax 2 | " Language: cooltt 3 | " Author: Carlo Angiuli, Favonia 4 | " Last Change: 2022 Jan 17 5 | 6 | if exists("b:current_syntax") 7 | finish 8 | endif 9 | 10 | setlocal iskeyword=a-z,A-Z,48-57,-,',/,# 11 | 12 | syn sync minlines=50 13 | syn sync maxlines=1000 14 | 15 | syn match coolttParenErr ')' 16 | syn match coolttBrackErr ']' 17 | syn match coolttBraceErr '}' 18 | 19 | syn region coolttEncl transparent matchgroup=coolttSymb start="(" end=")" contains=ALLBUT,coolttParenErr 20 | syn region coolttEncl transparent matchgroup=coolttSymb start="\[" end="\]" contains=ALLBUT,coolttBrackErr 21 | syn region coolttEncl transparent matchgroup=coolttSymb start="{" end="}" contains=ALLBUT,coolttBraceErr 22 | 23 | syn match coolttHole '?\k*' 24 | syn match coolttHole '?_\k*' 25 | 26 | syn keyword coolttKeyw zero suc nat fst snd elim type dim equation begin end 27 | syn keyword coolttKeyw cof sub ext coe hcom com hfill V vproj with struct sig tt ff # 28 | 29 | syn keyword coolttDecl def axiom let import section view export repack unfold abstract in shadowing generalize 30 | syn keyword coolttCmd #normalize #print #quit #fail #viz #debug on off 31 | 32 | syn match coolttSymb '=>\|\.=\|[.|,*×:;=≔_𝕀𝔽∂∧∨→⇒!]\|->\|⊤\|⊥' 33 | syn match coolttSymb '\\/\|/\\' 34 | 35 | syn region coolttComm excludenl start="\k\@1