├── .gitignore ├── LICENSE.md ├── README.md ├── algebraic-fauxtt ├── README.md ├── bin │ ├── dune │ └── fauxtt.ml ├── dune-project ├── examples │ ├── church.ftt │ └── funext.ftt ├── lib │ ├── core │ │ ├── TT.ml │ │ ├── TT.mli │ │ ├── context.ml │ │ ├── context.mli │ │ ├── dune │ │ ├── equal.ml │ │ ├── equal.mli │ │ ├── norm.ml │ │ ├── norm.mli │ │ ├── print.ml │ │ ├── print.mli │ │ ├── toplevel.ml │ │ ├── toplevel.mli │ │ ├── typecheck.ml │ │ ├── typecheck.mli │ │ ├── unify.ml │ │ └── unify.mli │ ├── parsing │ │ ├── dune │ │ ├── lexer.ml │ │ ├── parser.mly │ │ ├── syntax.ml │ │ ├── syntax.mli │ │ ├── ulexbuf.ml │ │ └── ulexbuf.mli │ └── util │ │ ├── config.ml │ │ ├── config.mli │ │ ├── dune │ │ ├── level.ml │ │ ├── level.mli │ │ ├── location.ml │ │ ├── location.mli │ │ ├── name.ml │ │ ├── name.mli │ │ └── print.ml └── test │ ├── church.t │ ├── church.ftt │ └── run.t │ ├── dune │ ├── hole.t │ ├── funhole.ftt │ ├── hole.ftt │ ├── run.t │ └── unscoped.ftt │ └── syntax.t │ ├── run.t │ └── syntax.ftt ├── holey-fauxtt ├── README.md ├── bin │ ├── dune │ └── fauxtt.ml ├── dune-project ├── examples │ ├── church.ftt │ └── funext.ftt ├── lib │ ├── core │ │ ├── TT.ml │ │ ├── TT.mli │ │ ├── context.ml │ │ ├── context.mli │ │ ├── dune │ │ ├── equal.ml │ │ ├── equal.mli │ │ ├── norm.ml │ │ ├── norm.mli │ │ ├── print.ml │ │ ├── print.mli │ │ ├── toplevel.ml │ │ ├── toplevel.mli │ │ ├── typecheck.ml │ │ ├── typecheck.mli │ │ ├── unify.ml │ │ └── unify.mli │ ├── parsing │ │ ├── dune │ │ ├── lexer.ml │ │ ├── parser.mly │ │ ├── syntax.ml │ │ ├── syntax.mli │ │ ├── ulexbuf.ml │ │ └── ulexbuf.mli │ └── util │ │ ├── config.ml │ │ ├── config.mli │ │ ├── dune │ │ ├── level.ml │ │ ├── level.mli │ │ ├── location.ml │ │ ├── location.mli │ │ ├── name.ml │ │ ├── name.mli │ │ └── print.ml └── test │ ├── church.t │ ├── church.ftt │ └── run.t │ ├── dune │ ├── hole.t │ ├── funhole.ftt │ ├── hole.ftt │ ├── run.t │ └── unscoped.ftt │ └── syntax.t │ ├── run.t │ └── syntax.ftt ├── monadic-fauxtt ├── README.md ├── bin │ ├── dune │ └── fauxtt.ml ├── dune-project ├── examples │ ├── church.ftt │ └── funext.ftt ├── lib │ ├── core │ │ ├── TT.ml │ │ ├── TT.mli │ │ ├── context.ml │ │ ├── context.mli │ │ ├── dune │ │ ├── equal.ml │ │ ├── equal.mli │ │ ├── norm.ml │ │ ├── norm.mli │ │ ├── print.ml │ │ ├── print.mli │ │ ├── toplevel.ml │ │ ├── toplevel.mli │ │ ├── typecheck.ml │ │ └── typecheck.mli │ ├── parsing │ │ ├── dune │ │ ├── lexer.ml │ │ ├── parser.mly │ │ ├── syntax.ml │ │ ├── syntax.mli │ │ ├── ulexbuf.ml │ │ └── ulexbuf.mli │ └── util │ │ ├── config.ml │ │ ├── config.mli │ │ ├── dune │ │ ├── level.ml │ │ ├── level.mli │ │ ├── location.ml │ │ ├── location.mli │ │ ├── name.ml │ │ ├── name.mli │ │ └── print.ml └── test │ ├── church.t │ ├── church.ftt │ └── run.t │ ├── dune │ └── syntax.t │ ├── run.t │ └── syntax.ftt └── slides ├── PL-for-PA-lecture-1-handout.pdf ├── PL-for-PA-lecture-1.tex ├── PL-for-PA-lecture-2-handout.pdf ├── PL-for-PA-lecture-2.tex ├── PL-for-PA-lecture-3-handout.pdf ├── PL-for-PA-lecture-3.tex ├── PL-for-PA-lecture-4-handout.pdf ├── PL-for-PA-lecture-4.tex └── writeOnce.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | slides/*.pdf 3 | *.exe 4 | 5 | 6 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2025 Andrej Bauer 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Faux Type Theory 2 | 3 | These are the materials for the lecture series [Programming language techniques for proof assistants](https://europroofnet.github.io/LFPSI25-Andrej/), delivered by [Andrej Bauer](https://www.andrej.com/en/) at the 4 | [International School on Logical Frameworks and Proof Systems Interoperability (LFPSI)](https://europroofnet.github.io/LFPSI25/), 5 | a [Final EuroProofNet Symposium](https://europroofnet.github.io/Symposium/) event that took place at [Institut Pascal](https://www.institut-pascal.universite-paris-saclay.fr/) on September 8–12, 2025. 6 | 7 | The lectures are going to be recorded. A link to the videos will be provided here. 8 | 9 | ## Lecture 1: From declarative to algorithmic type theory 10 | 11 | We study **Faux type theory**, a small type theory with a universe containing itself, dependent products, and local 12 | definitions. We present the theory in traditional declarative style. We then reformulate it to obtain an algorithmic 13 | presentation suitable for implementation. 14 | 15 | Material: 16 | 17 | * **[Lecture 1 slides](./slides/PL-for-PA-lecture-1-handout.pdf)** 18 | 19 | ## Lecture 2: A monadic type checker 20 | 21 | We implement Faux type theory in OCaml. We use external libraries for parsing and management of bound variables. 22 | The core type checker uses *monadic-style* implementaion that encapsulates the context in a reader monad. 23 | 24 | Material: 25 | 26 | * **[Lecture 2 slides](./slides/PL-for-PA-lecture-2-handout.pdf)** 27 | * **Implementation:** [`monadic-fauxtt`](./monadic-fauxtt) 28 | 29 | ## Lecture 3: Holes and unification 30 | 31 | Holes are parts of a term that the user has not provided. They can be filled in by a number of mechanisms: unification, 32 | type class resolution, interaction with the user, automated search, etc. In type theory, they appear as meta-variabales. 33 | We will look at a rudimentary implementation with holes that fills them in using unification. 34 | 35 | Material: 36 | 37 | * **[Lecture 3 slides](slides/PL-for-PA-lecture-3-handout.pdf)** 38 | * **Implementation:** [`holey-fauxtt`](./holey-fauxtt) 39 | 40 | ## Lecture 4: Variables as computational effects 41 | 42 | After a review of algebraic effects and handlers, we implement variables and meta-variables as computational effects. 43 | Doing so allows us to remove the monadic-style code and replace it with direct-style naive code. 44 | 45 | Material: 46 | 47 | * **[Lecture 4 slides](slides/PL-for-PA-lecture-4-handout.pdf)** 48 | * **Implementation:** [`algebraic-fauxtt`](./algebraic-fauxtt) 49 | -------------------------------------------------------------------------------- /algebraic-fauxtt/README.md: -------------------------------------------------------------------------------- 1 | # A monadic implementation of faux type theory 2 | 3 | **This is the basic version of Faux type theory, as presented in Lecture 2.** 4 | 5 | ## The type theory 6 | 7 | The dependent type theory `fauxtt` has the following ingridients: 8 | 9 | * A universe `Type` with `Type : Type`. 10 | * Dependent products, written as `forall (x : T₁), T₂` or `∀ (x : T₁), T₂` or `∏ (x : T₁), T₂`. 11 | * Functions, written as one of `fun (x : T) => e` or `λ (x : T) ⇒ e`. The typing annotation may 12 | be omitted, i.e., `fun x => e`, and multiple abstractions may be shortened as 13 | `λ x y (z u : T) (w : U) ⇒ e`. 14 | * Application `e₁ e₂`. 15 | * Type ascription written as `e : T`. 16 | * Local definitions written as `let x := e₁ in e₂`. 17 | 18 | Top-level commands: 19 | 20 | * `def x := e` -- define a value 21 | * `axiom x : T` -- assume a constant `x` of type `T` 22 | * `check e` -- print the type of `e` 23 | * `eval e` -- evaluate `e` a la call-by-value 24 | * `Load "⟨file⟩"` -- load a file 25 | 26 | ## Prerequisites 27 | 28 | * [OCaml](https://ocaml.org) and [OPAM](https://opam.ocaml.org) 29 | 30 | * The OPAM packages `dune`, `menhir`, `menhirLib`, `sedlex` and `bindlib`: 31 | 32 | opam install dune menhir menhirLib sedlex bindlib 33 | 34 | * It is recommended that you also install the `rlwrap` or `ledit` command line wrapper. 35 | 36 | ## Compilation 37 | 38 | You can type: 39 | 40 | * `dune build` to compile the `fauxtt.exe` executable. 41 | * `dune clean` to clean up. 42 | 43 | ## Usage 44 | 45 | Once you compile the program, you can run it in interactive mode as `./fauxtt.exe` 46 | 47 | Run `./fauxtt.exe --help` to see the command-line options and general usage. 48 | 49 | 50 | ## Source code 51 | 52 | The purpose of the implementation is to keep the source uncomplicated and short. The 53 | essential bits of source code can be found in the following files. It should be possible 54 | for you to just read the entire source code. 55 | 56 | It is best to first familiarize yourself with the core: 57 | 58 | * [`lib/core/TT.ml`](./lib/core/TT.ml) – the core type theory 59 | * [`lib/core/context.ml`](./lib/core/context.ml) – typing context 60 | * [`lib/core/typecheck.ml`](./lib/coretypecheck.ml) – type checking and elaboration 61 | * [`lib/core/norm.ml`](./lib/core/norm.ml) – normalization 62 | * [`lib/core/equal.ml`](./lib/core/equal.ml) – equality and normalization 63 | * [`lib/core/toplevel.ml`](./lib/core/toplevel.ml) – top-level commands 64 | 65 | Continue with the infrastructure: 66 | 67 | * [`lib/parsing/syntax.ml`](./lib/parsing/syntax.ml) – abstract syntax of the input code 68 | * [`lib/parsing/lexer.ml`](./lib/parsing/lexer.ml) – the lexer 69 | * [`lib/parsing/parser.mly`](./lib/parsing/parser.mly) – the parser 70 | * [`lib/util`](./lib/util) – various utilities 71 | * [`bin/fauxtt.ml`](bin/fauxtt.ml) – the main executable 72 | 73 | -------------------------------------------------------------------------------- /algebraic-fauxtt/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name "fauxtt") 3 | (public_name "fauxtt") 4 | (modules fauxtt) 5 | (promote (until-clean) (into ..)) 6 | (libraries parsing core unix)) 7 | -------------------------------------------------------------------------------- /algebraic-fauxtt/bin/fauxtt.ml: -------------------------------------------------------------------------------- 1 | (** The main executable. *) 2 | 3 | open Util 4 | 5 | (** The usage message. *) 6 | let usage = "Usage: fauxtt [option] ... [file] ..." 7 | 8 | (** A list of files to be loaded and run, together with information on whether they should 9 | be loaded in interactive mode. *) 10 | let files = ref [] 11 | 12 | (** Add a file to the list of files to be loaded, and record whether it should 13 | be processed in interactive mode. *) 14 | let add_file quiet filename = (files := (filename, quiet) :: !files) 15 | 16 | (** Command-line options *) 17 | let options = Arg.align [ 18 | 19 | ("--columns", 20 | Arg.Set_int Config.columns, 21 | " Set the maximum number of columns of pretty printing"); 22 | 23 | ("--ascii", 24 | Arg.Set Config.ascii, 25 | " Use ASCII characters only"); 26 | 27 | ("-V", 28 | Arg.Set_int Config.verbosity, 29 | " Set printing verbosity to "); 30 | 31 | ("-n", 32 | Arg.Clear Config.interactive_shell, 33 | " Do not run the interactive toplevel"); 34 | 35 | ("-l", 36 | Arg.String (fun str -> add_file true str), 37 | " Load into the initial environment"); 38 | ] 39 | 40 | (* Print the error message corresponding to an exception. *) 41 | let print_error ?(penv=Bindlib.empty_ctxt) = function 42 | | Parsing.Ulexbuf.Error {Location.data=err; Location.loc} -> 43 | Print.error "Lexical error at %t:@ %t" (Location.print loc) (Parsing.Ulexbuf.print_error err) 44 | 45 | | Core.Typecheck.Error {Location.data=err; Location.loc} -> 46 | Print.error "Typechecking error at %t:@ %t" 47 | (Location.print loc) 48 | (Core.Typecheck.print_error ~penv err) 49 | 50 | | Sys.Break -> 51 | Print.error "Interrupted." ; 52 | 53 | | e -> 54 | raise e 55 | 56 | (* Interactive toplevel. *) 57 | let interactive_shell () = 58 | Format.printf "Faux type theory implemented with algebraic effects 1.2@." ; 59 | 60 | let rec loop () = 61 | (try 62 | Core.Toplevel.exec_interactive () 63 | with 64 | | e -> print_error e) ; 65 | loop () 66 | in 67 | try 68 | loop () 69 | with 70 | End_of_file -> () 71 | 72 | (* The main program. *) 73 | let _main = 74 | Sys.catch_break true ; 75 | 76 | (* Parse the arguments. *) 77 | Arg.parse 78 | options 79 | (fun str -> add_file false str ; Config.interactive_shell := false) 80 | usage ; 81 | 82 | (* Files were accumulated in the wrong order, so we reverse them *) 83 | files := List.rev !files ; 84 | 85 | (* Set the maximum depth of pretty-printing, after which it prints ellipsis. *) 86 | Format.set_max_boxes !Config.max_boxes ; 87 | Format.set_margin !Config.columns ; 88 | Format.set_ellipsis_text "..." ; 89 | 90 | Core.Context.handle_context 91 | (fun () -> 92 | try 93 | List.iter (fun (fn, quiet) -> Core.Toplevel.load_file ~quiet fn) !files ; 94 | if !Config.interactive_shell then 95 | interactive_shell () 96 | with 97 | | e -> print_error e 98 | ) 99 | -------------------------------------------------------------------------------- /algebraic-fauxtt/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | (name "faux-type-theory") 3 | (version 1.2) 4 | (using menhir 2.0) 5 | (cram enable) 6 | 7 | (authors "Andrej Bauer ") 8 | (maintainers "Andrej Bauer ") 9 | (source (github andrejbauer/faux-type-theory)) 10 | (license "MIT") 11 | 12 | (generate_opam_files false) 13 | 14 | (package 15 | (name faux-type-theory) 16 | (synopsis "A minimalistic implementation of faux type implemented with algebraic effects") 17 | (description 18 | "This project shows how to implement a minimalist type theory, 19 | which nevertheless could serve as a basis for a serious interpretation." 20 | ) 21 | 22 | (depends 23 | (ocaml (>= 5.0.0)) 24 | (dune :build) 25 | (menhir :build) 26 | (menhirLib :build) 27 | (sedlex :build) 28 | (bindlib (and (>= 6.0) :build)) 29 | (odoc :with-doc))) 30 | -------------------------------------------------------------------------------- /algebraic-fauxtt/examples/church.ftt: -------------------------------------------------------------------------------- 1 | (* Church numerals *) 2 | 3 | def numeral := ∏ (A : Type), (A → A) → (A → A) 4 | 5 | eval numeral 6 | 7 | def zero : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ x) 8 | 9 | def succ : numeral → numeral := 10 | (λ n A (f : A → A) (x : A) ⇒ f (n A f x)) 11 | 12 | def one : numeral := succ zero 13 | 14 | def two : numeral := succ one 15 | 16 | def three : numeral := (λ A (f : A → A) (x : A) ⇒ f (f (f x))) 17 | 18 | def five := succ (succ (succ (succ (succ zero)))) 19 | 20 | def ( + ) : numeral → numeral → numeral := 21 | λ m n A (f : A → A) (x : A) ⇒ m A f (n A f x) 22 | 23 | def ( * ) : numeral → numeral → numeral := 24 | λ m n A (f : A → A) (x : A) ⇒ m A (n A f) x 25 | 26 | def ten := five + five 27 | 28 | def hundred := ten * ten 29 | 30 | def thousand := hundred * ten 31 | 32 | (* A trick to see the numerals *) 33 | axiom N : Type 34 | axiom Z : N 35 | axiom S : N → N 36 | 37 | eval (thousand N S Z) 38 | 39 | -------------------------------------------------------------------------------- /algebraic-fauxtt/examples/funext.ftt: -------------------------------------------------------------------------------- 1 | (* Check that function extensionality holds. *) 2 | 3 | axiom A : Type 4 | axiom P : (A → A) → Type 5 | axiom f : A → A 6 | 7 | def id := λ (A : Type) (x : A) ⇒ x 8 | 9 | (** Function composition. *) 10 | def compose := λ (A B C : Type) (g : B → C) (f : A → B) (x : A) => g (f x) 11 | 12 | axiom u : P f 13 | 14 | infer u : P f 15 | 16 | infer u : P (id (A → A) f) 17 | 18 | infer u : P (compose A A A (id A) f) 19 | 20 | 21 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/TT.ml: -------------------------------------------------------------------------------- 1 | (* Faux type theory *) 2 | 3 | open Util 4 | 5 | (** Term *) 6 | type tm = 7 | | Var of var (** A free variable *) 8 | | Meta of var (** meta-variable (hole) *) 9 | | Let of tm * ty * tm binder (** A let binding *) 10 | | Type (** the type of types *) 11 | | Prod of ty * ty binder (** dependent product *) 12 | | Lambda of ty * tm binder (** lambda abstraction *) 13 | | Apply of tm * tm (** application *) 14 | 15 | (** Type *) 16 | and ty = Ty of tm 17 | 18 | and var = tm Bindlib.var 19 | 20 | and 'a binder = (tm, 'a) Bindlib.binder 21 | 22 | (** A boxed term binder *) 23 | type 'a binder_ = 'a binder Bindlib.box 24 | 25 | (** A boxed term *) 26 | type tm_ = tm Bindlib.box 27 | 28 | (** A boxed type *) 29 | type ty_ = ty Bindlib.box 30 | 31 | let box_binder = Bindlib.box_binder 32 | 33 | (* Constructors for boxed terms and types *) 34 | 35 | let var_ = Bindlib.box_var 36 | 37 | let meta_ x = Bindlib.box (Meta x) 38 | 39 | let let_ = Bindlib.box_apply3 (fun e1 t e2 -> Let (e1, t, e2)) 40 | 41 | let type_ = Bindlib.box Type 42 | 43 | let ty_ = Bindlib.box_apply (fun t -> Ty t) 44 | 45 | let ty_type_ = Bindlib.box (Ty Type) 46 | 47 | let prod_ = Bindlib.box_apply2 (fun t u -> Prod (t, u)) 48 | 49 | let ty_prod_ = Bindlib.box_apply2 (fun t u -> Ty (Prod (t, u))) 50 | 51 | let lambda_ = Bindlib.box_apply2 (fun t e -> Lambda (t, e)) 52 | 53 | let apply_ = 54 | Bindlib.box_apply2 (fun e1 e2 -> Apply (e1, e2)) 55 | 56 | (* Lifting functions *) 57 | 58 | let rec lift_tm = function 59 | 60 | | Var v -> var_ v 61 | 62 | | Meta v -> meta_ v 63 | 64 | | Let (e1, t, e2) -> 65 | let_ (lift_tm e1) (lift_ty t) (box_binder lift_tm e2) 66 | 67 | | Type -> type_ 68 | 69 | | Prod (ty1, ty2) -> 70 | prod_ (lift_ty ty1) (box_binder lift_ty ty2) 71 | 72 | | Lambda (t, e) -> 73 | lambda_ (lift_ty t) (box_binder lift_tm e) 74 | 75 | | Apply (e1, e2) -> 76 | apply_ (lift_tm e1) (lift_tm e2) 77 | 78 | and lift_ty (Ty ty) = 79 | Bindlib.box_apply (fun ty -> Ty ty) (lift_tm ty) 80 | 81 | (* Helper functions for printing quantifiers *) 82 | 83 | let unbox = Bindlib.unbox 84 | 85 | let bind_var = Bindlib.bind_var 86 | 87 | let unbind = Bindlib.unbind 88 | 89 | let fresh_var x = Bindlib.new_var (fun x -> Var x) x 90 | 91 | let anonymous_var () = fresh_var (Name.anonymous ()) 92 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/TT.mli: -------------------------------------------------------------------------------- 1 | (** The faux type theory. *) 2 | 3 | (** Terms *) 4 | type tm = 5 | | Var of var (** variable *) 6 | | Meta of var (** meta-variable (hole) *) 7 | | Let of tm * ty * tm binder (** A let binding *) 8 | | Type (** the type of types qua term *) 9 | | Prod of ty * ty binder (** dependent product *) 10 | | Lambda of ty * tm binder (** function *) 11 | | Apply of tm * tm (** application *) 12 | 13 | (** Types *) 14 | and ty = Ty of tm 15 | 16 | (** Variable *) 17 | and var = tm Bindlib.var 18 | 19 | (** An entity with one bound variable *) 20 | and 'a binder = (tm, 'a) Bindlib.binder 21 | 22 | (** A boxed term, in the sense of [Bindlib]. *) 23 | type tm_ = tm Bindlib.box 24 | 25 | (** A boxed type, in the sense of [Bindlib]. *) 26 | type ty_ = ty Bindlib.box 27 | 28 | (** A boxed binder, in the sense of [Bindlib]. *) 29 | type 'a binder_ = 'a binder Bindlib.box 30 | 31 | (** Boxed constructors *) 32 | 33 | val var_ : var -> tm_ 34 | 35 | val meta_ : var -> tm_ 36 | 37 | val let_ : tm_ -> ty_ -> tm binder_ -> tm_ 38 | 39 | val type_ : tm_ 40 | 41 | val ty_ : tm_ -> ty_ 42 | 43 | val ty_type_ : ty_ 44 | 45 | val prod_ : ty_ -> ty binder_ -> tm_ 46 | 47 | val ty_prod_ : ty_ -> ty binder_ -> ty_ 48 | 49 | val lambda_ : ty_ -> tm binder_ -> tm_ 50 | 51 | val apply_ : tm_ -> tm_ -> tm_ 52 | 53 | (** Lifting functions *) 54 | 55 | val lift_tm : tm -> tm_ 56 | 57 | val lift_ty : ty -> ty_ 58 | 59 | val fresh_var : string -> var 60 | 61 | (** Generate a fresh variable that the user cannot. *) 62 | val anonymous_var : unit -> var 63 | 64 | (** Bind a variable in the given boxed entity. *) 65 | val bind_var : var -> 'a Bindlib.box -> 'a binder_ 66 | 67 | (** Unbind a variable in the given bound entity. *) 68 | val unbind : 'a binder -> var * 'a 69 | 70 | (** Unbox an entity. *) 71 | val unbox : 'a Bindlib.box -> 'a 72 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/context.ml: -------------------------------------------------------------------------------- 1 | (** Typing context and definitional equalities. *) 2 | 3 | open Effect 4 | open Effect.Deep 5 | 6 | module IdentMap = Map.Make(struct 7 | type t = string 8 | let compare = String.compare 9 | end) 10 | 11 | module VarMap = Map.Make(struct 12 | type t = TT.var 13 | let compare = Bindlib.compare_vars 14 | end) 15 | 16 | (** A typing context comprises two maps, the first one mapping strings to [Bindlib] variables, 17 | and the second mapping variables to their types and optional definitions. *) 18 | type t = 19 | { idents : TT.var IdentMap.t 20 | ; vars : (TT.tm option * TT.ty) VarMap.t 21 | } 22 | 23 | type _ Effect.t += 24 | | LookupVar : TT.var -> (TT.tm option * TT.ty) Effect.t 25 | | LookupIdent : string -> TT.var option Effect.t 26 | | LookupMeta : TT.var -> (TT.tm option * TT.ty) Effect.t 27 | | FreshMeta_ : string * TT.ty_ -> TT.tm_ Effect.t 28 | | SetMeta_ : TT.var * TT.tm_ -> bool Effect.t 29 | | TopExtend : (string * TT.tm option * TT.ty) -> unit Effect.t 30 | 31 | (** The initial, empty typing context. *) 32 | let initial = 33 | { idents = IdentMap.empty 34 | ; vars = VarMap.empty 35 | } 36 | 37 | let penv _ = Bindlib.empty_ctxt 38 | 39 | let _extend_var x v def ty ctx = 40 | { idents = (match x with None -> ctx.idents | Some x -> IdentMap.add x v ctx.idents) 41 | ; vars = VarMap.add v (def, ty) ctx.vars 42 | } 43 | 44 | let top_extend x ?def ty = 45 | perform (TopExtend (x, def, ty)) 46 | 47 | let lookup_ident x = 48 | perform (LookupIdent x) 49 | 50 | let lookup_var v = 51 | perform (LookupVar v) 52 | 53 | let lookup_meta v = 54 | perform (LookupMeta v) 55 | 56 | let with_ident_var x v ?def t c = 57 | try 58 | c () 59 | with 60 | | effect (LookupVar w), k when Bindlib.eq_vars v w -> 61 | continue k (def, t) 62 | 63 | | effect (LookupIdent y), k when String.equal x y -> 64 | continue k (Some v) 65 | 66 | | effect (FreshMeta_ (x, u_)), k when (def = None) -> 67 | let t_ = TT.lift_ty t in 68 | let u_ = TT.(ty_ (prod_ t_ (bind_var v u_))) in 69 | let e_ = perform (FreshMeta_ (x, u_)) in 70 | continue k TT.(apply_ e_ (var_ v)) 71 | 72 | | effect (SetMeta_ (mv, e_)), k when Bindlib.occur v e_ -> 73 | begin match def with 74 | | None -> continue k false 75 | | Some e' -> 76 | let e'_ = TT.lift_tm e' in 77 | let t_ = TT.lift_ty t in 78 | let b = perform (SetMeta_ (mv, TT.(let_ e'_ t_ (bind_var v e_)))) in 79 | continue k b 80 | end 81 | 82 | let with_ident x ?def t (c : TT.var -> 'a) = 83 | let v = TT.fresh_var x in 84 | with_ident_var x v ?def t (fun () -> c v) 85 | 86 | let with_var v ?def t (c : unit -> 'a) = 87 | let x = Util.Name.anonymous () in 88 | with_ident_var x v ?def t c 89 | 90 | let with_ident_ x ?def ty_ (c : TT.var -> 'a) = 91 | let ty = TT.unbox ty_ in 92 | let def = Option.map TT.unbox def in 93 | with_ident x ?def ty c 94 | 95 | let set_meta_ v e_ = 96 | perform (SetMeta_ (v, e_)) 97 | 98 | let fresh_meta_ x ty_ = 99 | perform (FreshMeta_ (x, ty_)) 100 | 101 | let with_meta_ x ty_ c = 102 | let e_ = fresh_meta_ x ty_ in 103 | c e_ 104 | 105 | let with_meta x ty c = 106 | let ty_ = TT.lift_ty ty in 107 | with_meta_ x ty_ (fun e_ -> c (TT.unbox e_)) 108 | 109 | let handle_context c = 110 | let ctx = ref initial in 111 | try 112 | c () 113 | with 114 | | effect (LookupVar v), k -> 115 | continue k (VarMap.find v !ctx.vars) 116 | 117 | | effect (LookupIdent x), k -> 118 | continue k (IdentMap.find_opt x !ctx.idents) 119 | 120 | | effect (TopExtend (x, def, ty)), k -> 121 | let v = TT.fresh_var x in 122 | ctx := { idents = IdentMap.add x v !ctx.idents ; vars = VarMap.add v (def, ty) !ctx.vars } ; 123 | continue k () 124 | 125 | exception UnresolvedMeta of TT.var 126 | 127 | let handle_metas c = 128 | let metas = ref (VarMap.empty : (TT.tm option * TT.ty) VarMap.t) in 129 | try 130 | let r = c () in 131 | VarMap.iter (fun mv -> function 132 | | Some _, _ -> () 133 | | None, _ -> raise (UnresolvedMeta mv)) 134 | !metas ; 135 | r 136 | with 137 | 138 | | effect (FreshMeta_ (x, ty_)), k -> 139 | let mv = TT.fresh_var x in 140 | let ty = TT.unbox ty_ in 141 | metas := VarMap.add mv (None, ty) !metas ; 142 | continue k (TT.meta_ mv) 143 | 144 | | effect (LookupMeta v), k -> 145 | continue k (VarMap.find v !metas) 146 | 147 | | effect (SetMeta_ (v, e_)), k -> 148 | begin match VarMap.find v !metas with 149 | 150 | | None, ty -> 151 | let e = TT.unbox e_ in 152 | metas := VarMap.add v (Some e, ty) !metas ; 153 | continue k true 154 | 155 | | Some _, _ -> assert false 156 | 157 | end 158 | 159 | | UnresolvedMeta mv -> 160 | Util.Print.error "unresolved hole %s@" (Bindlib.name_of mv) 161 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/context.mli: -------------------------------------------------------------------------------- 1 | (** Global context. *) 2 | type t 3 | 4 | (** The initial global typing context. *) 5 | val initial : t 6 | 7 | (** Assign a value to a meta-variable. It is the caller's responsbility to assign a value of correct type. 8 | It is an error to assign a value to an already defined meta. *) 9 | val set_meta_ : TT.var -> TT.tm_ -> bool 10 | 11 | (** Extend the context with a top-level definition and return it *) 12 | val top_extend : string -> ?def:TT.tm -> TT.ty -> unit 13 | 14 | (** The identifiers which should not be used for printing bound variables. *) 15 | val penv : t -> Bindlib.ctxt 16 | 17 | (** Lookup the definition associated with a variable, if any. *) 18 | val lookup_var : TT.var -> TT.tm option * TT.ty 19 | 20 | (** Lookup the definition associated with a meta-variable, if any. *) 21 | val lookup_meta : TT.var -> TT.tm option * TT.ty 22 | 23 | (** Lookup the variable which corresponds to a concrete name. *) 24 | val lookup_ident : string -> TT.var option 25 | 26 | (** Run a computation in a context extended with a variable, passing it the newly 27 | created variable. It is the callers responsibility that the result be valid in 28 | the original context. *) 29 | 30 | val handle_context : (unit -> 'a) -> 'a 31 | 32 | val handle_metas : (unit -> unit) -> unit 33 | 34 | val with_ident : string -> ?def:TT.tm -> TT.ty -> (TT.var -> 'a) -> 'a 35 | 36 | val with_ident_ : string -> ?def:TT.tm_ -> TT.ty_ -> (TT.var -> 'a) -> 'a 37 | 38 | val with_var : TT.var -> ?def:TT.tm -> TT.ty -> (unit -> 'a) -> 'a 39 | 40 | val with_meta : string -> TT.ty -> (TT.tm -> 'a) -> 'a 41 | 42 | val with_meta_ : string -> TT.ty_ -> (TT.tm_ -> 'a) -> 'a 43 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core) 3 | (libraries bindlib util parsing)) 4 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/equal.ml: -------------------------------------------------------------------------------- 1 | (** Equality and normalization. *) 2 | 3 | (** Compare expressions [e1] and [e2] at type [ty]? *) 4 | let rec equal_tm_at e1 e2 ty = 5 | (* short-circuit *) 6 | (e1 == e2) || 7 | begin 8 | (* The type directed phase *) 9 | let Norm.Ty ty' = Norm.norm_ty ty in 10 | match ty' with 11 | 12 | | Norm.Prod (t, u) -> 13 | (* Apply function extensionality. *) 14 | let (x, u) = TT.unbind u in 15 | Context.with_var x t 16 | (fun () -> 17 | let e1 = TT.(Apply (e1, Var x)) 18 | and e2 = TT.(Apply (e2, Var x)) in 19 | equal_tm_at e1 e2 u) 20 | 21 | | Norm.(Spine _ | Type) -> 22 | (* Type-directed phase is done, we compare normal forms. *) 23 | equal_tm e1 e2 24 | 25 | | Norm.(Lambda _) -> 26 | (* A type should never normalize to an abstraction or a let-binding *) 27 | assert false 28 | end 29 | 30 | (** Structurally compare weak head-normal forms of terms [e1] and [e2]. *) 31 | and equal_tm e1 e2 = 32 | let e1 = Norm.norm_tm e1 in 33 | let e2 = Norm.norm_tm e2 in 34 | match e1, e2 with 35 | 36 | | Norm.Type, Norm.Type -> 37 | true 38 | 39 | | Norm.Prod (t1, u1), Norm.Prod (t2, u2) -> 40 | equal_ty t1 t2 && 41 | begin 42 | let (x, u1, u2) = Bindlib.unbind2 u1 u2 in 43 | Context.with_var x t1 (fun () -> equal_ty u1 u2) 44 | end 45 | 46 | | Norm.Lambda _, Norm.Lambda _ -> 47 | (* We should never have to compare two lambdas, as that would mean that the 48 | type-directed phase did not figure out that these have product types. *) 49 | assert false 50 | 51 | | Norm.Spine (x1, es1), Norm.Spine (x2, es2) -> 52 | equal_spine x1 es1 x2 es2 53 | 54 | | Norm.(Type | Prod _ | Lambda _ | Spine _), _ -> 55 | false 56 | 57 | and equal_spine h1 es1 h2 es2 = 58 | let rec fold t es1 es2 = 59 | match es1, es2 with 60 | | [], [] -> true 61 | 62 | | ([], _::_) | (_::_, []) -> false 63 | 64 | | e1 :: es1, e2 :: es2 -> 65 | begin 66 | match Norm.as_prod t with 67 | | None -> false 68 | | Some (t, u) -> 69 | equal_tm_at e1 e2 t && 70 | fold (Bindlib.subst u e1) es1 es2 71 | end 72 | in 73 | 74 | let equal_heads h1 h2 = 75 | match h1, h2 with 76 | | Norm.Var x1, Norm.Var x2 -> Bindlib.eq_vars x1 x2 77 | | Norm.Meta x1, Norm.Meta x2 -> Bindlib.eq_vars x1 x2 78 | | Norm.Var _, Norm.Meta _ 79 | | Norm.Meta _, Norm.Var _ -> false 80 | in 81 | 82 | (equal_heads h1 h2) && 83 | begin 84 | match h1 with 85 | | Norm.Var x1 -> 86 | let _, t = Context.lookup_var x1 in fold t es1 es2 87 | | Norm.Meta x1 -> 88 | let _, t = Context.lookup_meta x1 in fold t es1 es2 89 | end 90 | 91 | (** Compare two types. *) 92 | and equal_ty (TT.Ty ty1) (TT.Ty ty2) = 93 | equal_tm_at ty1 ty2 TT.(Ty Type) 94 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/equal.mli: -------------------------------------------------------------------------------- 1 | (** Are the given terms equal at the given type? *) 2 | val equal_tm_at : TT.tm -> TT.tm -> TT.ty -> bool 3 | 4 | (** Are the given types equal? *) 5 | val equal_ty : TT.ty -> TT.ty -> bool 6 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/norm.ml: -------------------------------------------------------------------------------- 1 | type head = 2 | | Var of TT.var 3 | | Meta of TT.var 4 | 5 | type tm = 6 | | Type 7 | | Prod of TT.ty * TT.ty TT.binder 8 | | Lambda of TT.ty * TT.tm TT.binder 9 | | Spine of head * TT.tm list 10 | 11 | type ty = Ty of tm 12 | 13 | (** A normalization strategy. *) 14 | type strategy = 15 | | WHNF (** normalize to weak head-normal form *) 16 | | CBV (** call-by-value normalization *) 17 | 18 | (** Normalize an expression using the given strategy. *) 19 | let rec norm_tm' ~strategy e = 20 | match e with 21 | 22 | | TT.Type -> 23 | e 24 | 25 | | TT.Var x -> 26 | begin 27 | match Context.lookup_var x with 28 | | None, _ -> e 29 | | Some e, _ -> norm_tm' ~strategy e 30 | end 31 | 32 | | TT.Meta x -> 33 | begin 34 | match Context.lookup_meta x with 35 | | None, _ -> e 36 | | Some e, _ -> norm_tm' ~strategy e 37 | end 38 | 39 | | TT.Let (e1, t, e2) -> 40 | let e1 = 41 | match strategy with 42 | | WHNF -> e1 43 | | CBV -> norm_tm' ~strategy e1 44 | in 45 | let (v, e2) = TT.unbind e2 in 46 | Context.with_var v ~def:e1 t (fun () -> norm_tm' ~strategy e2) 47 | 48 | | TT.Prod _ -> 49 | e 50 | 51 | | TT.Lambda _ -> 52 | e 53 | 54 | | TT.Apply (e1, e2) -> 55 | let e1 = norm_tm' ~strategy e1 in 56 | let e2 = 57 | begin 58 | match strategy with 59 | | WHNF -> e2 60 | | CBV -> norm_tm' ~strategy e2 61 | end 62 | in 63 | begin 64 | match e1 with 65 | | TT.Lambda (_, e') -> 66 | norm_tm' ~strategy (Bindlib.subst e' e2) 67 | | _ -> 68 | TT.Apply (e1, e2) 69 | end 70 | 71 | (** Normalize a type *) 72 | let norm_ty' ~strategy (TT.Ty ty) = 73 | let ty = norm_tm' ~strategy ty in 74 | TT.Ty ty 75 | 76 | let eval_tm = norm_tm' ~strategy:CBV 77 | 78 | let norm_tm e = 79 | match norm_tm' ~strategy:WHNF e with 80 | | TT.Let _ -> assert false 81 | 82 | | TT.Type -> Type 83 | 84 | | TT.Prod (t, u) -> Prod (t, u) 85 | 86 | | TT.Lambda (t, e) -> Lambda (t, e) 87 | 88 | | TT.(Var _ | Meta _ | Apply _) as e -> 89 | let rec fold es = function 90 | | TT.Var x -> Var x, es 91 | | TT.Meta x -> Meta x, es 92 | | TT.Apply (e1, e2) -> fold (e2 :: es) e1 93 | | TT.(Let _ | Type | Prod _ | Lambda _) -> assert false 94 | in 95 | let x, es = fold [] e in 96 | Spine (x, es) 97 | 98 | let norm_ty (TT.Ty t) = 99 | let t = norm_tm t in 100 | Ty t 101 | 102 | (** Normalize a type to a product. *) 103 | let as_prod t = 104 | let TT.Ty t' = norm_ty' ~strategy:WHNF t in 105 | match t' with 106 | | TT.Prod (t, u) -> Some (t, u) 107 | | _ -> None 108 | 109 | (** Normalize a term to a variable. *) 110 | let as_var e = 111 | let e' = norm_tm' ~strategy:WHNF e in 112 | match e' with 113 | | TT.Var v -> Some v 114 | | _ -> None 115 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/norm.mli: -------------------------------------------------------------------------------- 1 | (** Weak-head normal term. *) 2 | type head = 3 | | Var of TT.var 4 | | Meta of TT.var 5 | 6 | type tm = 7 | | Type 8 | | Prod of TT.ty * TT.ty TT.binder 9 | | Lambda of TT.ty * TT.tm TT.binder 10 | | Spine of head * TT.tm list 11 | 12 | type ty = Ty of tm 13 | 14 | (** Evaluate a term using the call-by-value strategy *) 15 | val eval_tm : TT.tm -> TT.tm 16 | 17 | (** Normalize a term *) 18 | val norm_tm : TT.tm-> tm 19 | 20 | (** Normalize a type *) 21 | val norm_ty : TT.ty -> ty 22 | 23 | (** Convert a type to a product *) 24 | val as_prod : TT.ty -> (TT.ty * TT.ty TT.binder) option 25 | 26 | (** Convert a term to a variable *) 27 | val as_var : TT.tm -> TT.var option 28 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/print.ml: -------------------------------------------------------------------------------- 1 | (** Printing of terms and types. *) 2 | (* Printing routines *) 3 | 4 | module Level = Util.Level 5 | 6 | let as_prod ?(penv=Bindlib.empty_ctxt) = function 7 | | TT.(Ty (Prod (u, t))) when Bindlib.binder_occur t -> 8 | let (x, t, penv) = Bindlib.unbind_in penv t in 9 | Some (x, u, t, penv) 10 | | _ -> None 11 | 12 | let as_lambda ?(penv=Bindlib.empty_ctxt) = function 13 | | TT.Lambda (t, e) -> 14 | let (x, e, penv) = Bindlib.unbind_in penv e in 15 | Some (x, t, e, penv) 16 | | _ -> None 17 | 18 | let rec tm ?max_level ?(penv=Bindlib.empty_ctxt) e ppf = 19 | match e with 20 | 21 | | TT.Var x -> 22 | Format.fprintf ppf "%s" (Bindlib.name_of x) 23 | 24 | | TT.Meta x -> 25 | Format.fprintf ppf "?%s" (Bindlib.name_of x) 26 | 27 | | TT.Let (e1, _, e2) -> 28 | let (x, e2, penv') = Bindlib.unbind_in penv e2 in 29 | Util.Print.print ?max_level ~at_level:Level.let_binding ppf "let@ %s :=@ %t@ in@ %t" 30 | (Bindlib.name_of x) 31 | (tm ~max_level:Level.let_bound ~penv e1) 32 | (tm ~max_level:Level.let_body ~penv:penv' e2) 33 | 34 | | TT.Type -> 35 | Format.fprintf ppf "Type" 36 | 37 | | TT.Lambda (t, e) -> 38 | print_quantifier ?max_level ~at_level:Level.highest ~penv as_lambda 39 | (Util.Print.char_lambda ()) (" " ^ Util.Print.char_darrow ()) tm t e ppf 40 | 41 | | TT.Apply (e1, e2) -> 42 | print_apply ?max_level ~penv e1 e2 ppf 43 | 44 | | TT.Prod (u, t) -> 45 | print_quantifier ?max_level ~at_level:Level.highest ~penv as_prod 46 | (Util.Print.char_prod ()) "," ty u t ppf 47 | 48 | 49 | and ty ?max_level ?(penv=Bindlib.empty_ctxt) (Ty t) ppf = 50 | tm ?max_level ~penv t ppf 51 | 52 | and print_quantifier : 53 | 'a . ?max_level:Level.t -> at_level:Level.t -> 54 | penv:_ -> 55 | (?penv:_ -> 'a -> (TT.var * TT.ty * 'a * _) option) -> 56 | string -> string -> 57 | (?max_level:Level.t -> ?penv:_ -> 'a -> Format.formatter -> unit) -> 58 | TT.ty -> 'a TT.binder -> Format.formatter -> unit 59 | = 60 | fun ?max_level ~at_level ~penv as_quant quant comma print_v u v ppf -> 61 | let rec print_rest ~penv v = 62 | match as_quant ~penv v with 63 | | None -> 64 | Util.Print.print ppf "%s@ %t" comma (print_v ~penv v) ; 65 | 66 | | Some (x, u, v, penv') -> 67 | Format.fprintf ppf "%s@ %s@;<1 -4>(%s : %t)" comma quant (Bindlib.name_of x) (ty ~penv u) ; 68 | print_rest ~penv:penv' v 69 | in 70 | let printer ppf = 71 | Format.pp_open_hovbox ppf 2 ; 72 | let (x, v, penv') = Bindlib.unbind_in penv v in 73 | Format.fprintf ppf "%s@;<1 -4>(%s : %t)" quant (Bindlib.name_of x) (ty ~penv u) ; 74 | print_rest ~penv:penv' v ; 75 | Format.pp_close_box ppf () 76 | in 77 | Util.Print.print ?max_level ~at_level ppf "%t" printer 78 | 79 | and print_apply ?max_level ~penv e1 e2 ppf = 80 | let prnt () = 81 | Util.Print.print ppf ?max_level ~at_level:Level.app "%t@ %t" 82 | (tm ~max_level:Level.app_left ~penv e1) 83 | (tm ~max_level:Level.app_right ~penv e2) 84 | in 85 | match e1 with 86 | 87 | | Var x -> 88 | begin 89 | match Util.Name.fixity x with 90 | 91 | | Util.Name.Prefix -> 92 | Util.Print.print ppf ?max_level ~at_level:Level.prefix "%t@ %t" 93 | (Util.Name.print_var x) 94 | (tm ~max_level:Level.prefix_arg ~penv e2) 95 | 96 | | Util.Name.Word -> 97 | prnt () 98 | 99 | | Util.Name.Infix lvl -> 100 | begin match e2 with 101 | 102 | | Apply (e2', e2'') -> 103 | let (lvl, lvl_right, lvl_left) = Level.infix lvl in 104 | Util.Print.print ppf ?max_level ~at_level:lvl "%t@ %t@ %t" 105 | (tm ~max_level:lvl_left ~penv e2') 106 | (Util.Name.print_var ~parentheses:false x) 107 | (tm ~max_level:lvl_right ~penv e2'') 108 | 109 | | _ -> prnt () 110 | end 111 | end 112 | 113 | | _ -> prnt () 114 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/print.mli: -------------------------------------------------------------------------------- 1 | (** Printing of terms and types *) 2 | 3 | (** Print a term *) 4 | val tm : ?max_level:Util.Level.t -> ?penv:Bindlib.ctxt -> TT.tm -> Format.formatter -> unit 5 | 6 | (** Print a type *) 7 | val ty : ?max_level:Util.Level.t -> ?penv:Bindlib.ctxt -> TT.ty -> Format.formatter -> unit 8 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/toplevel.ml: -------------------------------------------------------------------------------- 1 | (** Top-level processing. *) 2 | 3 | type state = Context.t 4 | 5 | let initial = Context.initial 6 | 7 | let penv = Context.penv 8 | 9 | let exec_interactive () = 10 | let e = Parsing.Lexer.read_toplevel Parsing.Parser.commandline () in 11 | Typecheck.toplevel ~quiet:false e 12 | 13 | let load_file ~quiet fn = 14 | Typecheck.topfile ~quiet fn 15 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/toplevel.mli: -------------------------------------------------------------------------------- 1 | (** The top-level state of the proof assistant *) 2 | type state = Context.t 3 | 4 | (** Initial top-level state. *) 5 | val initial : state 6 | 7 | (** Read a top-level command from the standard input and execute it. *) 8 | val exec_interactive : unit -> unit 9 | 10 | (** Load the contents of a file and execute it. *) 11 | val load_file : quiet:bool -> string -> unit 12 | 13 | (** Names of bound variables, used for printing de Bruijn indices. *) 14 | val penv : state -> Bindlib.ctxt 15 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/typecheck.mli: -------------------------------------------------------------------------------- 1 | (** Type errors *) 2 | type type_error 3 | 4 | (** Exception signalling a type error. *) 5 | exception Error of type_error Util.Location.t 6 | 7 | (** Print error description. *) 8 | val print_error : ?penv:Bindlib.ctxt -> type_error -> Format.formatter -> unit 9 | 10 | (** Type-check a top-level command. *) 11 | val toplevel : quiet:bool -> Parsing.Syntax.toplevel -> unit 12 | 13 | (** Type-check the contents of a file. *) 14 | val topfile : quiet:bool -> string -> unit 15 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/unify.ml: -------------------------------------------------------------------------------- 1 | (** Equality and normalization. *) 2 | 3 | (** Unify expressions [e1] and [e2] at type [ty]? *) 4 | let rec unify_tm_at e1 e2 ty = 5 | (* short-circuit *) 6 | (e1 == e2) || 7 | begin 8 | (* The type directed phase *) 9 | let (Norm.Ty ty') = Norm.norm_ty ty in 10 | match ty' with 11 | 12 | | Norm.Prod (t, u) -> 13 | (* Apply function extensionality. *) 14 | let (x, u) = TT.unbind u in 15 | Context.with_var x t 16 | (fun () -> 17 | let e1 = TT.(Apply (e1, Var x)) 18 | and e2 = TT.(Apply (e2, Var x)) in 19 | unify_tm_at e1 e2 u) 20 | 21 | | Norm.(Type | Spine _) -> 22 | (* Type-directed phase is done, we compare normal forms. *) 23 | unify_tm e1 e2 24 | 25 | | Norm.Lambda _ -> 26 | (* A type should never normalize to an abstraction or a let-binding *) 27 | assert false 28 | end 29 | 30 | (** Structurally unify weak head-normal forms of terms [e1] and [e2]. *) 31 | and unify_tm e1 e2 : bool = 32 | let e1' = Norm.norm_tm e1 in 33 | let e2' = Norm.norm_tm e2 in 34 | match e1', e2' with 35 | 36 | | Norm.Type, Norm.Type -> 37 | true 38 | 39 | | Norm.Prod (t1, u1), Norm.Prod (t2, u2) -> 40 | unify_ty t1 t2 && 41 | begin 42 | let (x, u1, u2) = Bindlib.unbind2 u1 u2 in 43 | Context.with_var x t1 (fun () -> unify_ty u1 u2) 44 | end 45 | 46 | | Norm.Spine (Var x1, es1), Norm.Spine (Var x2, es2) when Bindlib.eq_vars x1 x2 -> 47 | let _, t = Context.lookup_var x1 in 48 | unify_spine t es1 es2 49 | 50 | | Norm.Spine (Meta x1, es1), Norm.Spine (Meta x2, es2) -> 51 | if Bindlib.eq_vars x1 x2 then 52 | let _, t = Context.lookup_meta x1 in 53 | unify_spine t es1 es2 54 | else 55 | (unify_meta x1 es1 e2) || (unify_meta x2 es2 e1) 56 | 57 | | Norm.Spine (Meta x1, es1), Norm.(Type | Prod _ | Spine (Var _, _)) -> 58 | unify_meta x1 es1 e2 59 | 60 | | Norm.(Type | Prod _ | Spine (Var _, _)), Norm.Spine (Meta x2, es2) -> 61 | unify_meta x2 es2 e1 62 | 63 | | Norm.Lambda _, _ | _, Norm.Lambda _ -> 64 | (* We should never have to compare two lambdas, as that would mean that the 65 | type-directed phase did not figure out that these have product types. *) 66 | assert false 67 | 68 | | Norm.(Type | Prod _ | Spine _), Norm.(Type | Prod _ | Spine _) -> 69 | false 70 | 71 | and unify_ty (TT.Ty ty1) (TT.Ty ty2) = 72 | unify_tm_at ty1 ty2 TT.(Ty Type) 73 | 74 | and unify_spine t es1 es2 = 75 | let rec fold t es1 es2 = 76 | match es1, es2 with 77 | 78 | | ([], _::_) | (_::_, []) -> false 79 | 80 | | [], [] -> true 81 | 82 | | e1 :: es1, e2 :: es2 -> 83 | match Norm.as_prod t with 84 | | None -> false 85 | | Some (t, u) -> 86 | begin 87 | match unify_tm_at e1 e2 t with 88 | | false -> false 89 | | true -> fold (Bindlib.subst u e1) es1 es2 90 | end 91 | in 92 | fold t es1 es2 93 | 94 | and unify_meta mv es e' = 95 | let rec abstract t ys = function 96 | | [] -> Some (TT.lift_tm e') 97 | | e :: es -> 98 | begin 99 | match Norm.as_prod t with 100 | | None -> assert false 101 | | Some (u, t) -> 102 | match Norm.as_var e with 103 | | None -> None 104 | | Some y -> 105 | if List.exists (Bindlib.eq_vars y) ys then 106 | None 107 | else begin 108 | begin match abstract (Bindlib.subst t (TT.Var y)) (y :: ys) es with 109 | | None -> None 110 | | Some e' -> 111 | let e' = TT.lambda_ (TT.lift_ty u) (Bindlib.bind_var y e') in 112 | Some e' 113 | end 114 | end 115 | end 116 | in 117 | let _, t = Context.lookup_meta mv in 118 | match abstract t [] es with 119 | | None -> false 120 | | Some e_ -> Context.set_meta_ mv e_ 121 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/core/unify.mli: -------------------------------------------------------------------------------- 1 | (** Unify terms at a type. *) 2 | val unify_tm_at : TT.tm -> TT.tm -> TT.ty -> bool 3 | 4 | (** Unifty types *) 5 | val unify_ty : TT.ty -> TT.ty -> bool 6 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/parsing/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parsing) 3 | (libraries sedlex menhirLib util) 4 | (preprocess (pps sedlex.ppx))) 5 | 6 | (menhir 7 | (modules parser)) -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/parsing/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | 3 | open Util 4 | 5 | %} 6 | 7 | (* Infix operations a la OCaml *) 8 | 9 | %token PREFIXOP INFIXOP0 INFIXOP1 INFIXOP2 INFIXOP3 INFIXOP4 10 | 11 | (* Names *) 12 | %token NAME 13 | %token UNDERSCORE QUESTIONMARK 14 | 15 | (* Parentheses & punctuations *) 16 | %token LPAREN RPAREN 17 | %token COLONEQ 18 | %token COMMA COLON DARROW ARROW 19 | 20 | (* Expressions *) 21 | %token LET IN 22 | %token TYPE 23 | %token PROD 24 | %token LAMBDA 25 | 26 | (* Toplevel commands *) 27 | %token QUOTED_STRING 28 | %token LOAD 29 | %token DEF 30 | %token INFER 31 | %token EVAL 32 | %token AXIOM 33 | 34 | (* End of input token *) 35 | %token EOF 36 | 37 | (* Precedence and fixity of infix operators *) 38 | %left INFIXOP0 39 | %right INFIXOP1 40 | %left INFIXOP2 41 | %left INFIXOP3 42 | %right INFIXOP4 43 | 44 | %start file 45 | %start commandline 46 | 47 | %% 48 | 49 | file: 50 | | f=filecontents EOF 51 | { f } 52 | 53 | 54 | filecontents: 55 | | 56 | { [] } 57 | 58 | | d=topcomp ds=filecontents 59 | { d :: ds } 60 | 61 | 62 | commandline: 63 | | topcomp EOF 64 | { $1 } 65 | 66 | 67 | (* Things that can be defined on toplevel. *) 68 | topcomp: mark_location(topcomp_) { $1 } 69 | topcomp_: 70 | | LOAD fn=QUOTED_STRING 71 | { Syntax.TopLoad fn } 72 | 73 | | DEF x=var_name COLONEQ e=term 74 | { Syntax.TopDefinition (x, None, e) } 75 | 76 | | DEF x=var_name COLON t=term COLONEQ e=term 77 | { Syntax.TopDefinition (x, Some t, e) } 78 | 79 | | INFER e=term 80 | { Syntax.TopInfer e } 81 | 82 | | EVAL e=term 83 | { Syntax.TopEval e } 84 | 85 | | AXIOM x=var_name COLON e=term 86 | { Syntax.TopAxiom (x, e) } 87 | 88 | 89 | term : mark_location(term_) { $1 } 90 | term_: 91 | | e=infix_term_ 92 | { e } 93 | 94 | | PROD a=prod_abstraction COMMA e=term 95 | { Syntax.prod a e } 96 | 97 | | e1=infix_term ARROW e2=term 98 | { Syntax.arrow e1 e2 } 99 | 100 | | LAMBDA a=lambda_abstraction DARROW e=term 101 | { Syntax.lambda a e } 102 | 103 | | LET x=var_name COLONEQ e1=term IN e2=term 104 | { Syntax.Let (x, e1, e2) } 105 | 106 | | e=infix_term COLON t=term 107 | { Syntax.Ascribe (e, t) } 108 | 109 | 110 | infix_term: mark_location(infix_term_) { $1 } 111 | infix_term_: 112 | | e=app_term_ 113 | { e } 114 | 115 | | e2=infix_term oploc=infix e3=infix_term 116 | { let {Location.data=op; loc} = oploc in 117 | let op = Location.locate ~loc (Syntax.Var op) in 118 | let e1 = Location.locate ~loc (Syntax.Apply (op, e2)) in 119 | Syntax.Apply (e1, e3) 120 | } 121 | 122 | 123 | app_term: mark_location(app_term_) { $1 } 124 | app_term_: 125 | | e=prefix_term_ 126 | { e } 127 | 128 | | e1=app_term e2=prefix_term 129 | { Syntax.Apply (e1, e2) } 130 | 131 | 132 | prefix_term: mark_location(prefix_term_) { $1 } 133 | prefix_term_: 134 | | e=simple_term_ 135 | { e } 136 | 137 | | oploc=prefix e2=prefix_term 138 | { let {Location.data=op; loc} = oploc in 139 | let op = Location.locate ~loc (Syntax.Var op) in 140 | Syntax.Apply (op, e2) 141 | } 142 | 143 | 144 | (* simple_term : mark_location(simple_term_) { $1 } *) 145 | simple_term_: 146 | | LPAREN e=term_ RPAREN 147 | { e } 148 | 149 | | TYPE 150 | { Syntax.Type } 151 | 152 | | x=var_name 153 | { Syntax.Var x } 154 | 155 | | QUESTIONMARK x=var_name 156 | { Syntax.Hole x } 157 | 158 | 159 | var_name: 160 | | NAME 161 | { $1 } 162 | 163 | | LPAREN op=infix RPAREN 164 | { op.Location.data } 165 | 166 | | LPAREN op=prefix RPAREN 167 | { op.Location.data } 168 | 169 | | UNDERSCORE 170 | { Name.anonymous () } 171 | 172 | 173 | %inline infix: 174 | | op=INFIXOP0 175 | { op } 176 | 177 | | op=INFIXOP1 178 | { op } 179 | 180 | | op=INFIXOP2 181 | { op } 182 | 183 | | op=INFIXOP3 184 | { op } 185 | 186 | | op=INFIXOP4 187 | { op } 188 | 189 | 190 | %inline prefix: 191 | | op=PREFIXOP 192 | { op } 193 | 194 | lambda_abstraction: 195 | | lst=nonempty_list(binder) 196 | { lst } 197 | 198 | prod_abstraction: 199 | | lst=nonempty_list(typed_binder) 200 | { lst } 201 | 202 | typed_binder: mark_location(typed_binder_) { $1 } 203 | typed_binder_: 204 | | LPAREN xs=nonempty_list(var_name) COLON t=term RPAREN 205 | { (xs, t) } 206 | 207 | binder: mark_location(binder_) { $1 } 208 | binder_: 209 | | LPAREN xs=nonempty_list(var_name) COLON t=term RPAREN 210 | { (xs, Some t) } 211 | 212 | | x=var_name 213 | { ([x], None) } 214 | 215 | 216 | mark_location(X): 217 | | x=X 218 | { Location.locate ~loc:(Location.make $startpos $endpos) x } 219 | 220 | %% 221 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/parsing/syntax.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type tm = tm' Location.t 4 | and tm' = 5 | | Var of string 6 | | Let of string * tm * tm 7 | | Type 8 | | Prod of (string * ty) * ty 9 | | Lambda of (string * ty option) * tm 10 | | Apply of tm * tm 11 | | Ascribe of tm * ty 12 | | Hole of string 13 | 14 | (* Parsed type (equal to tmession). *) 15 | and ty = tm 16 | 17 | (* Parsed top-level command. *) 18 | type toplevel = toplevel' Location.t 19 | and toplevel' = 20 | | TopLoad of string 21 | | TopDefinition of string * ty option * tm 22 | | TopInfer of tm 23 | | TopEval of tm 24 | | TopAxiom of string * ty 25 | 26 | let prod xus t = 27 | let rec fold = function 28 | | [] -> t 29 | | Location.{loc; data=(xs, u)} :: xus -> 30 | let rec fold' = function 31 | | [] -> fold xus 32 | | x :: xs -> 33 | Location.locate ~loc (Prod ((x, u), fold' xs)) 34 | in 35 | fold' xs 36 | in 37 | (fold xus).Location.data 38 | 39 | let lambda xus t = 40 | let rec fold = function 41 | | [] -> t 42 | | Location.{loc; data=(xs, uopt)} :: xus -> 43 | let rec fold' = function 44 | | [] -> fold xus 45 | | x :: xs -> 46 | Location.locate ~loc (Lambda ((x, uopt), fold' xs)) 47 | in 48 | fold' xs 49 | in 50 | (fold xus).Location.data 51 | 52 | let arrow u t = 53 | let x = Name.anonymous () in 54 | Prod ((x, u), t) 55 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/parsing/syntax.mli: -------------------------------------------------------------------------------- 1 | (* Concrete syntax as parsed by the parser. *) 2 | 3 | open Util 4 | 5 | (* Parsed term. *) 6 | type tm = tm' Location.t 7 | and tm' = 8 | | Var of string 9 | | Let of string * tm * tm 10 | | Type 11 | | Prod of (string * ty) * ty 12 | | Lambda of (string * ty option) * tm 13 | | Apply of tm * tm 14 | | Ascribe of tm * ty 15 | | Hole of string 16 | 17 | (* Parsed types are the same as terms. *) 18 | and ty = tm 19 | 20 | (* Parsed top-level command. *) 21 | type toplevel = toplevel' Location.t 22 | and toplevel' = 23 | | TopLoad of string 24 | | TopDefinition of string * ty option * tm 25 | | TopInfer of tm 26 | | TopEval of tm 27 | | TopAxiom of string * ty 28 | 29 | val prod : (string list * ty) Location.t list -> ty -> tm' 30 | 31 | val lambda : (string list * ty option) Location.t list -> tm -> tm' 32 | 33 | val arrow : ty -> ty -> tm' 34 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/parsing/ulexbuf.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | stream : Sedlexing.lexbuf ; 3 | mutable pos_start : Lexing.position ; 4 | mutable pos_end : Lexing.position ; 5 | mutable line_limit : int option ; 6 | mutable end_of_input : bool ; 7 | } 8 | 9 | type error = 10 | | SysError of string 11 | | Unexpected of string 12 | | MalformedUTF8 13 | | BadNumeral of string 14 | | UnclosedComment 15 | 16 | let print_error err ppf = match err with 17 | | SysError s -> Format.fprintf ppf "System error: %s" s 18 | | Unexpected s -> Format.fprintf ppf "Unexpected %s" s 19 | | MalformedUTF8 -> Format.fprintf ppf "Malformed UTF8" 20 | | BadNumeral s -> Format.fprintf ppf "Bad numeral %s" s 21 | | UnclosedComment -> Format.fprintf ppf "Input ended inside unclosed comment" 22 | 23 | exception Error of error Util.Location.t 24 | 25 | let error ~loc err = Stdlib.raise (Error (Util.Location.locate ~loc err)) 26 | 27 | let create_lexbuf ?(fn="") stream = 28 | let pos_end = 29 | Lexing.{ 30 | pos_fname = fn; 31 | pos_lnum = 1; 32 | pos_bol = 0; 33 | pos_cnum = 0; 34 | } 35 | in 36 | { pos_start = pos_end; pos_end; stream ; 37 | line_limit = None; end_of_input = false; } 38 | 39 | let from_channel ?(fn="") fh = 40 | create_lexbuf ~fn (Sedlexing.Utf8.from_channel fh) 41 | 42 | let from_string ?(fn="") s = 43 | create_lexbuf ~fn (Sedlexing.Utf8.from_string s) 44 | 45 | let lexeme { stream;_ } = Sedlexing.Utf8.lexeme stream 46 | 47 | let new_line ?(n=1) lexbuf = 48 | assert (n >= 0) ; 49 | if n = 0 then () else 50 | let open Lexing in 51 | let lcp = lexbuf.pos_end in 52 | lexbuf.pos_end <- 53 | { lcp with 54 | pos_lnum = lcp.pos_lnum + n ; 55 | pos_bol = lcp.pos_cnum ; 56 | } 57 | 58 | let update_pos ({pos_end; stream;_} as buf) = 59 | let p_start, p_end = Sedlexing.loc stream in 60 | buf.pos_start <- {pos_end with Lexing.pos_cnum = p_start}; 61 | buf.pos_end <- {pos_end with Lexing.pos_cnum = p_end } 62 | 63 | let reached_end_of_input b = 64 | b.end_of_input <- true 65 | 66 | let set_line_limit ll b = 67 | b.line_limit <- ll 68 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/parsing/ulexbuf.mli: -------------------------------------------------------------------------------- 1 | (** Support for UTF8 lexer. *) 2 | 3 | open Util 4 | 5 | (** The state of the parser: a stream, a beginning- and an end-position. *) 6 | type t = private { 7 | stream : Sedlexing.lexbuf ; 8 | mutable pos_start : Lexing.position ; 9 | mutable pos_end : Lexing.position ; 10 | mutable line_limit : int option ; 11 | mutable end_of_input : bool ; 12 | } 13 | 14 | type error = 15 | | SysError of string 16 | | Unexpected of string 17 | | MalformedUTF8 18 | | BadNumeral of string 19 | | UnclosedComment 20 | 21 | val print_error : error -> Format.formatter -> unit 22 | 23 | exception Error of error Location.t 24 | 25 | val error : loc:Location.location -> error -> 'a 26 | 27 | (** Update the start and end positions from the stream. *) 28 | val update_pos : t -> unit 29 | 30 | (** Register [n] new lines in the lexbuf's position. *) 31 | val new_line : ?n:int -> t -> unit 32 | 33 | (** The last matched lexeme as a string *) 34 | val lexeme : t -> string 35 | 36 | (** Create a lex-buffer from a channel. Set filename to [fn] (default ["?"]) *) 37 | val from_channel : ?fn:string -> in_channel -> t 38 | 39 | (** Create a lex-buffer from a string. Set filename to [fn] (default ["?"]) *) 40 | val from_string : ?fn:string -> string -> t 41 | 42 | val reached_end_of_input : t -> unit 43 | 44 | val set_line_limit : int option -> t -> unit 45 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/config.ml: -------------------------------------------------------------------------------- 1 | let interactive_shell = ref true 2 | 3 | let max_boxes = ref 42 4 | 5 | let columns = ref (Format.get_margin ()) 6 | 7 | let verbosity = ref 2 8 | 9 | let ascii = ref false 10 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/config.mli: -------------------------------------------------------------------------------- 1 | (** Configuration parameters that control how fauxtt works. *) 2 | 3 | (** Should the interactive shell be started. *) 4 | val interactive_shell : bool ref 5 | 6 | (** How deeply should large expressions be printed. *) 7 | val max_boxes : int ref 8 | 9 | (** How many columns should be used for printing expressions. *) 10 | val columns : int ref 11 | 12 | (** How verbose should the output be. *) 13 | val verbosity : int ref 14 | 15 | (** Should we restrict to ASCII-only output. *) 16 | val ascii : bool ref 17 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name util) 3 | (libraries bindlib)) 4 | 5 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/level.ml: -------------------------------------------------------------------------------- 1 | (** Precedence levels, support for pretty-printing. *) 2 | 3 | type t = int 4 | 5 | let parenthesize ~at_level ~max_level = max_level < at_level 6 | 7 | type infix = 8 | | Infix0 9 | | Infix1 10 | | Infix2 11 | | Infix3 12 | | Infix4 13 | 14 | let highest = 1000 15 | let least = 0 16 | 17 | let no_parens = least 18 | 19 | let prefix = 50 20 | let prefix_arg = 50 21 | 22 | let app = 100 23 | let app_left = app 24 | let app_right = app - 1 25 | 26 | let infix = function 27 | | Infix4 -> (200, 199, 200) 28 | | Infix3 -> (300, 300, 299) 29 | | Infix2 -> (400, 400, 399) 30 | | Infix1 -> (500, 499, 500) 31 | | Infix0 -> (600, 600, 599) 32 | 33 | let eq = 700 34 | let eq_left = eq - 1 35 | let eq_right = eq - 1 36 | 37 | let binder = 800 38 | let in_binder = binder 39 | let arr = binder 40 | let arr_left = arr - 1 41 | let arr_right = arr 42 | 43 | let ascription = 800 44 | 45 | let let_binding = 900 46 | let let_bound = 950 47 | let let_body = no_parens 48 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/level.mli: -------------------------------------------------------------------------------- 1 | (** Precedence of operators *) 2 | 3 | (** Levels of precedence -- higher level is less likely to be parenthesized. *) 4 | type t 5 | 6 | (** If we print [at_level] where [max_level] is the highest level that can still 7 | be printed without parenthesis, should we print parenthesis? *) 8 | val parenthesize : at_level:'a -> max_level:'a -> bool 9 | 10 | (** Following OCaml syntax, there are five levels of infix operators *) 11 | type infix = Infix0 | Infix1 | Infix2 | Infix3 | Infix4 12 | 13 | (** The highest possible level *) 14 | val highest : t 15 | 16 | (** The least possible level *) 17 | val least : t 18 | 19 | (** The level which never gets parenthesized (equal to [least]) *) 20 | val no_parens : t 21 | 22 | (** The level of a prefix operator and its argument *) 23 | val prefix : t 24 | val prefix_arg : t 25 | 26 | (** The level of application and its left and right arguments *) 27 | val app : t 28 | val app_left : t 29 | val app_right : t 30 | 31 | (** The level of an infix operator, and its left and right arguments *) 32 | val infix : infix -> t * t * t 33 | 34 | (** The level of an equality, and its arguments *) 35 | val eq : t 36 | val eq_left : t 37 | val eq_right : t 38 | 39 | (** The level of a binder (such as lambda) and its body *) 40 | val binder : t 41 | val in_binder : t 42 | 43 | (** The elvel of an arrow and its arguments *) 44 | val arr : t 45 | val arr_left : t 46 | val arr_right : t 47 | 48 | (** The level of type ascription *) 49 | val ascription : t 50 | 51 | (** The level of a let binding *) 52 | val let_binding : t 53 | 54 | (** The level of the let-bound expression *) 55 | val let_bound : t 56 | 57 | (** The level of the body of a let-bound expression *) 58 | val let_body : t 59 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/location.ml: -------------------------------------------------------------------------------- 1 | type location = 2 | | Location of Lexing.position * Lexing.position (** delimited location *) 3 | | Nowhere (** no location *) 4 | 5 | type 'a t = { data : 'a ; loc : location } 6 | 7 | let nowhere = Nowhere 8 | 9 | let make loc1 loc2 = Location (loc1, loc2) 10 | 11 | let of_lex lex = 12 | Location (Lexing.lexeme_start_p lex, Lexing.lexeme_end_p lex) 13 | 14 | let locate ?(loc=Nowhere) x = { data = x; loc = loc } 15 | 16 | let print loc ppf = 17 | match loc with 18 | | Nowhere -> 19 | Format.fprintf ppf "unknown location" 20 | | Location (begin_pos, end_pos) -> 21 | let begin_char = begin_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 22 | let end_char = end_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 23 | let begin_line = begin_pos.Lexing.pos_lnum in 24 | let filename = begin_pos.Lexing.pos_fname in 25 | 26 | if String.length filename != 0 then 27 | Format.fprintf ppf "file %S, line %d, charaters %d-%d" filename begin_line begin_char end_char 28 | else 29 | Format.fprintf ppf "line %d, characters %d-%d" (begin_line - 1) begin_char end_char 30 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/location.mli: -------------------------------------------------------------------------------- 1 | (** Source code locations. *) 2 | type location = 3 | | Location of Lexing.position * Lexing.position (** delimited location *) 4 | | Nowhere (** no location *) 5 | 6 | (** A datum tagged with a source code location *) 7 | type 'a t = private { data : 'a ; loc : location } 8 | 9 | (** Tag a datum with an (optional) location. *) 10 | val locate : ?loc:location -> 'a -> 'a t 11 | 12 | (** An unknown location, use with care. *) 13 | val nowhere : location 14 | 15 | (** Convert a [Lexing.lexbuf] location to a [location] *) 16 | val of_lex : Lexing.lexbuf -> location 17 | 18 | (** [make p1 p2] creates a location which starts at [p1] and ends at [p2]. *) 19 | val make : Lexing.position -> Lexing.position -> location 20 | 21 | (** Print a location *) 22 | val print : location -> Format.formatter -> unit 23 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/name.ml: -------------------------------------------------------------------------------- 1 | (** Names of variables. *) 2 | 3 | type fixity = 4 | | Word 5 | | Prefix 6 | | Infix of Level.infix 7 | 8 | let fixity x = 9 | let s = Bindlib.name_of x in 10 | if String.length s = 0 then 11 | Word 12 | else if String.length s > 1 && s.[0] = '*' && s.[1] = '*' then Infix Level.Infix4 13 | else 14 | match s.[0] with 15 | | '~' | '?' | '!' -> Prefix 16 | | '=' | '<' | '>' | '|' | '&' | '$' -> Infix Level.Infix0 17 | | '@' | '^' -> Infix Level.Infix1 18 | | '+' | '-' -> Infix Level.Infix2 19 | | '*' | '/' | '%' -> Infix Level.Infix3 20 | | _ -> Word 21 | 22 | let anonymous = 23 | let k = ref 0 in 24 | fun () -> (incr k ; "_" ^ string_of_int !k) 25 | 26 | let print_var ?(parentheses=true) x ppf = 27 | let s = Bindlib.name_of x in 28 | match fixity x with 29 | | Word -> Format.fprintf ppf "%s" s 30 | | Prefix | Infix _ -> 31 | if parentheses then 32 | Format.fprintf ppf "(%s)" s 33 | else 34 | Format.fprintf ppf "%s" s 35 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/name.mli: -------------------------------------------------------------------------------- 1 | (* Kinds of variable names. *) 2 | type fixity = 3 | | Word (* an ordinary word *) 4 | | Prefix (* prefix operator *) 5 | | Infix of Level.infix (* infix operator *) 6 | 7 | (* Generate a fresh name that the user cannot possibly generate *) 8 | val anonymous : unit -> string 9 | 10 | (* The fixity of a variable *) 11 | val fixity : 'a Bindlib.var -> fixity 12 | 13 | (* Print a variable name, possibly with parentheses if it is an operator. *) 14 | val print_var : ?parentheses:bool -> 'a Bindlib.var -> Format.formatter -> unit 15 | -------------------------------------------------------------------------------- /algebraic-fauxtt/lib/util/print.ml: -------------------------------------------------------------------------------- 1 | (** Support for pretty-printing and user messages. *) 2 | 3 | (** Print a message with given verbosity level. *) 4 | let message ~verbosity = 5 | if verbosity <= !Config.verbosity then 6 | fun fmt -> Format.eprintf (fmt ^^ "@.") 7 | else 8 | Format.ifprintf Format.err_formatter 9 | 10 | (** Report an error. *) 11 | let error fmt = message ~verbosity:1 fmt 12 | 13 | (** Report a warning. *) 14 | let warning fmt = message ~verbosity:2 ("Warning: " ^^ fmt) 15 | 16 | (** Report debugging information. *) 17 | let debug fmt = message ~verbosity:3 ("Debug: " ^^ fmt) 18 | 19 | (** Print an expression, possibly parenthesized. *) 20 | let print ?(at_level=Level.no_parens) ?(max_level=Level.highest) ppf = 21 | if Level.parenthesize ~at_level ~max_level then 22 | fun fmt -> Format.fprintf ppf ("(" ^^ fmt ^^ ")") 23 | else 24 | Format.fprintf ppf 25 | 26 | (** Print a sequence with given separator and printer. *) 27 | let sequence print_u separator us ppf = 28 | match us with 29 | | [] -> () 30 | | [u] -> print_u u ppf 31 | | u :: ((_ :: _) as us) -> 32 | print_u u ppf ; 33 | List.iter (fun u -> print ppf "%s@ " separator ; print_u u ppf) us 34 | 35 | (** Unicode and ascii versions of symbols. *) 36 | 37 | let char_lambda () = if !Config.ascii then "lambda" else "λ" 38 | let char_arrow () = if !Config.ascii then "->" else "→" 39 | let char_darrow () = if !Config.ascii then "=>" else "⇒" 40 | let char_prod () = if !Config.ascii then "forall" else "Π" 41 | let char_forall () = if !Config.ascii then "forall" else "∀" 42 | let char_equal () = if !Config.ascii then "==" else "≡" 43 | let char_vdash () = if !Config.ascii then "|-" else "⊢" 44 | -------------------------------------------------------------------------------- /algebraic-fauxtt/test/church.t/church.ftt: -------------------------------------------------------------------------------- 1 | (* Church numerals *) 2 | 3 | def numeral := ∏ (A : Type), (A → A) → (A → A) 4 | 5 | eval numeral 6 | 7 | def zero : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ x) 8 | 9 | def succ : numeral → numeral := 10 | (λ (n : numeral) (A : Type) (f : A → A) (x : A) ⇒ f (n A f x)) 11 | 12 | def one : numeral := succ zero 13 | 14 | def two : numeral := succ one 15 | 16 | def three : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ f (f (f x))) 17 | 18 | def five := succ (succ (succ (succ (succ zero)))) 19 | 20 | def ( + ) : numeral → numeral → numeral := 21 | (λ (m n : numeral) (A : Type) (f : A → A) (x : A) ⇒ m A f (n A f x)) 22 | 23 | def ( * ) : numeral → numeral → numeral := 24 | (λ (m n : numeral) (A : Type) (f : A → A) (x : A) ⇒ m A (n A f) x) 25 | 26 | def ten := five + five 27 | 28 | def hundred := ten * ten 29 | 30 | def thousand := hundred * ten 31 | 32 | (* A trick to see the numerals *) 33 | axiom N : Type 34 | axiom Z : N 35 | axiom S : N → N 36 | 37 | eval (thousand N S Z) 38 | -------------------------------------------------------------------------------- /algebraic-fauxtt/test/church.t/run.t: -------------------------------------------------------------------------------- 1 | $ fauxtt church.ftt 2 | numeral is defined. 3 | Π (A : Type), Π (_3 : Π (_1 : A), A), Π (_4 : A), A 4 | : Type 5 | zero is defined. 6 | succ is defined. 7 | one is defined. 8 | two is defined. 9 | three is defined. 10 | five is defined. 11 | + is defined. 12 | * is defined. 13 | ten is defined. 14 | hundred is defined. 15 | thousand is defined. 16 | N is assumed. 17 | Z is assumed. 18 | S is assumed. 19 | S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 20 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 21 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 22 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 23 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 24 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 25 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 26 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 27 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 28 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 29 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 30 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 31 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 32 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 33 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 34 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 35 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 36 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 37 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 38 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 39 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 40 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 41 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 42 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 43 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 44 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 45 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 46 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 47 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 48 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 49 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 50 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 51 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 52 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 53 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 54 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 55 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 56 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 57 | (S (S (S (S (S (S (S (S (S (S (S (S 58 | Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 59 | : N 60 | -------------------------------------------------------------------------------- /algebraic-fauxtt/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps %{bin:fauxtt})) 3 | -------------------------------------------------------------------------------- /algebraic-fauxtt/test/hole.t/funhole.ftt: -------------------------------------------------------------------------------- 1 | axiom A : Type 2 | axiom a : A 3 | axiom i : A → A 4 | 5 | infer λ (f : ?X) ⇒ i (f a) -------------------------------------------------------------------------------- /algebraic-fauxtt/test/hole.t/hole.ftt: -------------------------------------------------------------------------------- 1 | axiom A : Type 2 | axiom a : A 3 | infer (λ (x : ?X) ⇒ x) a 4 | infer λ (B : Type) (b : B) ⇒ (λ (x : ?X) ⇒ x) b 5 | infer let B := A in λ (b : B) ⇒ (λ (x : ?X) ⇒ x) b 6 | infer λ (B : Type) (f : B → B) (x : ?X) ⇒ f x 7 | -------------------------------------------------------------------------------- /algebraic-fauxtt/test/hole.t/run.t: -------------------------------------------------------------------------------- 1 | $ fauxtt hole.ftt 2 | A is assumed. 3 | a is assumed. 4 | (λ (x : A) ⇒ x) a 5 | : A 6 | λ (B : Type) ⇒ λ (b : B) ⇒ 7 | (λ (x : (λ (B1 : Type) ⇒ λ (b1 : B1) ⇒ B1) B b) ⇒ x) b 8 | : Π (B : Type), Π (b : B), (λ (B1 : Type) ⇒ λ (b1 : B1) ⇒ B1) B 9 | b 10 | let B := A in 11 | (λ (b : B) ⇒ (λ (x : (let B1 := A in (λ (b1 : B1) ⇒ B1)) b) ⇒ x) b) 12 | : Π (b : A), (let B := A in (λ (b1 : B) ⇒ B)) b 13 | λ (B : Type) ⇒ λ (f : Π (_1 : B), B) ⇒ λ 14 | (x : (λ (B1 : Type) ⇒ λ (f1 : Π (_1 : B1), B1) ⇒ B1) B f) ⇒ f x 15 | : Π (B : Type), Π (f : Π (_1 : B), B), 16 | Π (x : (λ (B1 : Type) ⇒ λ (f1 : Π (_1 : B1), B1) ⇒ B1) B f), 17 | B 18 | $ fauxtt unscoped.ftt 19 | Typechecking error at file "unscoped.ftt", line 1, charaters 44-45: 20 | this expression should have type B but has type ?X 21 | $ fauxtt funhole.ftt 22 | A is assumed. 23 | a is assumed. 24 | i is assumed. 25 | Typechecking error at file "funhole.ftt", line 5, charaters 21-26: 26 | this expression should be a function but has type ?X 27 | -------------------------------------------------------------------------------- /algebraic-fauxtt/test/hole.t/unscoped.ftt: -------------------------------------------------------------------------------- 1 | infer λ (x : ?X) (B : Type) (f : B → B) ⇒ f x 2 | -------------------------------------------------------------------------------- /algebraic-fauxtt/test/syntax.t/run.t: -------------------------------------------------------------------------------- 1 | $ fauxtt syntax.ftt 2 | Type 3 | : Type 4 | Type 5 | : Type 6 | A is defined. 7 | B is assumed. 8 | λ (A : Type) ⇒ A 9 | : Π (A : Type), Type 10 | λ (A : Type) ⇒ λ (B : Type) ⇒ λ (C : Type) ⇒ A 11 | : Π (A : Type), Π (B : Type), Π (C : Type), Type 12 | λ (A : Type) ⇒ λ (B : Type) ⇒ λ (C : Type) ⇒ λ (x : B) ⇒ λ 13 | (y : B) ⇒ x 14 | : Π (A : Type), Π (B : Type), Π (C : Type), Π (x : B), Π (y : B), B 15 | λ (A : Type) ⇒ A 16 | : Π (A : Type), Type 17 | λ (A : Type) ⇒ λ (B : Type) ⇒ λ (C : Type) ⇒ A 18 | : Π (A : Type), Π (B : Type), Π (C : Type), Type 19 | λ (x : B) ⇒ λ (y : B) ⇒ λ (z : B) ⇒ y 20 | : Π (_3 : B), Π (_4 : B), Π (_5 : B), B 21 | λ (A : Type) ⇒ λ (B : Type) ⇒ λ (C : Type) ⇒ λ (x : B) ⇒ λ 22 | (y : B) ⇒ x 23 | : Π (A : Type), Π (B : Type), Π (C : Type), Π (x : B), Π (y : B), B 24 | id is defined. 25 | λ (S : Type) ⇒ λ (c : S) ⇒ λ (T : Π (_4 : S), Type) ⇒ λ (u : T 26 | c) ⇒ let x := id S c in u 27 | : Π (S : Type), Π (c : S), Π (T : Π (_4 : S), Type), 28 | Π (u : T c), T (id S (id S c)) 29 | -------------------------------------------------------------------------------- /algebraic-fauxtt/test/syntax.t/syntax.ftt: -------------------------------------------------------------------------------- 1 | (* Every bit of syntax should appear in this file. *) 2 | 3 | infer Type 4 | 5 | eval Type 6 | 7 | def A := Type 8 | 9 | axiom B : A 10 | 11 | (* Functions *) 12 | 13 | infer fun (A : Type) => A 14 | 15 | infer fun (A B C : Type) => A 16 | 17 | infer fun (A B C : Type) (x y : B) => x 18 | 19 | infer λ (A : Type) ⇒ A 20 | 21 | infer λ (A B C : Type) ⇒ A 22 | 23 | infer (λ x y z ⇒ y) : B → B → B → B 24 | 25 | infer λ (A B C : Type) (x y : B) ⇒ x 26 | 27 | (* Let statement *) 28 | 29 | def id := fun (A : Type) (x : A) => x 30 | 31 | infer λ (S : Type) (c : S) (T : S → Type) (u : T c) ⇒ let x := id S c in (u : T (id S x)) 32 | -------------------------------------------------------------------------------- /holey-fauxtt/README.md: -------------------------------------------------------------------------------- 1 | # A monadic implementation of faux type theory 2 | 3 | **This is the basic version of Faux type theory, as presented in Lecture 2.** 4 | 5 | ## The type theory 6 | 7 | The dependent type theory `fauxtt` has the following ingridients: 8 | 9 | * A universe `Type` with `Type : Type`. 10 | * Dependent products, written as `forall (x : T₁), T₂` or `∀ (x : T₁), T₂` or `∏ (x : T₁), T₂`. 11 | * Functions, written as one of `fun (x : T) => e` or `λ (x : T) ⇒ e`. The typing annotation may 12 | be omitted, i.e., `fun x => e`, and multiple abstractions may be shortened as 13 | `λ x y (z u : T) (w : U) ⇒ e`. 14 | * Application `e₁ e₂`. 15 | * Type ascription written as `e : T`. 16 | * Local definitions written as `let x := e₁ in e₂`. 17 | 18 | Top-level commands: 19 | 20 | * `def x := e` -- define a value 21 | * `axiom x : T` -- assume a constant `x` of type `T` 22 | * `check e` -- print the type of `e` 23 | * `eval e` -- evaluate `e` a la call-by-value 24 | * `Load "⟨file⟩"` -- load a file 25 | 26 | ## Prerequisites 27 | 28 | * [OCaml](https://ocaml.org) and [OPAM](https://opam.ocaml.org) 29 | 30 | * The OPAM packages `dune`, `menhir`, `menhirLib`, `sedlex` and `bindlib`: 31 | 32 | opam install dune menhir menhirLib sedlex bindlib 33 | 34 | * It is recommended that you also install the `rlwrap` or `ledit` command line wrapper. 35 | 36 | ## Compilation 37 | 38 | You can type: 39 | 40 | * `dune build` to compile the `fauxtt.exe` executable. 41 | * `dune clean` to clean up. 42 | 43 | ## Usage 44 | 45 | Once you compile the program, you can run it in interactive mode as `./fauxtt.exe` 46 | 47 | Run `./fauxtt.exe --help` to see the command-line options and general usage. 48 | 49 | 50 | ## Source code 51 | 52 | The purpose of the implementation is to keep the source uncomplicated and short. The 53 | essential bits of source code can be found in the following files. It should be possible 54 | for you to just read the entire source code. 55 | 56 | It is best to first familiarize yourself with the core: 57 | 58 | * [`lib/core/TT.ml`](./lib/core/TT.ml) – the core type theory 59 | * [`lib/core/context.ml`](./lib/core/context.ml) – typing context 60 | * [`lib/core/typecheck.ml`](./lib/coretypecheck.ml) – type checking and elaboration 61 | * [`lib/core/norm.ml`](./lib/core/norm.ml) – normalization 62 | * [`lib/core/equal.ml`](./lib/core/equal.ml) – equality and normalization 63 | * [`lib/core/toplevel.ml`](./lib/core/toplevel.ml) – top-level commands 64 | 65 | Continue with the infrastructure: 66 | 67 | * [`lib/parsing/syntax.ml`](./lib/parsing/syntax.ml) – abstract syntax of the input code 68 | * [`lib/parsing/lexer.ml`](./lib/parsing/lexer.ml) – the lexer 69 | * [`lib/parsing/parser.mly`](./lib/parsing/parser.mly) – the parser 70 | * [`lib/util`](./lib/util) – various utilities 71 | * [`bin/fauxtt.ml`](bin/fauxtt.ml) – the main executable 72 | 73 | -------------------------------------------------------------------------------- /holey-fauxtt/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name "fauxtt") 3 | (public_name "fauxtt") 4 | (modules fauxtt) 5 | (promote (until-clean) (into ..)) 6 | (libraries parsing core unix)) 7 | -------------------------------------------------------------------------------- /holey-fauxtt/bin/fauxtt.ml: -------------------------------------------------------------------------------- 1 | (** The main executable. *) 2 | 3 | open Util 4 | 5 | (** The usage message. *) 6 | let usage = "Usage: fauxtt [option] ... [file] ..." 7 | 8 | (** A list of files to be loaded and run, together with information on whether they should 9 | be loaded in interactive mode. *) 10 | let files = ref [] 11 | 12 | (** Add a file to the list of files to be loaded, and record whether it should 13 | be processed in interactive mode. *) 14 | let add_file quiet filename = (files := (filename, quiet) :: !files) 15 | 16 | (** Command-line options *) 17 | let options = Arg.align [ 18 | 19 | ("--columns", 20 | Arg.Set_int Config.columns, 21 | " Set the maximum number of columns of pretty printing"); 22 | 23 | ("--ascii", 24 | Arg.Set Config.ascii, 25 | " Use ASCII characters only"); 26 | 27 | ("-V", 28 | Arg.Set_int Config.verbosity, 29 | " Set printing verbosity to "); 30 | 31 | ("-n", 32 | Arg.Clear Config.interactive_shell, 33 | " Do not run the interactive toplevel"); 34 | 35 | ("-l", 36 | Arg.String (fun str -> add_file true str), 37 | " Load into the initial environment"); 38 | ] 39 | 40 | (* Print the error message corresponding to an exception. *) 41 | let print_error ~penv = function 42 | | Parsing.Ulexbuf.Error {Location.data=err; Location.loc} -> 43 | Print.error "Lexical error at %t:@ %t" (Location.print loc) (Parsing.Ulexbuf.print_error err) 44 | 45 | | Core.Typecheck.Error {Location.data=err; Location.loc} -> 46 | Print.error "Typechecking error at %t:@ %t" 47 | (Location.print loc) 48 | (Core.Typecheck.print_error ~penv err) 49 | 50 | | Sys.Break -> 51 | Print.error "Interrupted." ; 52 | 53 | | e -> 54 | raise e 55 | 56 | (* Interactive toplevel. *) 57 | let interactive_shell state = 58 | Format.printf "Faux type theory with holes 1.1@." ; 59 | 60 | let rec loop state = 61 | let state = 62 | try 63 | Core.Toplevel.exec_interactive state 64 | with 65 | | e -> 66 | print_error ~penv:(Core.Toplevel.penv state) e ; state 67 | in loop state 68 | in 69 | try 70 | loop state 71 | with 72 | End_of_file -> () 73 | 74 | (* The main program. *) 75 | let _main = 76 | Sys.catch_break true ; 77 | 78 | (* Parse the arguments. *) 79 | Arg.parse 80 | options 81 | (fun str -> add_file false str ; Config.interactive_shell := false) 82 | usage ; 83 | 84 | (* Files were accumulated in the wrong order, so we reverse them *) 85 | files := List.rev !files ; 86 | 87 | (* Set the maximum depth of pretty-printing, after which it prints ellipsis. *) 88 | Format.set_max_boxes !Config.max_boxes ; 89 | Format.set_margin !Config.columns ; 90 | Format.set_ellipsis_text "..." ; 91 | 92 | let rec run_code topstate files = 93 | try 94 | begin 95 | match files with 96 | | [] -> 97 | if !Config.interactive_shell 98 | then interactive_shell topstate 99 | else () 100 | 101 | | (fn, quiet) :: files -> 102 | let topstate = Core.Toplevel.load_file ~quiet topstate fn in 103 | run_code topstate files 104 | end 105 | with 106 | | e -> 107 | print_error ~penv:(Core.Toplevel.penv topstate) e 108 | in 109 | 110 | run_code Core.Toplevel.initial !files 111 | -------------------------------------------------------------------------------- /holey-fauxtt/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | (name "faux-type-theory") 3 | (version 1.1) 4 | (using menhir 2.0) 5 | (cram enable) 6 | 7 | (authors "Andrej Bauer ") 8 | (maintainers "Andrej Bauer ") 9 | (source (github andrejbauer/faux-type-theory)) 10 | (license "MIT") 11 | 12 | (generate_opam_files false) 13 | 14 | (package 15 | (name faux-type-theory) 16 | (synopsis "A minimalistic implementation of faux type theory with holes") 17 | (description 18 | "This project shows how to implement a minimalist type theory, 19 | which nevertheless could serve as a basis for a serious interpretation." 20 | ) 21 | 22 | (depends 23 | (ocaml (>= 5.0.0)) 24 | (dune :build) 25 | (menhir :build) 26 | (menhirLib :build) 27 | (sedlex :build) 28 | (bindlib (and (>= 6.0) :build)) 29 | (odoc :with-doc))) 30 | -------------------------------------------------------------------------------- /holey-fauxtt/examples/church.ftt: -------------------------------------------------------------------------------- 1 | (* Church numerals *) 2 | 3 | def numeral := ∏ (A : Type), (A → A) → (A → A) 4 | 5 | eval numeral 6 | 7 | def zero : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ x) 8 | 9 | def succ : numeral → numeral := 10 | (λ n A (f : A → A) (x : A) ⇒ f (n A f x)) 11 | 12 | def one : numeral := succ zero 13 | 14 | def two : numeral := succ one 15 | 16 | def three : numeral := (λ A (f : A → A) (x : A) ⇒ f (f (f x))) 17 | 18 | def five := succ (succ (succ (succ (succ zero)))) 19 | 20 | def ( + ) : numeral → numeral → numeral := 21 | λ m n A (f : A → A) (x : A) ⇒ m A f (n A f x) 22 | 23 | def ( * ) : numeral → numeral → numeral := 24 | λ m n A (f : A → A) (x : A) ⇒ m A (n A f) x 25 | 26 | def ten := five + five 27 | 28 | def hundred := ten * ten 29 | 30 | def thousand := hundred * ten 31 | 32 | (* A trick to see the numerals *) 33 | axiom N : Type 34 | axiom Z : N 35 | axiom S : N → N 36 | 37 | eval (thousand N S Z) 38 | 39 | -------------------------------------------------------------------------------- /holey-fauxtt/examples/funext.ftt: -------------------------------------------------------------------------------- 1 | (* Check that function extensionality holds. *) 2 | 3 | axiom A : Type 4 | axiom P : (A → A) → Type 5 | axiom f : A → A 6 | 7 | def id := λ (A : Type) (x : A) ⇒ x 8 | 9 | (** Function composition. *) 10 | def compose := λ (A B C : Type) (g : B → C) (f : A → B) (x : A) => g (f x) 11 | 12 | axiom u : P f 13 | 14 | infer u : P f 15 | 16 | infer u : P (id (A → A) f) 17 | 18 | infer u : P (compose A A A (id A) f) 19 | 20 | 21 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/TT.ml: -------------------------------------------------------------------------------- 1 | (* Faux type theory *) 2 | 3 | open Util 4 | 5 | (** Term *) 6 | type tm = 7 | | Var of var (** A free variable *) 8 | | Meta of var (** meta-variable (hole) *) 9 | | Let of tm * ty * tm binder (** A let binding *) 10 | | Type (** the type of types *) 11 | | Prod of ty * ty binder (** dependent product *) 12 | | Lambda of ty * tm binder (** lambda abstraction *) 13 | | Apply of tm * tm (** application *) 14 | 15 | (** Type *) 16 | and ty = Ty of tm 17 | 18 | and var = tm Bindlib.var 19 | 20 | and 'a binder = (tm, 'a) Bindlib.binder 21 | 22 | (** A boxed term binder *) 23 | type 'a binder_ = 'a binder Bindlib.box 24 | 25 | (** A boxed term *) 26 | type tm_ = tm Bindlib.box 27 | 28 | (** A boxed type *) 29 | type ty_ = ty Bindlib.box 30 | 31 | let box_binder = Bindlib.box_binder 32 | 33 | (* Constructors for boxed terms and types *) 34 | 35 | let var_ = Bindlib.box_var 36 | 37 | let meta_ x = Bindlib.box (Meta x) 38 | 39 | let let_ = Bindlib.box_apply3 (fun e1 t e2 -> Let (e1, t, e2)) 40 | 41 | let type_ = Bindlib.box Type 42 | 43 | let ty_ = Bindlib.box_apply (fun t -> Ty t) 44 | 45 | let ty_type_ = Bindlib.box (Ty Type) 46 | 47 | let prod_ = Bindlib.box_apply2 (fun t u -> Prod (t, u)) 48 | 49 | let ty_prod_ = Bindlib.box_apply2 (fun t u -> Ty (Prod (t, u))) 50 | 51 | let lambda_ = Bindlib.box_apply2 (fun t e -> Lambda (t, e)) 52 | 53 | let apply_ = 54 | Bindlib.box_apply2 (fun e1 e2 -> Apply (e1, e2)) 55 | 56 | (* Lifting functions *) 57 | 58 | let rec lift_tm = function 59 | 60 | | Var v -> var_ v 61 | 62 | | Meta v -> meta_ v 63 | 64 | | Let (e1, t, e2) -> 65 | let_ (lift_tm e1) (lift_ty t) (box_binder lift_tm e2) 66 | 67 | | Type -> type_ 68 | 69 | | Prod (ty1, ty2) -> 70 | prod_ (lift_ty ty1) (box_binder lift_ty ty2) 71 | 72 | | Lambda (t, e) -> 73 | lambda_ (lift_ty t) (box_binder lift_tm e) 74 | 75 | | Apply (e1, e2) -> 76 | apply_ (lift_tm e1) (lift_tm e2) 77 | 78 | and lift_ty (Ty ty) = 79 | Bindlib.box_apply (fun ty -> Ty ty) (lift_tm ty) 80 | 81 | (* Helper functions for printing quantifiers *) 82 | 83 | let unbox = Bindlib.unbox 84 | 85 | let bind_var = Bindlib.bind_var 86 | 87 | let unbind = Bindlib.unbind 88 | 89 | let fresh_var x = Bindlib.new_var (fun x -> Var x) x 90 | 91 | let anonymous_var () = fresh_var (Name.anonymous ()) 92 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/TT.mli: -------------------------------------------------------------------------------- 1 | (** The faux type theory. *) 2 | 3 | (** Terms *) 4 | type tm = 5 | | Var of var (** variable *) 6 | | Meta of var (** meta-variable (hole) *) 7 | | Let of tm * ty * tm binder (** A let binding *) 8 | | Type (** the type of types qua term *) 9 | | Prod of ty * ty binder (** dependent product *) 10 | | Lambda of ty * tm binder (** function *) 11 | | Apply of tm * tm (** application *) 12 | 13 | (** Types *) 14 | and ty = Ty of tm 15 | 16 | (** Variable *) 17 | and var = tm Bindlib.var 18 | 19 | (** An entity with one bound variable *) 20 | and 'a binder = (tm, 'a) Bindlib.binder 21 | 22 | (** A boxed term, in the sense of [Bindlib]. *) 23 | type tm_ = tm Bindlib.box 24 | 25 | (** A boxed type, in the sense of [Bindlib]. *) 26 | type ty_ = ty Bindlib.box 27 | 28 | (** A boxed binder, in the sense of [Bindlib]. *) 29 | type 'a binder_ = 'a binder Bindlib.box 30 | 31 | (** Boxed constructors *) 32 | 33 | val var_ : var -> tm_ 34 | 35 | val meta_ : var -> tm_ 36 | 37 | val let_ : tm_ -> ty_ -> tm binder_ -> tm_ 38 | 39 | val type_ : tm_ 40 | 41 | val ty_ : tm_ -> ty_ 42 | 43 | val ty_type_ : ty_ 44 | 45 | val prod_ : ty_ -> ty binder_ -> tm_ 46 | 47 | val ty_prod_ : ty_ -> ty binder_ -> ty_ 48 | 49 | val lambda_ : ty_ -> tm binder_ -> tm_ 50 | 51 | val apply_ : tm_ -> tm_ -> tm_ 52 | 53 | (** Lifting functions *) 54 | 55 | val lift_tm : tm -> tm_ 56 | 57 | val lift_ty : ty -> ty_ 58 | 59 | val fresh_var : string -> var 60 | 61 | (** Generate a fresh variable that the user cannot. *) 62 | val anonymous_var : unit -> var 63 | 64 | (** Bind a variable in the given boxed entity. *) 65 | val bind_var : var -> 'a Bindlib.box -> 'a binder_ 66 | 67 | (** Unbind a variable in the given bound entity. *) 68 | val unbind : 'a binder -> var * 'a 69 | 70 | (** Unbox an entity. *) 71 | val unbox : 'a Bindlib.box -> 'a 72 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/context.ml: -------------------------------------------------------------------------------- 1 | (** Typing context and definitional equalities. *) 2 | 3 | module IdentMap = Map.Make(struct 4 | type t = string 5 | let compare = String.compare 6 | end) 7 | 8 | module VarMap = Map.Make(struct 9 | type t = TT.var 10 | let compare = Bindlib.compare_vars 11 | end) 12 | 13 | (** A typing context comprises two maps, the first one mapping strings to [Bindlib] variables, 14 | and the second mapping variables to their types and optional definitions. *) 15 | type t = 16 | { idents : TT.var IdentMap.t 17 | ; vars : (TT.tm option * TT.ty) VarMap.t 18 | ; locals : TT.var list 19 | ; metas : (TT.tm option * TT.ty) VarMap.t 20 | } 21 | 22 | type 'a m = t -> t * 'a 23 | 24 | module Monad = 25 | struct 26 | let ( let* ) : 'a 'b . 'a m -> ('a -> 'b m) -> 'b m = 27 | fun c1 c2 (ctx : t) -> 28 | let ctx, v1 = c1 ctx in 29 | c2 v1 ctx 30 | 31 | let ( >>= ) = ( let* ) 32 | 33 | let return : 'a . 'a -> 'a m = 34 | fun v t -> (t, v) 35 | 36 | (* Monadic conjunction *) 37 | let ( &&& ) c1 c2 = 38 | let* b = c1 in 39 | if b then c2 else return false 40 | 41 | (* Monadic disjunction *) 42 | let ( ||| ) c1 c2 = 43 | let* b = c1 in 44 | if b then return true else c2 45 | end 46 | 47 | (** The initial, empty typing context. *) 48 | let initial = 49 | { idents = IdentMap.empty 50 | ; vars = VarMap.empty 51 | ; locals = [] 52 | ; metas = VarMap.empty 53 | } 54 | 55 | let run ctx c = c ctx 56 | 57 | let penv _ = Bindlib.empty_ctxt 58 | 59 | let _extend_var x v def ty ctx = 60 | { ctx with 61 | idents = (match x with None -> ctx.idents | Some x -> IdentMap.add x v ctx.idents) 62 | ; locals = v :: ctx.locals 63 | ; vars = VarMap.add v (def, ty) ctx.vars 64 | } 65 | 66 | let _extend_meta v ty ctx = 67 | { ctx with metas = VarMap.add v (None, ty) ctx.metas } 68 | 69 | let top_extend x ?def ty ctx = 70 | let v = TT.fresh_var x in 71 | { ctx with 72 | idents = IdentMap.add x v ctx.idents 73 | ; vars = VarMap.add v (def, ty) ctx.vars 74 | } 75 | 76 | let extend x ?def ty ctx = 77 | let v = TT.fresh_var x in 78 | _extend_var (Some x) v def ty ctx, v 79 | 80 | let lookup_ident x ctx = 81 | ctx, IdentMap.find_opt x ctx.idents 82 | 83 | let lookup_var v ctx = 84 | ctx, VarMap.find v ctx.vars 85 | 86 | let lookup_meta v ctx = 87 | ctx, VarMap.find v ctx.metas 88 | 89 | let with_var v ?def t (c : 'a m) ctx = 90 | let local_ctx = _extend_var None v def t ctx in 91 | let {metas;_}, r = c local_ctx in 92 | { ctx with metas }, r 93 | 94 | let with_ident x ?def ty (c : TT.var -> 'a m) ctx = 95 | let local_ctx, v = extend x ?def ty ctx in 96 | let {metas;_}, r = c v local_ctx in 97 | { ctx with metas }, r 98 | 99 | let with_ident_ x ?def ty_ (c : TT.var -> 'a m) = 100 | let ty = TT.unbox ty_ in 101 | let def = Option.map TT.unbox def in 102 | with_ident x ?def ty c 103 | 104 | let define v e ctx = 105 | match VarMap.find v ctx.metas with 106 | 107 | | Some _, _ -> 108 | (* We need proper error reporting. *) 109 | assert false 110 | 111 | | None, ty -> 112 | let ctx = { ctx with metas = VarMap.add v (Some e, ty) ctx.metas } in 113 | ctx, () 114 | 115 | let with_meta_ x t_ c ctx = 116 | let mv = TT.fresh_var x in 117 | let rec fold t_ = function 118 | | [] -> TT.meta_ mv, t_ 119 | | v :: vs -> 120 | begin match VarMap.find v ctx.vars with 121 | | Some _, _ -> 122 | (* let e_ = TT.(lift_tm (Bindlib.subst (unbox (bind_var v e_)) e')) in *) 123 | (* let t_ = TT.(lift_ty (Bindlib.subst (unbox (bind_var v t_)) e')) in *) 124 | fold t_ vs 125 | | None, u -> 126 | let u_ = TT.lift_ty u in 127 | let t_ = TT.(ty_ (prod_ u_ (bind_var v t_))) in 128 | let e_, t_ = fold t_ vs in 129 | TT.(apply_ e_ (var_ v)), t_ 130 | end 131 | in 132 | let e_, t_ = fold t_ ctx.locals in 133 | let t = TT.unbox t_ in 134 | let ctx = { ctx with metas = VarMap.add mv (None, t) ctx.metas } in 135 | c e_ ctx 136 | 137 | let with_meta x ty c = 138 | let ty_ = TT.lift_ty ty in 139 | with_meta_ x ty_ (fun e_ -> c (TT.unbox e_)) 140 | 141 | let close_tm_ e_ ctx = 142 | let rec fold : TT.var list -> TT.tm_ option = function 143 | | [] -> Some e_ 144 | | v :: vs -> 145 | begin match VarMap.find v ctx.vars with 146 | | Some e', t -> 147 | if Bindlib.occur v e_ then 148 | begin match fold vs with 149 | | None -> None 150 | | Some e_ -> 151 | let e'_ = TT.lift_tm e' in 152 | let t_ = TT.lift_ty t in 153 | Some TT.(let_ e'_ t_ (bind_var v e_)) 154 | end 155 | else 156 | fold vs 157 | | None, _ -> 158 | (* Check that the variable does not appear in e_ *) 159 | if Bindlib.occur v e_ then 160 | None 161 | else 162 | fold vs 163 | end 164 | in 165 | ctx, fold (List.rev ctx.locals) 166 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/context.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | (* The monad for computing in a typing context *) 4 | type 'a m 5 | 6 | (** Monadic interface to contexts. *) 7 | module Monad : sig 8 | 9 | (** Thread context state through a computation *) 10 | val ( let* ) : 'b m -> ('b -> 'c m) -> 'c m 11 | 12 | (** Synonym for [let*] *) 13 | val ( >>= ) : 'b m -> ('b -> 'c m) -> 'c m 14 | 15 | (** Return a pure value *) 16 | val return : 'b -> 'b m 17 | 18 | (** Monadic conjunction *) 19 | val (&&&) : bool m -> bool m -> bool m 20 | 21 | (** Monadic disjunction *) 22 | val (|||) : bool m -> bool m -> bool m 23 | 24 | end 25 | 26 | (** The initial, empty typing context. *) 27 | val initial : t 28 | 29 | (** Run a computation in the given context. *) 30 | val run : t -> 'a m -> t * 'a 31 | 32 | (** Assign a value to a meta-variable. It is the caller's responsbility to assign a value of correct type. It is error 33 | to assign a value to an already defined meta. *) 34 | val define : TT.var -> TT.tm -> unit m 35 | 36 | (** Extend the context with a top-level definition and return it *) 37 | val top_extend : string -> ?def:TT.tm -> TT.ty -> t -> t 38 | 39 | (** The identifiers which should not be used for printing bound variables. *) 40 | val penv : t -> Bindlib.ctxt 41 | 42 | (** Lookup the definition associated with a variable, if any. *) 43 | val lookup_var : TT.var -> (TT.tm option * TT.ty) m 44 | 45 | (** Lookup the definition associated with a meta-variable, if any. *) 46 | val lookup_meta : TT.var -> (TT.tm option * TT.ty) m 47 | 48 | (** Lookup the variable which corresponds to a concrete name. *) 49 | val lookup_ident : string -> TT.var option m 50 | 51 | (** Run a computation in a context extended with a variable, passing it the newly 52 | created variable. It is the callers responsibility that the result be valid in 53 | the original context. *) 54 | 55 | val with_ident : string -> ?def:TT.tm -> TT.ty -> (TT.var -> 'a m) -> 'a m 56 | 57 | val with_ident_ : string -> ?def:TT.tm_ -> TT.ty_ -> (TT.var -> 'a m) -> 'a m 58 | 59 | val with_var : TT.var -> ?def:TT.tm -> TT.ty -> 'a m -> 'a m 60 | 61 | val with_meta : string -> TT.ty -> (TT.tm -> 'a m) -> 'a m 62 | 63 | val with_meta_ : string -> TT.ty_ -> (TT.tm_ -> 'a m) -> 'a m 64 | 65 | val close_tm_ : TT.tm_ -> TT.tm_ option m 66 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core) 3 | (libraries bindlib util parsing)) 4 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/equal.ml: -------------------------------------------------------------------------------- 1 | (** Equality and normalization. *) 2 | 3 | open Context.Monad 4 | 5 | (* Monadic conjunction *) 6 | let ( &&& ) c1 c2 = 7 | let* b = c1 in 8 | if b then c2 else return false 9 | 10 | (* Monadic disjunction *) 11 | let ( ||| ) c1 c2 = 12 | let* b = c1 in 13 | if b then return true else c2 14 | 15 | (** Compare expressions [e1] and [e2] at type [ty]? *) 16 | let rec equal_tm_at e1 e2 ty = 17 | (* short-circuit *) 18 | return (e1 == e2) ||| 19 | begin 20 | (* The type directed phase *) 21 | let* Norm.Ty ty' = Norm.norm_ty ty in 22 | match ty' with 23 | 24 | | Norm.Prod (t, u) -> 25 | (* Apply function extensionality. *) 26 | let (x, u) = TT.unbind u in 27 | Context.with_var x t 28 | (let e1 = TT.(Apply (e1, Var x)) 29 | and e2 = TT.(Apply (e2, Var x)) in 30 | equal_tm_at e1 e2 u) 31 | 32 | | Norm.(Spine _ | Type) -> 33 | (* Type-directed phase is done, we compare normal forms. *) 34 | equal_tm e1 e2 35 | 36 | | Norm.(Lambda _) -> 37 | (* A type should never normalize to an abstraction or a let-binding *) 38 | assert false 39 | end 40 | 41 | (** Structurally compare weak head-normal forms of terms [e1] and [e2]. *) 42 | and equal_tm e1 e2 = 43 | let* e1 = Norm.norm_tm e1 in 44 | let* e2 = Norm.norm_tm e2 in 45 | match e1, e2 with 46 | 47 | | Norm.Type, Norm.Type -> 48 | return true 49 | 50 | | Norm.Prod (t1, u1), Norm.Prod (t2, u2) -> 51 | equal_ty t1 t2 &&& 52 | begin 53 | let (x, u1, u2) = Bindlib.unbind2 u1 u2 in 54 | Context.with_var x t1 (equal_ty u1 u2) 55 | end 56 | 57 | | Norm.Lambda _, Norm.Lambda _ -> 58 | (* We should never have to compare two lambdas, as that would mean that the 59 | type-directed phase did not figure out that these have product types. *) 60 | assert false 61 | 62 | | Norm.Spine (x1, es1), Norm.Spine (x2, es2) -> 63 | equal_spine x1 es1 x2 es2 64 | 65 | | Norm.(Type | Prod _ | Lambda _ | Spine _), _ -> 66 | return false 67 | 68 | and equal_spine h1 es1 h2 es2 = 69 | let rec fold t es1 es2 = 70 | match es1, es2 with 71 | | [], [] -> return true 72 | 73 | | ([], _::_) | (_::_, []) -> return false 74 | 75 | | e1 :: es1, e2 :: es2 -> 76 | begin 77 | Norm.as_prod t >>= function 78 | | None -> return false 79 | | Some (t, u) -> (equal_tm_at e1 e2 t) &&& (fold (Bindlib.subst u e1) es1 es2) 80 | end 81 | in 82 | 83 | let equal_heads h1 h2 = 84 | match h1, h2 with 85 | | Norm.Var x1, Norm.Var x2 -> Bindlib.eq_vars x1 x2 86 | | Norm.Meta x1, Norm.Meta x2 -> Bindlib.eq_vars x1 x2 87 | | Norm.Var _, Norm.Meta _ 88 | | Norm.Meta _, Norm.Var _ -> false 89 | in 90 | 91 | (return @@ equal_heads h1 h2) &&& 92 | begin 93 | match h1 with 94 | | Norm.Var x1 -> 95 | let* _, t = Context.lookup_var x1 in fold t es1 es2 96 | | Norm.Meta x1 -> 97 | let* _, t = Context.lookup_meta x1 in fold t es1 es2 98 | end 99 | 100 | (** Compare two types. *) 101 | and equal_ty (TT.Ty ty1) (TT.Ty ty2) = 102 | equal_tm_at ty1 ty2 TT.(Ty Type) 103 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/equal.mli: -------------------------------------------------------------------------------- 1 | (** Are the given terms equal at the given type? *) 2 | val equal_tm_at : TT.tm -> TT.tm -> TT.ty -> bool Context.m 3 | 4 | (** Are the given types equal? *) 5 | val equal_ty : TT.ty -> TT.ty -> bool Context.m 6 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/norm.ml: -------------------------------------------------------------------------------- 1 | type head = 2 | | Var of TT.var 3 | | Meta of TT.var 4 | 5 | type tm = 6 | | Type 7 | | Prod of TT.ty * TT.ty TT.binder 8 | | Lambda of TT.ty * TT.tm TT.binder 9 | | Spine of head * TT.tm list 10 | 11 | type ty = Ty of tm 12 | 13 | (** A normalization strategy. *) 14 | type strategy = 15 | | WHNF (** normalize to weak head-normal form *) 16 | | CBV (** call-by-value normalization *) 17 | 18 | open Context.Monad 19 | 20 | (** Normalize an expression using the given strategy. *) 21 | let rec norm_tm' ~strategy e = 22 | match e with 23 | 24 | | TT.Type -> 25 | return e 26 | 27 | | TT.Var x -> 28 | begin 29 | Context.lookup_var x >>= function 30 | | None, _ -> return e 31 | | Some e, _ -> norm_tm' ~strategy e 32 | end 33 | 34 | | TT.Meta x -> 35 | begin 36 | Context.lookup_meta x >>= function 37 | | None, _ -> return e 38 | | Some e, _ -> norm_tm' ~strategy e 39 | end 40 | 41 | | TT.Let (e1, t, e2) -> 42 | let* e1 = 43 | match strategy with 44 | | WHNF -> return e1 45 | | CBV -> norm_tm' ~strategy e1 46 | in 47 | let (v, e2) = TT.unbind e2 in 48 | Context.with_var v ~def:e1 t (norm_tm' ~strategy e2) 49 | 50 | | TT.Prod _ -> 51 | return e 52 | 53 | | TT.Lambda _ -> 54 | return e 55 | 56 | | TT.Apply (e1, e2) -> 57 | let* e1 = norm_tm' ~strategy e1 in 58 | let* e2 = 59 | begin 60 | match strategy with 61 | | WHNF -> return e2 62 | | CBV -> norm_tm' ~strategy e2 63 | end 64 | in 65 | begin 66 | match e1 with 67 | | TT.Lambda (_, e') -> 68 | norm_tm' ~strategy (Bindlib.subst e' e2) 69 | | _ -> 70 | return @@ TT.Apply (e1, e2) 71 | end 72 | 73 | (** Normalize a type *) 74 | let norm_ty' ~strategy (TT.Ty ty) = 75 | let* ty = norm_tm' ~strategy ty in 76 | return @@ TT.Ty ty 77 | 78 | let eval_tm = norm_tm' ~strategy:CBV 79 | 80 | let norm_tm e = 81 | norm_tm' ~strategy:WHNF e >>= function 82 | | TT.Let _ -> assert false 83 | 84 | | TT.Type -> return Type 85 | 86 | | TT.Prod (t, u) -> return (Prod (t, u)) 87 | 88 | | TT.Lambda (t, e) -> return (Lambda (t, e)) 89 | 90 | | TT.(Var _ | Meta _ | Apply _) as e -> 91 | let rec fold es = function 92 | | TT.Var x -> Var x, es 93 | | TT.Meta x -> Meta x, es 94 | | TT.Apply (e1, e2) -> fold (e2 :: es) e1 95 | | TT.(Let _ | Type | Prod _ | Lambda _) -> assert false 96 | in 97 | let x, es = fold [] e in 98 | return @@ Spine (x, es) 99 | 100 | let norm_ty (TT.Ty t) = 101 | let* t = norm_tm t in 102 | return @@ Ty t 103 | 104 | (** Normalize a type to a product. *) 105 | let as_prod t = 106 | let* TT.Ty t' = norm_ty' ~strategy:WHNF t in 107 | match t' with 108 | | TT.Prod (t, u) -> return @@ Some (t, u) 109 | | _ -> return None 110 | 111 | (** Normalize a term to a variable. *) 112 | let as_var e = 113 | let* e' = norm_tm' ~strategy:WHNF e in 114 | match e' with 115 | | TT.Var v -> return @@ Some v 116 | | _ -> return None 117 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/norm.mli: -------------------------------------------------------------------------------- 1 | (** Weak-head normal term. *) 2 | type head = 3 | | Var of TT.var 4 | | Meta of TT.var 5 | 6 | type tm = 7 | | Type 8 | | Prod of TT.ty * TT.ty TT.binder 9 | | Lambda of TT.ty * TT.tm TT.binder 10 | | Spine of head * TT.tm list 11 | 12 | type ty = Ty of tm 13 | 14 | (** Evaluate a term using the call-by-value strategy *) 15 | val eval_tm : TT.tm -> TT.tm Context.m 16 | 17 | (** Normalize a term *) 18 | val norm_tm : TT.tm-> tm Context.m 19 | 20 | (** Normalize a type *) 21 | val norm_ty : TT.ty -> ty Context.m 22 | 23 | (** Convert a type to a product *) 24 | val as_prod : TT.ty -> (TT.ty * TT.ty TT.binder) option Context.m 25 | 26 | (** Convert a term to a variable *) 27 | val as_var : TT.tm -> TT.var option Context.m 28 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/print.ml: -------------------------------------------------------------------------------- 1 | (** Printing of terms and types. *) 2 | (* Printing routines *) 3 | 4 | module Level = Util.Level 5 | 6 | let as_prod ~penv = function 7 | | TT.(Ty (Prod (u, t))) when Bindlib.binder_occur t -> 8 | let (x, t, penv) = Bindlib.unbind_in penv t in 9 | Some (x, u, t, penv) 10 | | _ -> None 11 | 12 | let as_lambda ~penv = function 13 | | TT.Lambda (t, e) -> 14 | let (x, e, penv) = Bindlib.unbind_in penv e in 15 | Some (x, t, e, penv) 16 | | _ -> None 17 | 18 | let rec tm ?max_level ~penv e ppf = 19 | match e with 20 | 21 | | TT.Var x -> 22 | Format.fprintf ppf "%s" (Bindlib.name_of x) 23 | 24 | | TT.Meta x -> 25 | Format.fprintf ppf "?%s" (Bindlib.name_of x) 26 | 27 | | TT.Let (e1, _, e2) -> 28 | let (x, e2, penv') = Bindlib.unbind_in penv e2 in 29 | Util.Print.print ?max_level ~at_level:Level.let_binding ppf "let@ %s :=@ %t@ in@ %t" 30 | (Bindlib.name_of x) 31 | (tm ~max_level:Level.let_bound ~penv e1) 32 | (tm ~max_level:Level.let_body ~penv:penv' e2) 33 | 34 | | TT.Type -> 35 | Format.fprintf ppf "Type" 36 | 37 | | TT.Lambda (t, e) -> 38 | print_quantifier ?max_level ~at_level:Level.highest ~penv as_lambda 39 | (Util.Print.char_lambda ()) (" " ^ Util.Print.char_darrow ()) tm t e ppf 40 | 41 | | TT.Apply (e1, e2) -> 42 | print_apply ?max_level ~penv e1 e2 ppf 43 | 44 | | TT.Prod (u, t) -> 45 | print_quantifier ?max_level ~at_level:Level.highest ~penv as_prod 46 | (Util.Print.char_prod ()) "," ty u t ppf 47 | 48 | 49 | and ty ?max_level ~penv (Ty t) ppf = tm ?max_level ~penv t ppf 50 | 51 | and print_quantifier : 52 | 'a . ?max_level:Level.t -> at_level:Level.t -> 53 | penv:_ -> 54 | (penv:_ -> 'a -> (TT.var * TT.ty * 'a * _) option) -> 55 | string -> string -> 56 | (?max_level:Level.t -> penv:_ -> 'a -> Format.formatter -> unit) -> 57 | TT.ty -> 'a TT.binder -> Format.formatter -> unit 58 | = 59 | fun ?max_level ~at_level ~penv as_quant quant comma print_v u v ppf -> 60 | let rec print_rest ~penv v = 61 | match as_quant ~penv v with 62 | | None -> 63 | Util.Print.print ppf "%s@ %t" comma (print_v ~penv v) ; 64 | 65 | | Some (x, u, v, penv') -> 66 | Format.fprintf ppf "%s@ %s@;<1 -4>(%s : %t)" comma quant (Bindlib.name_of x) (ty ~penv u) ; 67 | print_rest ~penv:penv' v 68 | in 69 | let printer ppf = 70 | Format.pp_open_hovbox ppf 2 ; 71 | let (x, v, penv') = Bindlib.unbind_in penv v in 72 | Format.fprintf ppf "%s@;<1 -4>(%s : %t)" quant (Bindlib.name_of x) (ty ~penv u) ; 73 | print_rest ~penv:penv' v ; 74 | Format.pp_close_box ppf () 75 | in 76 | Util.Print.print ?max_level ~at_level ppf "%t" printer 77 | 78 | and print_apply ?max_level ~penv e1 e2 ppf = 79 | let prnt () = 80 | Util.Print.print ppf ?max_level ~at_level:Level.app "%t@ %t" 81 | (tm ~max_level:Level.app_left ~penv e1) 82 | (tm ~max_level:Level.app_right ~penv e2) 83 | in 84 | match e1 with 85 | 86 | | Var x -> 87 | begin 88 | match Util.Name.fixity x with 89 | 90 | | Util.Name.Prefix -> 91 | Util.Print.print ppf ?max_level ~at_level:Level.prefix "%t@ %t" 92 | (Util.Name.print_var x) 93 | (tm ~max_level:Level.prefix_arg ~penv e2) 94 | 95 | | Util.Name.Word -> 96 | prnt () 97 | 98 | | Util.Name.Infix lvl -> 99 | begin match e2 with 100 | 101 | | Apply (e2', e2'') -> 102 | let (lvl, lvl_right, lvl_left) = Level.infix lvl in 103 | Util.Print.print ppf ?max_level ~at_level:lvl "%t@ %t@ %t" 104 | (tm ~max_level:lvl_left ~penv e2') 105 | (Util.Name.print_var ~parentheses:false x) 106 | (tm ~max_level:lvl_right ~penv e2'') 107 | 108 | | _ -> prnt () 109 | end 110 | end 111 | 112 | | _ -> prnt () 113 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/print.mli: -------------------------------------------------------------------------------- 1 | (** Printing of terms and types *) 2 | 3 | (** Print a term *) 4 | val tm : ?max_level:Util.Level.t -> penv:Bindlib.ctxt -> TT.tm -> Format.formatter -> unit 5 | 6 | (** Print a type *) 7 | val ty : ?max_level:Util.Level.t -> penv:Bindlib.ctxt -> TT.ty -> Format.formatter -> unit 8 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/toplevel.ml: -------------------------------------------------------------------------------- 1 | (** Top-level processing. *) 2 | 3 | type state = Context.t 4 | 5 | let initial = Context.initial 6 | 7 | let penv = Context.penv 8 | 9 | let exec_interactive ctx = 10 | let e = Parsing.Lexer.read_toplevel Parsing.Parser.commandline () in 11 | Typecheck.toplevel ~quiet:false ctx e 12 | 13 | let load_file ~quiet ctx fn = 14 | Typecheck.topfile ~quiet ctx fn 15 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/toplevel.mli: -------------------------------------------------------------------------------- 1 | (** The top-level state of the proof assistant *) 2 | type state 3 | 4 | (** Initial top-level state. *) 5 | val initial : state 6 | 7 | (** Read a top-level command from the standard input and execute it. *) 8 | val exec_interactive : state -> state 9 | 10 | (** Load the contents of a file and execute it. *) 11 | val load_file : quiet:bool -> state -> string -> state 12 | 13 | (** Names of bound variables, used for printing de Bruijn indices. *) 14 | val penv : state -> Bindlib.ctxt 15 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/typecheck.mli: -------------------------------------------------------------------------------- 1 | (** Type errors *) 2 | type type_error 3 | 4 | (** Exception signalling a type error. *) 5 | exception Error of type_error Util.Location.t 6 | 7 | (** Print error description. *) 8 | val print_error : penv:Bindlib.ctxt -> type_error -> Format.formatter -> unit 9 | 10 | (** Type-check a top-level command. *) 11 | val toplevel : quiet:bool -> Context.t -> Parsing.Syntax.toplevel -> Context.t 12 | 13 | (** Type-check the contents of a file. *) 14 | val topfile : quiet:bool -> Context.t -> string -> Context.t 15 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/unify.ml: -------------------------------------------------------------------------------- 1 | (** Equality and normalization. *) 2 | 3 | open Context.Monad 4 | 5 | (** Unify expressions [e1] and [e2] at type [ty]? *) 6 | let rec unify_tm_at e1 e2 ty = 7 | (* short-circuit *) 8 | return (e1 == e2) ||| 9 | begin 10 | (* The type directed phase *) 11 | let* (Norm.Ty ty') = Norm.norm_ty ty in 12 | match ty' with 13 | 14 | | Norm.Prod (t, u) -> 15 | (* Apply function extensionality. *) 16 | let (x, u) = TT.unbind u in 17 | Context.with_var x t 18 | (let e1 = TT.(Apply (e1, Var x)) 19 | and e2 = TT.(Apply (e2, Var x)) in 20 | unify_tm_at e1 e2 u) 21 | 22 | | Norm.(Type | Spine _) -> 23 | (* Type-directed phase is done, we compare normal forms. *) 24 | unify_tm e1 e2 25 | 26 | | Norm.Lambda _ -> 27 | (* A type should never normalize to an abstraction or a let-binding *) 28 | assert false 29 | end 30 | 31 | (** Structurally unify weak head-normal forms of terms [e1] and [e2]. *) 32 | and unify_tm e1 e2 : bool Context.m = 33 | let* e1' = Norm.norm_tm e1 in 34 | let* e2' = Norm.norm_tm e2 in 35 | match e1', e2' with 36 | 37 | | Norm.Type, Norm.Type -> 38 | return true 39 | 40 | | Norm.Prod (t1, u1), Norm.Prod (t2, u2) -> 41 | unify_ty t1 t2 &&& 42 | begin 43 | let (x, u1, u2) = Bindlib.unbind2 u1 u2 in 44 | Context.with_var x t1 (unify_ty u1 u2) 45 | end 46 | 47 | | Norm.Spine (Var x1, es1), Norm.Spine (Var x2, es2) when Bindlib.eq_vars x1 x2 -> 48 | let* _, t = Context.lookup_var x1 in 49 | unify_spine t es1 es2 50 | 51 | | Norm.Spine (Meta x1, es1), Norm.Spine (Meta x2, es2) -> 52 | if Bindlib.eq_vars x1 x2 then 53 | let* _, t = Context.lookup_meta x1 in 54 | unify_spine t es1 es2 55 | else 56 | (unify_meta x1 es1 e2) ||| (unify_meta x2 es2 e1) 57 | 58 | | Norm.Spine (Meta x1, es1), Norm.(Type | Prod _ | Spine (Var _, _)) -> 59 | unify_meta x1 es1 e2 60 | 61 | | Norm.(Type | Prod _ | Spine (Var _, _)), Norm.Spine (Meta x2, es2) -> 62 | unify_meta x2 es2 e1 63 | 64 | | Norm.Lambda _, _ | _, Norm.Lambda _ -> 65 | (* We should never have to compare two lambdas, as that would mean that the 66 | type-directed phase did not figure out that these have product types. *) 67 | assert false 68 | 69 | | Norm.(Type | Prod _ | Spine _), Norm.(Type | Prod _ | Spine _) -> 70 | return false 71 | 72 | and unify_ty (TT.Ty ty1) (TT.Ty ty2) = 73 | unify_tm_at ty1 ty2 TT.(Ty Type) 74 | 75 | and unify_spine t es1 es2 = 76 | let rec fold t es1 es2 = 77 | match es1, es2 with 78 | 79 | | ([], _::_) | (_::_, []) -> return false 80 | 81 | | [], [] -> return true 82 | 83 | | e1 :: es1, e2 :: es2 -> 84 | Norm.as_prod t >>= function 85 | | None -> return false 86 | | Some (t, u) -> 87 | begin 88 | unify_tm_at e1 e2 t >>= function 89 | | false -> return false 90 | | true -> fold (Bindlib.subst u e1) es1 es2 91 | end 92 | in 93 | fold t es1 es2 94 | 95 | and unify_meta mv es e' = 96 | let rec abstract t ys = function 97 | | [] -> return @@ Some (TT.lift_tm e') 98 | | e :: es -> 99 | begin 100 | Norm.as_prod t >>= function 101 | | None -> assert false 102 | | Some (u, t) -> 103 | Norm.as_var e >>= function 104 | | None -> return None 105 | | Some y -> 106 | if List.exists (Bindlib.eq_vars y) ys then 107 | return None 108 | else begin 109 | abstract (Bindlib.subst t (TT.Var y)) (y :: ys) es >>= function 110 | | None -> return None 111 | | Some e' -> 112 | let e' = TT.lambda_ (TT.lift_ty u) (Bindlib.bind_var y e') in 113 | return (Some e') 114 | end 115 | 116 | end 117 | in 118 | let* _, t = Context.lookup_meta mv in 119 | abstract t [] es >>= function 120 | | None -> return false 121 | | Some e_ -> 122 | begin 123 | Context.close_tm_ e_ >>= function 124 | | None -> return false 125 | | Some e_ -> 126 | let e = TT.unbox e_ in 127 | let* _ = Context.define mv e in 128 | return true 129 | end 130 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/core/unify.mli: -------------------------------------------------------------------------------- 1 | (** Unify terms at a type. *) 2 | val unify_tm_at : TT.tm -> TT.tm -> TT.ty -> bool Context.m 3 | 4 | (** Unifty types *) 5 | val unify_ty : TT.ty -> TT.ty -> bool Context.m 6 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/parsing/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parsing) 3 | (libraries sedlex menhirLib util) 4 | (preprocess (pps sedlex.ppx))) 5 | 6 | (menhir 7 | (modules parser)) -------------------------------------------------------------------------------- /holey-fauxtt/lib/parsing/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | 3 | open Util 4 | 5 | %} 6 | 7 | (* Infix operations a la OCaml *) 8 | 9 | %token PREFIXOP INFIXOP0 INFIXOP1 INFIXOP2 INFIXOP3 INFIXOP4 10 | 11 | (* Names *) 12 | %token NAME 13 | %token UNDERSCORE QUESTIONMARK 14 | 15 | (* Parentheses & punctuations *) 16 | %token LPAREN RPAREN 17 | %token COLONEQ 18 | %token COMMA COLON DARROW ARROW 19 | 20 | (* Expressions *) 21 | %token LET IN 22 | %token TYPE 23 | %token PROD 24 | %token LAMBDA 25 | 26 | (* Toplevel commands *) 27 | %token QUOTED_STRING 28 | %token LOAD 29 | %token DEF 30 | %token INFER 31 | %token EVAL 32 | %token AXIOM 33 | 34 | (* End of input token *) 35 | %token EOF 36 | 37 | (* Precedence and fixity of infix operators *) 38 | %left INFIXOP0 39 | %right INFIXOP1 40 | %left INFIXOP2 41 | %left INFIXOP3 42 | %right INFIXOP4 43 | 44 | %start file 45 | %start commandline 46 | 47 | %% 48 | 49 | file: 50 | | f=filecontents EOF 51 | { f } 52 | 53 | 54 | filecontents: 55 | | 56 | { [] } 57 | 58 | | d=topcomp ds=filecontents 59 | { d :: ds } 60 | 61 | 62 | commandline: 63 | | topcomp EOF 64 | { $1 } 65 | 66 | 67 | (* Things that can be defined on toplevel. *) 68 | topcomp: mark_location(topcomp_) { $1 } 69 | topcomp_: 70 | | LOAD fn=QUOTED_STRING 71 | { Syntax.TopLoad fn } 72 | 73 | | DEF x=var_name COLONEQ e=term 74 | { Syntax.TopDefinition (x, None, e) } 75 | 76 | | DEF x=var_name COLON t=term COLONEQ e=term 77 | { Syntax.TopDefinition (x, Some t, e) } 78 | 79 | | INFER e=term 80 | { Syntax.TopInfer e } 81 | 82 | | EVAL e=term 83 | { Syntax.TopEval e } 84 | 85 | | AXIOM x=var_name COLON e=term 86 | { Syntax.TopAxiom (x, e) } 87 | 88 | 89 | term : mark_location(term_) { $1 } 90 | term_: 91 | | e=infix_term_ 92 | { e } 93 | 94 | | PROD a=prod_abstraction COMMA e=term 95 | { Syntax.prod a e } 96 | 97 | | e1=infix_term ARROW e2=term 98 | { Syntax.arrow e1 e2 } 99 | 100 | | LAMBDA a=lambda_abstraction DARROW e=term 101 | { Syntax.lambda a e } 102 | 103 | | LET x=var_name COLONEQ e1=term IN e2=term 104 | { Syntax.Let (x, e1, e2) } 105 | 106 | | e=infix_term COLON t=term 107 | { Syntax.Ascribe (e, t) } 108 | 109 | 110 | infix_term: mark_location(infix_term_) { $1 } 111 | infix_term_: 112 | | e=app_term_ 113 | { e } 114 | 115 | | e2=infix_term oploc=infix e3=infix_term 116 | { let {Location.data=op; loc} = oploc in 117 | let op = Location.locate ~loc (Syntax.Var op) in 118 | let e1 = Location.locate ~loc (Syntax.Apply (op, e2)) in 119 | Syntax.Apply (e1, e3) 120 | } 121 | 122 | 123 | app_term: mark_location(app_term_) { $1 } 124 | app_term_: 125 | | e=prefix_term_ 126 | { e } 127 | 128 | | e1=app_term e2=prefix_term 129 | { Syntax.Apply (e1, e2) } 130 | 131 | 132 | prefix_term: mark_location(prefix_term_) { $1 } 133 | prefix_term_: 134 | | e=simple_term_ 135 | { e } 136 | 137 | | oploc=prefix e2=prefix_term 138 | { let {Location.data=op; loc} = oploc in 139 | let op = Location.locate ~loc (Syntax.Var op) in 140 | Syntax.Apply (op, e2) 141 | } 142 | 143 | 144 | (* simple_term : mark_location(simple_term_) { $1 } *) 145 | simple_term_: 146 | | LPAREN e=term_ RPAREN 147 | { e } 148 | 149 | | TYPE 150 | { Syntax.Type } 151 | 152 | | x=var_name 153 | { Syntax.Var x } 154 | 155 | | QUESTIONMARK x=var_name 156 | { Syntax.Hole x } 157 | 158 | 159 | var_name: 160 | | NAME 161 | { $1 } 162 | 163 | | LPAREN op=infix RPAREN 164 | { op.Location.data } 165 | 166 | | LPAREN op=prefix RPAREN 167 | { op.Location.data } 168 | 169 | | UNDERSCORE 170 | { Name.anonymous () } 171 | 172 | 173 | %inline infix: 174 | | op=INFIXOP0 175 | { op } 176 | 177 | | op=INFIXOP1 178 | { op } 179 | 180 | | op=INFIXOP2 181 | { op } 182 | 183 | | op=INFIXOP3 184 | { op } 185 | 186 | | op=INFIXOP4 187 | { op } 188 | 189 | 190 | %inline prefix: 191 | | op=PREFIXOP 192 | { op } 193 | 194 | lambda_abstraction: 195 | | lst=nonempty_list(binder) 196 | { lst } 197 | 198 | prod_abstraction: 199 | | lst=nonempty_list(typed_binder) 200 | { lst } 201 | 202 | typed_binder: mark_location(typed_binder_) { $1 } 203 | typed_binder_: 204 | | LPAREN xs=nonempty_list(var_name) COLON t=term RPAREN 205 | { (xs, t) } 206 | 207 | binder: mark_location(binder_) { $1 } 208 | binder_: 209 | | LPAREN xs=nonempty_list(var_name) COLON t=term RPAREN 210 | { (xs, Some t) } 211 | 212 | | x=var_name 213 | { ([x], None) } 214 | 215 | 216 | mark_location(X): 217 | | x=X 218 | { Location.locate ~loc:(Location.make $startpos $endpos) x } 219 | 220 | %% 221 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/parsing/syntax.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type tm = tm' Location.t 4 | and tm' = 5 | | Var of string 6 | | Let of string * tm * tm 7 | | Type 8 | | Prod of (string * ty) * ty 9 | | Lambda of (string * ty option) * tm 10 | | Apply of tm * tm 11 | | Ascribe of tm * ty 12 | | Hole of string 13 | 14 | (* Parsed type (equal to tmession). *) 15 | and ty = tm 16 | 17 | (* Parsed top-level command. *) 18 | type toplevel = toplevel' Location.t 19 | and toplevel' = 20 | | TopLoad of string 21 | | TopDefinition of string * ty option * tm 22 | | TopInfer of tm 23 | | TopEval of tm 24 | | TopAxiom of string * ty 25 | 26 | let prod xus t = 27 | let rec fold = function 28 | | [] -> t 29 | | Location.{loc; data=(xs, u)} :: xus -> 30 | let rec fold' = function 31 | | [] -> fold xus 32 | | x :: xs -> 33 | Location.locate ~loc (Prod ((x, u), fold' xs)) 34 | in 35 | fold' xs 36 | in 37 | (fold xus).Location.data 38 | 39 | let lambda xus t = 40 | let rec fold = function 41 | | [] -> t 42 | | Location.{loc; data=(xs, uopt)} :: xus -> 43 | let rec fold' = function 44 | | [] -> fold xus 45 | | x :: xs -> 46 | Location.locate ~loc (Lambda ((x, uopt), fold' xs)) 47 | in 48 | fold' xs 49 | in 50 | (fold xus).Location.data 51 | 52 | let arrow u t = 53 | let x = Name.anonymous () in 54 | Prod ((x, u), t) 55 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/parsing/syntax.mli: -------------------------------------------------------------------------------- 1 | (* Concrete syntax as parsed by the parser. *) 2 | 3 | open Util 4 | 5 | (* Parsed term. *) 6 | type tm = tm' Location.t 7 | and tm' = 8 | | Var of string 9 | | Let of string * tm * tm 10 | | Type 11 | | Prod of (string * ty) * ty 12 | | Lambda of (string * ty option) * tm 13 | | Apply of tm * tm 14 | | Ascribe of tm * ty 15 | | Hole of string 16 | 17 | (* Parsed types are the same as terms. *) 18 | and ty = tm 19 | 20 | (* Parsed top-level command. *) 21 | type toplevel = toplevel' Location.t 22 | and toplevel' = 23 | | TopLoad of string 24 | | TopDefinition of string * ty option * tm 25 | | TopInfer of tm 26 | | TopEval of tm 27 | | TopAxiom of string * ty 28 | 29 | val prod : (string list * ty) Location.t list -> ty -> tm' 30 | 31 | val lambda : (string list * ty option) Location.t list -> tm -> tm' 32 | 33 | val arrow : ty -> ty -> tm' 34 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/parsing/ulexbuf.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | stream : Sedlexing.lexbuf ; 3 | mutable pos_start : Lexing.position ; 4 | mutable pos_end : Lexing.position ; 5 | mutable line_limit : int option ; 6 | mutable end_of_input : bool ; 7 | } 8 | 9 | type error = 10 | | SysError of string 11 | | Unexpected of string 12 | | MalformedUTF8 13 | | BadNumeral of string 14 | | UnclosedComment 15 | 16 | let print_error err ppf = match err with 17 | | SysError s -> Format.fprintf ppf "System error: %s" s 18 | | Unexpected s -> Format.fprintf ppf "Unexpected %s" s 19 | | MalformedUTF8 -> Format.fprintf ppf "Malformed UTF8" 20 | | BadNumeral s -> Format.fprintf ppf "Bad numeral %s" s 21 | | UnclosedComment -> Format.fprintf ppf "Input ended inside unclosed comment" 22 | 23 | exception Error of error Util.Location.t 24 | 25 | let error ~loc err = Stdlib.raise (Error (Util.Location.locate ~loc err)) 26 | 27 | let create_lexbuf ?(fn="") stream = 28 | let pos_end = 29 | Lexing.{ 30 | pos_fname = fn; 31 | pos_lnum = 1; 32 | pos_bol = 0; 33 | pos_cnum = 0; 34 | } 35 | in 36 | { pos_start = pos_end; pos_end; stream ; 37 | line_limit = None; end_of_input = false; } 38 | 39 | let from_channel ?(fn="") fh = 40 | create_lexbuf ~fn (Sedlexing.Utf8.from_channel fh) 41 | 42 | let from_string ?(fn="") s = 43 | create_lexbuf ~fn (Sedlexing.Utf8.from_string s) 44 | 45 | let lexeme { stream;_ } = Sedlexing.Utf8.lexeme stream 46 | 47 | let new_line ?(n=1) lexbuf = 48 | assert (n >= 0) ; 49 | if n = 0 then () else 50 | let open Lexing in 51 | let lcp = lexbuf.pos_end in 52 | lexbuf.pos_end <- 53 | { lcp with 54 | pos_lnum = lcp.pos_lnum + n ; 55 | pos_bol = lcp.pos_cnum ; 56 | } 57 | 58 | let update_pos ({pos_end; stream;_} as buf) = 59 | let p_start, p_end = Sedlexing.loc stream in 60 | buf.pos_start <- {pos_end with Lexing.pos_cnum = p_start}; 61 | buf.pos_end <- {pos_end with Lexing.pos_cnum = p_end } 62 | 63 | let reached_end_of_input b = 64 | b.end_of_input <- true 65 | 66 | let set_line_limit ll b = 67 | b.line_limit <- ll 68 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/parsing/ulexbuf.mli: -------------------------------------------------------------------------------- 1 | (** Support for UTF8 lexer. *) 2 | 3 | open Util 4 | 5 | (** The state of the parser: a stream, a beginning- and an end-position. *) 6 | type t = private { 7 | stream : Sedlexing.lexbuf ; 8 | mutable pos_start : Lexing.position ; 9 | mutable pos_end : Lexing.position ; 10 | mutable line_limit : int option ; 11 | mutable end_of_input : bool ; 12 | } 13 | 14 | type error = 15 | | SysError of string 16 | | Unexpected of string 17 | | MalformedUTF8 18 | | BadNumeral of string 19 | | UnclosedComment 20 | 21 | val print_error : error -> Format.formatter -> unit 22 | 23 | exception Error of error Location.t 24 | 25 | val error : loc:Location.location -> error -> 'a 26 | 27 | (** Update the start and end positions from the stream. *) 28 | val update_pos : t -> unit 29 | 30 | (** Register [n] new lines in the lexbuf's position. *) 31 | val new_line : ?n:int -> t -> unit 32 | 33 | (** The last matched lexeme as a string *) 34 | val lexeme : t -> string 35 | 36 | (** Create a lex-buffer from a channel. Set filename to [fn] (default ["?"]) *) 37 | val from_channel : ?fn:string -> in_channel -> t 38 | 39 | (** Create a lex-buffer from a string. Set filename to [fn] (default ["?"]) *) 40 | val from_string : ?fn:string -> string -> t 41 | 42 | val reached_end_of_input : t -> unit 43 | 44 | val set_line_limit : int option -> t -> unit 45 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/config.ml: -------------------------------------------------------------------------------- 1 | let interactive_shell = ref true 2 | 3 | let max_boxes = ref 42 4 | 5 | let columns = ref (Format.get_margin ()) 6 | 7 | let verbosity = ref 2 8 | 9 | let ascii = ref false 10 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/config.mli: -------------------------------------------------------------------------------- 1 | (** Configuration parameters that control how fauxtt works. *) 2 | 3 | (** Should the interactive shell be started. *) 4 | val interactive_shell : bool ref 5 | 6 | (** How deeply should large expressions be printed. *) 7 | val max_boxes : int ref 8 | 9 | (** How many columns should be used for printing expressions. *) 10 | val columns : int ref 11 | 12 | (** How verbose should the output be. *) 13 | val verbosity : int ref 14 | 15 | (** Should we restrict to ASCII-only output. *) 16 | val ascii : bool ref 17 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name util) 3 | (libraries bindlib)) 4 | 5 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/level.ml: -------------------------------------------------------------------------------- 1 | (** Precedence levels, support for pretty-printing. *) 2 | 3 | type t = int 4 | 5 | let parenthesize ~at_level ~max_level = max_level < at_level 6 | 7 | type infix = 8 | | Infix0 9 | | Infix1 10 | | Infix2 11 | | Infix3 12 | | Infix4 13 | 14 | let highest = 1000 15 | let least = 0 16 | 17 | let no_parens = least 18 | 19 | let prefix = 50 20 | let prefix_arg = 50 21 | 22 | let app = 100 23 | let app_left = app 24 | let app_right = app - 1 25 | 26 | let infix = function 27 | | Infix4 -> (200, 199, 200) 28 | | Infix3 -> (300, 300, 299) 29 | | Infix2 -> (400, 400, 399) 30 | | Infix1 -> (500, 499, 500) 31 | | Infix0 -> (600, 600, 599) 32 | 33 | let eq = 700 34 | let eq_left = eq - 1 35 | let eq_right = eq - 1 36 | 37 | let binder = 800 38 | let in_binder = binder 39 | let arr = binder 40 | let arr_left = arr - 1 41 | let arr_right = arr 42 | 43 | let ascription = 800 44 | 45 | let let_binding = 900 46 | let let_bound = 950 47 | let let_body = no_parens 48 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/level.mli: -------------------------------------------------------------------------------- 1 | (** Precedence of operators *) 2 | 3 | (** Levels of precedence -- higher level is less likely to be parenthesized. *) 4 | type t 5 | 6 | (** If we print [at_level] where [max_level] is the highest level that can still 7 | be printed without parenthesis, should we print parenthesis? *) 8 | val parenthesize : at_level:'a -> max_level:'a -> bool 9 | 10 | (** Following OCaml syntax, there are five levels of infix operators *) 11 | type infix = Infix0 | Infix1 | Infix2 | Infix3 | Infix4 12 | 13 | (** The highest possible level *) 14 | val highest : t 15 | 16 | (** The least possible level *) 17 | val least : t 18 | 19 | (** The level which never gets parenthesized (equal to [least]) *) 20 | val no_parens : t 21 | 22 | (** The level of a prefix operator and its argument *) 23 | val prefix : t 24 | val prefix_arg : t 25 | 26 | (** The level of application and its left and right arguments *) 27 | val app : t 28 | val app_left : t 29 | val app_right : t 30 | 31 | (** The level of an infix operator, and its left and right arguments *) 32 | val infix : infix -> t * t * t 33 | 34 | (** The level of an equality, and its arguments *) 35 | val eq : t 36 | val eq_left : t 37 | val eq_right : t 38 | 39 | (** The level of a binder (such as lambda) and its body *) 40 | val binder : t 41 | val in_binder : t 42 | 43 | (** The elvel of an arrow and its arguments *) 44 | val arr : t 45 | val arr_left : t 46 | val arr_right : t 47 | 48 | (** The level of type ascription *) 49 | val ascription : t 50 | 51 | (** The level of a let binding *) 52 | val let_binding : t 53 | 54 | (** The level of the let-bound expression *) 55 | val let_bound : t 56 | 57 | (** The level of the body of a let-bound expression *) 58 | val let_body : t 59 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/location.ml: -------------------------------------------------------------------------------- 1 | type location = 2 | | Location of Lexing.position * Lexing.position (** delimited location *) 3 | | Nowhere (** no location *) 4 | 5 | type 'a t = { data : 'a ; loc : location } 6 | 7 | let nowhere = Nowhere 8 | 9 | let make loc1 loc2 = Location (loc1, loc2) 10 | 11 | let of_lex lex = 12 | Location (Lexing.lexeme_start_p lex, Lexing.lexeme_end_p lex) 13 | 14 | let locate ?(loc=Nowhere) x = { data = x; loc = loc } 15 | 16 | let print loc ppf = 17 | match loc with 18 | | Nowhere -> 19 | Format.fprintf ppf "unknown location" 20 | | Location (begin_pos, end_pos) -> 21 | let begin_char = begin_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 22 | let end_char = end_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 23 | let begin_line = begin_pos.Lexing.pos_lnum in 24 | let filename = begin_pos.Lexing.pos_fname in 25 | 26 | if String.length filename != 0 then 27 | Format.fprintf ppf "file %S, line %d, charaters %d-%d" filename begin_line begin_char end_char 28 | else 29 | Format.fprintf ppf "line %d, characters %d-%d" (begin_line - 1) begin_char end_char 30 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/location.mli: -------------------------------------------------------------------------------- 1 | (** Source code locations. *) 2 | type location = 3 | | Location of Lexing.position * Lexing.position (** delimited location *) 4 | | Nowhere (** no location *) 5 | 6 | (** A datum tagged with a source code location *) 7 | type 'a t = private { data : 'a ; loc : location } 8 | 9 | (** Tag a datum with an (optional) location. *) 10 | val locate : ?loc:location -> 'a -> 'a t 11 | 12 | (** An unknown location, use with care. *) 13 | val nowhere : location 14 | 15 | (** Convert a [Lexing.lexbuf] location to a [location] *) 16 | val of_lex : Lexing.lexbuf -> location 17 | 18 | (** [make p1 p2] creates a location which starts at [p1] and ends at [p2]. *) 19 | val make : Lexing.position -> Lexing.position -> location 20 | 21 | (** Print a location *) 22 | val print : location -> Format.formatter -> unit 23 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/name.ml: -------------------------------------------------------------------------------- 1 | (** Names of variables. *) 2 | 3 | type fixity = 4 | | Word 5 | | Prefix 6 | | Infix of Level.infix 7 | 8 | let fixity x = 9 | let s = Bindlib.name_of x in 10 | if String.length s = 0 then 11 | Word 12 | else if String.length s > 1 && s.[0] = '*' && s.[1] = '*' then Infix Level.Infix4 13 | else 14 | match s.[0] with 15 | | '~' | '?' | '!' -> Prefix 16 | | '=' | '<' | '>' | '|' | '&' | '$' -> Infix Level.Infix0 17 | | '@' | '^' -> Infix Level.Infix1 18 | | '+' | '-' -> Infix Level.Infix2 19 | | '*' | '/' | '%' -> Infix Level.Infix3 20 | | _ -> Word 21 | 22 | let anonymous = 23 | let k = ref 0 in 24 | fun () -> (incr k ; "_" ^ string_of_int !k) 25 | 26 | let print_var ?(parentheses=true) x ppf = 27 | let s = Bindlib.name_of x in 28 | match fixity x with 29 | | Word -> Format.fprintf ppf "%s" s 30 | | Prefix | Infix _ -> 31 | if parentheses then 32 | Format.fprintf ppf "(%s)" s 33 | else 34 | Format.fprintf ppf "%s" s 35 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/name.mli: -------------------------------------------------------------------------------- 1 | (* Kinds of variable names. *) 2 | type fixity = 3 | | Word (* an ordinary word *) 4 | | Prefix (* prefix operator *) 5 | | Infix of Level.infix (* infix operator *) 6 | 7 | (* Generate a fresh name that the user cannot possibly generate *) 8 | val anonymous : unit -> string 9 | 10 | (* The fixity of a variable *) 11 | val fixity : 'a Bindlib.var -> fixity 12 | 13 | (* Print a variable name, possibly with parentheses if it is an operator. *) 14 | val print_var : ?parentheses:bool -> 'a Bindlib.var -> Format.formatter -> unit 15 | -------------------------------------------------------------------------------- /holey-fauxtt/lib/util/print.ml: -------------------------------------------------------------------------------- 1 | (** Support for pretty-printing and user messages. *) 2 | 3 | (** Print a message with given verbosity level. *) 4 | let message ~verbosity = 5 | if verbosity <= !Config.verbosity then 6 | fun fmt -> Format.eprintf (fmt ^^ "@.") 7 | else 8 | Format.ifprintf Format.err_formatter 9 | 10 | (** Report an error. *) 11 | let error fmt = message ~verbosity:1 fmt 12 | 13 | (** Report a warning. *) 14 | let warning fmt = message ~verbosity:2 ("Warning: " ^^ fmt) 15 | 16 | (** Report debugging information. *) 17 | let debug fmt = message ~verbosity:3 ("Debug: " ^^ fmt) 18 | 19 | (** Print an expression, possibly parenthesized. *) 20 | let print ?(at_level=Level.no_parens) ?(max_level=Level.highest) ppf = 21 | if Level.parenthesize ~at_level ~max_level then 22 | fun fmt -> Format.fprintf ppf ("(" ^^ fmt ^^ ")") 23 | else 24 | Format.fprintf ppf 25 | 26 | (** Print a sequence with given separator and printer. *) 27 | let sequence print_u separator us ppf = 28 | match us with 29 | | [] -> () 30 | | [u] -> print_u u ppf 31 | | u :: ((_ :: _) as us) -> 32 | print_u u ppf ; 33 | List.iter (fun u -> print ppf "%s@ " separator ; print_u u ppf) us 34 | 35 | (** Unicode and ascii versions of symbols. *) 36 | 37 | let char_lambda () = if !Config.ascii then "lambda" else "λ" 38 | let char_arrow () = if !Config.ascii then "->" else "→" 39 | let char_darrow () = if !Config.ascii then "=>" else "⇒" 40 | let char_prod () = if !Config.ascii then "forall" else "Π" 41 | let char_forall () = if !Config.ascii then "forall" else "∀" 42 | let char_equal () = if !Config.ascii then "==" else "≡" 43 | let char_vdash () = if !Config.ascii then "|-" else "⊢" 44 | -------------------------------------------------------------------------------- /holey-fauxtt/test/church.t/church.ftt: -------------------------------------------------------------------------------- 1 | (* Church numerals *) 2 | 3 | def numeral := ∏ (A : Type), (A → A) → (A → A) 4 | 5 | eval numeral 6 | 7 | def zero : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ x) 8 | 9 | def succ : numeral → numeral := 10 | (λ (n : numeral) (A : Type) (f : A → A) (x : A) ⇒ f (n A f x)) 11 | 12 | def one : numeral := succ zero 13 | 14 | def two : numeral := succ one 15 | 16 | def three : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ f (f (f x))) 17 | 18 | def five := succ (succ (succ (succ (succ zero)))) 19 | 20 | def ( + ) : numeral → numeral → numeral := 21 | (λ (m n : numeral) (A : Type) (f : A → A) (x : A) ⇒ m A f (n A f x)) 22 | 23 | def ( * ) : numeral → numeral → numeral := 24 | (λ (m n : numeral) (A : Type) (f : A → A) (x : A) ⇒ m A (n A f) x) 25 | 26 | def ten := five + five 27 | 28 | def hundred := ten * ten 29 | 30 | def thousand := hundred * ten 31 | 32 | (* A trick to see the numerals *) 33 | axiom N : Type 34 | axiom Z : N 35 | axiom S : N → N 36 | 37 | eval (thousand N S Z) 38 | -------------------------------------------------------------------------------- /holey-fauxtt/test/church.t/run.t: -------------------------------------------------------------------------------- 1 | $ fauxtt church.ftt 2 | numeral is defined. 3 | Π (A : Type), Π (_3 : Π (_1 : A), A), Π (_4 : A), A 4 | : Type 5 | zero is defined. 6 | succ is defined. 7 | one is defined. 8 | two is defined. 9 | three is defined. 10 | five is defined. 11 | + is defined. 12 | * is defined. 13 | ten is defined. 14 | hundred is defined. 15 | thousand is defined. 16 | N is assumed. 17 | Z is assumed. 18 | S is assumed. 19 | S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 20 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 21 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 22 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 23 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 24 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 25 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 26 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 27 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 28 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 29 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 30 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 31 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 32 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 33 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 34 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 35 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 36 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 37 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 38 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 39 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 40 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 41 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 42 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 43 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 44 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 45 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 46 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 47 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 48 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 49 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 50 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 51 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 52 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 53 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 54 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 55 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 56 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 57 | (S (S (S (S (S (S (S (S (S (S (S (S 58 | Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 59 | : N 60 | -------------------------------------------------------------------------------- /holey-fauxtt/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps %{bin:fauxtt})) 3 | -------------------------------------------------------------------------------- /holey-fauxtt/test/hole.t/funhole.ftt: -------------------------------------------------------------------------------- 1 | axiom A : Type 2 | axiom a : A 3 | axiom i : A → A 4 | 5 | infer λ (f : ?X) ⇒ i (f a) -------------------------------------------------------------------------------- /holey-fauxtt/test/hole.t/hole.ftt: -------------------------------------------------------------------------------- 1 | axiom A : Type 2 | axiom a : A 3 | infer (λ (x : ?X) ⇒ x) a 4 | infer λ (B : Type) (b : B) ⇒ (λ (x : ?X) ⇒ x) b 5 | infer let B := A in λ (b : B) ⇒ (λ (x : ?X) ⇒ x) b 6 | infer λ (B : Type) (f : B → B) (x : ?X) ⇒ f x 7 | -------------------------------------------------------------------------------- /holey-fauxtt/test/hole.t/run.t: -------------------------------------------------------------------------------- 1 | $ fauxtt hole.ftt 2 | A is assumed. 3 | a is assumed. 4 | (λ (x : A) ⇒ x) a 5 | : A 6 | λ (B : Type) ⇒ λ (b : B) ⇒ 7 | (λ (x : (λ (B1 : Type) ⇒ λ (b1 : B1) ⇒ B1) B b) ⇒ x) b 8 | : Π (B : Type), Π (b : B), (λ (B1 : Type) ⇒ λ (b1 : B1) ⇒ B1) B 9 | b 10 | let B := A in 11 | (λ (b : B) ⇒ (λ (x : (let B1 := A in (λ (b1 : B1) ⇒ B1)) b) ⇒ x) b) 12 | : Π (b : A), (let B := A in (λ (b1 : B) ⇒ B)) b 13 | λ (B : Type) ⇒ λ (f : Π (_1 : B), B) ⇒ λ 14 | (x : (λ (B1 : Type) ⇒ λ (f1 : Π (_1 : B1), B1) ⇒ B1) B f) ⇒ f x 15 | : Π (B : Type), Π (f : Π (_1 : B), B), 16 | Π (x : (λ (B1 : Type) ⇒ λ (f1 : Π (_1 : B1), B1) ⇒ B1) B f), 17 | B 18 | $ fauxtt unscoped.ftt 19 | Typechecking error at file "unscoped.ftt", line 1, charaters 44-45: 20 | this expression should have type B but has type ?X 21 | $ fauxtt funhole.ftt 22 | A is assumed. 23 | a is assumed. 24 | i is assumed. 25 | Typechecking error at file "funhole.ftt", line 5, charaters 21-26: 26 | this expression should be a function but has type ?X 27 | -------------------------------------------------------------------------------- /holey-fauxtt/test/hole.t/unscoped.ftt: -------------------------------------------------------------------------------- 1 | infer λ (x : ?X) (B : Type) (f : B → B) ⇒ f x 2 | -------------------------------------------------------------------------------- /holey-fauxtt/test/syntax.t/run.t: -------------------------------------------------------------------------------- 1 | $ fauxtt syntax.ftt 2 | Type 3 | : Type 4 | Type 5 | : Type 6 | A is defined. 7 | B is assumed. 8 | λ (A : Type) ⇒ A 9 | : Π (A : Type), Type 10 | λ (A : Type) ⇒ λ (B : Type) ⇒ λ (C : Type) ⇒ A 11 | : Π (A : Type), Π (B : Type), Π (C : Type), Type 12 | λ (A : Type) ⇒ λ (B : Type) ⇒ λ (C : Type) ⇒ λ (x : B) ⇒ λ 13 | (y : B) ⇒ x 14 | : Π (A : Type), Π (B : Type), Π (C : Type), Π (x : B), Π (y : B), B 15 | λ (A : Type) ⇒ A 16 | : Π (A : Type), Type 17 | λ (A : Type) ⇒ λ (B : Type) ⇒ λ (C : Type) ⇒ A 18 | : Π (A : Type), Π (B : Type), Π (C : Type), Type 19 | λ (x : B) ⇒ λ (y : B) ⇒ λ (z : B) ⇒ y 20 | : Π (_3 : B), Π (_4 : B), Π (_5 : B), B 21 | λ (A : Type) ⇒ λ (B : Type) ⇒ λ (C : Type) ⇒ λ (x : B) ⇒ λ 22 | (y : B) ⇒ x 23 | : Π (A : Type), Π (B : Type), Π (C : Type), Π (x : B), Π (y : B), B 24 | id is defined. 25 | λ (S : Type) ⇒ λ (c : S) ⇒ λ (T : Π (_4 : S), Type) ⇒ λ (u : T 26 | c) ⇒ let x := id S c in u 27 | : Π (S : Type), Π (c : S), Π (T : Π (_4 : S), Type), 28 | Π (u : T c), T (id S (id S c)) 29 | -------------------------------------------------------------------------------- /holey-fauxtt/test/syntax.t/syntax.ftt: -------------------------------------------------------------------------------- 1 | (* Every bit of syntax should appear in this file. *) 2 | 3 | infer Type 4 | 5 | eval Type 6 | 7 | def A := Type 8 | 9 | axiom B : A 10 | 11 | (* Functions *) 12 | 13 | infer fun (A : Type) => A 14 | 15 | infer fun (A B C : Type) => A 16 | 17 | infer fun (A B C : Type) (x y : B) => x 18 | 19 | infer λ (A : Type) ⇒ A 20 | 21 | infer λ (A B C : Type) ⇒ A 22 | 23 | infer (λ x y z ⇒ y) : B → B → B → B 24 | 25 | infer λ (A B C : Type) (x y : B) ⇒ x 26 | 27 | (* Let statement *) 28 | 29 | def id := fun (A : Type) (x : A) => x 30 | 31 | infer λ (S : Type) (c : S) (T : S → Type) (u : T c) ⇒ let x := id S c in (u : T (id S x)) 32 | -------------------------------------------------------------------------------- /monadic-fauxtt/README.md: -------------------------------------------------------------------------------- 1 | # A monadic implementation of faux type theory 2 | 3 | **This is the basic version of Faux type theory, as presented in Lecture 2.** 4 | 5 | ## The type theory 6 | 7 | The dependent type theory `fauxtt` has the following ingridients: 8 | 9 | * A universe `Type` with `Type : Type`. 10 | * Dependent products, written as `forall (x : T₁), T₂` or `∀ (x : T₁), T₂` or `∏ (x : T₁), T₂`. 11 | * Functions, written as one of `fun (x : T) => e` or `λ (x : T) ⇒ e`. The typing annotation may 12 | be omitted, i.e., `fun x => e`, and multiple abstractions may be shortened as 13 | `λ x y (z u : T) (w : U) ⇒ e`. 14 | * Application `e₁ e₂`. 15 | * Type ascription written as `e : T`. 16 | * Local definitions written as `let x := e₁ in e₂`. 17 | 18 | Top-level commands: 19 | 20 | * `def x := e` -- define a value 21 | * `axiom x : T` -- assume a constant `x` of type `T` 22 | * `check e` -- print the type of `e` 23 | * `eval e` -- evaluate `e` a la call-by-value 24 | * `Load "⟨file⟩"` -- load a file 25 | 26 | ## Prerequisites 27 | 28 | * [OCaml](https://ocaml.org) and [OPAM](https://opam.ocaml.org) 29 | 30 | * The OPAM packages `dune`, `menhir`, `menhirLib`, `sedlex` and `bindlib`: 31 | 32 | opam install dune menhir menhirLib sedlex bindlib 33 | 34 | * It is recommended that you also install the `rlwrap` or `ledit` command line wrapper. 35 | 36 | ## Compilation 37 | 38 | You can type: 39 | 40 | * `dune build` to compile the `fauxtt.exe` executable. 41 | * `dune clean` to clean up. 42 | 43 | ## Usage 44 | 45 | Once you compile the program, you can run it in interactive mode as `./fauxtt.exe` 46 | 47 | Run `./fauxtt.exe --help` to see the command-line options and general usage. 48 | 49 | 50 | ## Source code 51 | 52 | The purpose of the implementation is to keep the source uncomplicated and short. The 53 | essential bits of source code can be found in the following files. It should be possible 54 | for you to just read the entire source code. 55 | 56 | It is best to first familiarize yourself with the core: 57 | 58 | * [`lib/core/TT.ml`](./lib/core/TT.ml) – the core type theory 59 | * [`lib/core/context.ml`](./lib/core/context.ml) – typing context 60 | * [`lib/core/typecheck.ml`](./lib/coretypecheck.ml) – type checking and elaboration 61 | * [`lib/core/norm.ml`](./lib/core/norm.ml) – normalization 62 | * [`lib/core/equal.ml`](./lib/core/equal.ml) – equality and normalization 63 | * [`lib/core/toplevel.ml`](./lib/core/toplevel.ml) – top-level commands 64 | 65 | Continue with the infrastructure: 66 | 67 | * [`lib/parsing/syntax.ml`](./lib/parsing/syntax.ml) – abstract syntax of the input code 68 | * [`lib/parsing/lexer.ml`](./lib/parsing/lexer.ml) – the lexer 69 | * [`lib/parsing/parser.mly`](./lib/parsing/parser.mly) – the parser 70 | * [`lib/util`](./lib/util) – various utilities 71 | * [`bin/fauxtt.ml`](bin/fauxtt.ml) – the main executable 72 | 73 | -------------------------------------------------------------------------------- /monadic-fauxtt/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name "fauxtt") 3 | (public_name "fauxtt") 4 | (modules fauxtt) 5 | (promote (until-clean) (into ..)) 6 | (libraries parsing core unix)) 7 | -------------------------------------------------------------------------------- /monadic-fauxtt/bin/fauxtt.ml: -------------------------------------------------------------------------------- 1 | (** The main executable. *) 2 | 3 | open Util 4 | 5 | (** The usage message. *) 6 | let usage = "Usage: fauxtt [option] ... [file] ..." 7 | 8 | (** A list of files to be loaded and run, together with information on whether they should 9 | be loaded in interactive mode. *) 10 | let files = ref [] 11 | 12 | (** Add a file to the list of files to be loaded, and record whether it should 13 | be processed in interactive mode. *) 14 | let add_file quiet filename = (files := (filename, quiet) :: !files) 15 | 16 | (** Command-line options *) 17 | let options = Arg.align [ 18 | 19 | ("--columns", 20 | Arg.Set_int Config.columns, 21 | " Set the maximum number of columns of pretty printing"); 22 | 23 | ("--wrapper", 24 | Arg.String (fun str -> Config.wrapper := [str]), 25 | " Specify a command-line wrapper to be used (such as rlwrap or ledit)"); 26 | 27 | ("--no-wrapper", 28 | Arg.Unit (fun () -> Config.wrapper := []), 29 | " Do not use a command-line wrapper"); 30 | 31 | ("--no-prelude", 32 | Arg.Unit (fun () -> Config.prelude_file := Config.PreludeNone), 33 | " Do not load the prelude.tt file"); 34 | 35 | ("--prelude", 36 | Arg.String (fun str -> Config.prelude_file := Config.PreludeFile str), 37 | " Specify the prelude file to load initially"); 38 | 39 | ("--ascii", 40 | Arg.Set Config.ascii, 41 | " Use ASCII characters only"); 42 | 43 | ("-V", 44 | Arg.Set_int Config.verbosity, 45 | " Set printing verbosity to "); 46 | 47 | ("-n", 48 | Arg.Clear Config.interactive_shell, 49 | " Do not run the interactive toplevel"); 50 | 51 | ("-l", 52 | Arg.String (fun str -> add_file true str), 53 | " Load into the initial environment"); 54 | ] 55 | 56 | (* Print the error message corresponding to an exception. *) 57 | let print_error ~penv = function 58 | | Parsing.Ulexbuf.Error {Location.data=err; Location.loc} -> 59 | Print.error "Lexical error at %t:@ %t" (Location.print loc) (Parsing.Ulexbuf.print_error err) 60 | 61 | | Core.Typecheck.Error {Location.data=err; Location.loc} -> 62 | Print.error "Typechecking error at %t:@ %t" 63 | (Location.print loc) 64 | (Core.Typecheck.print_error ~penv err) 65 | 66 | | Sys.Break -> 67 | Print.error "Interrupted." ; 68 | 69 | | e -> 70 | raise e 71 | 72 | (* Interactive toplevel. *) 73 | let interactive_shell state = 74 | Format.printf "Faux type theory 1.0@." ; 75 | 76 | let rec loop state = 77 | let state = 78 | try 79 | Core.Toplevel.exec_interactive state 80 | with 81 | | e -> 82 | print_error ~penv:(Core.Toplevel.penv state) e ; state 83 | in loop state 84 | in 85 | try 86 | loop state 87 | with 88 | End_of_file -> () 89 | 90 | (* The main program. *) 91 | let _main = 92 | Sys.catch_break true ; 93 | 94 | (* Parse the arguments. *) 95 | Arg.parse 96 | options 97 | (fun str -> add_file false str ; Config.interactive_shell := false) 98 | usage ; 99 | 100 | (* Attempt to wrap yourself with a line-editing wrapper. *) 101 | if !Config.interactive_shell then 102 | begin match !Config.wrapper with 103 | | [] -> () 104 | | _::_ as lst -> 105 | let n = Array.length Sys.argv + 2 in 106 | let args = Array.make n "" in 107 | Array.blit Sys.argv 0 args 1 (n - 2) ; 108 | args.(n - 1) <- "--no-wrapper" ; 109 | List.iter 110 | (fun wrapper -> 111 | try 112 | args.(0) <- wrapper ; 113 | Unix.execvp wrapper args 114 | with Unix.Unix_error _ -> ()) 115 | lst 116 | end ; 117 | 118 | (* Files were accumulated in the wrong order, so we reverse them *) 119 | files := List.rev !files ; 120 | 121 | (* Should we load the prelude file? *) 122 | begin 123 | match !Config.prelude_file with 124 | | Config.PreludeNone -> () 125 | | Config.PreludeFile f -> add_file true f 126 | | Config.PreludeDefault -> 127 | (* look for prelude next to the executable and don't whine if it is not there *) 128 | let d = Filename.dirname Sys.argv.(0) in 129 | let f = Filename.concat d "prelude.tt" in 130 | if Sys.file_exists f then add_file true f 131 | end ; 132 | 133 | (* Set the maximum depth of pretty-printing, after which it prints ellipsis. *) 134 | Format.set_max_boxes !Config.max_boxes ; 135 | Format.set_margin !Config.columns ; 136 | Format.set_ellipsis_text "..." ; 137 | 138 | let rec run_code topstate files = 139 | try 140 | begin 141 | match files with 142 | | [] -> 143 | if !Config.interactive_shell 144 | then interactive_shell topstate 145 | else () 146 | 147 | | (fn, quiet) :: files -> 148 | let topstate = Core.Toplevel.load_file ~quiet topstate fn in 149 | run_code topstate files 150 | end 151 | with 152 | | e -> 153 | print_error ~penv:(Core.Toplevel.penv topstate) e 154 | in 155 | 156 | run_code Core.Toplevel.initial !files 157 | -------------------------------------------------------------------------------- /monadic-fauxtt/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | (name "faux-type-theory") 3 | (version 1.0) 4 | (using menhir 2.0) 5 | (cram enable) 6 | 7 | (authors "Andrej Bauer ") 8 | (maintainers "Andrej Bauer ") 9 | (source (github andrejbauer/faux-type-theory)) 10 | (license "MIT") 11 | 12 | (generate_opam_files false) 13 | 14 | (package 15 | (name faux-type-theory) 16 | (synopsis "A minimalistic implementation of faux type theory") 17 | (description 18 | "This project shows how to implement a minimalist type theory, 19 | which nevertheless could serve as a basis for a serious interpretation." 20 | ) 21 | 22 | (depends 23 | (ocaml (>= 5.0.0)) 24 | (dune :build) 25 | (menhir :build) 26 | (menhirLib :build) 27 | (sedlex :build) 28 | (bindlib (and (>= 6.0) :build)) 29 | (odoc :with-doc))) -------------------------------------------------------------------------------- /monadic-fauxtt/examples/church.ftt: -------------------------------------------------------------------------------- 1 | (* Church numerals *) 2 | 3 | def numeral := ∏ (A : Type), (A → A) → (A → A) 4 | 5 | eval numeral 6 | 7 | def zero : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ x) 8 | 9 | def succ : numeral → numeral := 10 | (λ n A (f : A → A) (x : A) ⇒ f (n A f x)) 11 | 12 | def one : numeral := succ zero 13 | 14 | def two : numeral := succ one 15 | 16 | def three : numeral := (λ A (f : A → A) (x : A) ⇒ f (f (f x))) 17 | 18 | def five := succ (succ (succ (succ (succ zero)))) 19 | 20 | def ( + ) : numeral → numeral → numeral := 21 | λ m n A (f : A → A) (x : A) ⇒ m A f (n A f x) 22 | 23 | def ( * ) : numeral → numeral → numeral := 24 | λ m n A (f : A → A) (x : A) ⇒ m A (n A f) x 25 | 26 | def ten := five + five 27 | 28 | def hundred := ten * ten 29 | 30 | def thousand := hundred * ten 31 | 32 | (* A trick to see the numerals *) 33 | axiom N : Type 34 | axiom Z : N 35 | axiom S : N → N 36 | 37 | eval (thousand N S Z) 38 | 39 | -------------------------------------------------------------------------------- /monadic-fauxtt/examples/funext.ftt: -------------------------------------------------------------------------------- 1 | (* Check that function extensionality holds. *) 2 | 3 | axiom A : Type 4 | axiom P : (A → A) → Type 5 | axiom f : A → A 6 | 7 | def id := λ (A : Type) (x : A) ⇒ x 8 | 9 | (** Function composition. *) 10 | def compose := λ (A B C : Type) (g : B → C) (f : A → B) (x : A) => g (f x) 11 | 12 | axiom u : P f 13 | 14 | infer u : P f 15 | 16 | infer u : P (id (A → A) f) 17 | 18 | infer u : P (compose A A A (id A) f) 19 | 20 | 21 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/TT.ml: -------------------------------------------------------------------------------- 1 | (* Faux type theory *) 2 | 3 | open Util 4 | 5 | (** Term *) 6 | type tm = 7 | | Var of var (** A free variable *) 8 | | Let of tm * ty * tm binder (** A let binding *) 9 | | Type (** the type of types *) 10 | | Prod of ty * ty binder (** dependent product *) 11 | | Lambda of ty * tm binder (** lambda abstraction *) 12 | | Apply of tm * tm (** application *) 13 | 14 | (** Type *) 15 | and ty = Ty of tm 16 | 17 | and var = tm Bindlib.var 18 | 19 | and 'a binder = (tm, 'a) Bindlib.binder 20 | 21 | (** A boxed term binder *) 22 | type 'a binder_ = 'a binder Bindlib.box 23 | 24 | (** A boxed term *) 25 | type tm_ = tm Bindlib.box 26 | 27 | (** A boxed type *) 28 | type ty_ = ty Bindlib.box 29 | 30 | let box_binder = Bindlib.box_binder 31 | 32 | (* Constructors for boxed terms and types *) 33 | 34 | let var_ = Bindlib.box_var 35 | 36 | let let_ = Bindlib.box_apply3 (fun e1 t e2 -> Let (e1, t, e2)) 37 | 38 | let type_ = Bindlib.box Type 39 | 40 | let ty_ = Bindlib.box_apply (fun t -> Ty t) 41 | 42 | let ty_type_ = Bindlib.box (Ty Type) 43 | 44 | let prod_ = Bindlib.box_apply2 (fun t u -> Prod (t, u)) 45 | 46 | let ty_prod_ = Bindlib.box_apply2 (fun t u -> Ty (Prod (t, u))) 47 | 48 | let lambda_ = Bindlib.box_apply2 (fun t e -> Lambda (t, e)) 49 | 50 | let apply_ = 51 | Bindlib.box_apply2 (fun e1 e2 -> Apply (e1, e2)) 52 | 53 | (* Lifting functions *) 54 | 55 | let rec lift_tm = function 56 | 57 | | Var v -> var_ v 58 | 59 | | Let (e1, t, e2) -> 60 | let_ (lift_tm e1) (lift_ty t) (box_binder lift_tm e2) 61 | 62 | | Type -> type_ 63 | 64 | | Prod (ty1, ty2) -> 65 | prod_ (lift_ty ty1) (box_binder lift_ty ty2) 66 | 67 | | Lambda (t, e) -> 68 | lambda_ (lift_ty t) (box_binder lift_tm e) 69 | 70 | | Apply (e1, e2) -> 71 | apply_ (lift_tm e1) (lift_tm e2) 72 | 73 | and lift_ty (Ty ty) = 74 | Bindlib.box_apply (fun ty -> Ty ty) (lift_tm ty) 75 | 76 | (* Helper functions for printing quantifiers *) 77 | 78 | let unbox = Bindlib.unbox 79 | 80 | let bind_var = Bindlib.bind_var 81 | 82 | let unbind = Bindlib.unbind 83 | 84 | let fresh_var x = Bindlib.new_var (fun x -> Var x) x 85 | 86 | let anonymous_var () = fresh_var (Name.anonymous ()) 87 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/TT.mli: -------------------------------------------------------------------------------- 1 | (** The faux type theory. *) 2 | 3 | (** Terms *) 4 | type tm = 5 | | Var of var (** variable *) 6 | | Let of tm * ty * tm binder (** A let binding *) 7 | | Type (** the type of types qua term *) 8 | | Prod of ty * ty binder (** dependent product *) 9 | | Lambda of ty * tm binder (** function *) 10 | | Apply of tm * tm (** application *) 11 | 12 | (** Types *) 13 | and ty = Ty of tm 14 | 15 | (** Variable *) 16 | and var = tm Bindlib.var 17 | 18 | (** An entity with one bound variable *) 19 | and 'a binder = (tm, 'a) Bindlib.binder 20 | 21 | (** A boxed term, in the sense of [Bindlib]. *) 22 | type tm_ = tm Bindlib.box 23 | 24 | (** A boxed type, in the sense of [Bindlib]. *) 25 | type ty_ = ty Bindlib.box 26 | 27 | (** A boxed binder, in the sense of [Bindlib]. *) 28 | type 'a binder_ = 'a binder Bindlib.box 29 | 30 | (** Boxed constructors *) 31 | 32 | val var_ : var -> tm_ 33 | 34 | val let_ : tm_ -> ty_ -> tm binder_ -> tm_ 35 | 36 | val type_ : tm_ 37 | 38 | val ty_ : tm_ -> ty_ 39 | 40 | val ty_type_ : ty_ 41 | 42 | val prod_ : ty_ -> ty binder_ -> tm_ 43 | 44 | val ty_prod_ : ty_ -> ty binder_ -> ty_ 45 | 46 | val lambda_ : ty_ -> tm binder_ -> tm_ 47 | 48 | val apply_ : tm_ -> tm_ -> tm_ 49 | 50 | (** Lifting functions *) 51 | 52 | val lift_tm : tm -> tm_ 53 | 54 | val lift_ty : ty -> ty_ 55 | 56 | val fresh_var : string -> var 57 | 58 | (** Generate a fresh variable that the user cannot. *) 59 | val anonymous_var : unit -> var 60 | 61 | (** Bind a variable in the given boxed entity. *) 62 | val bind_var : var -> 'a Bindlib.box -> 'a binder_ 63 | 64 | (** Unbind a variable in the given bound entity. *) 65 | val unbind : 'a binder -> var * 'a 66 | 67 | (** Unbox an entity. *) 68 | val unbox : 'a Bindlib.box -> 'a 69 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/context.ml: -------------------------------------------------------------------------------- 1 | (** Typing context and definitional equalities. *) 2 | 3 | module IdentMap = Map.Make(struct 4 | type t = string 5 | let compare = String.compare 6 | end) 7 | 8 | module VarMap = Map.Make(struct 9 | type t = TT.var 10 | let compare = Bindlib.compare_vars 11 | end) 12 | 13 | (** A typing context comprises two maps, the first one mapping strings to [Bindlib] variables, 14 | and the second mapping variables to their types and optional definitions. *) 15 | type t = 16 | { idents : TT.var IdentMap.t 17 | ; vars : (TT.tm option * TT.ty) VarMap.t 18 | } 19 | 20 | type 'a m = t -> 'a 21 | 22 | module Monad = 23 | struct 24 | let ( let* ) c1 c2 (ctx : t) = 25 | let v1 = c1 ctx in 26 | c2 v1 ctx 27 | 28 | let ( >>= ) = ( let* ) 29 | 30 | let return v (_ : t) = v 31 | end 32 | 33 | (** The initial, empty typing context. *) 34 | let initial = 35 | { idents = IdentMap.empty 36 | ; vars = VarMap.empty 37 | } 38 | 39 | let run ctx c = c ctx 40 | 41 | let penv _ = Bindlib.empty_ctxt 42 | 43 | let extend_var_ x v ?def_ ty_ {idents;vars} = 44 | let ty = Bindlib.unbox ty_ 45 | and def = Option.map Bindlib.unbox def_ in 46 | { idents = IdentMap.add x v idents 47 | ; vars = VarMap.add v (def, ty) vars 48 | } 49 | 50 | let extend_var x v ?def ty {idents; vars} = 51 | { idents = IdentMap.add x v idents 52 | ; vars = VarMap.add v (def, ty) vars 53 | } 54 | 55 | let extend x ?def ty ctx = 56 | let v = TT.fresh_var x in 57 | v, extend_var x v ?def ty ctx 58 | 59 | let lookup_ident x {idents; _} = IdentMap.find_opt x idents 60 | 61 | let lookup v {vars; _} = VarMap.find v vars 62 | 63 | let lookup_ty v ctx = snd (lookup v ctx) 64 | 65 | let lookup_def v ctx = fst (lookup v ctx) 66 | 67 | let with_var v ?def t (c : 'a m) ctx = 68 | let x = Bindlib.name_of v in 69 | let local_ctx = extend_var x v ?def t ctx in 70 | c local_ctx 71 | 72 | let with_ident_ x ?def ty (c : TT.var -> 'a m) ctx = 73 | let v = TT.fresh_var x in 74 | let local_ctx = extend_var_ x v ?def_:def ty ctx in 75 | c v local_ctx 76 | 77 | let with_ident x ?def ty (c : TT.var -> 'a m) ctx = 78 | let v, local_ctx = extend x ?def ty ctx in 79 | c v local_ctx 80 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/context.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | (* The monad for computing in a typing context *) 4 | type 'a m 5 | 6 | (** Monadic interface to contexts. *) 7 | module Monad : sig 8 | 9 | (** Thread context state through a computation *) 10 | val ( let* ) : 'b m -> ('b -> 'c m) -> 'c m 11 | 12 | (** Synonym for [let*] *) 13 | val ( >>= ) : 'b m -> ('b -> 'c m) -> 'c m 14 | 15 | (** Return a pure value *) 16 | val return : 'b -> 'b m 17 | 18 | end 19 | 20 | (** The initial, empty typing context. *) 21 | val initial : t 22 | 23 | (** Run a computation in the given context. *) 24 | val run : t -> 'a m -> 'a 25 | 26 | (** Extend the context with a variable and return it *) 27 | val extend : string -> ?def:TT.tm -> TT.ty -> t -> TT.var * t 28 | 29 | (** The identifiers which should not be used for printing bound variables. *) 30 | val penv : t -> Bindlib.ctxt 31 | 32 | (** Lookup the type of a variable *) 33 | val lookup_ty : TT.var -> TT.ty m 34 | 35 | (** Lookup the definition associated with a variable, if any. *) 36 | val lookup_def : TT.var -> TT.tm option m 37 | 38 | (** Lookup the variable which corresponds to a concrete name. *) 39 | val lookup_ident : string -> TT.var option m 40 | 41 | (** Run a computation in a context extended with a variable, passing it the newly 42 | created variable. It is the callers responsibility that the result be valid in 43 | the original context. *) 44 | 45 | val with_ident : string -> ?def:TT.tm -> TT.ty -> (TT.var -> 'a m) -> 'a m 46 | 47 | val with_ident_ : string -> ?def:TT.tm_ -> TT.ty_ -> (TT.var -> 'a m) -> 'a m 48 | 49 | val with_var : TT.var -> ?def:TT.tm -> TT.ty -> 'a m -> 'a m 50 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core) 3 | (libraries bindlib util parsing)) 4 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/equal.ml: -------------------------------------------------------------------------------- 1 | (** Equality and normalization. *) 2 | 3 | open Context.Monad 4 | 5 | (* Monadic conjunction *) 6 | let ( &&& ) c1 c2 = 7 | let* b = c1 in 8 | if b then c2 else return false 9 | 10 | (* Monadic disjunction *) 11 | let ( ||| ) c1 c2 = 12 | let* b = c1 in 13 | if b then return true else c2 14 | 15 | (** Compare expressions [e1] and [e2] at type [ty]? *) 16 | let rec equal_tm_at e1 e2 ty = 17 | (* short-circuit *) 18 | return (e1 == e2) ||| 19 | begin 20 | (* The type directed phase *) 21 | let* Norm.Ty ty' = Norm.norm_ty ty in 22 | match ty' with 23 | 24 | | Norm.Prod (t, u) -> 25 | (* Apply function extensionality. *) 26 | let (x, u) = TT.unbind u in 27 | Context.with_var x t 28 | (let e1 = TT.(Apply (e1, Var x)) 29 | and e2 = TT.(Apply (e2, Var x)) in 30 | equal_tm_at e1 e2 u) 31 | 32 | | Norm.(Spine _ | Type) -> 33 | (* Type-directed phase is done, we compare normal forms. *) 34 | equal_tm e1 e2 35 | 36 | | Norm.(Lambda _) -> 37 | (* A type should never normalize to an abstraction or a let-binding *) 38 | assert false 39 | end 40 | 41 | (** Structurally compare weak head-normal forms of terms [e1] and [e2]. *) 42 | and equal_tm e1 e2 = 43 | let* e1 = Norm.norm_tm e1 in 44 | let* e2 = Norm.norm_tm e2 in 45 | match e1, e2 with 46 | 47 | | Norm.Type, Norm.Type -> 48 | return true 49 | 50 | | Norm.Prod (t1, u1), Norm.Prod (t2, u2) -> 51 | equal_ty t1 t2 &&& 52 | begin 53 | let (x, u1, u2) = Bindlib.unbind2 u1 u2 in 54 | Context.with_var x t1 (equal_ty u1 u2) 55 | end 56 | 57 | | Norm.Lambda _, Norm.Lambda _ -> 58 | (* We should never have to compare two lambdas, as that would mean that the 59 | type-directed phase did not figure out that these have product types. *) 60 | assert false 61 | 62 | | Norm.Spine (x1, es1), Norm.Spine (x2, es2) -> 63 | equal_spine x1 es1 x2 es2 64 | 65 | | Norm.(Type | Prod _ | Lambda _ | Spine _), _ -> 66 | return false 67 | 68 | and equal_spine x1 es1 x2 es2 = 69 | let rec fold t es1 es2 = 70 | match es1, es2 with 71 | | [], [] -> return true 72 | 73 | | ([], _::_) | (_::_, []) -> return false 74 | 75 | | e1 :: es1, e2 :: es2 -> 76 | begin 77 | Norm.as_prod t >>= function 78 | | None -> return false 79 | | Some (t, u) -> (equal_tm_at e1 e2 t) &&& (fold (Bindlib.subst u e1) es1 es2) 80 | end 81 | in 82 | 83 | (return @@ Bindlib.eq_vars x1 x2) &&& 84 | begin 85 | let* t = Context.lookup_ty x1 in 86 | fold t es1 es2 87 | end 88 | 89 | (** Compare two types. *) 90 | and equal_ty (TT.Ty ty1) (TT.Ty ty2) = 91 | equal_tm_at ty1 ty2 TT.(Ty Type) 92 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/equal.mli: -------------------------------------------------------------------------------- 1 | (** Are the given terms equal at the given type? *) 2 | val equal_tm_at : TT.tm -> TT.tm -> TT.ty -> bool Context.m 3 | 4 | (** Are the given types equal? *) 5 | val equal_ty : TT.ty -> TT.ty -> bool Context.m 6 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/norm.ml: -------------------------------------------------------------------------------- 1 | type tm = 2 | | Type 3 | | Prod of TT.ty * TT.ty TT.binder 4 | | Lambda of TT.ty * TT.tm TT.binder 5 | | Spine of TT.var * TT.tm list 6 | 7 | type ty = Ty of tm 8 | 9 | (** A normalization strategy. *) 10 | type strategy = 11 | | WHNF (** normalize to weak head-normal form *) 12 | | CBV (** call-by-value normalization *) 13 | 14 | open Context.Monad 15 | 16 | (** Normalize an expression using the given strategy. *) 17 | let rec norm_tm' ~strategy e = 18 | match e with 19 | 20 | | TT.Type -> 21 | return e 22 | 23 | | TT.Var x -> 24 | begin 25 | Context.lookup_def x >>= function 26 | | None -> return e 27 | | Some e -> norm_tm' ~strategy e 28 | end 29 | 30 | | TT.Let (e1, t, e2) -> 31 | let* e1 = 32 | match strategy with 33 | | WHNF -> return e1 34 | | CBV -> norm_tm' ~strategy e1 35 | in 36 | let (v, e2) = TT.unbind e2 in 37 | Context.with_var v ~def:e1 t (norm_tm' ~strategy e2) 38 | 39 | | TT.Prod _ -> 40 | return e 41 | 42 | | TT.Lambda _ -> 43 | return e 44 | 45 | | TT.Apply (e1, e2) -> 46 | let* e1 = norm_tm' ~strategy e1 in 47 | let* e2 = 48 | begin 49 | match strategy with 50 | | WHNF -> return e2 51 | | CBV -> norm_tm' ~strategy e2 52 | end 53 | in 54 | begin 55 | match e1 with 56 | | TT.Lambda (_, e') -> 57 | norm_tm' ~strategy (Bindlib.subst e' e2) 58 | | _ -> 59 | return @@ TT.Apply (e1, e2) 60 | end 61 | 62 | (** Normalize a type *) 63 | let norm_ty' ~strategy (TT.Ty ty) = 64 | let* ty = norm_tm' ~strategy ty in 65 | return @@ TT.Ty ty 66 | 67 | let eval_tm = norm_tm' ~strategy:CBV 68 | 69 | let norm_tm e = 70 | norm_tm' ~strategy:WHNF e >>= function 71 | | TT.Let _ -> assert false 72 | 73 | | TT.Type -> return Type 74 | 75 | | TT.Prod (t, u) -> return (Prod (t, u)) 76 | 77 | | TT.Lambda (t, e) -> return (Lambda (t, e)) 78 | 79 | | TT.(Var _ | Apply _) as e -> 80 | let rec fold es = function 81 | | TT.Var x -> x, es 82 | | TT.Apply (e1, e2) -> fold (e2 :: es) e1 83 | | TT.(Let _ | Type | Prod _ | Lambda _) -> assert false 84 | in 85 | let x, es = fold [] e in 86 | return @@ Spine (x, es) 87 | 88 | let norm_ty (TT.Ty t) = 89 | let* t = norm_tm t in 90 | return @@ Ty t 91 | 92 | (** Normalize a type to a product. *) 93 | let as_prod t = 94 | let* TT.Ty t' = norm_ty' ~strategy:WHNF t in 95 | match t' with 96 | | TT.Prod (t, u) -> return @@ Some (t, u) 97 | | _ -> return None 98 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/norm.mli: -------------------------------------------------------------------------------- 1 | (** Weak-head normal term. *) 2 | type tm = 3 | | Type 4 | | Prod of TT.ty * TT.ty TT.binder 5 | | Lambda of TT.ty * TT.tm TT.binder 6 | | Spine of TT.var * TT.tm list 7 | 8 | type ty = Ty of tm 9 | 10 | (** Evaluate a term using the call-by-value strategy *) 11 | val eval_tm : TT.tm -> TT.tm Context.m 12 | 13 | (** Normalize a term *) 14 | val norm_tm : TT.tm-> tm Context.m 15 | 16 | (** Normalize a type *) 17 | val norm_ty : TT.ty -> ty Context.m 18 | 19 | (** Convert a type to a product *) 20 | val as_prod : TT.ty -> (TT.ty * TT.ty TT.binder) option Context.m 21 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/print.ml: -------------------------------------------------------------------------------- 1 | (** Printing of terms and types. *) 2 | (* Printing routines *) 3 | 4 | module Level = Util.Level 5 | 6 | let as_prod ~penv = function 7 | | TT.(Ty (Prod (u, t))) when Bindlib.binder_occur t -> 8 | let (x, t, penv) = Bindlib.unbind_in penv t in 9 | Some (x, u, t, penv) 10 | | _ -> None 11 | 12 | let as_lambda ~penv = function 13 | | TT.Lambda (t, e) -> 14 | let (x, e, penv) = Bindlib.unbind_in penv e in 15 | Some (x, t, e, penv) 16 | | _ -> None 17 | 18 | let rec tm ?max_level ~penv e ppf = 19 | match e with 20 | 21 | | TT.Var x -> 22 | Format.fprintf ppf "%s" (Bindlib.name_of x) 23 | 24 | | TT.Let (e1, _, e2) -> 25 | let (x, e2, penv') = Bindlib.unbind_in penv e2 in 26 | Util.Print.print ?max_level ~at_level:Level.let_binding ppf "let@ %s :=@ %t@ in@ %t" 27 | (Bindlib.name_of x) 28 | (tm ~max_level:Level.let_bound ~penv e1) 29 | (tm ~max_level:Level.let_body ~penv:penv' e2) 30 | 31 | | TT.Type -> 32 | Format.fprintf ppf "Type" 33 | 34 | | TT.Lambda (t, e) -> 35 | print_quantifier ?max_level ~at_level:Level.highest ~penv as_lambda 36 | (Util.Print.char_lambda ()) tm t e ppf 37 | 38 | | TT.Apply (e1, e2) -> 39 | print_apply ?max_level ~penv e1 e2 ppf 40 | 41 | | TT.Prod (u, t) -> 42 | print_quantifier ?max_level ~at_level:Level.highest ~penv as_prod 43 | (Util.Print.char_prod ()) ty u t ppf 44 | 45 | 46 | and ty ?max_level ~penv (Ty t) ppf = tm ?max_level ~penv t ppf 47 | 48 | and print_quantifier : 49 | 'a . ?max_level:Level.t -> at_level:Level.t -> 50 | penv:_ -> 51 | (penv:_ -> 'a -> (TT.var * TT.ty * 'a * _) option) -> 52 | string -> 53 | (?max_level:Level.t -> penv:_ -> 'a -> Format.formatter -> unit) -> 54 | TT.ty -> 'a TT.binder -> Format.formatter -> unit 55 | = 56 | fun ?max_level ~at_level ~penv as_quant quant print_v u v ppf -> 57 | let rec print_rest ~penv v = 58 | match as_quant ~penv v with 59 | | None -> 60 | Util.Print.print ppf ",@ %t" (print_v ~penv v) ; 61 | 62 | | Some (x, u, v, penv') -> 63 | Format.fprintf ppf ",@ %s@;<1 -4>(%s : %t)" quant (Bindlib.name_of x) (ty ~penv u) ; 64 | print_rest ~penv:penv' v 65 | in 66 | let printer ppf = 67 | Format.pp_open_hovbox ppf 2 ; 68 | let (x, v, penv') = Bindlib.unbind_in penv v in 69 | Format.fprintf ppf "%s@;<1 -4>(%s : %t)" quant (Bindlib.name_of x) (ty ~penv u) ; 70 | print_rest ~penv:penv' v ; 71 | Format.pp_close_box ppf () 72 | in 73 | Util.Print.print ?max_level ~at_level ppf "%t" printer 74 | 75 | and print_apply ?max_level ~penv e1 e2 ppf = 76 | let prnt () = 77 | Util.Print.print ppf ?max_level ~at_level:Level.app "%t@ %t" 78 | (tm ~max_level:Level.app_left ~penv e1) 79 | (tm ~max_level:Level.app_right ~penv e2) 80 | in 81 | match e1 with 82 | 83 | | Var x -> 84 | begin 85 | match Util.Name.fixity x with 86 | 87 | | Util.Name.Prefix -> 88 | Util.Print.print ppf ?max_level ~at_level:Level.prefix "%t@ %t" 89 | (Util.Name.print_var x) 90 | (tm ~max_level:Level.prefix_arg ~penv e2) 91 | 92 | | Util.Name.Word -> 93 | prnt () 94 | 95 | | Util.Name.Infix lvl -> 96 | begin match e2 with 97 | 98 | | Apply (e2', e2'') -> 99 | let (lvl, lvl_right, lvl_left) = Level.infix lvl in 100 | Util.Print.print ppf ?max_level ~at_level:lvl "%t@ %t@ %t" 101 | (tm ~max_level:lvl_left ~penv e2') 102 | (Util.Name.print_var ~parentheses:false x) 103 | (tm ~max_level:lvl_right ~penv e2'') 104 | 105 | | _ -> prnt () 106 | end 107 | end 108 | 109 | | _ -> prnt () 110 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/print.mli: -------------------------------------------------------------------------------- 1 | (** Printing of terms and types *) 2 | 3 | (** Print a term *) 4 | val tm : ?max_level:Util.Level.t -> penv:Bindlib.ctxt -> TT.tm -> Format.formatter -> unit 5 | 6 | (** Print a type *) 7 | val ty : ?max_level:Util.Level.t -> penv:Bindlib.ctxt -> TT.ty -> Format.formatter -> unit 8 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/toplevel.ml: -------------------------------------------------------------------------------- 1 | (** Top-level processing. *) 2 | 3 | type state = Context.t 4 | 5 | let initial = Context.initial 6 | 7 | let penv = Context.penv 8 | 9 | let exec_interactive ctx = 10 | let e = Parsing.Lexer.read_toplevel Parsing.Parser.commandline () in 11 | Typecheck.toplevel ~quiet:false ctx e 12 | 13 | let load_file ~quiet ctx fn = 14 | Typecheck.topfile ~quiet ctx fn 15 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/toplevel.mli: -------------------------------------------------------------------------------- 1 | (** The top-level state of the proof assistant *) 2 | type state 3 | 4 | (** Initial top-level state. *) 5 | val initial : state 6 | 7 | (** Read a top-level command from the standard input and execute it. *) 8 | val exec_interactive : state -> state 9 | 10 | (** Load the contents of a file and execute it. *) 11 | val load_file : quiet:bool -> state -> string -> state 12 | 13 | (** Names of bound variables, used for printing de Bruijn indices. *) 14 | val penv : state -> Bindlib.ctxt 15 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/typecheck.ml: -------------------------------------------------------------------------------- 1 | (** Faux type checking. *) 2 | 3 | module Syntax = Parsing.Syntax 4 | 5 | module Location = Util.Location 6 | 7 | (** Type errors *) 8 | type type_error = 9 | | UnknownIdent of string 10 | | TypeExpected of TT.ty * TT.ty 11 | | TypeExpectedButFunction of TT.ty 12 | | FunctionExpected of TT.ty 13 | | CannotInferArgument of string 14 | 15 | exception Error of type_error Location.t 16 | 17 | (** [error ~loc err] raises the given type-checking error. *) 18 | let error ~loc err = Stdlib.raise (Error (Location.locate ~loc err)) 19 | 20 | let print_error ~penv err ppf = 21 | match err with 22 | 23 | | UnknownIdent x -> Format.fprintf ppf "unknown identifier %s" x 24 | 25 | | TypeExpected (ty_expected, ty_actual) -> 26 | Format.fprintf ppf "this expression should have type %t but has type %t" 27 | (Print.ty ~penv ty_expected) 28 | (Print.ty ~penv ty_actual) 29 | 30 | | TypeExpectedButFunction ty -> 31 | Format.fprintf ppf "this expression is a function but should have type %t" 32 | (Print.ty ~penv ty) 33 | 34 | | FunctionExpected ty -> 35 | Format.fprintf ppf "this expression should be a function but has type %t" 36 | (Print.ty ~penv ty) 37 | 38 | | CannotInferArgument x -> 39 | Format.fprintf ppf "cannot infer the type of %s" x 40 | 41 | 42 | open Context.Monad 43 | 44 | (** [infer_ e] infers the type [ty] of expression [e]. It returns 45 | the processed boxed expression [e] and its boxed type [ty]. *) 46 | let rec infer_ {Location.data=e'; loc} : (TT.tm_ * TT.ty_) Context.m = 47 | match e' with 48 | 49 | | Syntax.Var x -> 50 | begin 51 | Context.lookup_ident x >>= function 52 | | None -> error ~loc (UnknownIdent x) 53 | | Some v -> 54 | let* t = Context.lookup_ty v in 55 | return (TT.var_ v, TT.lift_ty t) 56 | end 57 | 58 | | Syntax.Let (x, e1, e2) -> 59 | let* (e1, t1) = infer_ e1 in 60 | Context.with_ident_ x ~def:e1 t1 61 | (fun v -> 62 | let* (e2, t2) = infer_ e2 in 63 | let t2 = TT.(lift_ty (Bindlib.subst (unbox (bind_var v t2)) (unbox e1))) in 64 | return TT.(let_ e1 t1 (bind_var v e2), t2)) 65 | 66 | | Syntax.Type -> 67 | return TT.(type_, ty_type_) 68 | 69 | | Syntax.Prod ((x, u), t) -> 70 | let* u = check_ty_ u in 71 | Context.with_ident_ x u 72 | (fun v -> 73 | let* t = check_ty_ t in 74 | return TT.(prod_ u (bind_var v t), ty_type_)) 75 | 76 | | Syntax.Lambda ((x, Some u), e) -> 77 | let* u = check_ty_ u in 78 | Context.with_ident_ x u 79 | (fun v -> 80 | let* (e, t) = infer_ e in 81 | return TT.(lambda_ u (bind_var v e), ty_prod_ u (bind_var v t))) 82 | 83 | | Syntax.Lambda ((x, None), _) -> 84 | error ~loc (CannotInferArgument x) 85 | 86 | | Syntax.Apply (e1, e2) -> 87 | let* (e1_, t1_) = infer_ e1 in 88 | let t1 = TT.unbox t1_ in 89 | begin 90 | Norm.as_prod t1 >>= function 91 | | None -> error ~loc (FunctionExpected t1) 92 | | Some (u, t) -> 93 | let* e2_ = check_ e2 u in 94 | let e2 = Bindlib.unbox e2_ in 95 | return TT.(apply_ e1_ e2_, TT.lift_ty (Bindlib.subst t e2)) 96 | end 97 | 98 | | Syntax.Ascribe (e, t) -> 99 | let* t = check_ty_ t in 100 | let* e = check_ e (TT.unbox t) in 101 | return (e, t) 102 | 103 | and check_ ({Location.data=e'; loc} as e) (ty : TT.ty) : TT.tm_ Context.m = 104 | match e' with 105 | 106 | | Syntax.Lambda ((x, None), e) -> 107 | begin 108 | Norm.as_prod ty >>= function 109 | | None -> error ~loc (TypeExpectedButFunction ty) 110 | | Some (t, u) -> 111 | Context.with_ident x t 112 | (fun v -> 113 | let u' = Bindlib.subst u (TT.Var v) in 114 | let* e = check_ e u' in 115 | return TT.(lambda_ (TT.lift_ty t) (bind_var v e))) 116 | end 117 | 118 | | Syntax.Let (x, e1, e2) -> 119 | let* (e1, t1) = infer_ e1 in 120 | Context.with_ident_ x ~def:e1 t1 121 | (fun v -> 122 | let* e2 = check_ e2 ty in 123 | return TT.(let_ e1 t1 (bind_var v e2))) 124 | 125 | | Syntax.Lambda ((_, Some _), _) 126 | | Syntax.Apply _ 127 | | Syntax.Prod _ 128 | | Syntax.Var _ 129 | | Syntax.Type 130 | | Syntax.Ascribe _ -> 131 | begin 132 | let* (e, ty'_) = infer_ e in 133 | let ty' = TT.unbox ty'_ in 134 | Equal.equal_ty ty ty' >>= function 135 | | true -> return e 136 | | false -> error ~loc (TypeExpected (ty, ty')) 137 | end 138 | 139 | and check_ty_ t = 140 | let* t = check_ t TT.(Ty Type) in 141 | return (TT.ty_ t) 142 | 143 | (** [check e ty] checks that [e] has type [ty]. It returns the processed term [e]. *) 144 | let check e t = 145 | let* e = check_ e t in 146 | return (Bindlib.unbox e) 147 | 148 | (** [infer e] infers the type of [e]. It returns the processed term and type. *) 149 | let infer e = 150 | let* (e_, t_) = infer_ e in 151 | return (TT.unbox e_, TT.unbox t_) 152 | 153 | (** [check_ty ctx t] checks that [t] is a type in context [ctx]. It returns the processed 154 | type [t]. *) 155 | let check_ty t = 156 | let* t_ = check_ty_ t in 157 | return (TT.unbox t_) 158 | 159 | let rec toplevel ~quiet ctx {Location.data=tc; _} = 160 | let ctx = toplevel' ~quiet ctx tc in 161 | ctx 162 | 163 | and toplevel' ~quiet ctx = function 164 | 165 | | Syntax.TopLoad file -> 166 | topfile ~quiet ctx file 167 | 168 | | Syntax.TopDefinition (x, None, e) -> 169 | let e, ty = Context.run ctx (infer e) in 170 | let _, ctx = Context.extend x ~def:e ty ctx in 171 | if not quiet then Format.printf "%s is defined.@." x ; 172 | ctx 173 | 174 | | Syntax.TopDefinition (x, Some ty, e) -> 175 | let ty = Context.run ctx (check_ty ty) in 176 | let e = Context.run ctx (check e ty) in 177 | let _, ctx = Context.extend x ~def:e ty ctx in 178 | if not quiet then Format.printf "%s is defined.@." x ; 179 | ctx 180 | 181 | | Syntax.TopInfer e -> 182 | let e, ty = Context.run ctx (infer e) in 183 | Format.printf "@[%t@]@\n : @[%t@]@." 184 | (Print.tm ~penv:(Context.penv ctx) e) 185 | (Print.ty ~penv:(Context.penv ctx) ty) ; 186 | ctx 187 | 188 | | Syntax.TopEval e -> 189 | let e, ty = Context.run ctx (infer e) in 190 | let e = Context.run ctx (Norm.eval_tm e) in 191 | Format.printf "@[%t@]@\n : @[%t@]@." 192 | (Print.tm ~penv:(Context.penv ctx) e) 193 | (Print.ty ~penv:(Context.penv ctx) ty) ; 194 | ctx 195 | 196 | | Syntax.TopAxiom (x, ty) -> 197 | let ty = Context.run ctx (check_ty ty) in 198 | let _, ctx = Context.extend x ty ctx in 199 | if not quiet then Format.printf "%s is assumed.@." x ; 200 | ctx 201 | 202 | and topfile ~quiet ctx file = 203 | let rec fold ctx = function 204 | | [] -> ctx 205 | | top_cmd :: lst -> 206 | let ctx = toplevel ~quiet ctx top_cmd in 207 | fold ctx lst 208 | in 209 | let cmds = Parsing.Lexer.read_file Parsing.Parser.file file in 210 | fold ctx cmds 211 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/core/typecheck.mli: -------------------------------------------------------------------------------- 1 | (** Type errors *) 2 | type type_error 3 | 4 | (** Exception signalling a type error. *) 5 | exception Error of type_error Util.Location.t 6 | 7 | (** Print error description. *) 8 | val print_error : penv:Bindlib.ctxt -> type_error -> Format.formatter -> unit 9 | 10 | (** Type-check a top-level command. *) 11 | val toplevel : quiet:bool -> Context.t -> Parsing.Syntax.toplevel -> Context.t 12 | 13 | (** Type-check the contents of a file. *) 14 | val topfile : quiet:bool -> Context.t -> string -> Context.t 15 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/parsing/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parsing) 3 | (libraries sedlex menhirLib util) 4 | (preprocess (pps sedlex.ppx))) 5 | 6 | (menhir 7 | (modules parser)) -------------------------------------------------------------------------------- /monadic-fauxtt/lib/parsing/lexer.ml: -------------------------------------------------------------------------------- 1 | (** Lexing with support for UTF8 characers. *) 2 | 3 | open Util 4 | 5 | (** Reserved words. *) 6 | let reserved = [ 7 | ("axiom", Parser.AXIOM) ; 8 | ("def", Parser.DEF) ; 9 | ("eval", Parser.EVAL) ; 10 | ("fun", Parser.LAMBDA) ; 11 | ("λ", Parser.LAMBDA) ; 12 | ("infer", Parser.INFER) ; 13 | ("let", Parser.LET) ; 14 | ("load", Parser.LOAD) ; 15 | ("forall", Parser.PROD) ; 16 | ("∀", Parser.PROD) ; 17 | ("Π", Parser.PROD) ; 18 | ("∏", Parser.PROD) ; 19 | ("in", Parser.IN) ; 20 | ("Type", Parser.TYPE) 21 | ] 22 | 23 | let name = 24 | [%sedlex.regexp? (('_' | alphabetic), 25 | Star ('_' | alphabetic 26 | | 185 | 178 | 179 | 8304 .. 8351 (* sub-/super-scripts *) 27 | | '0'..'9' | '\'')) | math] 28 | 29 | (* 30 | let digit = [%sedlex.regexp? '0'..'9'] 31 | let numeral = [%sedlex.regexp? Opt '-', Plus digit] 32 | *) 33 | 34 | let symbolchar = [%sedlex.regexp? ('!' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~')] 35 | 36 | let prefixop = [%sedlex.regexp? ('~' | '?' | '!'), Star symbolchar ] 37 | let infixop0 = [%sedlex.regexp? ('=' | '<' | '>' | '|' | '&' | '$'), Star symbolchar] 38 | let infixop1 = [%sedlex.regexp? ('@' | '^'), Star symbolchar ] 39 | let infixop2 = [%sedlex.regexp? ('+' | '-'), Star symbolchar ] 40 | let infixop3 = [%sedlex.regexp? ('*' | '/' | '%'), Star symbolchar ] 41 | let infixop4 = [%sedlex.regexp? "**", Star symbolchar ] 42 | 43 | let start_longcomment = [%sedlex.regexp? "(*"] 44 | let end_longcomment= [%sedlex.regexp? "*)"] 45 | 46 | let newline = [%sedlex.regexp? ('\n' | '\r' | "\n\r" | "\r\n")] 47 | let hspace = [%sedlex.regexp? (' ' | '\t' | '\r')] 48 | 49 | let quoted_string = [%sedlex.regexp? '"', Star (Compl '"'), '"'] 50 | 51 | let update_eoi ({ Ulexbuf.pos_end; line_limit;_ } as lexbuf) = 52 | match line_limit with None -> () | Some line_limit -> 53 | if pos_end.Lexing.pos_lnum >= line_limit 54 | then Ulexbuf.reached_end_of_input lexbuf 55 | 56 | let loc_of lex = Location.make lex.Ulexbuf.pos_start lex.Ulexbuf.pos_end 57 | 58 | let safe_int_of_string lexbuf = 59 | let s = Ulexbuf.lexeme lexbuf in 60 | try 61 | int_of_string s 62 | with 63 | Invalid_argument _ -> Ulexbuf.error ~loc:(loc_of lexbuf) (Ulexbuf.BadNumeral s) 64 | 65 | let rec token ({ Ulexbuf.end_of_input;_ } as lexbuf) = 66 | if end_of_input then Parser.EOF else token_aux lexbuf 67 | 68 | and token_aux ({ Ulexbuf.stream;_ } as lexbuf) = 69 | let f () = Ulexbuf.update_pos lexbuf in 70 | match%sedlex stream with 71 | | newline -> f (); Ulexbuf.new_line lexbuf; token_aux lexbuf 72 | | start_longcomment -> f (); comments 0 lexbuf 73 | | Plus hspace -> f (); token_aux lexbuf 74 | | quoted_string -> f (); 75 | let s = Ulexbuf.lexeme lexbuf in 76 | let l = String.length s in 77 | let n = ref 0 in 78 | String.iter (fun c -> if c = '\n' then incr n) s; 79 | Ulexbuf.new_line ~n:!n lexbuf; 80 | Parser.QUOTED_STRING (String.sub s 1 (l - 2)) 81 | | '_' -> f (); Parser.UNDERSCORE 82 | | '(' -> f (); Parser.LPAREN 83 | | ')' -> f (); Parser.RPAREN 84 | | ',' -> f (); Parser.COMMA 85 | | ':' -> f (); Parser.COLON 86 | | "=>" | 8658 | 10233 -> f (); Parser.DARROW 87 | | "->" | 8594 | 10230 -> f (); Parser.ARROW 88 | | ":=" -> f (); Parser.COLONEQ 89 | 90 | (* We record the location of operators here because menhir cannot handle %infix and 91 | mark_location simultaneously, it seems. *) 92 | | prefixop -> f (); let op = Location.locate ~loc:(loc_of lexbuf) (Ulexbuf.lexeme lexbuf) in 93 | Parser.PREFIXOP op 94 | | infixop0 -> f (); let op = Location.locate ~loc:(loc_of lexbuf) (Ulexbuf.lexeme lexbuf) in 95 | Parser.INFIXOP0 op 96 | | infixop1 -> f (); let op = Location.locate ~loc:(loc_of lexbuf) (Ulexbuf.lexeme lexbuf) in 97 | Parser.INFIXOP1 op 98 | | infixop2 -> f (); let op = Location.locate ~loc:(loc_of lexbuf) (Ulexbuf.lexeme lexbuf) in 99 | Parser.INFIXOP2 op 100 | (* Comes before infixop3 because ** matches the infixop3 pattern too *) 101 | | infixop4 -> f (); let op = Location.locate ~loc:(loc_of lexbuf) (Ulexbuf.lexeme lexbuf) in 102 | Parser.INFIXOP4 op 103 | | infixop3 -> f (); let op = Location.locate ~loc:(loc_of lexbuf) (Ulexbuf.lexeme lexbuf) in 104 | Parser.INFIXOP3 op 105 | 106 | | eof -> f (); Parser.EOF 107 | | name -> f (); 108 | let n = Ulexbuf.lexeme lexbuf in 109 | begin try List.assoc n reserved 110 | with Not_found -> Parser.NAME n 111 | end 112 | (* 113 | | numeral -> f (); let k = safe_int_of_string lexbuf in NUMERAL k 114 | *) 115 | | any -> f (); 116 | let w = Ulexbuf.lexeme lexbuf in 117 | let loc = loc_of lexbuf in 118 | Ulexbuf.error ~loc (Ulexbuf.Unexpected w) 119 | | _ -> assert false 120 | 121 | and comments level ({ Ulexbuf.stream;_ } as lexbuf) = 122 | match%sedlex stream with 123 | | end_longcomment -> 124 | if level = 0 then 125 | begin Ulexbuf.update_pos lexbuf; token lexbuf end 126 | else 127 | comments (level-1) lexbuf 128 | 129 | | start_longcomment -> comments (level+1) lexbuf 130 | | '\n' -> Ulexbuf.new_line lexbuf; comments level lexbuf 131 | | eof -> Ulexbuf.error ~loc:(loc_of lexbuf) Ulexbuf.UnclosedComment 132 | | any -> comments level lexbuf 133 | | _ -> assert false 134 | 135 | 136 | (** run a menhir parser with a sedlexer on a t *) 137 | (* the type of run is also: *) 138 | (* (t -> 'a) -> ('a, 'b) MenhirLib.Convert.traditional -> t -> 'b *) 139 | let run 140 | (lexer : Ulexbuf.t -> 'a) 141 | (parser : (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b) 142 | (lexbuf : Ulexbuf.t) : 'b = 143 | let lexer () = 144 | let token = lexer lexbuf in 145 | (token, lexbuf.Ulexbuf.pos_start, lexbuf.Ulexbuf.pos_end) in 146 | let parser = MenhirLib.Convert.Simplified.traditional2revised parser in 147 | try 148 | parser lexer 149 | with 150 | | Parser.Error -> 151 | let w = Ulexbuf.lexeme lexbuf in 152 | let loc = loc_of lexbuf in 153 | Ulexbuf.error ~loc (Ulexbuf.Unexpected w) 154 | | Sedlexing.MalFormed -> 155 | let loc = loc_of lexbuf in 156 | Ulexbuf.error ~loc Ulexbuf.MalformedUTF8 157 | (* | Sedlexing.InvalidCodepoint _ -> *) 158 | (* assert false (\* Shouldn't happen with UTF8 *\) *) 159 | 160 | 161 | let read_file parse fn = 162 | try 163 | let fh = open_in fn in 164 | let lex = Ulexbuf.from_channel ~fn fh in 165 | try 166 | let terms = run token parse lex in 167 | close_in fh; 168 | terms 169 | with 170 | (* Close the file in case of any parsing errors. *) 171 | Ulexbuf.Error err -> close_in fh; raise (Ulexbuf.Error err) 172 | with 173 | (* Any errors when opening or closing a file are fatal. *) 174 | Sys_error msg -> raise (Ulexbuf.error ~loc:Location.Nowhere (Ulexbuf.SysError msg)) 175 | 176 | 177 | let read_toplevel parse () = 178 | let all_white str = 179 | let n = String.length str in 180 | let rec fold k = 181 | k >= n || 182 | (str.[k] = ' ' || str.[k] = '\n' || str.[k] = '\t') && fold (k+1) 183 | in 184 | fold 0 185 | in 186 | 187 | let ends_with_backslash_or_empty str = 188 | let i = String.length str - 1 in 189 | if i >= 0 && str.[i] = '\\' 190 | then (true, String.sub str 0 i) 191 | else (all_white str, str) 192 | in 193 | 194 | let rec read_more prompt acc = 195 | print_string prompt ; 196 | let str = read_line () in 197 | let more, str = ends_with_backslash_or_empty str in 198 | let acc = acc ^ "\n" ^ str in 199 | if more 200 | then read_more " " acc 201 | else acc 202 | in 203 | 204 | let str = read_more "# " "" in 205 | let lex = Ulexbuf.from_string (str ^ "\n") in 206 | run token parse lex 207 | 208 | let read_string parse s = 209 | let lex = Ulexbuf.from_string s in 210 | run token parse lex 211 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/parsing/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | 3 | open Util 4 | 5 | %} 6 | 7 | (* Infix operations a la OCaml *) 8 | 9 | %token PREFIXOP INFIXOP0 INFIXOP1 INFIXOP2 INFIXOP3 INFIXOP4 10 | 11 | (* Names *) 12 | %token NAME 13 | %token UNDERSCORE 14 | 15 | (* Parentheses & punctuations *) 16 | %token LPAREN RPAREN 17 | %token COLONEQ 18 | %token COMMA COLON DARROW ARROW 19 | 20 | (* Expressions *) 21 | %token LET IN 22 | %token TYPE 23 | %token PROD 24 | %token LAMBDA 25 | 26 | (* Toplevel commands *) 27 | %token QUOTED_STRING 28 | %token LOAD 29 | %token DEF 30 | %token INFER 31 | %token EVAL 32 | %token AXIOM 33 | 34 | (* End of input token *) 35 | %token EOF 36 | 37 | (* Precedence and fixity of infix operators *) 38 | %left INFIXOP0 39 | %right INFIXOP1 40 | %left INFIXOP2 41 | %left INFIXOP3 42 | %right INFIXOP4 43 | 44 | %start file 45 | %start commandline 46 | 47 | %% 48 | 49 | file: 50 | | f=filecontents EOF 51 | { f } 52 | 53 | 54 | filecontents: 55 | | 56 | { [] } 57 | 58 | | d=topcomp ds=filecontents 59 | { d :: ds } 60 | 61 | 62 | commandline: 63 | | topcomp EOF 64 | { $1 } 65 | 66 | 67 | (* Things that can be defined on toplevel. *) 68 | topcomp: mark_location(topcomp_) { $1 } 69 | topcomp_: 70 | | LOAD fn=QUOTED_STRING 71 | { Syntax.TopLoad fn } 72 | 73 | | DEF x=var_name COLONEQ e=term 74 | { Syntax.TopDefinition (x, None, e) } 75 | 76 | | DEF x=var_name COLON t=term COLONEQ e=term 77 | { Syntax.TopDefinition (x, Some t, e) } 78 | 79 | | INFER e=term 80 | { Syntax.TopInfer e } 81 | 82 | | EVAL e=term 83 | { Syntax.TopEval e } 84 | 85 | | AXIOM x=var_name COLON e=term 86 | { Syntax.TopAxiom (x, e) } 87 | 88 | 89 | term : mark_location(term_) { $1 } 90 | term_: 91 | | e=infix_term_ 92 | { e } 93 | 94 | | PROD a=prod_abstraction COMMA e=term 95 | { Syntax.prod a e } 96 | 97 | | e1=infix_term ARROW e2=term 98 | { Syntax.arrow e1 e2 } 99 | 100 | | LAMBDA a=lambda_abstraction DARROW e=term 101 | { Syntax.lambda a e } 102 | 103 | | LET x=var_name COLONEQ e1=term IN e2=term 104 | { Syntax.Let (x, e1, e2) } 105 | 106 | | e=infix_term COLON t=term 107 | { Syntax.Ascribe (e, t) } 108 | 109 | 110 | infix_term: mark_location(infix_term_) { $1 } 111 | infix_term_: 112 | | e=app_term_ 113 | { e } 114 | 115 | | e2=infix_term oploc=infix e3=infix_term 116 | { let {Location.data=op; loc} = oploc in 117 | let op = Location.locate ~loc (Syntax.Var op) in 118 | let e1 = Location.locate ~loc (Syntax.Apply (op, e2)) in 119 | Syntax.Apply (e1, e3) 120 | } 121 | 122 | 123 | app_term: mark_location(app_term_) { $1 } 124 | app_term_: 125 | | e=prefix_term_ 126 | { e } 127 | 128 | | e1=app_term e2=prefix_term 129 | { Syntax.Apply (e1, e2) } 130 | 131 | 132 | prefix_term: mark_location(prefix_term_) { $1 } 133 | prefix_term_: 134 | | e=simple_term_ 135 | { e } 136 | 137 | | oploc=prefix e2=prefix_term 138 | { let {Location.data=op; loc} = oploc in 139 | let op = Location.locate ~loc (Syntax.Var op) in 140 | Syntax.Apply (op, e2) 141 | } 142 | 143 | 144 | (* simple_term : mark_location(simple_term_) { $1 } *) 145 | simple_term_: 146 | | LPAREN e=term_ RPAREN 147 | { e } 148 | 149 | | TYPE 150 | { Syntax.Type } 151 | 152 | | x=var_name 153 | { Syntax.Var x } 154 | 155 | 156 | var_name: 157 | | NAME 158 | { $1 } 159 | 160 | | LPAREN op=infix RPAREN 161 | { op.Location.data } 162 | 163 | | LPAREN op=prefix RPAREN 164 | { op.Location.data } 165 | 166 | | UNDERSCORE 167 | { Name.anonymous () } 168 | 169 | 170 | %inline infix: 171 | | op=INFIXOP0 172 | { op } 173 | 174 | | op=INFIXOP1 175 | { op } 176 | 177 | | op=INFIXOP2 178 | { op } 179 | 180 | | op=INFIXOP3 181 | { op } 182 | 183 | | op=INFIXOP4 184 | { op } 185 | 186 | 187 | %inline prefix: 188 | | op=PREFIXOP 189 | { op } 190 | 191 | lambda_abstraction: 192 | | lst=nonempty_list(binder) 193 | { lst } 194 | 195 | prod_abstraction: 196 | | lst=nonempty_list(typed_binder) 197 | { lst } 198 | 199 | typed_binder: mark_location(typed_binder_) { $1 } 200 | typed_binder_: 201 | | LPAREN xs=nonempty_list(var_name) COLON t=term RPAREN 202 | { (xs, t) } 203 | 204 | binder: mark_location(binder_) { $1 } 205 | binder_: 206 | | LPAREN xs=nonempty_list(var_name) COLON t=term RPAREN 207 | { (xs, Some t) } 208 | 209 | | x=var_name 210 | { ([x], None) } 211 | 212 | 213 | mark_location(X): 214 | | x=X 215 | { Location.locate ~loc:(Location.make $startpos $endpos) x } 216 | 217 | %% 218 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/parsing/syntax.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type tm = tm' Location.t 4 | and tm' = 5 | | Var of string 6 | | Let of string * tm * tm 7 | | Type 8 | | Prod of (string * ty) * ty 9 | | Lambda of (string * ty option) * tm 10 | | Apply of tm * tm 11 | | Ascribe of tm * ty 12 | 13 | (* Parsed type (equal to tmession). *) 14 | and ty = tm 15 | 16 | (* Parsed top-level command. *) 17 | type toplevel = toplevel' Location.t 18 | and toplevel' = 19 | | TopLoad of string 20 | | TopDefinition of string * ty option * tm 21 | | TopInfer of tm 22 | | TopEval of tm 23 | | TopAxiom of string * ty 24 | 25 | let prod xus t = 26 | let rec fold = function 27 | | [] -> t 28 | | Location.{loc; data=(xs, u)} :: xus -> 29 | let rec fold' = function 30 | | [] -> fold xus 31 | | x :: xs -> 32 | Location.locate ~loc (Prod ((x, u), fold' xs)) 33 | in 34 | fold' xs 35 | in 36 | (fold xus).Location.data 37 | 38 | let lambda xus t = 39 | let rec fold = function 40 | | [] -> t 41 | | Location.{loc; data=(xs, uopt)} :: xus -> 42 | let rec fold' = function 43 | | [] -> fold xus 44 | | x :: xs -> 45 | Location.locate ~loc (Lambda ((x, uopt), fold' xs)) 46 | in 47 | fold' xs 48 | in 49 | (fold xus).Location.data 50 | 51 | let arrow u t = 52 | let x = Name.anonymous () in 53 | Prod ((x, u), t) 54 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/parsing/syntax.mli: -------------------------------------------------------------------------------- 1 | (* Concrete syntax as parsed by the parser. *) 2 | 3 | open Util 4 | 5 | (* Parsed term. *) 6 | type tm = tm' Location.t 7 | and tm' = 8 | | Var of string 9 | | Let of string * tm * tm 10 | | Type 11 | | Prod of (string * ty) * ty 12 | | Lambda of (string * ty option) * tm 13 | | Apply of tm * tm 14 | | Ascribe of tm * ty 15 | 16 | (* Parsed types are the same as terms. *) 17 | and ty = tm 18 | 19 | (* Parsed top-level command. *) 20 | type toplevel = toplevel' Location.t 21 | and toplevel' = 22 | | TopLoad of string 23 | | TopDefinition of string * ty option * tm 24 | | TopInfer of tm 25 | | TopEval of tm 26 | | TopAxiom of string * ty 27 | 28 | val prod : (string list * ty) Location.t list -> ty -> tm' 29 | 30 | val lambda : (string list * ty option) Location.t list -> tm -> tm' 31 | 32 | val arrow : ty -> ty -> tm' 33 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/parsing/ulexbuf.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | stream : Sedlexing.lexbuf ; 3 | mutable pos_start : Lexing.position ; 4 | mutable pos_end : Lexing.position ; 5 | mutable line_limit : int option ; 6 | mutable end_of_input : bool ; 7 | } 8 | 9 | type error = 10 | | SysError of string 11 | | Unexpected of string 12 | | MalformedUTF8 13 | | BadNumeral of string 14 | | UnclosedComment 15 | 16 | let print_error err ppf = match err with 17 | | SysError s -> Format.fprintf ppf "System error: %s" s 18 | | Unexpected s -> Format.fprintf ppf "Unexpected %s" s 19 | | MalformedUTF8 -> Format.fprintf ppf "Malformed UTF8" 20 | | BadNumeral s -> Format.fprintf ppf "Bad numeral %s" s 21 | | UnclosedComment -> Format.fprintf ppf "Input ended inside unclosed comment" 22 | 23 | exception Error of error Util.Location.t 24 | 25 | let error ~loc err = Stdlib.raise (Error (Util.Location.locate ~loc err)) 26 | 27 | let create_lexbuf ?(fn="") stream = 28 | let pos_end = 29 | Lexing.{ 30 | pos_fname = fn; 31 | pos_lnum = 1; 32 | pos_bol = 0; 33 | pos_cnum = 0; 34 | } 35 | in 36 | { pos_start = pos_end; pos_end; stream ; 37 | line_limit = None; end_of_input = false; } 38 | 39 | let from_channel ?(fn="") fh = 40 | create_lexbuf ~fn (Sedlexing.Utf8.from_channel fh) 41 | 42 | let from_string ?(fn="") s = 43 | create_lexbuf ~fn (Sedlexing.Utf8.from_string s) 44 | 45 | let lexeme { stream;_ } = Sedlexing.Utf8.lexeme stream 46 | 47 | let new_line ?(n=1) lexbuf = 48 | assert (n >= 0) ; 49 | if n = 0 then () else 50 | let open Lexing in 51 | let lcp = lexbuf.pos_end in 52 | lexbuf.pos_end <- 53 | { lcp with 54 | pos_lnum = lcp.pos_lnum + n ; 55 | pos_bol = lcp.pos_cnum ; 56 | } 57 | 58 | let update_pos ({pos_end; stream;_} as buf) = 59 | let p_start, p_end = Sedlexing.loc stream in 60 | buf.pos_start <- {pos_end with Lexing.pos_cnum = p_start}; 61 | buf.pos_end <- {pos_end with Lexing.pos_cnum = p_end } 62 | 63 | let reached_end_of_input b = 64 | b.end_of_input <- true 65 | 66 | let set_line_limit ll b = 67 | b.line_limit <- ll 68 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/parsing/ulexbuf.mli: -------------------------------------------------------------------------------- 1 | (** Support for UTF8 lexer. *) 2 | 3 | open Util 4 | 5 | (** The state of the parser: a stream, a beginning- and an end-position. *) 6 | type t = private { 7 | stream : Sedlexing.lexbuf ; 8 | mutable pos_start : Lexing.position ; 9 | mutable pos_end : Lexing.position ; 10 | mutable line_limit : int option ; 11 | mutable end_of_input : bool ; 12 | } 13 | 14 | type error = 15 | | SysError of string 16 | | Unexpected of string 17 | | MalformedUTF8 18 | | BadNumeral of string 19 | | UnclosedComment 20 | 21 | val print_error : error -> Format.formatter -> unit 22 | 23 | exception Error of error Location.t 24 | 25 | val error : loc:Location.location -> error -> 'a 26 | 27 | (** Update the start and end positions from the stream. *) 28 | val update_pos : t -> unit 29 | 30 | (** Register [n] new lines in the lexbuf's position. *) 31 | val new_line : ?n:int -> t -> unit 32 | 33 | (** The last matched lexeme as a string *) 34 | val lexeme : t -> string 35 | 36 | (** Create a lex-buffer from a channel. Set filename to [fn] (default ["?"]) *) 37 | val from_channel : ?fn:string -> in_channel -> t 38 | 39 | (** Create a lex-buffer from a string. Set filename to [fn] (default ["?"]) *) 40 | val from_string : ?fn:string -> string -> t 41 | 42 | val reached_end_of_input : t -> unit 43 | 44 | val set_line_limit : int option -> t -> unit 45 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/config.ml: -------------------------------------------------------------------------------- 1 | type prelude = 2 | | PreludeNone (** Do not load the prelude file *) 3 | | PreludeDefault (** Load the default prelude file *) 4 | | PreludeFile of string (** Load a specific prelude file *) 5 | 6 | let prelude_file = ref PreludeDefault 7 | 8 | let interactive_shell = ref true 9 | 10 | let wrapper = ref ["rlwrap"; "ledit"] 11 | 12 | let max_boxes = ref 42 13 | 14 | let columns = ref (Format.get_margin ()) 15 | 16 | let verbosity = ref 2 17 | 18 | let ascii = ref false 19 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/config.mli: -------------------------------------------------------------------------------- 1 | (** Configuration parameters that control how fauxtt works. *) 2 | 3 | (** How to load the prelude file. *) 4 | type prelude = 5 | | PreludeNone (** Do not load the prelude file *) 6 | | PreludeDefault (** Load the default prelude file *) 7 | | PreludeFile of string (** Load a specific prelude file *) 8 | 9 | (** The prelude file to load. *) 10 | val prelude_file : prelude ref 11 | 12 | (** Should the interactive shell be started. *) 13 | val interactive_shell : bool ref 14 | 15 | (** List of command-line wrappers to try to use for command-line editing in interactive mode. *) 16 | val wrapper : string list ref 17 | 18 | (** How deeply should large expressions be printed. *) 19 | val max_boxes : int ref 20 | 21 | (** How many columns should be used for printing expressions. *) 22 | val columns : int ref 23 | 24 | (** How verbose should the output be. *) 25 | val verbosity : int ref 26 | 27 | (** Should we restrict to ASCII-only output. *) 28 | val ascii : bool ref 29 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name util) 3 | (libraries bindlib)) 4 | 5 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/level.ml: -------------------------------------------------------------------------------- 1 | (** Precedence levels, support for pretty-printing. *) 2 | 3 | type t = int 4 | 5 | let parenthesize ~at_level ~max_level = max_level < at_level 6 | 7 | type infix = 8 | | Infix0 9 | | Infix1 10 | | Infix2 11 | | Infix3 12 | | Infix4 13 | 14 | let highest = 1000 15 | let least = 0 16 | 17 | let no_parens = least 18 | 19 | let prefix = 50 20 | let prefix_arg = 50 21 | 22 | let app = 100 23 | let app_left = app 24 | let app_right = app - 1 25 | 26 | let infix = function 27 | | Infix4 -> (200, 199, 200) 28 | | Infix3 -> (300, 300, 299) 29 | | Infix2 -> (400, 400, 399) 30 | | Infix1 -> (500, 499, 500) 31 | | Infix0 -> (600, 600, 599) 32 | 33 | let eq = 700 34 | let eq_left = eq - 1 35 | let eq_right = eq - 1 36 | 37 | let binder = 800 38 | let in_binder = binder 39 | let arr = binder 40 | let arr_left = arr - 1 41 | let arr_right = arr 42 | 43 | let ascription = 800 44 | 45 | let let_binding = 900 46 | let let_bound = 950 47 | let let_body = no_parens 48 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/level.mli: -------------------------------------------------------------------------------- 1 | (** Precedence of operators *) 2 | 3 | (** Levels of precedence -- higher level is less likely to be parenthesized. *) 4 | type t 5 | 6 | (** If we print [at_level] where [max_level] is the highest level that can still 7 | be printed without parenthesis, should we print parenthesis? *) 8 | val parenthesize : at_level:'a -> max_level:'a -> bool 9 | 10 | (** Following OCaml syntax, there are five levels of infix operators *) 11 | type infix = Infix0 | Infix1 | Infix2 | Infix3 | Infix4 12 | 13 | (** The highest possible level *) 14 | val highest : t 15 | 16 | (** The least possible level *) 17 | val least : t 18 | 19 | (** The level which never gets parenthesized (equal to [least]) *) 20 | val no_parens : t 21 | 22 | (** The level of a prefix operator and its argument *) 23 | val prefix : t 24 | val prefix_arg : t 25 | 26 | (** The level of application and its left and right arguments *) 27 | val app : t 28 | val app_left : t 29 | val app_right : t 30 | 31 | (** The level of an infix operator, and its left and right arguments *) 32 | val infix : infix -> t * t * t 33 | 34 | (** The level of an equality, and its arguments *) 35 | val eq : t 36 | val eq_left : t 37 | val eq_right : t 38 | 39 | (** The level of a binder (such as lambda) and its body *) 40 | val binder : t 41 | val in_binder : t 42 | 43 | (** The elvel of an arrow and its arguments *) 44 | val arr : t 45 | val arr_left : t 46 | val arr_right : t 47 | 48 | (** The level of type ascription *) 49 | val ascription : t 50 | 51 | (** The level of a let binding *) 52 | val let_binding : t 53 | 54 | (** The level of the let-bound expression *) 55 | val let_bound : t 56 | 57 | (** The level of the body of a let-bound expression *) 58 | val let_body : t 59 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/location.ml: -------------------------------------------------------------------------------- 1 | type location = 2 | | Location of Lexing.position * Lexing.position (** delimited location *) 3 | | Nowhere (** no location *) 4 | 5 | type 'a t = { data : 'a ; loc : location } 6 | 7 | let nowhere = Nowhere 8 | 9 | let make loc1 loc2 = Location (loc1, loc2) 10 | 11 | let of_lex lex = 12 | Location (Lexing.lexeme_start_p lex, Lexing.lexeme_end_p lex) 13 | 14 | let locate ?(loc=Nowhere) x = { data = x; loc = loc } 15 | 16 | let print loc ppf = 17 | match loc with 18 | | Nowhere -> 19 | Format.fprintf ppf "unknown location" 20 | | Location (begin_pos, end_pos) -> 21 | let begin_char = begin_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 22 | let end_char = end_pos.Lexing.pos_cnum - begin_pos.Lexing.pos_bol in 23 | let begin_line = begin_pos.Lexing.pos_lnum in 24 | let filename = begin_pos.Lexing.pos_fname in 25 | 26 | if String.length filename != 0 then 27 | Format.fprintf ppf "file %S, line %d, charaters %d-%d" filename begin_line begin_char end_char 28 | else 29 | Format.fprintf ppf "line %d, characters %d-%d" (begin_line - 1) begin_char end_char 30 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/location.mli: -------------------------------------------------------------------------------- 1 | (** Source code locations. *) 2 | type location = 3 | | Location of Lexing.position * Lexing.position (** delimited location *) 4 | | Nowhere (** no location *) 5 | 6 | (** A datum tagged with a source code location *) 7 | type 'a t = private { data : 'a ; loc : location } 8 | 9 | (** Tag a datum with an (optional) location. *) 10 | val locate : ?loc:location -> 'a -> 'a t 11 | 12 | (** An unknown location, use with care. *) 13 | val nowhere : location 14 | 15 | (** Convert a [Lexing.lexbuf] location to a [location] *) 16 | val of_lex : Lexing.lexbuf -> location 17 | 18 | (** [make p1 p2] creates a location which starts at [p1] and ends at [p2]. *) 19 | val make : Lexing.position -> Lexing.position -> location 20 | 21 | (** Print a location *) 22 | val print : location -> Format.formatter -> unit 23 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/name.ml: -------------------------------------------------------------------------------- 1 | (** Names of variables. *) 2 | 3 | type fixity = 4 | | Word 5 | | Prefix 6 | | Infix of Level.infix 7 | 8 | let fixity x = 9 | let s = Bindlib.name_of x in 10 | if String.length s = 0 then 11 | Word 12 | else if String.length s > 1 && s.[0] = '*' && s.[1] = '*' then Infix Level.Infix4 13 | else 14 | match s.[0] with 15 | | '~' | '?' | '!' -> Prefix 16 | | '=' | '<' | '>' | '|' | '&' | '$' -> Infix Level.Infix0 17 | | '@' | '^' -> Infix Level.Infix1 18 | | '+' | '-' -> Infix Level.Infix2 19 | | '*' | '/' | '%' -> Infix Level.Infix3 20 | | _ -> Word 21 | 22 | let anonymous = 23 | let k = ref 0 in 24 | fun () -> (incr k ; "_" ^ string_of_int !k) 25 | 26 | let print_var ?(parentheses=true) x ppf = 27 | let s = Bindlib.name_of x in 28 | match fixity x with 29 | | Word -> Format.fprintf ppf "%s" s 30 | | Prefix | Infix _ -> 31 | if parentheses then 32 | Format.fprintf ppf "(%s)" s 33 | else 34 | Format.fprintf ppf "%s" s 35 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/name.mli: -------------------------------------------------------------------------------- 1 | (* Kinds of variable names. *) 2 | type fixity = 3 | | Word (* an ordinary word *) 4 | | Prefix (* prefix operator *) 5 | | Infix of Level.infix (* infix operator *) 6 | 7 | (* Generate a fresh name that the user cannot possibly generate *) 8 | val anonymous : unit -> string 9 | 10 | (* The fixity of a variable *) 11 | val fixity : 'a Bindlib.var -> fixity 12 | 13 | (* Print a variable name, possibly with parentheses if it is an operator. *) 14 | val print_var : ?parentheses:bool -> 'a Bindlib.var -> Format.formatter -> unit 15 | -------------------------------------------------------------------------------- /monadic-fauxtt/lib/util/print.ml: -------------------------------------------------------------------------------- 1 | (** Support for pretty-printing and user messages. *) 2 | 3 | (** Print a message with given verbosity level. *) 4 | let message ~verbosity = 5 | if verbosity <= !Config.verbosity then 6 | fun fmt -> Format.eprintf (fmt ^^ "@.") 7 | else 8 | Format.ifprintf Format.err_formatter 9 | 10 | (** Report an error. *) 11 | let error fmt = message ~verbosity:1 fmt 12 | 13 | (** Report a warning. *) 14 | let warning fmt = message ~verbosity:2 ("Warning: " ^^ fmt) 15 | 16 | (** Report debugging information. *) 17 | let debug fmt = message ~verbosity:3 ("Debug: " ^^ fmt) 18 | 19 | (** Print an expression, possibly parenthesized. *) 20 | let print ?(at_level=Level.no_parens) ?(max_level=Level.highest) ppf = 21 | if Level.parenthesize ~at_level ~max_level then 22 | fun fmt -> Format.fprintf ppf ("(" ^^ fmt ^^ ")") 23 | else 24 | Format.fprintf ppf 25 | 26 | (** Print a sequence with given separator and printer. *) 27 | let sequence print_u separator us ppf = 28 | match us with 29 | | [] -> () 30 | | [u] -> print_u u ppf 31 | | u :: ((_ :: _) as us) -> 32 | print_u u ppf ; 33 | List.iter (fun u -> print ppf "%s@ " separator ; print_u u ppf) us 34 | 35 | (** Unicode and ascii versions of symbols. *) 36 | 37 | let char_lambda () = if !Config.ascii then "lambda" else "λ" 38 | let char_arrow () = if !Config.ascii then "->" else "→" 39 | let char_darrow () = if !Config.ascii then "=>" else "⇒" 40 | let char_prod () = if !Config.ascii then "forall" else "Π" 41 | let char_forall () = if !Config.ascii then "forall" else "∀" 42 | let char_equal () = if !Config.ascii then "==" else "≡" 43 | let char_vdash () = if !Config.ascii then "|-" else "⊢" 44 | -------------------------------------------------------------------------------- /monadic-fauxtt/test/church.t/church.ftt: -------------------------------------------------------------------------------- 1 | (* Church numerals *) 2 | 3 | def numeral := ∏ (A : Type), (A → A) → (A → A) 4 | 5 | eval numeral 6 | 7 | def zero : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ x) 8 | 9 | def succ : numeral → numeral := 10 | (λ (n : numeral) (A : Type) (f : A → A) (x : A) ⇒ f (n A f x)) 11 | 12 | def one : numeral := succ zero 13 | 14 | def two : numeral := succ one 15 | 16 | def three : numeral := (λ (A : Type) (f : A → A) (x : A) ⇒ f (f (f x))) 17 | 18 | def five := succ (succ (succ (succ (succ zero)))) 19 | 20 | def ( + ) : numeral → numeral → numeral := 21 | (λ (m n : numeral) (A : Type) (f : A → A) (x : A) ⇒ m A f (n A f x)) 22 | 23 | def ( * ) : numeral → numeral → numeral := 24 | (λ (m n : numeral) (A : Type) (f : A → A) (x : A) ⇒ m A (n A f) x) 25 | 26 | def ten := five + five 27 | 28 | def hundred := ten * ten 29 | 30 | def thousand := hundred * ten 31 | 32 | (* A trick to see the numerals *) 33 | axiom N : Type 34 | axiom Z : N 35 | axiom S : N → N 36 | 37 | eval (thousand N S Z) 38 | -------------------------------------------------------------------------------- /monadic-fauxtt/test/church.t/run.t: -------------------------------------------------------------------------------- 1 | $ fauxtt church.ftt 2 | numeral is defined. 3 | Π (A : Type), Π (_3 : Π (_1 : A), A), Π (_4 : A), A 4 | : Type 5 | zero is defined. 6 | succ is defined. 7 | one is defined. 8 | two is defined. 9 | three is defined. 10 | five is defined. 11 | + is defined. 12 | * is defined. 13 | ten is defined. 14 | hundred is defined. 15 | thousand is defined. 16 | N is assumed. 17 | Z is assumed. 18 | S is assumed. 19 | S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 20 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 21 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 22 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 23 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 24 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 25 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 26 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 27 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 28 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 29 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 30 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 31 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 32 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 33 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 34 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 35 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 36 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 37 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 38 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 39 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 40 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 41 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 42 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 43 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 44 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 45 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 46 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 47 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 48 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 49 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 50 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 51 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 52 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 53 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 54 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 55 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 56 | (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S 57 | (S (S (S (S (S (S (S (S (S (S (S (S 58 | Z))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) 59 | : N 60 | -------------------------------------------------------------------------------- /monadic-fauxtt/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps %{bin:fauxtt})) 3 | -------------------------------------------------------------------------------- /monadic-fauxtt/test/syntax.t/run.t: -------------------------------------------------------------------------------- 1 | $ fauxtt syntax.ftt 2 | Type 3 | : Type 4 | Type 5 | : Type 6 | A is defined. 7 | B is assumed. 8 | λ (A : Type), A 9 | : Π (A : Type), Type 10 | λ (A : Type), λ (B : Type), λ (C : Type), A 11 | : Π (A : Type), Π (B : Type), Π (C : Type), Type 12 | λ (A : Type), λ (B : Type), λ (C : Type), λ (x : B), λ (y : B), x 13 | : Π (A : Type), Π (B : Type), Π (C : Type), Π (x : B), Π (y : B), B 14 | λ (A : Type), A 15 | : Π (A : Type), Type 16 | λ (A : Type), λ (B : Type), λ (C : Type), A 17 | : Π (A : Type), Π (B : Type), Π (C : Type), Type 18 | λ (x : B), λ (y : B), λ (z : B), y 19 | : Π (_3 : B), Π (_4 : B), Π (_5 : B), B 20 | λ (A : Type), λ (B : Type), λ (C : Type), λ (x : B), λ (y : B), x 21 | : Π (A : Type), Π (B : Type), Π (C : Type), Π (x : B), Π (y : B), B 22 | id is defined. 23 | λ (S : Type), λ (c : S), λ (T : Π (_4 : S), Type), λ (u : T c), let x := 24 | id S c in u 25 | : Π (S : Type), Π (c : S), Π (T : Π (_4 : S), Type), 26 | Π (u : T c), T (id S (id S c)) 27 | -------------------------------------------------------------------------------- /monadic-fauxtt/test/syntax.t/syntax.ftt: -------------------------------------------------------------------------------- 1 | (* Every bit of syntax should appear in this file. *) 2 | 3 | infer Type 4 | 5 | eval Type 6 | 7 | def A := Type 8 | 9 | axiom B : A 10 | 11 | (* Functions *) 12 | 13 | infer fun (A : Type) => A 14 | 15 | infer fun (A B C : Type) => A 16 | 17 | infer fun (A B C : Type) (x y : B) => x 18 | 19 | infer λ (A : Type) ⇒ A 20 | 21 | infer λ (A B C : Type) ⇒ A 22 | 23 | infer (λ x y z ⇒ y) : B → B → B → B 24 | 25 | infer λ (A B C : Type) (x y : B) ⇒ x 26 | 27 | (* Let statement *) 28 | 29 | def id := fun (A : Type) (x : A) => x 30 | 31 | infer λ (S : Type) (c : S) (T : S → Type) (u : T c) ⇒ let x := id S c in (u : T (id S x)) 32 | -------------------------------------------------------------------------------- /slides/PL-for-PA-lecture-1-handout.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrejbauer/faux-type-theory/b033df385dcf9f48a775c7459b11dc0737f61c7a/slides/PL-for-PA-lecture-1-handout.pdf -------------------------------------------------------------------------------- /slides/PL-for-PA-lecture-2-handout.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrejbauer/faux-type-theory/b033df385dcf9f48a775c7459b11dc0737f61c7a/slides/PL-for-PA-lecture-2-handout.pdf -------------------------------------------------------------------------------- /slides/PL-for-PA-lecture-3-handout.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrejbauer/faux-type-theory/b033df385dcf9f48a775c7459b11dc0737f61c7a/slides/PL-for-PA-lecture-3-handout.pdf -------------------------------------------------------------------------------- /slides/PL-for-PA-lecture-4-handout.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrejbauer/faux-type-theory/b033df385dcf9f48a775c7459b11dc0737f61c7a/slides/PL-for-PA-lecture-4-handout.pdf -------------------------------------------------------------------------------- /slides/writeOnce.ml: -------------------------------------------------------------------------------- 1 | open Effect 2 | open Effect.Deep 3 | 4 | type _ Effect.t += 5 | | Get : unit -> int Effect.t 6 | | Put : int -> unit Effect.t 7 | 8 | let get () = perform (Get ()) 9 | let put s = perform (Put s) 10 | 11 | type mode = Initial | Modified 12 | 13 | exception InvalidWrite 14 | 15 | let with_state (s : int) c = 16 | let r = ref (Initial, s) in 17 | try 18 | c () 19 | with 20 | | effect (Get ()), k -> continue k (snd !r) 21 | | effect (Put s), k -> 22 | (match !r with 23 | | (Initial, _) -> r := (Modified, s) ; continue k () 24 | | (Modified, _) -> raise InvalidWrite) 25 | 26 | let eightyeight = 27 | with_state 42 28 | (fun _ -> 29 | let a = get () in 30 | put (a + 4) ; 31 | a + get ()) 32 | 33 | let writeTwice = 34 | with_state 42 35 | (fun _ -> 36 | let a = get () in 37 | put (a + 4) ; 38 | if a * a > 666 then put 10 ; 39 | a + get ()) 40 | --------------------------------------------------------------------------------