├── test ├── dune └── syntax.t │ ├── syntax.stt │ └── run.t ├── _tags ├── lib ├── util │ ├── dune │ ├── config.ml │ ├── name.mli │ ├── location.mli │ ├── config.mli │ ├── level.ml │ ├── name.ml │ ├── location.ml │ ├── print.ml │ └── level.mli ├── core │ ├── dune │ ├── equal.mli │ ├── print.mli │ ├── norm.mli │ ├── toplevel.ml │ ├── toplevel.mli │ ├── typecheck.mli │ ├── norm.ml │ ├── context.mli │ ├── TT.mli │ ├── TT.ml │ ├── context.ml │ ├── equal.ml │ ├── print.ml │ └── typecheck.ml └── parsing │ ├── dune │ ├── syntax.mli │ ├── ulexbuf.mli │ ├── syntax.ml │ ├── ulexbuf.ml │ ├── parser.mly │ └── lexer.ml ├── .gitignore ├── bin ├── dune └── spartan.ml ├── examples ├── funext.stt └── numerals.stt ├── dune-project ├── LICENSE.md ├── spartan-type-theory.opam └── README.md /test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps %{bin:spartan})) 3 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: bin_annot 2 | : include 3 | 4 | -------------------------------------------------------------------------------- /lib/util/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name util) 3 | (libraries bindlib)) 4 | 5 | -------------------------------------------------------------------------------- /lib/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name core) 3 | (libraries bindlib util parsing)) 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | /spartan.native 3 | /spartan.byte 4 | /spartan.docdir 5 | /spartan.exe 6 | -------------------------------------------------------------------------------- /lib/parsing/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parsing) 3 | (libraries sedlex menhirLib util) 4 | (preprocess (pps sedlex.ppx))) 5 | 6 | (menhir 7 | (modules parser)) -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name "spartan") 3 | (public_name "spartan") 4 | (modules spartan) 5 | (promote (until-clean) (into ..)) 6 | (libraries parsing core unix)) 7 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /lib/core/norm.mli: -------------------------------------------------------------------------------- 1 | type strategy = WHNF | CBV 2 | 3 | (** Normalize a term *) 4 | val norm_tm : strategy:strategy -> TT.tm -> TT.tm Context.m 5 | 6 | (** Normalize a type *) 7 | val norm_ty : strategy:strategy -> TT.ty -> TT.ty Context.m 8 | 9 | (** Convert a type to a product *) 10 | val as_prod : TT.ty -> (TT.ty * TT.ty TT.binder) option Context.m 11 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /examples/funext.stt: -------------------------------------------------------------------------------- 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 | check u : P f 15 | 16 | check u : P (id (A → A) f) 17 | 18 | check u : P (compose A A A (id A) f) 19 | 20 | 21 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /test/syntax.t/syntax.stt: -------------------------------------------------------------------------------- 1 | (* Every bit of syntax should appear in this file. *) 2 | 3 | check Type 4 | 5 | eval Type 6 | 7 | def A := Type 8 | 9 | axiom B : A 10 | 11 | (* Functions *) 12 | 13 | check fun (A : Type) => A 14 | 15 | check fun (A B C : Type) => A 16 | 17 | check fun (A B C : Type) (x y : B) => x 18 | 19 | check λ (A : Type) ⇒ A 20 | 21 | check λ (A B C : Type) ⇒ A 22 | 23 | check (λ x y z ⇒ y) : B → B → B → B 24 | 25 | check λ (A B C : Type) (x y : B) ⇒ x 26 | 27 | (* Let statement *) 28 | 29 | def id := fun (A : Type) (x : A) => x 30 | 31 | check λ (S : Type) (c : S) (T : S → Type) (u : T c) ⇒ let x := id S c in (u : T (id S x)) 32 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | (name "spartan-type-theory") 3 | (version 2.0) 4 | (using menhir 2.0) 5 | (cram enable) 6 | 7 | (authors "Andrej Bauer ") 8 | (maintainers "Andrej Bauer ") 9 | (source (github andrejbauer/spartan-type-theory)) 10 | (license "MIT") 11 | 12 | (generate_opam_files true) 13 | 14 | (package 15 | (name spartan-type-theory) 16 | (synopsis "A minimalistic implementation of dependent 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 (>= 4.07.0)) 24 | (dune :build) 25 | (menhir :build) 26 | (menhirLib :build) 27 | (sedlex :build) 28 | (bindlib (and (>= 6.0) :build)) 29 | (odoc :with-doc))) -------------------------------------------------------------------------------- /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 type (equal to tmession). *) 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 * tm 24 | | TopCheck 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 | -------------------------------------------------------------------------------- /lib/util/config.mli: -------------------------------------------------------------------------------- 1 | (** Configuration parameters that control how Spartan 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /examples/numerals.stt: -------------------------------------------------------------------------------- 1 | (* Church numerals *) 2 | 3 | def numeral := ∏ (A : Type), (A → A) → (A → A) 4 | 5 | eval numeral 6 | 7 | def zero := (λ (A : Type) (f : A → A) (x : A) ⇒ x) : numeral 8 | 9 | def succ := 10 | (λ (n : numeral) (A : Type) (f : A → A) (x : A) ⇒ f (n A f x)) : numeral → numeral 11 | 12 | def one := succ zero : numeral 13 | 14 | def two := succ one : numeral 15 | 16 | def three := (λ (A : Type) (f : A → A) (x : A) ⇒ f (f (f x))) : numeral 17 | 18 | def five := succ (succ (succ (succ (succ zero)))) 19 | 20 | def ( + ) := 21 | (λ (m n : numeral) (A : Type) (f : A → A) (x : A) ⇒ m A f (n A f x)) 22 | : numeral → numeral → numeral 23 | 24 | def ( * ) := 25 | (λ (m n : numeral) (A : Type) (f : A → A) (x : A) ⇒ m A (n A f) x) 26 | : numeral → numeral → numeral 27 | 28 | def ten := five + five 29 | 30 | def hundred := ten * ten 31 | 32 | def thousand := hundred * ten 33 | 34 | (* A trick to see the numerals *) 35 | axiom N : Type 36 | axiom Z : N 37 | axiom S : N → N 38 | 39 | eval (thousand N S Z) 40 | -------------------------------------------------------------------------------- /test/syntax.t/run.t: -------------------------------------------------------------------------------- 1 | $ spartan syntax.stt 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 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 | -------------------------------------------------------------------------------- /spartan-type-theory.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "2.0" 4 | synopsis: "A minimalistic implementation of dependent type theory" 5 | description: """ 6 | This project shows how to implement a minimalist type theory, 7 | which nevertheless could serve as a basis for a serious interpretation.""" 8 | maintainer: ["Andrej Bauer "] 9 | authors: ["Andrej Bauer "] 10 | license: "MIT" 11 | homepage: "https://github.com/andrejbauer/spartan-type-theory" 12 | bug-reports: "https://github.com/andrejbauer/spartan-type-theory/issues" 13 | depends: [ 14 | "ocaml" {>= "4.07.0"} 15 | "dune" {>= "3.6" & build} 16 | "menhir" {build} 17 | "menhirLib" {build} 18 | "sedlex" {build} 19 | "bindlib" {>= "6.0" & build} 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/andrejbauer/spartan-type-theory.git" 37 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 * tm 21 | | TopCheck 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 | -------------------------------------------------------------------------------- /lib/core/norm.ml: -------------------------------------------------------------------------------- 1 | (** A normalization strategy. *) 2 | type strategy = 3 | | WHNF (** normalize to weak head-normal form *) 4 | | CBV (** call-by-value normalization *) 5 | 6 | open Context.Monad 7 | 8 | (** Normalize an expression. *) 9 | let rec norm_tm ~strategy e = 10 | match e with 11 | 12 | | TT.Type -> 13 | return e 14 | 15 | | TT.Var x -> 16 | begin 17 | Context.lookup_var x >>= function 18 | | (None, _) -> return e 19 | | (Some e, _) -> norm_tm ~strategy e 20 | end 21 | 22 | | TT.Let (e1, t, e2) -> 23 | let* e1 = 24 | match strategy with 25 | | WHNF -> return e1 26 | | CBV -> norm_tm ~strategy e1 27 | in 28 | let (v, e2) = TT.unbind e2 in 29 | Context.with_var v ~def:e1 t (norm_tm ~strategy e2) 30 | 31 | | TT.Prod _ -> 32 | return e 33 | 34 | | TT.Lambda _ -> 35 | return e 36 | 37 | | TT.Apply (e1, e2) -> 38 | let* e1 = norm_tm ~strategy e1 in 39 | let* e2 = 40 | begin 41 | match strategy with 42 | | WHNF -> return e2 43 | | CBV -> norm_tm ~strategy e2 44 | end 45 | in 46 | begin 47 | match e1 with 48 | | TT.Lambda (_, e') -> 49 | norm_tm ~strategy (Bindlib.subst e' e2) 50 | | _ -> 51 | return @@ TT.Apply (e1, e2) 52 | end 53 | 54 | (** Normalize a type *) 55 | let norm_ty ~strategy (TT.Ty ty) = 56 | let* ty = norm_tm ~strategy ty in 57 | return @@ TT.Ty ty 58 | 59 | (** Normalize a type to a product. *) 60 | let as_prod t = 61 | let* TT.Ty t' = norm_ty ~strategy:WHNF t in 62 | match t' with 63 | | TT.Prod (t, u) -> return @@ Some (t, u) 64 | | _ -> return None 65 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 list of identifiers which should not be used for printing bound variables. *) 30 | val penv : t -> Bindlib.ctxt 31 | 32 | (* Lookup the type and value of the given variable *) 33 | val lookup_var : TT.var -> (TT.tm option * TT.ty) m 34 | 35 | (* Lookup the information associated with a variable *) 36 | val lookup_var_ : TT.var -> (TT.tm_ option * TT.ty_) m 37 | 38 | val lookup_ident : string -> TT.var option m 39 | 40 | (** Run a computation in a context extended with a variable, passing it the newly 41 | created variable. It is the callers responsibility that the result be valid in 42 | the original context. *) 43 | (* val with_var_ : string -> TT.ty_ -> ?def:TT.tm_ -> (TT.var -> 'a m) -> 'a m *) 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /lib/core/TT.mli: -------------------------------------------------------------------------------- 1 | (** The spartan type theory core *) 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 | (** Variagble *) 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /lib/core/TT.ml: -------------------------------------------------------------------------------- 1 | (* Spartan 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 | -------------------------------------------------------------------------------- /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 is a list of known identifiers and definitional equalities. *) 14 | type t = 15 | { idents : TT.var IdentMap.t 16 | ; vars : (TT.tm option * TT.ty) VarMap.t 17 | } 18 | 19 | type 'a m = t -> 'a 20 | 21 | module Monad = 22 | struct 23 | let ( let* ) c1 c2 (ctx : t) = 24 | let v1 = c1 ctx in 25 | c2 v1 ctx 26 | 27 | let ( >>= ) = ( let* ) 28 | 29 | let return v (_ : t) = v 30 | end 31 | 32 | (** The initial, empty typing context. *) 33 | let initial = 34 | { idents = IdentMap.empty 35 | ; vars = VarMap.empty 36 | } 37 | 38 | let run ctx c = c ctx 39 | 40 | let penv _ = Bindlib.empty_ctxt 41 | 42 | let extend_var_ x v ?def_ ty_ {idents;vars} = 43 | let ty = Bindlib.unbox ty_ 44 | and def = Option.map Bindlib.unbox def_ in 45 | { idents = IdentMap.add x v idents 46 | ; vars = VarMap.add v (def, ty) vars 47 | } 48 | 49 | let extend_var x v ?def ty {idents; vars} = 50 | { idents = IdentMap.add x v idents 51 | ; vars = VarMap.add v (def, ty) vars 52 | } 53 | 54 | let extend x ?def ty ctx = 55 | let v = TT.fresh_var x in 56 | v, extend_var x v ?def ty ctx 57 | 58 | let lookup_ident x {idents; _} = IdentMap.find_opt x idents 59 | 60 | let lookup_var v {vars; _} = VarMap.find v vars 61 | 62 | let lookup_var_ v {vars; _} = 63 | let (def, t) = VarMap.find v vars in 64 | (Option.map TT.lift_tm def, TT.lift_ty t) 65 | 66 | let with_var v ?def t (c : 'a m) ctx = 67 | let x = Bindlib.name_of v in 68 | let local_ctx = extend_var x v ?def t ctx in 69 | c local_ctx 70 | 71 | let with_ident_ x ?def ty (c : TT.var -> 'a m) ctx = 72 | let v = TT.fresh_var x in 73 | let local_ctx = extend_var_ x v ?def_:def ty ctx in 74 | c v local_ctx 75 | 76 | let with_ident x ?def ty (c : TT.var -> 'a m) ctx = 77 | let v, local_ctx = extend x ?def ty ctx in 78 | c v local_ctx 79 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # An implementation of spartan type theory (**obsolete**) 2 | 3 | **NOTE: This repository has been superseded by [Faux type theory](https://github.com/andrejbauer/faux-type-theory).** 4 | 5 | This repository shows how to implement a minimalist type theory of the kind that is sometimes 6 | called “spartan”. The version shown here is an updated version of the one presented at the 7 | [School and Workshop on Univalent Mathematics](https://unimath.github.io/bham2017/) which took 8 | place at the University of Birmingham in December 2017. 9 | 10 | ## The type theory 11 | 12 | The dependent type theory `spartan` has the following ingridients: 13 | 14 | * A universe `Type` with `Type : Type`. 15 | * Dependent products, written as `forall (x : T₁), T₂` or `∀ (x : T₁), T₂` or `∏ (x : T₁), T₂`. 16 | * Functions, written as one of `fun (x : T) => e` or `λ (x : T) ⇒ e`. The typing annotation may 17 | be omitted, i.e., `fun x => e`, and multiple abstractions may be shortened as 18 | `λ x y (z u : T) (w : U) ⇒ e`. 19 | * Application `e₁ e₂`. 20 | * Type ascription written as `e : T`. 21 | 22 | Top-level commands: 23 | 24 | * `Definition x := e.` -- define a value 25 | * `Axiom x : T.` -- assume a constant `x` of type `T` 26 | * `Check e.` -- print the type of `e` 27 | * `Eval e.` -- evaluate `e` a la call-by-value 28 | * `Load "⟨file⟩".` -- load a file 29 | 30 | ## Prerequisites 31 | 32 | * [OCaml](https://ocaml.org) and [OPAM](https://opam.ocaml.org) 33 | 34 | * The OPAM packages `dune`, `menhir`, `mehirLib`, `sedlex` and `bindlib`: 35 | 36 | opam install dune menhir menihirLib sedlex bindlib 37 | 38 | * It is recommended that you also install the `rlwrap` or `ledit` command line wrapper. 39 | 40 | ## Compilation 41 | 42 | You can type: 43 | 44 | * `dune build` to compile the `spartan.exe` executable. 45 | * `dune clean` to clean up. 46 | 47 | ## Usage 48 | 49 | Once you compile the program, you can run it in interactive mode as `./spartan.exe` 50 | 51 | Run `./spartan.exe --help` to see the command-line options and general usage. 52 | 53 | 54 | ## Source code 55 | 56 | The purpose of the implementation is to keep the source uncomplicated and short. The 57 | essential bits of source code can be found in the following files. It should be possible 58 | for you to just read the entire source code. 59 | 60 | It is best to first familiarize yourself with the core: 61 | 62 | * [`lib/core/TT.ml`](./lib/core/TT.ml) – the core type theory 63 | * [`lib/core/context.ml`](./lib/core/context.ml) – typing context 64 | * [`lib/core/typecheck.ml`](./lib/coretypecheck.ml) – type checking and elaboration 65 | * [`lib/core/norm.ml`](./lib/core/norm.ml) – normalization 66 | * [`lib/core/equal.ml`](./lib/core/equal.ml) – equality and normalization 67 | * [`lib/core/toplevel.ml`](./lib/core/toplevel.ml) – top-level commands 68 | 69 | Continue with the infrastructure: 70 | 71 | * [`lib/parsing/syntax.ml`](./lib/parsing/syntax.ml) – abstract syntax of the input code 72 | * [`lib/parsing/lexer.ml`](./lib/parsing/lexer.ml) – the lexer 73 | * [`lib/parsing/parser.mly`](./lib/parsing/parser.mly) – the parser 74 | * [`lib/util`](./lib/util) – various utilities 75 | * [`bin/spartan.ml`](bin/spartan.ml) – the main executable 76 | 77 | -------------------------------------------------------------------------------- /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* TT.Ty ty' = Norm.norm_ty ~strategy:WHNF ty in 22 | match ty' with 23 | 24 | | TT.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 | | TT.(Var _ | Type | Apply _) -> 33 | (* Type-directed phase is done, we compare normal forms. *) 34 | equal_tm e1 e2 35 | 36 | | TT.(Lambda _ | Let _) -> 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 ~strategy:Norm.WHNF e1 in 44 | let* e2 = Norm.norm_tm ~strategy:Norm.WHNF e2 in 45 | match e1, e2 with 46 | 47 | | TT.Type, TT.Type -> 48 | return true 49 | 50 | | TT.Prod (t1, u1), TT.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 | | TT.Lambda _, TT.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 | | TT.Let _, _ | _, TT.Let _ -> 63 | assert false 64 | 65 | | TT.(Var _ | Apply _), TT.(Var _ | Apply _) -> 66 | begin 67 | equal_neutral e1 e2 >>= function 68 | | None -> return false 69 | | Some _ -> return true 70 | end 71 | 72 | | TT.(Var _ | Type | Prod _ | Lambda _ | Apply _), _ -> 73 | return false 74 | 75 | and equal_neutral e1 e2 = 76 | match e1, e2 with 77 | 78 | | TT.Var x, TT.Var y -> 79 | if Bindlib.eq_vars x y then 80 | let* (_, t) = Context.lookup_var x in 81 | return (Some t) 82 | else 83 | return None 84 | 85 | | TT.Apply (e1, e1'), TT.Apply (e2, e2') -> 86 | begin 87 | equal_neutral e1 e2 >>= function 88 | | None -> return None 89 | | Some t -> 90 | begin 91 | Norm.as_prod t >>= function 92 | | None -> return None 93 | | Some (t, u) -> 94 | begin 95 | equal_tm_at e1' e2' t >>= function 96 | | false -> return None 97 | | true -> return @@ Some (Bindlib.subst u e1') 98 | end 99 | 100 | end 101 | end 102 | 103 | | TT.(Var _ | Apply _), _ 104 | | _, TT.(Var _ | Apply _) -> 105 | return None 106 | 107 | | TT.(Type | Prod _ | Lambda _ | Let _), _ -> 108 | assert false 109 | 110 | (** Compare two types. *) 111 | and equal_ty (TT.Ty ty1) (TT.Ty ty2) = 112 | equal_tm_at ty1 ty2 TT.(Ty Type) 113 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 CHECK 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, e) } 75 | 76 | | CHECK e=term 77 | { Syntax.TopCheck e } 78 | 79 | | EVAL e=term 80 | { Syntax.TopEval e } 81 | 82 | | AXIOM x=var_name COLON e=term 83 | { Syntax.TopAxiom (x, e) } 84 | 85 | 86 | term : mark_location(term_) { $1 } 87 | term_: 88 | | e=infix_term_ 89 | { e } 90 | 91 | | PROD a=prod_abstraction COMMA e=term 92 | { Syntax.prod a e } 93 | 94 | | e1=infix_term ARROW e2=term 95 | { Syntax.arrow e1 e2 } 96 | 97 | | LAMBDA a=lambda_abstraction DARROW e=term 98 | { Syntax.lambda a e } 99 | 100 | | LET x=var_name COLONEQ e1=term IN e2=term 101 | { Syntax.Let (x, e1, e2) } 102 | 103 | | e=infix_term COLON t=term 104 | { Syntax.Ascribe (e, t) } 105 | 106 | 107 | infix_term: mark_location(infix_term_) { $1 } 108 | infix_term_: 109 | | e=app_term_ 110 | { e } 111 | 112 | | e2=infix_term oploc=infix e3=infix_term 113 | { let {Location.data=op; loc} = oploc in 114 | let op = Location.locate ~loc (Syntax.Var op) in 115 | let e1 = Location.locate ~loc (Syntax.Apply (op, e2)) in 116 | Syntax.Apply (e1, e3) 117 | } 118 | 119 | 120 | app_term: mark_location(app_term_) { $1 } 121 | app_term_: 122 | | e=prefix_term_ 123 | { e } 124 | 125 | | e1=app_term e2=prefix_term 126 | { Syntax.Apply (e1, e2) } 127 | 128 | 129 | prefix_term: mark_location(prefix_term_) { $1 } 130 | prefix_term_: 131 | | e=simple_term_ 132 | { e } 133 | 134 | | oploc=prefix e2=prefix_term 135 | { let {Location.data=op; loc} = oploc in 136 | let op = Location.locate ~loc (Syntax.Var op) in 137 | Syntax.Apply (op, e2) 138 | } 139 | 140 | 141 | (* simple_term : mark_location(simple_term_) { $1 } *) 142 | simple_term_: 143 | | LPAREN e=term_ RPAREN 144 | { e } 145 | 146 | | TYPE 147 | { Syntax.Type } 148 | 149 | | x=var_name 150 | { Syntax.Var x } 151 | 152 | 153 | var_name: 154 | | NAME 155 | { $1 } 156 | 157 | | LPAREN op=infix RPAREN 158 | { op.Location.data } 159 | 160 | | LPAREN op=prefix RPAREN 161 | { op.Location.data } 162 | 163 | | UNDERSCORE 164 | { Name.anonymous () } 165 | 166 | 167 | %inline infix: 168 | | op=INFIXOP0 169 | { op } 170 | 171 | | op=INFIXOP1 172 | { op } 173 | 174 | | op=INFIXOP2 175 | { op } 176 | 177 | | op=INFIXOP3 178 | { op } 179 | 180 | | op=INFIXOP4 181 | { op } 182 | 183 | 184 | %inline prefix: 185 | | op=PREFIXOP 186 | { op } 187 | 188 | lambda_abstraction: 189 | | lst=nonempty_list(binder) 190 | { lst } 191 | 192 | prod_abstraction: 193 | | lst=nonempty_list(typed_binder) 194 | { lst } 195 | 196 | typed_binder: mark_location(typed_binder_) { $1 } 197 | typed_binder_: 198 | | LPAREN xs=nonempty_list(var_name) COLON t=term RPAREN 199 | { (xs, t) } 200 | 201 | binder: mark_location(binder_) { $1 } 202 | binder_: 203 | | LPAREN xs=nonempty_list(var_name) COLON t=term RPAREN 204 | { (xs, Some t) } 205 | 206 | | x=var_name 207 | { ([x], None) } 208 | 209 | 210 | mark_location(X): 211 | | x=X 212 | { Location.locate ~loc:(Location.make $startpos $endpos) x } 213 | 214 | %% 215 | -------------------------------------------------------------------------------- /bin/spartan.ml: -------------------------------------------------------------------------------- 1 | (** The main executable. *) 2 | 3 | open Util 4 | 5 | (** The usage message. *) 6 | let usage = "Usage: spartan [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 "Spartan type theory@." ; 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 | -------------------------------------------------------------------------------- /lib/core/typecheck.ml: -------------------------------------------------------------------------------- 1 | (** Spartan type checking. *) 2 | 3 | module ISyntax = 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 | | ISyntax.Var x -> 50 | begin 51 | Context.lookup_ident x >>= function 52 | | None -> error ~loc (UnknownIdent x) 53 | | Some v -> 54 | let* (_, t) = Context.lookup_var_ v in 55 | return (TT.var_ v, t) 56 | end 57 | 58 | | ISyntax.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 | | ISyntax.Type -> 67 | return TT.(type_, ty_type_) 68 | 69 | | ISyntax.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 | | ISyntax.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 | | ISyntax.Lambda ((x, None), _) -> 84 | error ~loc (CannotInferArgument x) 85 | 86 | | ISyntax.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 | | ISyntax.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 | (** [check ctx e ty] checks that [e] has type [ty] in context [ctx]. 104 | It returns the processed expression [e]. *) 105 | and check_ ({Location.data=e'; loc} as e) (ty : TT.ty) : TT.tm_ Context.m = 106 | match e' with 107 | 108 | | ISyntax.Lambda ((x, None), e) -> 109 | begin 110 | Norm.as_prod ty >>= function 111 | | None -> error ~loc (TypeExpectedButFunction ty) 112 | | Some (t, u) -> 113 | Context.with_ident x t 114 | (fun v -> 115 | let u' = Bindlib.subst u (TT.Var v) in 116 | let* e = check_ e u' in 117 | return TT.(lambda_ (TT.lift_ty t) (bind_var v e))) 118 | end 119 | 120 | | ISyntax.Let (x, e1, e2) -> 121 | let* (e1, t1) = infer_ e1 in 122 | Context.with_ident_ x ~def:e1 t1 123 | (fun v -> 124 | let* e2 = check_ e2 ty in 125 | return TT.(let_ e1 t1 (bind_var v e2))) 126 | 127 | | ISyntax.Lambda ((_, Some _), _) 128 | | ISyntax.Apply _ 129 | | ISyntax.Prod _ 130 | | ISyntax.Var _ 131 | | ISyntax.Type 132 | | ISyntax.Ascribe _ -> 133 | begin 134 | let* (e, ty'_) = infer_ e in 135 | let ty' = TT.unbox ty'_ in 136 | Equal.equal_ty ty ty' >>= function 137 | | true -> return e 138 | | false -> error ~loc (TypeExpected (ty, ty')) 139 | end 140 | 141 | 142 | (** [check_ty ctx t] checks that [t] is a type in context [ctx]. It returns the processed 143 | type [t]. *) 144 | and check_ty_ t = 145 | let* t = check_ t TT.(Ty Type) in 146 | return (TT.ty_ t) 147 | 148 | let infer e = 149 | let* (e_, t_) = infer_ e in 150 | return (TT.unbox e_, TT.unbox t_) 151 | 152 | let check_ty t = 153 | let* t_ = check_ty_ t in 154 | return (TT.unbox t_) 155 | 156 | let rec toplevel ~quiet ctx {Location.data=tc; _} = 157 | let ctx = toplevel' ~quiet ctx tc in 158 | ctx 159 | 160 | and toplevel' ~quiet ctx = function 161 | 162 | | ISyntax.TopLoad file -> 163 | topfile ~quiet ctx file 164 | 165 | | ISyntax.TopDefinition (x, e) -> 166 | let e, ty = Context.run ctx (infer e) in 167 | let _, ctx = Context.extend x ~def:e ty ctx in 168 | if not quiet then Format.printf "%s is defined.@." x ; 169 | ctx 170 | 171 | | ISyntax.TopCheck e -> 172 | let e, ty = Context.run ctx (infer e) in 173 | Format.printf "@[%t@]@\n : @[%t@]@." 174 | (Print.tm ~penv:(Context.penv ctx) e) 175 | (Print.ty ~penv:(Context.penv ctx) ty) ; 176 | ctx 177 | 178 | | ISyntax.TopEval e -> 179 | let e, ty = Context.run ctx (infer e) in 180 | let e = Context.run ctx (Norm.norm_tm ~strategy:Norm.CBV e) in 181 | Format.printf "@[%t@]@\n : @[%t@]@." 182 | (Print.tm ~penv:(Context.penv ctx) e) 183 | (Print.ty ~penv:(Context.penv ctx) ty) ; 184 | ctx 185 | 186 | | ISyntax.TopAxiom (x, ty) -> 187 | let ty = Context.run ctx (check_ty ty) in 188 | let _, ctx = Context.extend x ty ctx in 189 | if not quiet then Format.printf "%s is assumed.@." x ; 190 | ctx 191 | 192 | and topfile ~quiet ctx file = 193 | let rec fold ctx = function 194 | | [] -> ctx 195 | | top_cmd :: lst -> 196 | let ctx = toplevel ~quiet ctx top_cmd in 197 | fold ctx lst 198 | in 199 | let cmds = Parsing.Lexer.read_file Parsing.Parser.file file in 200 | fold ctx cmds 201 | -------------------------------------------------------------------------------- /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 | ("check", Parser.CHECK) ; 9 | ("def", Parser.DEF) ; 10 | ("eval", Parser.EVAL) ; 11 | ("fun", Parser.LAMBDA) ; 12 | ("λ", Parser.LAMBDA) ; 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 | --------------------------------------------------------------------------------