├── .editorconfig ├── .gitignore ├── .vscode ├── extensions.json ├── settings.json └── tasks.json ├── Makefile ├── README.md ├── src ├── bin │ ├── jbuild │ └── main.ml └── lib │ ├── EnvMonad.ml │ ├── Model.ml │ ├── Model.mli │ ├── ProofState.ml │ ├── ProofState.mli │ ├── Signature.ml │ ├── Subst.ml │ ├── Subst.mli │ └── jbuild ├── tests ├── Test.ml └── jbuild └── tt.opam /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | indent_style = space 5 | indent_size = 2 6 | end_of_line = lf 7 | charset = utf-8 8 | trim_trailing_whitespace = true 9 | insert_final_newline = true 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _opam 2 | *.install 3 | 4 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Emacs.gitignore 5 | 6 | # -*- mode: gitignore; -*- 7 | *~ 8 | \#*\# 9 | /.emacs.desktop 10 | /.emacs.desktop.lock 11 | *.elc 12 | auto-save-list 13 | tramp 14 | .\#* 15 | 16 | # Org-mode 17 | .org-id-locations 18 | *_archive 19 | 20 | # flymake-mode 21 | *_flymake.* 22 | 23 | # eshell files 24 | /eshell/history 25 | /eshell/lastdir 26 | 27 | # elpa packages 28 | /elpa/ 29 | 30 | # reftex files 31 | *.rel 32 | 33 | # AUCTeX auto folder 34 | /auto/ 35 | 36 | # cask packages 37 | .cask/ 38 | dist/ 39 | 40 | # Flycheck 41 | flycheck_*.el 42 | 43 | # server auth directory 44 | /server/ 45 | 46 | # projectiles files 47 | .projectile 48 | 49 | # directory configuration 50 | .dir-locals.el 51 | 52 | 53 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Linux.gitignore 54 | 55 | *~ 56 | 57 | # temporary files which can be created if a process still has a handle open of a deleted file 58 | .fuse_hidden* 59 | 60 | # KDE directory preferences 61 | .directory 62 | 63 | # Linux trash folder which might appear on any partition or disk 64 | .Trash-* 65 | 66 | # .nfs files are created when an open file is removed but is still being accessed 67 | .nfs* 68 | 69 | 70 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/macOS.gitignore 71 | 72 | # General 73 | .DS_Store 74 | .AppleDouble 75 | .LSOverride 76 | 77 | # Icon must end with two \r 78 | Icon 79 | 80 | 81 | # Thumbnails 82 | ._* 83 | 84 | # Files that might appear in the root of a volume 85 | .DocumentRevisions-V100 86 | .fseventsd 87 | .Spotlight-V100 88 | .TemporaryItems 89 | .Trashes 90 | .VolumeIcon.icns 91 | .com.apple.timemachine.donotpresent 92 | 93 | # Directories potentially created on remote AFP share 94 | .AppleDB 95 | .AppleDesktop 96 | Network Trash Folder 97 | Temporary Items 98 | .apdisk 99 | 100 | 101 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/OCaml.gitignore 102 | 103 | *.annot 104 | *.cmo 105 | *.cma 106 | *.cmi 107 | *.a 108 | *.o 109 | *.cmx 110 | *.cmxs 111 | *.cmxa 112 | 113 | # ocamlbuild working directory 114 | _build/ 115 | 116 | # ocamlbuild targets 117 | *.byte 118 | *.native 119 | 120 | # oasis generated files 121 | setup.data 122 | setup.log 123 | 124 | # Merlin configuring file for Vim and Emacs 125 | .merlin 126 | 127 | 128 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/SublimeText.gitignore 129 | 130 | # Cache files for Sublime Text 131 | *.tmlanguage.cache 132 | *.tmPreferences.cache 133 | *.stTheme.cache 134 | 135 | # Workspace files are user-specific 136 | *.sublime-workspace 137 | 138 | # Project files should be checked into the repository, unless a significant 139 | # proportion of contributors will probably not be using Sublime Text 140 | # *.sublime-project 141 | 142 | # SFTP configuration file 143 | sftp-config.json 144 | 145 | # Package control specific files 146 | Package Control.last-run 147 | Package Control.ca-list 148 | Package Control.ca-bundle 149 | Package Control.system-ca-bundle 150 | Package Control.cache/ 151 | Package Control.ca-certs/ 152 | Package Control.merged-ca-bundle 153 | Package Control.user-ca-bundle 154 | oscrypto-ca-bundle.crt 155 | bh_unicode_properties.cache 156 | 157 | # Sublime-github package stores a github token in this file 158 | # https://packagecontrol.io/packages/sublime-github 159 | GitHub.sublime-settings 160 | 161 | 162 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/TeX.gitignore 163 | 164 | ## Core latex/pdflatex auxiliary files: 165 | *.aux 166 | *.lof 167 | *.log 168 | *.lot 169 | *.fls 170 | *.out 171 | *.toc 172 | *.fmt 173 | *.fot 174 | *.cb 175 | *.cb2 176 | 177 | ## Intermediate documents: 178 | *.dvi 179 | *.xdv 180 | *-converted-to.* 181 | # these rules might exclude image files for figures etc. 182 | # *.ps 183 | # *.eps 184 | # *.pdf 185 | 186 | ## Generated if empty string is given at "Please type another file name for output:" 187 | .pdf 188 | 189 | ## Bibliography auxiliary files (bibtex/biblatex/biber): 190 | *.bbl 191 | *.bcf 192 | *.blg 193 | *-blx.aux 194 | *-blx.bib 195 | *.run.xml 196 | 197 | ## Build tool auxiliary files: 198 | *.fdb_latexmk 199 | *.synctex 200 | *.synctex(busy) 201 | *.synctex.gz 202 | *.synctex.gz(busy) 203 | *.pdfsync 204 | 205 | ## Auxiliary and intermediate files from other packages: 206 | # algorithms 207 | *.alg 208 | *.loa 209 | 210 | # achemso 211 | acs-*.bib 212 | 213 | # amsthm 214 | *.thm 215 | 216 | # beamer 217 | *.nav 218 | *.pre 219 | *.snm 220 | *.vrb 221 | 222 | # changes 223 | *.soc 224 | 225 | # cprotect 226 | *.cpt 227 | 228 | # elsarticle (documentclass of Elsevier journals) 229 | *.spl 230 | 231 | # endnotes 232 | *.ent 233 | 234 | # fixme 235 | *.lox 236 | 237 | # feynmf/feynmp 238 | *.mf 239 | *.mp 240 | *.t[1-9] 241 | *.t[1-9][0-9] 242 | *.tfm 243 | 244 | #(r)(e)ledmac/(r)(e)ledpar 245 | *.end 246 | *.?end 247 | *.[1-9] 248 | *.[1-9][0-9] 249 | *.[1-9][0-9][0-9] 250 | *.[1-9]R 251 | *.[1-9][0-9]R 252 | *.[1-9][0-9][0-9]R 253 | *.eledsec[1-9] 254 | *.eledsec[1-9]R 255 | *.eledsec[1-9][0-9] 256 | *.eledsec[1-9][0-9]R 257 | *.eledsec[1-9][0-9][0-9] 258 | *.eledsec[1-9][0-9][0-9]R 259 | 260 | # glossaries 261 | *.acn 262 | *.acr 263 | *.glg 264 | *.glo 265 | *.gls 266 | *.glsdefs 267 | 268 | # gnuplottex 269 | *-gnuplottex-* 270 | 271 | # gregoriotex 272 | *.gaux 273 | *.gtex 274 | 275 | # hyperref 276 | *.brf 277 | 278 | # knitr 279 | *-concordance.tex 280 | # TODO Comment the next line if you want to keep your tikz graphics files 281 | *.tikz 282 | *-tikzDictionary 283 | 284 | # listings 285 | *.lol 286 | 287 | # makeidx 288 | *.idx 289 | *.ilg 290 | *.ind 291 | *.ist 292 | 293 | # minitoc 294 | *.maf 295 | *.mlf 296 | *.mlt 297 | *.mtc[0-9]* 298 | *.slf[0-9]* 299 | *.slt[0-9]* 300 | *.stc[0-9]* 301 | 302 | # minted 303 | _minted* 304 | *.pyg 305 | 306 | # morewrites 307 | *.mw 308 | 309 | # nomencl 310 | *.nlo 311 | 312 | # pax 313 | *.pax 314 | 315 | # pdfpcnotes 316 | *.pdfpc 317 | 318 | # sagetex 319 | *.sagetex.sage 320 | *.sagetex.py 321 | *.sagetex.scmd 322 | 323 | # scrwfile 324 | *.wrt 325 | 326 | # sympy 327 | *.sout 328 | *.sympy 329 | sympy-plots-for-*.tex/ 330 | 331 | # pdfcomment 332 | *.upa 333 | *.upb 334 | 335 | # pythontex 336 | *.pytxcode 337 | pythontex-files-*/ 338 | 339 | # thmtools 340 | *.loe 341 | 342 | # TikZ & PGF 343 | *.dpth 344 | *.md5 345 | *.auxlock 346 | 347 | # todonotes 348 | *.tdo 349 | 350 | # easy-todo 351 | *.lod 352 | 353 | # xindy 354 | *.xdy 355 | 356 | # xypic precompiled matrices 357 | *.xyc 358 | 359 | # endfloat 360 | *.ttt 361 | *.fff 362 | 363 | # Latexian 364 | TSWLatexianTemp* 365 | 366 | ## Editors: 367 | # WinEdt 368 | *.bak 369 | *.sav 370 | 371 | # Texpad 372 | .texpadtmp 373 | 374 | # Kile 375 | *.backup 376 | 377 | # KBibTeX 378 | *~[0-9]* 379 | 380 | # auto folder when using emacs and auctex 381 | /auto/* 382 | 383 | # expex forward references with \gathertags 384 | *-tags.tex 385 | 386 | 387 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Vim.gitignore 388 | 389 | # Swap 390 | [._]*.s[a-v][a-z] 391 | [._]*.sw[a-p] 392 | [._]s[a-v][a-z] 393 | [._]sw[a-p] 394 | 395 | # Session 396 | Session.vim 397 | 398 | # Temporary 399 | .netrwhist 400 | *~ 401 | # Auto-generated tag files 402 | tags 403 | 404 | 405 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/VisualStudioCode.gitignore 406 | 407 | .vscode/* 408 | !.vscode/settings.json 409 | !.vscode/tasks.json 410 | !.vscode/launch.json 411 | !.vscode/extensions.json 412 | 413 | 414 | -------------------------------------------------------------------------------- /.vscode/extensions.json: -------------------------------------------------------------------------------- 1 | { 2 | "recommendations": [ 3 | "EditorConfig.EditorConfig", 4 | "freebroccolo.reasonml", 5 | "freebroccolo.input-assist", 6 | "stkb.rewrap" 7 | ] 8 | } 9 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "editor.formatOnSave": false, 3 | "editor.detectIndentation": false, 4 | "editor.insertSpaces": true, 5 | "editor.tabSize": 2, 6 | "editor.trimAutoWhitespace": true, 7 | "files.exclude": { 8 | "_build": true, 9 | "_opam": true, 10 | "**/.merlin": true, 11 | "**/*.install": true 12 | }, 13 | "search.exclude": {} 14 | } 15 | -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=733558 3 | // for the documentation about the tasks.json format 4 | "version": "2.0.0", 5 | "tasks": [ 6 | { 7 | "label": "build", 8 | "type": "shell", 9 | "group": "build", 10 | "command": "make", 11 | "problemMatcher": ["$ocamlc"], 12 | "presentation": { 13 | "echo": false, 14 | "reveal": "silent", 15 | "focus": false, 16 | "panel": "shared" 17 | } 18 | }, 19 | { 20 | "label": "clean", 21 | "type": "shell", 22 | "group": "build", 23 | "command": "make clean", 24 | "problemMatcher": ["$ocamlc"], 25 | "presentation": { 26 | "echo": false, 27 | "reveal": "silent", 28 | "focus": false, 29 | "panel": "shared" 30 | } 31 | }, 32 | { 33 | "label": "test", 34 | "type": "shell", 35 | "group": { 36 | "kind": "test", 37 | "isDefault": true 38 | }, 39 | "command": "make test", 40 | "presentation": { 41 | "echo": false, 42 | "reveal": "silent", 43 | "focus": false, 44 | "panel": "shared" 45 | } 46 | }, 47 | { 48 | "label": "top", 49 | "type": "shell", 50 | "group": "build", 51 | "command": "make top", 52 | "problemMatcher": ["$ocamlc"], 53 | "presentation": { 54 | "echo": false, 55 | "reveal": "always", 56 | "focus": true, 57 | "panel": "dedicated" 58 | }, 59 | "isBackground": true 60 | } 61 | ] 62 | } 63 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | UNAME := $(shell uname -s) 2 | ifeq ($(UNAME),Darwin) 3 | OPEN := open 4 | endif 5 | ifeq ($(UNAME),Linux) 6 | OPEN := xdg-open 7 | endif 8 | 9 | OPAM=opam 10 | EXEC=${OPAM} config exec 11 | DUNE=${EXEC} jbuilder -- 12 | 13 | .PHONY: all build clean doc test top 14 | 15 | all: build 16 | 17 | build: 18 | @${DUNE} build @install 19 | 20 | clean: 21 | @${DUNE} clean 22 | 23 | doc: 24 | @${DUNE} build @doc 25 | ifdef OPEN 26 | ${OPEN} _build/default/_doc/tt/index.html 27 | endif 28 | 29 | test: 30 | @${DUNE} build @runtest 31 | 32 | top: 33 | @${DUNE} utop src/lib 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # tt 2 | 3 | secret project 4 | 5 | ### Elaboration 6 | Elaboration structure and algorithm is inspired by the following, in no specific order: 7 | 8 | + McBride's OLEG and its descendents (Epigram, Idris) 9 | + Sterling and Harper's "Dependent LCF" 10 | + Huet's "Constructive Engine" 11 | 12 | We take the idea of tactics as information-increasing transitions between valid contexts (which contain definitional extensions) from McBride; unlike McBride we use explicit substitutions. Because of this difference, we do not use McBride's "attack, guess, solve" yoga in order to maintain correctness of intermediate states. 13 | 14 | It is possible to view this as a generalization of Dependent LCF's proof state structure to include definitional extension; while Dependent LCF probably cannot be implemented efficiently, this generalization can. 15 | 16 | ## Installing 17 | 18 | ### Prerequisites 19 | 20 | | prerequisite | | version | how to install | 21 | | ------------ | ---- | :--------------------------------------------------------------------- | ------------------------------- | 22 | | Opam | `>=` | [`1.2.2`](https://github.com/ocaml/opam/releases/tag/1.2.2) | manually or via package manager | 23 | | OCaml | `>=` | [`4.06.1+flambda`](https://github.com/ocaml/ocaml/releases/tag/4.06.1) | `opam switch 4.06.1+flambda` | 24 | | utop | `>=` | [`2.0.2`](https://github.com/diml/utop/releases/tag/2.0.2) | `opam install utop` (optional) | 25 | 26 | ### Installing Dependencies 27 | 28 | ``` 29 | $ git clone https://github.com/jonsterling/tt 30 | $ cd tt 31 | $ opam update 32 | $ opam pin add -y . 33 | ``` 34 | 35 | ### Building 36 | 37 | ``` 38 | $ make 39 | ``` 40 | 41 | ### Toplevel 42 | 43 | Requires `utop` (see prerequisites). 44 | 45 | ``` 46 | $ make top 47 | ``` 48 | 49 | ### Tests 50 | 51 | ``` 52 | $ make test 53 | ``` 54 | -------------------------------------------------------------------------------- /src/bin/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executables 4 | ((names (main)) 5 | (flags (:standard -short-paths -strict-formats -w +a-3-4-6-9-30-32-39-41-42-44-48-60 -warn-error +a -open Base)) 6 | (ocamlopt_flags (:standard -short-paths -strict-formats -w +a-3-4-6-9-30-32-39-41-42-44-48-60 -warn-error +a -open Base -O3 -bin-annot -principal -unboxed-types)) 7 | (libraries (cmdliner lwt.unix tt)) 8 | (preprocess (pps (ppx_deriving.std ppx_jane ppx_driver.runner))))) 9 | 10 | (install 11 | ((section bin) 12 | (files ((main.exe as tt))))) 13 | -------------------------------------------------------------------------------- /src/bin/main.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | let cmd_help: unit Lwt.t Term.t * Term.info = 4 | let doc = "show help" in 5 | Term. 6 | ( ret @@ pure @@ `Help ( `Pager, None ) 7 | , info "help" ~doc 8 | ) 9 | 10 | let cmd_default = 11 | Term. 12 | ( ret @@ pure @@ `Help ( `Pager, None ) 13 | , info "tt" ~version:"0.0.0" 14 | ) 15 | 16 | let cmds = [ 17 | cmd_help; 18 | ] 19 | 20 | let main () = 21 | match Term.eval_choice cmd_default cmds with 22 | | `Error _e -> Caml.exit 1 23 | | `Ok expr -> Lwt_main.run expr 24 | | _ -> Caml.exit 0 25 | 26 | let () = 27 | if not !Sys.interactive then 28 | main () 29 | -------------------------------------------------------------------------------- /src/lib/EnvMonad.ml: -------------------------------------------------------------------------------- 1 | module type EnvMonad = sig 2 | module Key : sig 3 | type t 4 | [@@deriving (compare, sexp, show)] 5 | end 6 | 7 | module T : sig 8 | (* Semantically, 'jdg should be a poset; we refer to its order as the "information order". *) 9 | type ('a, 'jdg) t 10 | [@@deriving (compare, sexp, show)] 11 | end 12 | 13 | module Env : sig 14 | (* This is intended to be abstract. Sometimes to interface with other code outside the monad, 15 | we need a way to turn a monadic action into a value, inside the monad. This is helpful 16 | when dealing with higher order functions, such as in the case of pretty-printers. *) 17 | type 'jdg t 18 | [@@deriving (compare, sexp, show)] 19 | end 20 | 21 | val get_env : ('jdg Env.t, 'jdg) T.t 22 | 23 | val run : 'jdg Env.t -> ('a, 'jdg) T.t -> 'a 24 | 25 | val find : Key.t -> ('a, 'jdg) T.t 26 | 27 | val alloc : 'jdg -> (Key.t, 'a) T.t 28 | 29 | (* INVARIANT: the update must be monotone in the sense of the information order on 'jdg. 30 | Behavior is UNDEFINED when the update is not an improvement. *) 31 | val improve : Key.t -> 'jdg -> (unit, 'a) T.t 32 | 33 | include Monad.S2 34 | with type ('a, 'jdg) t := ('a, 'jdg) T.t 35 | end 36 | -------------------------------------------------------------------------------- /src/lib/Model.ml: -------------------------------------------------------------------------------- 1 | open Signature 2 | 3 | module type Model = sig 4 | module F : sig 5 | (* signature endofunctor *) 6 | type 'a t 7 | end 8 | 9 | module T : sig 10 | (* algebra for the signature endofunctor *) 11 | type t 12 | [@@deriving (compare, sexp, show)] 13 | end 14 | 15 | val into : T.t F.t -> T.t 16 | val var : int -> T.t 17 | val subst : (T.t, T.t) Subst.Tensor.t -> T.t 18 | end 19 | 20 | module type EffectfulTermModel = sig 21 | include Model 22 | 23 | module M : Monad.S 24 | val out : T.t -> [`F of T.t F.t | `V of int] M.t 25 | val pretty : Caml.Format.formatter -> T.t -> unit M.t 26 | end 27 | 28 | module type TermModel = sig 29 | include EffectfulTermModel 30 | with module M = Monad.Ident 31 | end 32 | 33 | module Pure (Sig : Signature) : sig 34 | include TermModel 35 | with module F = Sig 36 | end = struct 37 | module F = Sig 38 | 39 | module T = struct 40 | type t = 41 | | Var of int 42 | | In of t Sig.t 43 | [@@deriving (compare, hash, sexp, show)] 44 | end 45 | 46 | module M = Monad.Ident 47 | 48 | let var i = T.Var i 49 | 50 | let into tf = T.In tf 51 | 52 | let out t = 53 | match t with 54 | | T.Var i -> `V i 55 | | T.In tf -> `F tf 56 | 57 | let rec weaken n sb = 58 | match n with 59 | | 0 -> sb 60 | | _ -> weaken (n - 1) @@ Subst.ext (Subst.cmp sb Subst.wk) (T.Var 0) 61 | 62 | let rec subst (t, sb) = 63 | match Subst.out sb, t with 64 | | Subst.F.Id, _ -> t 65 | | _, T.Var i -> proj sb i 66 | | _, T.In tf -> T.In (Sig.map (fun i a -> subst (a, weaken i sb)) tf) 67 | 68 | and proj sb ix = 69 | match Subst.out sb with 70 | | Subst.F.Id -> T.Var ix 71 | | Subst.F.Cmp (sb1, sb0) -> subst (proj sb0 ix, sb1) 72 | | Subst.F.Ext (sb, t) -> if ix = 0 then t else proj sb (ix - 1) 73 | | Subst.F.Wk -> T.Var (ix + 1) 74 | 75 | let rec pretty fmt t = 76 | match t with 77 | | T.Var i -> Fmt.pf fmt "#%i" i 78 | | T.In tf -> Sig.pretty pretty fmt tf 79 | end 80 | 81 | module ExplicitSubst (Sig : Signature) : sig 82 | include TermModel 83 | with module F = Sig 84 | end = struct 85 | module F = Sig 86 | module M = Monad.Ident 87 | 88 | module T = struct 89 | type node = 90 | | Var of int 91 | | In of closure ref Sig.t 92 | 93 | and closure = 94 | | Ret of node 95 | | Clo of (node, closure ref) Subst.Tensor.t 96 | [@@deriving (compare, sexp, show)] 97 | 98 | type t = closure ref 99 | [@@deriving (compare, sexp, show)] 100 | end 101 | 102 | let var i = 103 | ref (T.Ret (T.Var i)) 104 | 105 | let rec weaken n sb = 106 | match n with 107 | | 0 -> sb 108 | | _ -> weaken (n - 1) @@ Subst.ext (Subst.cmp sb Subst.wk) (var 0) 109 | 110 | let into tf = ref (T.Ret (T.In tf)) 111 | 112 | let subst (t, sb) = 113 | match Subst.out sb, !t with 114 | | Subst.F.Id, _ -> t 115 | | _, T.Clo (t, sb') -> ref (T.Clo (t, Subst.cmp sb sb')) 116 | | _, T.Ret t -> ref (T.Clo (t, sb)) 117 | 118 | let rec unwrap : T.t -> T.node = 119 | fun r -> 120 | match !r with 121 | | T.Clo tensor -> 122 | let node = subst_node tensor in 123 | r := T.Ret node; 124 | node 125 | | T.Ret node -> node 126 | 127 | and subst_ix : (int, T.t) Subst.Tensor.t -> T.node = 128 | fun (ix, sb) -> 129 | match Subst.out sb with 130 | | Subst.F.Id -> 131 | T.Var ix 132 | | Subst.F.Cmp (sb1, sb0) -> 133 | subst_node (subst_ix (ix, sb0), sb1) 134 | | Subst.F.Ext (sb, t) -> 135 | if ix = 0 then unwrap t else subst_ix (ix - 1, sb) 136 | | Subst.F.Wk -> 137 | T.Var (ix + 1) 138 | 139 | and subst_node : (T.node, T.t) Subst.Tensor.t -> T.node = 140 | fun (node, sb) -> 141 | match node with 142 | | T.In tf -> T.In (Sig.map (fun i a -> subst (a, weaken i sb)) tf) 143 | | T.Var ix -> subst_ix (ix, sb) 144 | 145 | let out t = 146 | match unwrap t with 147 | | T.Var ix -> `V ix 148 | | T.In tf -> `F tf 149 | 150 | let rec pretty fmt t = 151 | match unwrap t with 152 | | T.Var ix -> Fmt.pf fmt "#%i" ix 153 | | T.In tf -> Sig.pretty pretty fmt tf 154 | end 155 | -------------------------------------------------------------------------------- /src/lib/Model.mli: -------------------------------------------------------------------------------- 1 | open Signature 2 | 3 | module type Model = sig 4 | module F : sig 5 | (* signature endofunctor *) 6 | type 'a t 7 | end 8 | 9 | module T : sig 10 | (* algebra for the signature endofunctor *) 11 | type t 12 | [@@deriving (compare, sexp, show)] 13 | end 14 | 15 | val into : T.t F.t -> T.t 16 | val var : int -> T.t 17 | val subst : (T.t, T.t) Subst.Tensor.t -> T.t 18 | end 19 | 20 | module type EffectfulTermModel = sig 21 | include Model 22 | 23 | module M : Monad.S 24 | 25 | val out : T.t -> [`F of T.t F.t | `V of int] M.t 26 | val pretty : Caml.Format.formatter -> T.t -> unit M.t 27 | end 28 | 29 | module type TermModel = sig 30 | include EffectfulTermModel 31 | with module M = Monad.Ident 32 | end 33 | 34 | module Pure (Sig : Signature) : sig 35 | include TermModel 36 | with module F = Sig 37 | end 38 | 39 | (* As example of the flexibility of this system *) 40 | module ExplicitSubst (Sig : Signature) : sig 41 | include TermModel 42 | with module F = Sig 43 | end 44 | -------------------------------------------------------------------------------- /src/lib/ProofState.ml: -------------------------------------------------------------------------------- 1 | open Signature 2 | open EnvMonad 3 | 4 | (* This is a model with references to holes *) 5 | module ProofState (Mon : EnvMonad) (Sig : Signature) = struct 6 | module T = struct 7 | type t = 8 | | Var of int 9 | | In of t Sig.t 10 | | Ref of [`Defer of (Mon.Key.t, t) Subst.Tensor.t | `Done of t] ref 11 | [@@deriving (compare, sexp, show)] 12 | (* Wrapping the above in a reference to a sum lets me avoid 13 | having to destructively update the environment in order to 14 | make updates that memoize lookup-and-subst operations; these 15 | are different from other updates to the environment in that they 16 | contain no change in information. Better to deal with it locally! *) 17 | end 18 | 19 | module Subject = struct 20 | type t = 21 | | Ask 22 | | Ret of T.t 23 | [@@deriving (compare, sexp, show)] 24 | end 25 | 26 | module Jdg = struct 27 | type t = { 28 | cx : T.t list; 29 | ty : T.t; 30 | hole : Subject.t; 31 | } 32 | [@@deriving (compare, sexp, show)] 33 | end 34 | 35 | module TermF = struct 36 | type 'a t = 'a Sig.t 37 | [@@deriving (compare, sexp, show)] 38 | end 39 | 40 | module M_Basic = 41 | struct 42 | type 'a t = ('a, Jdg.t) Mon.T.t 43 | let return = Mon.return 44 | let map = `Define_using_bind 45 | let bind = Mon.bind 46 | end 47 | 48 | module M = 49 | struct 50 | type 'a t = 'a M_Basic.t 51 | include Monad.Make (M_Basic) 52 | end 53 | 54 | let var i = T.Var i 55 | 56 | let into tf = T.In tf 57 | 58 | let rec weaken n sb = 59 | match n with 60 | | 0 -> sb 61 | | _ -> weaken (n - 1) @@ Subst.ext (Subst.cmp sb Subst.wk) (T.Var 0) 62 | 63 | let rec subst (t, sb) = 64 | match Subst.out sb, t with 65 | | Subst.F.Id, _ -> t 66 | | _, T.Var i -> proj sb i 67 | | _, T.In tf -> T.In (Sig.map (fun i a -> subst (a, weaken i sb)) tf) 68 | | _, T.Ref r -> 69 | match !r with 70 | | `Defer (key, sb') -> T.Ref (ref @@ `Defer (key, Subst.cmp sb sb')) 71 | | `Done t -> subst (t, sb) 72 | 73 | and proj sb ix = 74 | match Subst.out sb with 75 | | Subst.F.Id -> T.Var ix 76 | | Subst.F.Cmp (sb1, sb0) -> subst (proj sb0 ix, sb1) 77 | | Subst.F.Ext (_, t) -> if ix = 0 then t else proj sb (ix - 1) 78 | | Subst.F.Wk -> T.Var (ix + 1) 79 | 80 | (* The clever bit is that when we hit a reference into the proof state, 81 | we look it up and perform its associated deferred substitution; then 82 | we destructively update the reference accordingly. This is justified 83 | because we require as an invariant that updates to the proof state be 84 | monotone. *) 85 | let rec out t = 86 | match t with 87 | | T.Var i -> Mon.return @@ `V i 88 | | T.In tf -> Mon.return @@ `F tf 89 | | T.Ref r -> 90 | match !r with 91 | | `Done t -> out t 92 | | `Defer (key, sb) -> 93 | Mon.bind (Mon.find key) ~f:begin fun Jdg.{hole} -> 94 | match hole with 95 | | Subject.Ask -> failwith "[out]: got Ask" 96 | | Subject.Ret t -> 97 | let t' = subst (t, sb) in 98 | r := `Done t'; 99 | out t' 100 | end 101 | 102 | let rec pretty fmt t = 103 | Mon.bind (out t) ~f:begin fun tf -> 104 | match tf with 105 | | `V i -> Mon.return @@ Fmt.pf fmt "#%i" i 106 | | `F tf -> 107 | Mon.bind Mon.get_env ~f:begin fun env -> 108 | Mon.return @@ 109 | Sig.pretty (fun fmt t -> Mon.run env (pretty fmt t)) fmt tf 110 | end 111 | end 112 | 113 | let hole key = 114 | T.Ref (ref @@ `Defer (key, Subst.id)) 115 | end 116 | -------------------------------------------------------------------------------- /src/lib/ProofState.mli: -------------------------------------------------------------------------------- 1 | open Signature 2 | open Model 3 | open EnvMonad 4 | 5 | (* This is a model with references to holes *) 6 | module ProofState (Mon : EnvMonad) (Sig : Signature) : sig 7 | module T : sig 8 | type t 9 | [@@deriving (compare, sexp, show)] 10 | end 11 | 12 | module Subject : sig 13 | (* A subject is Ask if it has not been refined yet; it is Ret if it has been refined. 14 | The information order is that [Ask <= Ret t]. *) 15 | type t = 16 | | Ask 17 | | Ret of T.t 18 | [@@deriving (compare, sexp, show)] 19 | end 20 | 21 | module Jdg : sig 22 | type t = { 23 | cx : T.t list; 24 | ty : T.t; 25 | hole : Subject.t; 26 | } 27 | [@@deriving (compare, sexp, show)] 28 | end 29 | 30 | module TermF : sig 31 | type 'a t = 'a Sig.t 32 | [@@deriving (compare, sexp, show)] 33 | end 34 | 35 | module M : Monad.S 36 | with type 'a t = ('a, Jdg.t) Mon.T.t 37 | 38 | include EffectfulTermModel 39 | with module F := TermF 40 | and module M := M 41 | and module T := T 42 | 43 | val hole : Mon.Key.t -> T.t 44 | 45 | val out : T.t -> [`F of T.t TermF.t | `V of int] M.t 46 | end 47 | -------------------------------------------------------------------------------- /src/lib/Signature.ml: -------------------------------------------------------------------------------- 1 | module type Signature = sig 2 | (* This is meant to be the signature endofunctor *) 3 | type 'a t 4 | [@@deriving (compare, hash, sexp, show)] 5 | 6 | (* The function takes an extra parameter to indicate underneath how many 7 | binders it is being called. This feels a little ad-hoc, but it seems 8 | to suffice. *) 9 | val map : f:(int -> 'a -> 'b) -> 'a t -> 'b t 10 | 11 | val pretty : ih:('a Fmt.t) -> 'a t Fmt.t 12 | end 13 | -------------------------------------------------------------------------------- /src/lib/Subst.ml: -------------------------------------------------------------------------------- 1 | module F = struct 2 | type ('a, 's) t = 3 | | Id 4 | | Wk 5 | | Cmp of 's * 's 6 | | Ext of 's * 'a 7 | [@@deriving (compare, hash, sexp, show)] 8 | end 9 | 10 | module T = struct 11 | type 'a t = 12 | | In of ('a, 'a t) F.t 13 | [@@deriving (compare, hash, sexp, show)] 14 | end 15 | 16 | module Tensor = struct 17 | type ('a, 'b) t = 'a * 'b T.t 18 | [@@deriving (compare, hash, sexp, show)] 19 | end 20 | 21 | let out s = 22 | let T.In sf = s in 23 | sf 24 | 25 | let into sf = T.In sf 26 | 27 | let id = into F.Id 28 | 29 | let wk = into F.Wk 30 | 31 | let cmp s2 s1 = into @@ F.Cmp (s2, s1) 32 | 33 | let ext s t = into @@ F.Ext (s, t) 34 | -------------------------------------------------------------------------------- /src/lib/Subst.mli: -------------------------------------------------------------------------------- 1 | module F : sig 2 | type ('a, 's) t = 3 | | Id 4 | | Wk 5 | | Cmp of 's * 's 6 | | Ext of 's * 'a 7 | [@@deriving (compare, hash, sexp, show)] 8 | end 9 | 10 | module T : sig 11 | type 'a t 12 | [@@deriving (compare, hash, sexp, show)] 13 | end 14 | 15 | module Tensor : sig 16 | type ('a, 'b) t = 'a * 'b T.t 17 | [@@deriving (compare, hash, sexp, show)] 18 | end 19 | 20 | val into : ('a, 'a T.t) F.t -> 'a T.t 21 | 22 | val out : 'a T.t -> ('a, 'a T.t) F.t 23 | 24 | val id : 'a T.t 25 | 26 | val wk : 'a T.t 27 | 28 | val cmp : 'a T.t -> 'a T.t -> 'a T.t 29 | 30 | val ext : 'a T.t -> 'a -> 'a T.t 31 | -------------------------------------------------------------------------------- /src/lib/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library 4 | ((name TT) 5 | (flags (:standard -short-paths -strict-formats -w +a-3-4-6-9-30-32-39-41-42-44-48-60 -warn-error +a -open Base)) 6 | (ocamlopt_flags (:standard -short-paths -strict-formats -w +a-3-4-6-9-30-32-39-41-42-44-48-60 -warn-error +a -open Base -O3 -bin-annot -principal -unboxed-types)) 7 | (public_name tt) 8 | (libraries (fmt)) 9 | (preprocess (pps (ppx_deriving.std ppx_jane ppx_driver.runner))))) 10 | -------------------------------------------------------------------------------- /tests/Test.ml: -------------------------------------------------------------------------------- 1 | open TT 2 | open Model 3 | open EnvMonad 4 | open ProofState 5 | 6 | 7 | module LC = struct 8 | type 'a t = 9 | | Lam of 'a 10 | | App of 'a * 'a 11 | | Pair of 'a * 'a 12 | | Pi of 'a * 'a 13 | | Sg of 'a * 'a 14 | | Unit 15 | | Univ 16 | [@@deriving (compare, hash, sexp, show)] 17 | 18 | let map ~f t = 19 | match t with 20 | | Lam a -> Lam (f 1 a) 21 | | App (a1, a2) -> App (f 0 a1, f 0 a2) 22 | | Pair (a1, a2) -> Pair (f 0 a1, f 0 a2) 23 | | Pi (dom, cod) -> Pi (f 0 dom, f 1 cod) 24 | | Sg (dom, cod) -> Sg (f 0 dom, f 1 cod) 25 | | Unit -> Unit 26 | | Univ -> Univ 27 | 28 | let pretty ~ih fmt t = 29 | match t with 30 | | Lam a -> Fmt.pf fmt "@[(lam@ %a)@]" ih a 31 | | App (a0, a1) -> Fmt.pf fmt "@[(app@ %a@ %a)@]" ih a0 ih a1 32 | | Pair (a0, a1) -> Fmt.pf fmt "@[(cons@ %a@ %a)@]" ih a0 ih a1 33 | | Pi (dom, cod) -> Fmt.pf fmt "@[(->@ %a@ %a)@]" ih dom ih cod 34 | | Sg (dom, cod) -> Fmt.pf fmt "@[(*@ %a@ %a)@]" ih dom ih cod 35 | | Unit -> Fmt.pf fmt "unit" 36 | | Univ -> Fmt.pf fmt "univ" 37 | end 38 | 39 | module LCPure = Pure (LC) 40 | 41 | module Tac (Env : EnvMonad) = struct 42 | module E = ProofState (Env) (LC) 43 | 44 | module Let_syntax = struct 45 | let bind m ~f = Env.bind m f 46 | end 47 | 48 | let ask cx ty = 49 | let%bind key = Env.alloc E.Jdg.{cx; ty; hole = E.Subject.Ask} in 50 | Env.return (key, E.hole key) 51 | 52 | let fill key tm = 53 | match%bind Env.find key with 54 | | E.Jdg.{cx; ty; hole = E.Subject.Ask} -> 55 | Env.improve key E.Jdg.{cx; ty; hole = E.Subject.Ret tm} 56 | | _ -> failwith "fill" 57 | 58 | let match_hole key = 59 | match%bind Env.find key with 60 | | E.Jdg.{cx; ty; hole = E.Subject.Ask} -> 61 | let%bind pat = E.out ty in 62 | Env.return (cx, pat) 63 | | _ -> failwith "match_hole" 64 | 65 | let lambda key = 66 | match%bind match_hole key with 67 | | cx, `F (LC.Pi (dom, cod)) -> 68 | let%bind (kbdy, bdy) = ask (dom :: cx) cod in 69 | let%bind _ = fill key @@ E.into @@ LC.Lam bdy in 70 | Env.return kbdy 71 | | _ -> failwith "lambda" 72 | 73 | let pair key = 74 | match%bind match_hole key with 75 | | cx, `F (LC.Sg (dom, cod)) -> 76 | let%bind (k1, t1) = ask cx dom in 77 | let%bind (k2, t2) = ask cx @@ E.subst (cod, Subst.ext Subst.id t1) in 78 | let%bind _ = fill key @@ E.into @@ LC.Pair (t1, t2) in 79 | Env.return (k1, k2) 80 | | _ -> failwith "pair" 81 | end 82 | -------------------------------------------------------------------------------- /tests/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executables 4 | ((names (test)) 5 | (flags (:standard -short-paths -strict-formats -w +a-3-4-6-9-30-32-39-41-42-44-48-60 -warn-error +a -open Base)) 6 | (ocamlopt_flags (:standard -short-paths -strict-formats -w +a-3-4-6-9-30-32-39-41-42-44-48-60 -warn-error +a -open Base -O3 -bin-annot -principal -unboxed-types)) 7 | (libraries (tt)) 8 | (preprocess (pps (ppx_deriving.std ppx_jane ppx_driver.runner))))) 9 | 10 | (install 11 | ((section bin) 12 | (files ((test.exe as test))))) 13 | 14 | (alias 15 | ((name runtest) 16 | (deps (test.exe)) 17 | (action (run ${<})))) 18 | -------------------------------------------------------------------------------- /tt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2.2" 2 | name: "tt" 3 | version: "0.0" 4 | maintainer: "jonsterling@users.noreply.github.com" 5 | authors: ["Jon Sterling"] 6 | homepage: "https://github.com/jonsterling/tt" 7 | bug-reports: "https://github.com/jonsterling/tt/issues" 8 | dev-repo: "https://github.com/jonsterling/tt.git" 9 | license: "Apache-2.0" 10 | depends: [ 11 | "base" {= "v0.10.0"} 12 | "cmdliner" {= "1.0.2"} 13 | "fmt" {= "0.8.5"} 14 | "jbuilder" {build & = "1.0+beta17"} 15 | "lwt" {= "3.2.1"} 16 | "menhir" {>= "20171013"} 17 | "ppx_deriving" {= "4.2.1"} 18 | "ppx_expect" {= "v0.10.0"} 19 | "ppx_hash" {= "v0.10.0"} 20 | "ppx_jane" {= "v0.10.0"} 21 | "ppx_metaquot" {= "v0.10.0"} 22 | "ppx_traverse" {= "v0.10.0"} 23 | "topkg" {= "0.9.1"} 24 | "uuseg" {= "10.0.0"} 25 | "uutf" {= "1.0.1"} 26 | ] 27 | build: [ 28 | ["make"] 29 | ] 30 | --------------------------------------------------------------------------------