├── dune-project ├── src ├── lib │ ├── mode_theory.mli │ ├── guarded_mode_theory.mli │ ├── load.mli │ ├── concrete_mode_theory.ml │ ├── dune │ ├── driver.mli │ ├── mode_theory.ml │ ├── load.ml │ ├── check.mli │ ├── domain.mli │ ├── syntax.mli │ ├── nbe.mli │ ├── abstract_mode_theory.mli │ ├── concrete_syntax.ml │ ├── concrete_syntax.mli │ ├── domain.ml │ ├── lex.mll │ ├── grammar.mly │ ├── guarded_mode_theory.ml │ ├── syntax.ml │ ├── driver.ml │ ├── guarded_mode_theory1.ml │ ├── check.ml │ └── nbe.ml └── bin │ ├── dune │ └── main.ml ├── Makefile ├── test ├── eta.tt ├── example.tt ├── fib.tt ├── eq.tt └── guarded_rec.tt ├── mitten.opam ├── normalize_lib.opam ├── LICENSE ├── README.md └── .gitignore /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (using menhir 2.0) 3 | -------------------------------------------------------------------------------- /src/lib/mode_theory.mli: -------------------------------------------------------------------------------- 1 | include Abstract_mode_theory.S 2 | -------------------------------------------------------------------------------- /src/lib/guarded_mode_theory.mli: -------------------------------------------------------------------------------- 1 | include Abstract_mode_theory.S 2 | -------------------------------------------------------------------------------- /src/lib/load.mli: -------------------------------------------------------------------------------- 1 | exception Parse_error of string 2 | val load_file : string -> Concrete_syntax.signature 3 | -------------------------------------------------------------------------------- /src/bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names main) 3 | (libraries normalize_lib cmdliner)) 4 | 5 | (install 6 | (section bin) 7 | (package mitten) 8 | (files (main.exe as mitten))) 9 | -------------------------------------------------------------------------------- /src/lib/concrete_mode_theory.ml: -------------------------------------------------------------------------------- 1 | type mode = String 2 | 3 | type m = String 4 | 5 | type cell = 6 | | Atom of string 7 | | HComp of cell * cell 8 | | VComp of cell * cell 9 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OPAM=opam 2 | EXEC=${OPAM} config exec 3 | DUNE=${EXEC} dune -- 4 | 5 | .PHONY: all build clean test top 6 | 7 | all: build 8 | 9 | build: 10 | @${DUNE} build @install 11 | 12 | clean: 13 | @${DUNE} clean 14 | 15 | doc: 16 | @${DUNE} build @doc 17 | -------------------------------------------------------------------------------- /src/lib/dune: -------------------------------------------------------------------------------- 1 | (menhir 2 | (flags --explain --table) 3 | (modules grammar)) 4 | 5 | (ocamllex lex) 6 | 7 | (library 8 | (name Normalizer) 9 | (libraries sexplib menhirLib) 10 | (flags (:standard -w -9-32-37)) 11 | (modules_without_implementation abstract_mode_theory) 12 | (public_name normalize_lib)) 13 | -------------------------------------------------------------------------------- /src/lib/driver.mli: -------------------------------------------------------------------------------- 1 | type env 2 | 3 | type output = 4 | NoOutput of env 5 | | NF_term of Syntax.t * Syntax.t 6 | | NF_def of Concrete_syntax.ident * Syntax.t 7 | | Quit 8 | 9 | val output : env -> output -> unit 10 | val update_env : env -> output -> env 11 | 12 | val process_sign : ?env:env -> Concrete_syntax.signature -> unit 13 | -------------------------------------------------------------------------------- /test/eta.tt: -------------------------------------------------------------------------------- 1 | let idfun : (A : U<0>) -> (B : U<0>) -> (A -> B) -> (A -> B) @ s = 2 | fun A -> fun B -> fun x -> x 3 | 4 | normalize def idfun 5 | 6 | let idpair : (A : U<0>) -> (B : U<0>) -> (A * B) -> (A * B) @ s= 7 | fun A -> fun B -> fun x -> x 8 | 9 | normalize def idpair 10 | 11 | normalize (fun A -> fun x -> x) at (A : U<0>) -> A -> A @ s 12 | -------------------------------------------------------------------------------- /test/example.tt: -------------------------------------------------------------------------------- 1 | ;; ------------------- Modal elimination tests ---------------------- 2 | let triv : (A : U<0>) -> (x : A) -> <> @ S = 3 | fun A -> fun x -> mod idm x 4 | 5 | ;; -------------- The next function for the later modality, next1 is defined over the universe ----------- 6 | let next : (A : U<0>) -> A -> << l | A >> @ T = 7 | fun A -> fun x -> mod l x 8 | 9 | normalize next Nat 2 at << l | Nat >> @ T 10 | -------------------------------------------------------------------------------- /src/lib/mode_theory.ml: -------------------------------------------------------------------------------- 1 | (* include the mode theory that you plan to use here and recompile. Options are 2 | 1. Guarded_mode_theory – for guarded recursion 3 | 1a. Guarded_mode_theory1 – for guarded recursion with clean NBE algorighm 4 | 2. Minimal_mode_theory – for the test mode theory with one mode, one non trivial modality, and no non trivial 2-cell 5 | 3. Adj_mode_theory – for the walking adjunction mode theory *) 6 | include Guarded_mode_theory1 7 | -------------------------------------------------------------------------------- /mitten.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "mitten" 3 | version: "0.0" 4 | maintainer: "stassen@cs.au.dk" 5 | authors: ["Philipp Stassen" "Daniel Gratzer"] 6 | homepage: "https://github.com/logsem/mitten" 7 | bug-reports: "https://github.com/logsem/mitten/issues" 8 | dev-repo: "git+https://github.com/logsem/mitten.git" 9 | license: "MIT" 10 | depends: [ 11 | "dune" {build} 12 | "cmdliner" {>= "1.1.0"} 13 | "sexplib" {>= "0.11.0"} 14 | "ppx_compare" {>= "0.14"} 15 | ] 16 | build: [ 17 | [make] 18 | ] 19 | -------------------------------------------------------------------------------- /normalize_lib.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "normalize_lib" 3 | version: "0.0" 4 | maintainer: "Daniel Gratzer" 5 | authors: ["Daniel Gratzer"] 6 | homepage: "https://github.com/jozefg/nbe-for-mltt" 7 | bug-reports: "https://github.com/jozefg/nbe-for-mltt/issues" 8 | license: "MIT" 9 | dev-repo: "git+https://github.com/jozefg/nbe-for-mltt" 10 | build: [ 11 | ["dune" "build" "--only-packages" name 12 | "--root" "." "-j" jobs "@install"] 13 | ] 14 | depends: [ 15 | "dune" {build} 16 | "menhir" {>= "20180703"} 17 | "sexplib" {>= "0.11.0"} 18 | ] 19 | -------------------------------------------------------------------------------- /test/fib.tt: -------------------------------------------------------------------------------- 1 | ; Not really a particularly interesting program, but good for computing stuff. 2 | 3 | let plus : (x : {idm | Nat}) -> (y : {idm | Nat}) -> Nat @ s = 4 | fun m -> 5 | fun n -> 6 | rec n at x -> Nat with 7 | | zero -> m 8 | | suc _, p -> suc p 9 | 10 | normalize plus {idm, 2} {idm, 2} at Nat @ s 11 | 12 | let fib : (x : {idm | Nat}) -> Nat @ s = 13 | fun n -> 14 | let worker : Nat * Nat = 15 | rec n at _ -> Nat * Nat with 16 | | zero -> pair (1, 0) 17 | | suc _, p -> pair (plus {idm, (fst p)} {idm, (snd p)}, fst p) in 18 | snd worker 19 | 20 | normalize fib {idm, 25} at Nat @ s 21 | -------------------------------------------------------------------------------- /test/eq.tt: -------------------------------------------------------------------------------- 1 | ;; Runs with the minimal mode theory 2 | 3 | let test : Id Nat 0 0 @ s = refl 0 4 | 5 | let subst : 6 | (A : {idm | (x : {idm | Nat}) -> U<0>}) 7 | -> (n : {idm | Nat}) -> (m : {idm | Nat}) 8 | -> (e : {idm | Id Nat n m}) 9 | -> (p : {idm | A n}) 10 | -> A m @ s = 11 | fun A n m eq -> 12 | match eq at x y q -> (p : {idm | A x}) -> (A y) with 13 | | refl _ -> fun x -> x 14 | 15 | let uhoh : (A : {idm | U<0>}) -> (p : {idm | Nat}) -> U<0> @ s = 16 | fun A n -> 17 | rec n at _ -> U<0> with 18 | | zero -> Id Nat 0 0 19 | | suc _, _ -> A 20 | 21 | let absurd : (A : {idm | U<0>}) -> (p : {idm | Id Nat 0 1}) -> A @ s = 22 | fun A eq -> subst (uhoh A) 0 1 eq (refl 0) 23 | 24 | normalize def absurd 25 | -------------------------------------------------------------------------------- /src/lib/load.ml: -------------------------------------------------------------------------------- 1 | open Lex 2 | open Lexing 3 | 4 | exception Parse_error of string 5 | 6 | let print_position lexbuf = 7 | let pos = lexbuf.lex_curr_p in 8 | Printf.sprintf "%s:%d:%d" pos.pos_fname 9 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 10 | 11 | let parse_with_error lexbuf = 12 | try Grammar.sign Lex.token lexbuf with 13 | | SyntaxError msg -> 14 | let location = print_position lexbuf in 15 | let msg = Printf.sprintf "%s: %s\n" location msg in 16 | raise (Parse_error msg) 17 | | Grammar.Error -> 18 | let location = print_position lexbuf in 19 | let msg = Printf.sprintf "%s: syntax error.\n" location in 20 | raise (Parse_error msg) 21 | 22 | let load_file filename = 23 | let ch = open_in filename in 24 | let lexbuf = Lexing.from_channel ch in 25 | lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; 26 | let sign = parse_with_error lexbuf in 27 | close_in ch; sign 28 | -------------------------------------------------------------------------------- /src/lib/check.mli: -------------------------------------------------------------------------------- 1 | open Mode_theory 2 | type env_entry = 3 | Term of {term : Domain.t; mu : m; tp : Domain.t; md : mode} 4 | | TopLevel of {term : Domain.t; tp : Domain.t; md : mode} 5 | | M of m 6 | type env = env_entry list 7 | 8 | val env_to_sem_env : env -> Domain.env 9 | 10 | type error = 11 | Cannot_synth_term of Syntax.t 12 | | Type_mismatch of Syntax.t * Syntax.t * Syntax.t 13 | | Term_or_Type_mismatch of Syntax.t * Syntax.t 14 | | Expecting_universe of Syntax.t 15 | | Modality_mismatch of m * m * Syntax.t * Syntax.t 16 | | Mode_mismatch of mode * mode * Syntax.t 17 | | Cell_fail of m * m * Syntax.t * Syntax.t 18 | | Misc of string 19 | 20 | val pp_error : error -> string 21 | 22 | exception Type_error of error 23 | 24 | val check : env:env -> size:int -> term:Syntax.t -> tp:Domain.t -> m:mode -> unit 25 | val synth : env:env -> size:int -> term:Syntax.t -> m:mode -> Domain.t 26 | val check_tp : env:env -> size:int -> term:Syntax.t -> m:mode -> unit 27 | -------------------------------------------------------------------------------- /src/lib/domain.mli: -------------------------------------------------------------------------------- 1 | open Mode_theory 2 | 3 | type envhead = 4 | | Val of t 5 | | M of m 6 | and env = envhead list 7 | and clos = Clos of {term : Syntax.t; env : env} 8 | and clos2 = Clos2 of {term : Syntax.t; env : env} 9 | and clos3 = Clos3 of {term : Syntax.t; env : env} 10 | and t = 11 | | Lam of clos 12 | | Neutral of {tp : t; term : ne} 13 | | Nat 14 | | Zero 15 | | Suc of t 16 | | Pi of m * t * clos 17 | | Sig of t * clos 18 | | Pair of t * t 19 | | Refl of t 20 | | Id of t * t * t 21 | | Uni of Syntax.uni_level 22 | | Tymod of m * t 23 | | Mod of m * t 24 | and ne = 25 | | Var of int (* DeBruijn levels for variables *) 26 | | Ap of m * ne * nf 27 | | Fst of ne 28 | | Snd of ne 29 | | NRec of clos * t * clos2 * ne 30 | | Letmod of m * m * clos * clos * t * ne 31 | | J of clos3 * clos * t * t * t * ne 32 | | Axiom of string * t 33 | and nf = 34 | | Normal of {tp : t; term : t} 35 | 36 | val env_val : env -> int -> t 37 | 38 | val mk_var : t -> int -> t 39 | -------------------------------------------------------------------------------- /src/lib/syntax.mli: -------------------------------------------------------------------------------- 1 | open Mode_theory 2 | type uni_level = int 3 | and t = 4 | | Var of int (* DeBruijn indices for variables *) 5 | | Let of t * (* BINDS *) t | Check of t * t 6 | | Nat | Zero | Suc of t | NRec of (* BINDS *) t * t * (* BINDS 2 *) t * t 7 | | Pi of m * t * (* BINDS *) t | Lam of (* BINDS *) t | Ap of m * t * t 8 | | Sig of t * (* BINDS *) t | Pair of t * t | Fst of t | Snd of t 9 | | Id of t * t * t | Refl of t | J of (* BINDS 3 *) t * (* BINDS *) t * t 10 | | Uni of uni_level 11 | | TyMod of m * t 12 | | Mod of m * t 13 | | Letmod of m * m * (* BINDS *) t * (* BINDS *) t * t 14 | | Axiom of string * t 15 | (*In contrast to the Domain letmod here we do not include the typing information for the modal argument*) 16 | type envhead = 17 | | Ty of t 18 | | Mo of m 19 | 20 | type env = envhead list 21 | val env_length : envhead list -> int 22 | (*val shift : env -> t -> cell -> t*) 23 | 24 | exception Illformed 25 | (* val of_sexp : Sexplib.Sexp.t -> t *) 26 | val to_sexp : Sexplib.Sexp.t list -> t -> Sexplib.Sexp.t 27 | val pp : t -> string 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2021 Philipp Stassen and Daniel Gratzer 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and 4 | associated documentation files (the “Software”), to deal in the Software without restriction, 5 | including without limitation the rights to use, copy, modify, merge, publish, distribute, 6 | sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is 7 | furnished to do so, subject to the following conditions: 8 | 9 | The above copyright notice and this permission notice shall be included in all copies or substantial 10 | portions of the Software. 11 | 12 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT 13 | NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 14 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES 15 | OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 16 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 17 | -------------------------------------------------------------------------------- /src/lib/nbe.mli: -------------------------------------------------------------------------------- 1 | exception Nbe_failed of string 2 | 3 | (* Main functions for doing a full normalization *) 4 | val normalize : env:Syntax.env -> term:Syntax.t -> tp:Syntax.t -> Syntax.t 5 | 6 | (* Evaluate a syntactic term into a semantic value *) 7 | val eval : Syntax.t -> Domain.env -> Domain.t 8 | 9 | val read_back_nf : int -> Domain.nf -> Syntax.t 10 | val read_back_tp : int -> Domain.t -> Syntax.t 11 | 12 | (* Check whether a semantic element is equal to another *) 13 | val check_nf : Mode_theory.mode -> int -> Domain.nf -> Domain.nf -> bool 14 | val check_ne : Mode_theory.mode -> int -> Domain.ne -> Domain.ne -> bool 15 | (* If subtype = true then we check whether the first argument is a subtype of the latter *) 16 | val check_tp : Mode_theory.mode -> subtype:bool -> int -> Domain.t -> Domain.t -> bool 17 | 18 | (* Functions to manipulate elements of the semantic domain *) 19 | val gen_do_clos : Domain.clos -> Domain.envhead -> Domain.t 20 | val gen_do_clos2 : Domain.clos2 -> Domain.envhead -> Domain.envhead -> Domain.t 21 | val do_clos : Domain.clos -> Domain.t -> Domain.t 22 | val do_clos2 : Domain.clos2 -> Domain.t -> Domain.t -> Domain.t 23 | val do_ap : Domain.t -> Domain.t -> Domain.t 24 | -------------------------------------------------------------------------------- /src/lib/abstract_mode_theory.mli: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | open Sexplib 4 | module C = Concrete_syntax 5 | 6 | exception Modality_error of string 7 | 8 | type mode 9 | type m 10 | 11 | val idm : m 12 | val compm : m * m -> m 13 | 14 | val dom_mod : m -> mode -> mode 15 | val cod_mod : m -> mode -> mode 16 | 17 | val eq_mode : mode -> mode -> bool 18 | (* leq is the function that takes two modalities and returns true IFF there exists a two cell between these modalities (this 2-cell is unique, since we are in a preorder mode theory) *) 19 | val leq : m -> m -> bool 20 | (* eq_mod takes two modalities and returns true IFF the modalities are equal. A posetal mode theory can use leq here. Otherwise it boils down to checking the boundaries. *) 21 | val eq_mod : m -> m -> bool 22 | 23 | val mode_to_sexp : mode -> Sexp.t 24 | val mode_pp : mode -> string 25 | 26 | val mod_to_sexp : m -> Sexp.t 27 | val mod_pp : m -> string 28 | 29 | (* Binding functions, inspiration can be taken from the guarded_mode_theory.ml file. 30 | * Note, that during the binding process modalities have to be checked for composability!!*) 31 | val bind_mode : C.mode -> mode 32 | val bind_m : C.m -> m 33 | end 34 | -------------------------------------------------------------------------------- /src/bin/main.ml: -------------------------------------------------------------------------------- 1 | open Normalizer 2 | open Cmdliner 3 | 4 | let perform_norm input = Load.load_file input |> Driver.process_sign 5 | 6 | let main input = 7 | try perform_norm input; 0 with 8 | | Invalid_argument s -> Printf.eprintf "Internal error (invalid argument): %s\n" s; 1 9 | | Failure s -> Printf.eprintf "Internal error (Failure): %s\n" s; 1 10 | | Load.Parse_error s -> Printf.eprintf "Frontend error: %s\n" s; 1 11 | | Nbe.Nbe_failed s -> Printf.eprintf "Internal error (Failed to normalize): %s\n" s; 1 12 | | Check.Type_error e -> Printf.eprintf "Type error\n%s\n" (Check.pp_error e); 1 13 | | Syntax.Illformed -> Printf.eprintf "Syntax error.\n"; 1 14 | | Mode_theory.Modality_error str -> Printf.eprintf "Modality error: %s\n" str; 1 15 | 16 | let input_file = 17 | let doc = "File containing the term to reduce" in 18 | Arg.(value & pos 0 file "" & info [] ~docv:"input file" ~doc) 19 | 20 | let info = 21 | let doc = "Typecheck and normalize terms in MTT" in 22 | let err_exit = Cmd.Exit.info ~doc:"on an ill-formed or terms." 1 in 23 | Cmd.info "mitten" ~version:"0.0" ~doc ~exits:(err_exit :: Cmd.Exit.defaults) 24 | 25 | let () = 26 | let t = Term.(const main $ input_file) in 27 | exit @@ Cmd.eval' @@ Cmd.v info t 28 | -------------------------------------------------------------------------------- /src/lib/concrete_syntax.ml: -------------------------------------------------------------------------------- 1 | type ident = string 2 | type uni_level = int 3 | 4 | type mode = string 5 | 6 | type m = string list 7 | 8 | type cell = 9 | | Idc of m 10 | | Atom of string 11 | | HComp of cell * cell 12 | | VComp of cell * cell 13 | 14 | type binder = Binder of {name : ident; body : t} 15 | and bindern = BinderN of {names : ident list; body : t} 16 | and binder2 = Binder2 of {name1 : ident; name2 : ident; body : t} 17 | and binder3 = Binder3 of {name1 : ident; name2 : ident; name3 : ident; body : t} 18 | and t = 19 | | Var of ident 20 | | Let of t * binder 21 | | Check of {term : t; tp : t} 22 | | Nat 23 | | Suc of t 24 | | Lit of int 25 | | NRec of {mot : binder; zero : t; suc : binder2; nat : t} 26 | | Pi of m * t * binder 27 | | Lam of bindern 28 | | Ap of t * (m * t) list 29 | | Sig of t * binder 30 | | Pair of t * t 31 | | Fst of t 32 | | Snd of t 33 | | Id of t * t * t 34 | | Refl of t 35 | | J of {mot : binder3; refl : binder; eq : t} 36 | | Uni of uni_level 37 | | TyMod of m * t 38 | | Mod of m * t 39 | | Letmod of m * m * binder * binder * t 40 | 41 | type decl = 42 | Def of {name : ident; def : t; tp : t; md : mode} 43 | | NormalizeDef of ident 44 | | NormalizeTerm of {term : t; tp : t; md : mode} 45 | | Axiom of {name : ident; tp : t; md : mode} 46 | | Quit 47 | 48 | type signature = decl list 49 | -------------------------------------------------------------------------------- /src/lib/concrete_syntax.mli: -------------------------------------------------------------------------------- 1 | type ident = string 2 | type uni_level = int 3 | 4 | type mode = string 5 | 6 | type m = string list 7 | 8 | type cell = 9 | | Idc of m 10 | | Atom of string 11 | | HComp of cell * cell 12 | | VComp of cell * cell 13 | 14 | type binder = Binder of {name : ident; body : t} 15 | and bindern = BinderN of {names : ident list; body : t} 16 | and binder2 = Binder2 of {name1 : ident; name2 : ident; body : t} 17 | and binder3 = Binder3 of {name1 : ident; name2 : ident; name3 : ident; body : t} 18 | and t = 19 | | Var of ident 20 | | Let of t * binder 21 | | Check of {term : t; tp : t} 22 | | Nat 23 | | Suc of t 24 | | Lit of int 25 | | NRec of {mot : binder; zero : t; suc : binder2; nat : t} 26 | | Pi of m * t * binder 27 | | Lam of bindern 28 | | Ap of t * (m * t) list 29 | | Sig of t * binder 30 | | Pair of t * t 31 | | Fst of t 32 | | Snd of t 33 | | Id of t * t * t 34 | | Refl of t 35 | | J of {mot : binder3; refl : binder; eq : t} 36 | | Uni of uni_level 37 | | TyMod of m * t 38 | | Mod of m * t 39 | | Letmod of m * m * binder * binder * t 40 | 41 | type decl = 42 | Def of {name : ident; def : t; tp : t; md : mode} 43 | | NormalizeDef of ident 44 | | NormalizeTerm of {term : t; tp : t; md : mode} 45 | | Axiom of {name : ident; tp : t; md : mode} 46 | | Quit 47 | 48 | type signature = decl list 49 | -------------------------------------------------------------------------------- /src/lib/domain.ml: -------------------------------------------------------------------------------- 1 | open Mode_theory 2 | 3 | type envhead = 4 | | Val of t 5 | | M of m 6 | and env = envhead list 7 | and clos = Clos of {term : Syntax.t; env : env} 8 | and clos2 = Clos2 of {term : Syntax.t; env : env} 9 | and clos3 = Clos3 of {term : Syntax.t; env : env} 10 | and t = 11 | | Lam of clos 12 | | Neutral of {tp : t; term : ne} 13 | | Nat 14 | | Zero 15 | | Suc of t 16 | | Pi of m * t * clos 17 | | Sig of t * clos 18 | | Pair of t * t 19 | | Refl of t 20 | | Id of t * t * t 21 | | Uni of Syntax.uni_level 22 | | Tymod of m * t 23 | | Mod of m * t 24 | and ne = 25 | | Var of int (* DeBruijn levels for variables *) 26 | | Ap of m * ne * nf 27 | | Fst of ne 28 | | Snd of ne 29 | | NRec of clos * t * clos2 * ne 30 | | Letmod of m * m * clos * clos * t * ne 31 | | J of clos3 * clos * t * t * t * ne 32 | | Axiom of string * t 33 | and nf = 34 | | Normal of {tp : t; term : t} 35 | 36 | let mk_var tp lev = Neutral {tp; term = Var lev} 37 | 38 | (* env_val is giving the nth entry of the environment list, ONLY counting values. env_cell then gives the corresponding 39 | cell as it is required for the nbe algorithm *) 40 | 41 | let rec env_val env i = 42 | match env with 43 | | [] -> failwith "env_val should not reach the empty list" 44 | | head :: lst -> 45 | match head with 46 | | Val v -> if Int.equal i 0 then v 47 | else if i > 0 then env_val lst (i - 1) 48 | else failwith "env_cell does not accept negativ Input" 49 | | M _ -> env_val lst i 50 | 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## posetal-mitten 2 | 3 | An implementation of MTT with modal dependent products (pi), modal types, dependent sums (sigma), 4 | natural numbers, and a cumulative hierarchy. This implementation correctly handles eta for both pi 5 | and sigma. 6 | 7 | This implementation only permits pre-order mode theories so that there is at most one 2-cell between 8 | any pair of modalities. 9 | 10 | This implementation has also been extended to include a type checker based on Coquand's semantic 11 | type checker. In order to interact with the normalizer, therefore, one can write a file containing a 12 | list of definitions and commands to normalize various terms. 13 | 14 | ## Prerequisites 15 | 16 | Tested under ocaml 4.07.1 and dune 2.8.5. Sexplib, menhir, ppx_compare and cmdliner libraries need 17 | to be installed. 18 | 19 | ## How to use it 20 | 21 | Building mitten with `make build` or `dune build`. Execute mitten with `dune exec mitten 22 | PATH/TO/FILE`. If there is no output, everything type checked. The commands `normalize` and 23 | `normalize def` print the normalized term. 24 | 25 | ## For example: 26 | 27 | ``` 28 | let plus : (x : {idm | Nat}) -> (y : {idm | Nat}) -> Nat @ s = 29 | fun m -> 30 | fun n -> 31 | rec n at x -> Nat with 32 | | zero -> m 33 | | suc _, p -> suc p 34 | 35 | normalize plus {idm, 2} {idm, 2} at Nat @ s 36 | 37 | let fib : (x : {idm | Nat}) -> Nat @ s = 38 | fun n -> 39 | let worker : Nat * Nat = 40 | rec n at _ -> Nat * Nat with 41 | | zero -> pair (1, 0) 42 | | suc _, p -> pair (plus {idm, (fst p)} {idm, (snd p)}, fst p) in 43 | snd worker 44 | 45 | normalize fib {idm, 25} at Nat @ s 46 | ``` 47 | 48 | A list of other examples may be found in `test/`. 49 | 50 | The implementation is derived from [nbe-for-mltt](https://github.com/jozefg/nbe-for-mltt). 51 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | # -*- mode: gitignore; -*- 3 | *~ 4 | \#*\# 5 | /.emacs.desktop 6 | /.emacs.desktop.lock 7 | *.elc 8 | auto-save-list 9 | tramp 10 | .\#* 11 | 12 | # Org-mode 13 | .org-id-locations 14 | *_archive 15 | 16 | # flymake-mode 17 | *_flymake.* 18 | 19 | # eshell files 20 | /eshell/history 21 | /eshell/lastdir 22 | 23 | # elpa packages 24 | /elpa/ 25 | 26 | # reftex files 27 | *.rel 28 | 29 | # AUCTeX auto folder 30 | auto/ 31 | 32 | # cask packages 33 | .cask/ 34 | dist/ 35 | 36 | # Flycheck 37 | flycheck_*.el 38 | 39 | # server auth directory 40 | /server/ 41 | 42 | # projectiles files 43 | .projectile 44 | 45 | # directory configuration 46 | .dir-locals.el 47 | 48 | 49 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Linux.gitignore 50 | 51 | *~ 52 | 53 | # temporary files which can be created if a process still has a handle open of a deleted file 54 | .fuse_hidden* 55 | 56 | # KDE directory preferences 57 | .directory 58 | 59 | # Linux trash folder which might appear on any partition or disk 60 | .Trash-* 61 | 62 | # .nfs files are created when an open file is removed but is still being accessed 63 | .nfs* 64 | 65 | 66 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/macOS.gitignore 67 | 68 | # General 69 | .DS_Store 70 | .AppleDouble 71 | .LSOverride 72 | 73 | # Icon must end with two \r 74 | Icon 75 | 76 | 77 | # Thumbnails 78 | ._* 79 | 80 | # Files that might appear in the root of a volume 81 | .DocumentRevisions-V100 82 | .fseventsd 83 | .Spotlight-V100 84 | .TemporaryItems 85 | .Trashes 86 | .VolumeIcon.icns 87 | .com.apple.timemachine.donotpresent 88 | 89 | # Directories potentially created on remote AFP share 90 | .AppleDB 91 | .AppleDesktop 92 | Network Trash Folder 93 | Temporary Items 94 | .apdisk 95 | 96 | 97 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/OCaml.gitignore 98 | 99 | *.annot 100 | *.cmo 101 | *.cma 102 | *.cmi 103 | *.a 104 | *.o 105 | *.cmx 106 | *.cmxs 107 | *.cmxa 108 | 109 | # ocamlbuild working directory 110 | _build/ 111 | 112 | # ocamlbuild targets 113 | *.byte 114 | *.native 115 | 116 | # oasis generated files 117 | setup.data 118 | setup.log 119 | 120 | # Merlin configuring file for Vim and Emacs 121 | .merlin 122 | -------------------------------------------------------------------------------- /src/lib/lex.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Grammar 4 | 5 | exception SyntaxError of string 6 | 7 | let next_line lexbuf = 8 | let pos = lexbuf.lex_curr_p in 9 | lexbuf.lex_curr_p <- 10 | { pos with pos_bol = lexbuf.lex_curr_pos; 11 | pos_lnum = pos.pos_lnum + 1 12 | } 13 | 14 | let make_table num elems = 15 | let table = Hashtbl.create num in 16 | List.iter (fun (k, v) -> Hashtbl.add table k v) elems; 17 | table 18 | 19 | let keywords = 20 | make_table 0 [ 21 | ("zero", ZERO); 22 | ("suc", SUC); 23 | ("Nat", NAT); 24 | ("let", LET); 25 | ("in", IN); 26 | ("with", WITH); 27 | ("rec", REC); 28 | ("pair", PAIR); 29 | ("fst", FST); 30 | ("snd", SND); 31 | ("fun", LAM); 32 | ("letmod", LETMOD); 33 | ("mod", MOD); 34 | ("idm", IDM); 35 | ("match", MATCH); 36 | ("Id", ID); 37 | ("refl", REFL); 38 | ("U", UNIV); 39 | ("def", DEF); 40 | ("at", AT); 41 | ("normalize", NORMALIZE); 42 | ("quit", QUIT); 43 | ("axiom", AXIOM); 44 | ] 45 | } 46 | 47 | let number = ['0'-'9']['0'-'9']* 48 | let whitespace = [' ' '\t']+ 49 | let line_ending = '\r' | '\n' | "\r\n" 50 | let atom_first = ['a'-'z' 'A'-'Z' '_'] 51 | let atom_next = ['a'-'z' 'A'-'Z' '_' '-' '*' '/' '0'-'9'] 52 | let atom = atom_first atom_next* 53 | 54 | rule token = parse 55 | | number 56 | { (NUMERAL (int_of_string (Lexing.lexeme lexbuf))) } 57 | | ';' 58 | {comment lexbuf} 59 | | '{' 60 | { LBRACE } 61 | | '}' 62 | { RBRACE } 63 | | '(' 64 | { LPR } 65 | | ')' 66 | { RPR } 67 | | '[' 68 | { LBR } 69 | | ']' 70 | { RBR } 71 | | '|' 72 | { PIPE } 73 | | ',' 74 | { COMMA } 75 | | '.' 76 | { POINT } 77 | | '*' 78 | { TIMES } 79 | | ':' 80 | { COLON } 81 | | "=" 82 | { EQUALS } 83 | | "->" 84 | { RIGHT_ARROW } 85 | | "<-" 86 | { LEFT_ARROW } 87 | | "<" 88 | { LANGLE } 89 | | ">" 90 | { RANGLE } 91 | | "λ" 92 | { LAM } 93 | | "@" 94 | { ATSIGN } 95 | | '_' 96 | { UNDERSCORE } 97 | | line_ending 98 | { new_line lexbuf; token lexbuf } 99 | | whitespace 100 | { token lexbuf } 101 | | eof 102 | { EOF } 103 | | atom 104 | { 105 | let input = lexeme lexbuf in 106 | begin try 107 | let kwd = Hashtbl.find keywords input in 108 | kwd 109 | with Not_found -> 110 | (Grammar.ATOM input) 111 | end 112 | } 113 | | _ 114 | { Printf.eprintf "Unexpected char: %s" (lexeme lexbuf); token lexbuf } 115 | and comment = parse 116 | | line_ending 117 | { new_line lexbuf; token lexbuf } 118 | | _ 119 | { comment lexbuf } 120 | -------------------------------------------------------------------------------- /src/lib/grammar.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Concrete_syntax 3 | %} 4 | 5 | %token NUMERAL 6 | %token ATOM 7 | %token COLON PIPE AT COMMA RIGHT_ARROW LEFT_ARROW UNDERSCORE POINT 8 | %token LPR RPR LBR RBR LANGLE RANGLE LBRACE RBRACE ATSIGN 9 | %token EQUALS 10 | %token TIMES FST SND PAIR 11 | %token LAM LET IN WITH DEF 12 | %token REC SUC NAT ZERO 13 | %token MOD LETMOD IDM 14 | %token ID REFL MATCH 15 | %token UNIV 16 | %token QUIT NORMALIZE 17 | %token EOF 18 | %token AXIOM 19 | 20 | %start sign 21 | %% 22 | 23 | name: 24 | | s = ATOM 25 | { s } 26 | | UNDERSCORE 27 | { "_" } 28 | 29 | decl: 30 | | LET; nm = name; COLON; tp = term; ATSIGN; md = mode; EQUALS; body = term 31 | { Def {name = nm; def = body; tp; md} } 32 | | QUIT { Quit } 33 | | NORMALIZE; DEF; a = name 34 | { NormalizeDef a } 35 | | NORMALIZE; tm = term; AT; tp = term; ATSIGN; md = mode 36 | { NormalizeTerm {term = tm; tp; md} } 37 | | AXIOM; nm = name; COLON; tp = term; ATSIGN; md = mode 38 | { Axiom {name = nm; tp; md} } 39 | ; 40 | 41 | sign: 42 | | EOF { [] } 43 | | d = decl; s = sign { d :: s }; 44 | 45 | atomic: 46 | | LPR; t = term; RPR 47 | { t } 48 | | LBR; t = term; AT; tp = term RBR 49 | { Check {term = t; tp} } 50 | | a = name 51 | { Var a } 52 | | ZERO 53 | { Lit 0 } 54 | | n = NUMERAL 55 | { Lit n } 56 | | UNIV; LANGLE; i = NUMERAL; RANGLE 57 | { Uni i } 58 | | NAT { Nat } 59 | | PAIR; LPR; left = term; COMMA; right = term; RPR 60 | { Pair (left, right) } 61 | | LANGLE; LANGLE; mu = modality; PIPE; tm = term; RANGLE; RANGLE 62 | {TyMod (mu, tm)} 63 | ; 64 | 65 | spine: 66 | | LBRACE; mu = modality; COMMA; tm = term; RBRACE 67 | {mu, tm} 68 | | t = atomic 69 | {[], t} 70 | ; 71 | 72 | term: 73 | | f = atomic; args = list(spine) 74 | { Ap (f, args) } 75 | | LET; name = name; COLON; tp = term; EQUALS; def = term; IN; body = term 76 | { Let (Check {term = def; tp}, Binder {name; body}) } 77 | | LET; name = name; EQUALS; def = term; IN; body = term 78 | { Let (def, Binder {name; body}) } 79 | | LPR t = term; AT; tp = term RPR 80 | { Check {term = t; tp} } 81 | | SUC; t = term { Suc t } 82 | | REC; n = term; AT; mot_name = name; RIGHT_ARROW; mot = term; WITH; 83 | PIPE; ZERO; RIGHT_ARROW; zero_case = term; 84 | PIPE; SUC; suc_var = name; COMMA; ih_var = name; RIGHT_ARROW; suc_case = term 85 | { NRec { 86 | mot = Binder {name = mot_name; body = mot}; 87 | zero = zero_case; 88 | suc = Binder2 {name1 = suc_var; name2 = ih_var; body = suc_case}; 89 | nat = n 90 | } } 91 | | MATCH; eq = term; AT; name1 = name; name2 = name; name3 = name; RIGHT_ARROW; mot_term = term; WITH 92 | PIPE; REFL; name = name; RIGHT_ARROW; refl = term; 93 | { J {mot = Binder3 {name1; name2; name3; body = mot_term}; refl = Binder {name; body = refl}; eq} } 94 | | ID; tp = atomic; left = atomic; right = atomic 95 | { Id (tp, left, right) } 96 | | REFL; t = atomic 97 | { Refl t } 98 | | LAM; names = nonempty_list(name); RIGHT_ARROW; body = term 99 | { Lam (BinderN {names; body}) } 100 | | LPR; name = name; COLON; LBRACE; mu = modality; PIPE; dom = term; RBRACE; RPR RIGHT_ARROW; cod = term 101 | { Pi (mu, dom, Binder {name; body = cod}) } 102 | | LBRACE; mu = modality; PIPE; dom = term; RBRACE; RIGHT_ARROW; cod = term 103 | { Pi (mu, dom, Binder {name = ""; body = cod}) } 104 | | LPR; name = name; COLON; dom = term; RPR; RIGHT_ARROW; cod = term 105 | { Pi ([], dom, Binder {name; body = cod}) } 106 | | dom = atomic; RIGHT_ARROW; cod = term 107 | { Pi ([], dom, Binder {name = ""; body = cod}) } 108 | | LPR name = name; COLON; left = term; RPR; TIMES; right = term 109 | { Sig (left, Binder {name; body = right}) } 110 | | left = atomic; TIMES; right = term 111 | { Sig (left, Binder {name = ""; body = right}) } 112 | | FST; t = term { Fst t } 113 | | SND; t = term { Snd t } 114 | | LETMOD; mu = modality; LPR; LAM; name_tp = name; RIGHT_ARROW; tp = term; RPR; MOD; nu = modality; LPR; name_tm = name; RPR; LEFT_ARROW; tm1 = term; IN; tm2 = term 115 | {Letmod (mu, nu, Binder {name = name_tp; body = tp}, Binder {name = name_tm; body = tm2}, tm1)} 116 | | MOD; mu = modality; tm = term 117 | {Mod (mu, tm)} 118 | ; 119 | 120 | mode: 121 | | s = name 122 | { s }; 123 | 124 | modality: 125 | | mod1 = atomic_modality; POINT; mod2 = modality 126 | {List.append mod2 mod1} 127 | | mu = atomic_modality 128 | {mu}; 129 | 130 | atomic_modality: 131 | | IDM 132 | { [] } 133 | | mu = name 134 | { [mu] } 135 | | LPR; mu = modality; RPR 136 | {mu}; 137 | -------------------------------------------------------------------------------- /src/lib/guarded_mode_theory.ml: -------------------------------------------------------------------------------- 1 | open Sexplib 2 | module C = Concrete_syntax 3 | module SMap = Map.Make(String) 4 | 5 | exception Modality_error of string 6 | let error_m str = raise (Modality_error str) 7 | 8 | type mode = 9 | | S 10 | | T 11 | 12 | let equal_mode m n = 13 | match m, n with 14 | | S, S -> true 15 | | T, T -> true 16 | | _ -> false 17 | 18 | type m_constr = 19 | | L 20 | | D 21 | | G 22 | 23 | (* In this implementation the concatenation is the wrong way around, i.e. mu :: nu = nu o mu. 24 | This is corrected in the compm function 25 | *) 26 | type m = m_constr list 27 | 28 | let equal_m mu nu = 29 | match mu, nu with 30 | | L, L -> true 31 | | D, D -> true 32 | | G, G -> true 33 | | _ -> false 34 | 35 | let idm = [] 36 | let compm (mu, nu) = List.append nu mu 37 | 38 | let dom_m_constr mu = 39 | match mu with 40 | | L -> T 41 | | D -> S 42 | | G -> T 43 | 44 | let dom_mod mu mode = 45 | match mu with 46 | | [] -> mode 47 | | mu :: _ -> 48 | dom_m_constr mu 49 | 50 | let cod_m_constr mu = 51 | match mu with 52 | | L -> T 53 | | D -> T 54 | | G -> S 55 | 56 | let rec cod_mod mu mode = 57 | match mu with 58 | | [] -> mode 59 | | mu :: tail -> 60 | cod_mod tail (cod_m_constr mu) 61 | 62 | 63 | let eq_mode m1 m2 = 64 | match m1, m2 with 65 | | S, S -> true 66 | | T, T -> true 67 | | _, _ -> false 68 | 69 | let rec purge_GD mu = 70 | match mu with 71 | | [] -> [] 72 | | D :: tail -> 73 | begin 74 | match tail with 75 | | G :: tail1 -> purge_GD tail1 76 | | lst -> D :: lst 77 | end 78 | | nu :: tail -> nu :: purge_GD tail 79 | 80 | let rec purge_GL mu = 81 | match mu with 82 | | [] -> [] 83 | | L :: tail -> 84 | begin 85 | match tail with 86 | | G :: tail1 -> G :: purge_GL tail1 87 | | lst -> L :: lst 88 | end 89 | | nu :: tail -> nu :: purge_GL tail 90 | 91 | let purger mu = 92 | let pre_nu = ref [] in 93 | let post_nu = ref mu in 94 | while Bool.not (List.equal equal_m !pre_nu !post_nu) do 95 | pre_nu := !post_nu; 96 | let new_mu = purge_GD (!post_nu) |> purge_GL in 97 | post_nu := new_mu 98 | done; 99 | !post_nu 100 | 101 | let rec leq mu nu = 102 | match purger mu, purger nu with 103 | | [], [] -> true 104 | | G :: D :: tail1 , G :: D :: tail2 | L :: tail1, L :: tail2 -> leq tail1 tail2 105 | | G :: D :: tail, nu -> leq tail nu 106 | | nu, L :: tail -> leq nu tail 107 | | mu1 :: tail1 , mu2 :: tail2 -> Bool.(&&) (equal_m mu1 mu2) (leq tail1 tail2) 108 | | _ -> false 109 | 110 | let eq_mod mu nu = Bool.(&&) (leq mu nu) (leq nu mu) 111 | 112 | (* We only have the identity and compositions of it. 113 | Hence if the domain of the cells are equal, there is no flex. 114 | *) 115 | 116 | let mode_to_sexp = function 117 | | S -> Sexp.Atom "s" 118 | | T -> Sexp.Atom "t" 119 | 120 | let mode_pp m = mode_to_sexp m |> Sexp.to_string_hum 121 | 122 | let m_constr_sexp mu = 123 | match mu with 124 | | L -> Sexp.Atom "l" 125 | | D -> Sexp.Atom "d" 126 | | G -> Sexp.Atom "g" 127 | 128 | let mod_to_sexp mu = 129 | let rec rec_helper mu = 130 | match List.rev mu with 131 | | [] -> [] 132 | | mu :: tail -> m_constr_sexp mu :: rec_helper tail in 133 | Sexp.List (rec_helper mu) 134 | 135 | let mod_pp mu = mod_to_sexp mu |> Sexp.to_string_hum 136 | 137 | (* Maps for binding modalities, cells and modes *) 138 | 139 | let mode_smap = [("s", S); ("S", S); ("t", T); ("T", T)] |> List.to_seq |> SMap.of_seq 140 | 141 | let m_smap = [("l", L); ("d", D); ("g", G)] |> List.to_seq |> SMap.of_seq 142 | 143 | let m_macros = [("box", "g" :: ["d"])] |> List.to_seq |> SMap.of_seq 144 | 145 | let cell_smap = [("dg_id", ([G; D], [])); ("id_l", ([], [L]))] |> List.to_seq |> SMap.of_seq 146 | 147 | let bind_mode str = 148 | match SMap.find_opt str mode_smap with 149 | | Some v -> v 150 | | None -> error_m (str ^ " is not a mode of the bowling pin") 151 | 152 | let find_mod str = 153 | match SMap.find_opt str m_smap with 154 | | Some v -> v 155 | | None -> error_m (str ^ " is not a modality of bowling pin") 156 | 157 | let find_cell str = 158 | match SMap.find_opt str cell_smap with 159 | | Some v -> v 160 | | None -> error_m (str ^ " is not a 2-cell of the bowling pin") 161 | 162 | (* Macros should be purged during the bind process, so that the constructors are not part of the backend *) 163 | let rec purge_macros mu = 164 | match mu with 165 | | [] -> [] 166 | | str :: tail -> 167 | let new_tail = purge_macros tail in 168 | match SMap.find_opt str m_macros with 169 | | Option.Some lst -> List.append lst new_tail 170 | | Option.None -> str :: new_tail 171 | 172 | let rec bind_m mu = 173 | match purge_macros mu with 174 | | [] -> [] 175 | | str :: tail -> 176 | let bound_mod = (find_mod str) in 177 | let bound_tail = bind_m tail in 178 | if equal_mode (cod_m_constr bound_mod) (dom_mod bound_tail (cod_m_constr bound_mod)) then bound_mod :: bound_tail 179 | else error_m (mod_pp (bound_mod :: bound_tail) ^ " is not well-formed") 180 | -------------------------------------------------------------------------------- /src/lib/syntax.ml: -------------------------------------------------------------------------------- 1 | open Sexplib 2 | open Mode_theory 3 | type uni_level = int 4 | 5 | type t = 6 | | Var of int (* DeBruijn indices for variables *) 7 | | Let of t * (* BINDS *) t | Check of t * t 8 | | Nat | Zero | Suc of t | NRec of (* BINDS *) t * t * (* BINDS 2 *) t * t 9 | | Pi of m * t * (* BINDS *) t | Lam of (* BINDS *) t | Ap of m * t * t 10 | | Sig of t * (* BINDS *) t | Pair of t * t | Fst of t | Snd of t 11 | | Id of t * t * t | Refl of t | J of (* BINDS 3 *) t * (* BINDS *) t * t 12 | | Uni of uni_level 13 | | TyMod of m * t 14 | | Mod of m * t 15 | | Letmod of m * m * (* BINDS *) t * (* BINDS *) t * t 16 | | Axiom of string * t 17 | 18 | type envhead = 19 | | Ty of t 20 | | Mo of m 21 | 22 | type env = envhead list 23 | 24 | exception Illformed 25 | 26 | let rec nth lst id = 27 | match lst with 28 | | [] -> failwith "syntax shift mistake, context too short?" 29 | | x :: xs -> if Int.equal id 0 then x else nth xs (id - 1) 30 | 31 | let rec env_length lst = 32 | match lst with 33 | | [] -> 0 34 | | Ty _ :: xs -> (env_length xs) + 1 35 | | Mo _ :: xs -> (env_length xs) 36 | 37 | let find_idx ~equal key xs = 38 | let rec go i = function 39 | | [] -> None 40 | | x :: xs -> 41 | if equal key x then Some i else go (i + 1) xs in 42 | go 0 xs 43 | 44 | let to_sexp env t = 45 | let counter = ref 0 in 46 | let rec int_of_syn = function 47 | | Zero -> Some 0 48 | | Suc t -> 49 | begin 50 | match int_of_syn t with 51 | | Some i -> Some (i + 1) 52 | | None -> None 53 | end 54 | | _ -> None in 55 | let rec go env = function 56 | (* need pp for cells to pretty print variables also for non trivial cells *) 57 | | Var i -> if i >= List.length env 58 | then Sexp.Atom ("free" ^ string_of_int i) 59 | else List.nth env i 60 | | Nat -> Sexp.Atom "Nat" 61 | | Let (def, body) -> 62 | incr counter; 63 | let var = Sexp.Atom ("x" ^ string_of_int (! counter)) in 64 | Sexp.List 65 | [Sexp.Atom "let"; 66 | Sexp.List [var; go env def]; 67 | go (var :: env) body] 68 | | Check (term, tp) -> Sexp.List [Sexp.Atom "check"; go env term; go env tp] 69 | | Zero -> Sexp.Atom "zero" 70 | | Suc t -> 71 | begin 72 | match int_of_syn t with 73 | | Some i -> Sexp.Atom (string_of_int (i + 1)) 74 | | None -> Sexp.List [Sexp.Atom "suc"; go env t] 75 | end 76 | | NRec (motive, zero, suc, n) -> 77 | incr counter; 78 | let mvar = Sexp.Atom ("x" ^ string_of_int (! counter)) in 79 | incr counter; 80 | let suc_var1 = Sexp.Atom ("x" ^ string_of_int (! counter)) in 81 | incr counter; 82 | let suc_var2 = Sexp.Atom ("x" ^ string_of_int (! counter)) in 83 | Sexp.List 84 | [Sexp.Atom "nrec"; 85 | Sexp.List [mvar; go (mvar :: env) motive]; 86 | go env zero; 87 | Sexp.List [suc_var1; suc_var2; go (suc_var2 :: suc_var1 :: env) suc]; 88 | go env n] 89 | | Pi (mu, src, dest) -> 90 | incr counter; 91 | let var = Sexp.Atom ("x" ^ string_of_int (! counter)) in 92 | Sexp.List [Sexp.Atom "Pi"; mod_to_sexp mu; go env src; Sexp.List [var; Sexp.Atom "->"; go (var :: env) dest]] 93 | | Lam t -> 94 | incr counter; 95 | let var = Sexp.Atom ("x" ^ string_of_int (! counter)) in 96 | Sexp.List [Sexp.Atom "lam"; Sexp.List [var; go (var :: env) t]] 97 | | Ap (mu, t1, t2) -> 98 | Sexp.List [Sexp.Atom "ap"; mod_to_sexp mu; go env t1; go env t2] 99 | | Sig (fst, snd) -> 100 | incr counter; 101 | let var = Sexp.Atom ("x" ^ string_of_int (! counter)) in 102 | Sexp.List [Sexp.Atom "Sig"; go env fst; Sexp.List [var; go (var :: env) snd]] 103 | | Pair (t1, t2) -> 104 | Sexp.List [Sexp.Atom "pair"; go env t1; go env t2] 105 | | Fst t -> Sexp.List [Sexp.Atom "fst"; go env t] 106 | | Snd t -> Sexp.List [Sexp.Atom "snd"; go env t] 107 | | Uni i -> Sexp.List [Sexp.Atom "U"; Sexp.Atom (string_of_int i)] 108 | | TyMod (mu, tp) -> Sexp.List [Sexp.Atom "<"; mod_to_sexp mu; Sexp.Atom "|"; go env tp; Sexp.Atom ">"] 109 | | Mod (mu, tm) -> Sexp.List [Sexp.Atom "mod"; mod_to_sexp mu; go env tm] 110 | | Letmod (mu, nu, tymot, deptm, tm) -> 111 | incr counter; 112 | let mvar = Sexp.Atom ("x" ^ string_of_int (! counter)) in 113 | incr counter; 114 | let tm_var = Sexp.Atom ("x" ^ string_of_int (! counter)) in 115 | Sexp.List [Sexp.Atom "let"; mod_to_sexp mu; Sexp.Atom "mod"; mod_to_sexp nu; Sexp.Atom "<-"; go env tm ; Sexp.Atom "in"; Sexp.List [go (tm_var :: env) deptm]; Sexp.Atom "at"; go (mvar :: env) tymot] 116 | | Id (ty, le, ri) -> Sexp.List [Sexp.Atom "Id"; go env ty; go env le; go env ri] 117 | | Refl term -> Sexp.List [Sexp.Atom "Refl"; go env term] 118 | | J (mot, refltm, eq) -> 119 | incr counter; 120 | let rivar = Sexp.Atom ("x" ^ string_of_int (! counter)) in 121 | incr counter; 122 | let levar = Sexp.Atom ("x" ^ string_of_int (! counter)) in 123 | incr counter; 124 | let prfvar = Sexp.Atom ("x" ^ string_of_int (! counter)) in 125 | Sexp.List [Sexp.Atom "J"; go (prfvar :: levar :: rivar :: env) mot; go (levar :: env) refltm; go env eq] 126 | | Axiom (str, _) -> Sexp.Atom str in 127 | go env t 128 | 129 | let pp t = to_sexp [] t |> Sexp.to_string_hum 130 | -------------------------------------------------------------------------------- /src/lib/driver.ml: -------------------------------------------------------------------------------- 1 | module CS = Concrete_syntax 2 | module S = Syntax 3 | module D = Domain 4 | module M = Mode_theory 5 | 6 | type env = Env of {size : int; check_env : Check.env; bindings : string list} 7 | 8 | let initial_env = Env {size = 0; check_env = []; bindings = []} 9 | 10 | type output = 11 | NoOutput of env 12 | | NF_term of S.t * S.t 13 | | NF_def of CS.ident * S.t 14 | | Quit 15 | 16 | let update_env env = function 17 | | NoOutput env -> env 18 | | NF_term _ | NF_def _ | Quit -> env 19 | 20 | let output (Env {bindings; _}) = function 21 | | NoOutput _ -> () 22 | | NF_term (s, t) -> 23 | let open Sexplib in 24 | let s_rep = 25 | Syntax.to_sexp (List.map (fun x -> Sexp.Atom x) bindings) s 26 | |> Sexp.to_string_hum in 27 | Printf.printf "Computed normal form of\n %s\nas\n %s\n%!" s_rep (S.pp t) 28 | | NF_def (name, t) -> Printf.printf "Computed normal form of [%s]:\n %s\n%!" name (S.pp t) 29 | | Quit -> exit 0 30 | 31 | let find_idx key = 32 | let rec go i = function 33 | | [] -> raise (Check.Type_error (Check.Misc ("Unbound variable: " ^ key))) 34 | | x :: xs -> if String.equal x key then i else go (i + 1) xs in 35 | go 0 36 | 37 | let rec int_to_term = function 38 | | 0 -> S.Zero 39 | | n -> S.Suc (int_to_term (n - 1)) 40 | 41 | let rec unravel_spine f = function 42 | | [] -> f 43 | | x :: xs -> unravel_spine (x f) xs 44 | 45 | let rec bind env = function 46 | | CS.Var i -> S.Var (find_idx i env) 47 | | CS.Let (tp, Binder {name; body}) -> 48 | S.Let (bind env tp, bind (name :: env) body) 49 | | CS.Check {term; tp} -> S.Check (bind env term, bind env tp) 50 | | CS.Nat -> S.Nat 51 | | CS.Suc t -> S.Suc (bind env t) 52 | | CS.Lit i -> int_to_term i 53 | | CS.NRec 54 | { mot = Binder {name = mot_name; body = mot_body}; 55 | zero; 56 | suc = Binder2 {name1 = suc_name1; name2 = suc_name2; body = suc_body}; 57 | nat} -> 58 | S.NRec 59 | (bind (mot_name :: env) mot_body, 60 | bind env zero, 61 | bind (suc_name2 :: suc_name1 :: env) suc_body, 62 | bind env nat) 63 | | CS.Pi (mu, src, Binder {name; body}) -> S.Pi (M.bind_m mu, bind env src, bind (name :: env) body) 64 | | CS.Lam (BinderN {names = []; body}) -> 65 | bind env body 66 | | CS.Lam (BinderN {names = x :: names; body}) -> 67 | let lam = CS.Lam (BinderN {names; body}) in 68 | S.Lam (bind (x :: env) lam) 69 | | CS.Ap (f, args) -> 70 | List.map (fun (mu, t) f -> S.Ap (M.bind_m mu, f, bind env t)) args |> unravel_spine (bind env f) 71 | | CS.Sig (tp, Binder {name; body}) -> 72 | S.Sig (bind env tp, bind (name :: env) body) 73 | | CS.Pair (l, r) -> S.Pair (bind env l, bind env r) 74 | | CS.Fst p -> S.Fst (bind env p) 75 | | CS.Snd p -> S.Snd (bind env p) 76 | | CS.J 77 | {mot = Binder3 {name1 = left; name2 = right; name3 = prf; body = mot_body}; 78 | refl = Binder {name = refl_name; body = refl_body}; 79 | eq} -> 80 | S.J 81 | (bind (prf :: right :: left :: env) mot_body, 82 | bind (refl_name :: env) refl_body, 83 | bind env eq) 84 | | CS.Id (tp, left, right) -> 85 | S.Id (bind env tp, bind env left, bind env right) 86 | | CS.Refl t -> S.Refl (bind env t) 87 | | CS.Uni i -> S.Uni i 88 | | CS.TyMod (mu, tp) -> S.TyMod (M.bind_m mu, bind env tp) 89 | | CS.Mod (mu, tp) -> S.Mod (M.bind_m mu, bind env tp) 90 | | CS.Letmod (mu, nu, Binder {name; body = tp}, Binder {name = mod_var; body}, def) -> 91 | S.Letmod (M.bind_m mu, M.bind_m nu, bind (name :: env) tp, bind (mod_var :: env) body, bind env def) 92 | 93 | let process_decl (Env {size; check_env; bindings}) = function 94 | | CS.Def {name; def; tp; md} -> 95 | let bind_md = M.bind_mode md in 96 | let def = bind bindings def in 97 | let tp = bind bindings tp in 98 | Check.check_tp ~size ~env:check_env ~term:tp ~m:bind_md; 99 | let sem_env = Check.env_to_sem_env check_env in 100 | let sem_tp = Nbe.eval tp sem_env in 101 | Check.check ~size ~env:check_env ~term:def ~tp:sem_tp ~m:bind_md; 102 | let sem_def = Nbe.eval def sem_env in 103 | let new_entry = Check.TopLevel {term = sem_def; tp = sem_tp; md = bind_md} in 104 | NoOutput (Env {size = size + 1; check_env = new_entry :: check_env; bindings = name :: bindings }) 105 | | CS.NormalizeDef name -> 106 | let err = Check.Type_error (Check.Misc ("Unbound variable: " ^ name)) in 107 | begin 108 | match List.nth check_env (find_idx name bindings) with 109 | | Check.TopLevel {term; tp; md = _} -> NF_def (name, Nbe.read_back_nf 0 (D.Normal {term; tp})) 110 | | _ -> raise err 111 | | exception Failure _ -> raise err 112 | end 113 | | CS.NormalizeTerm {term; tp; md} -> 114 | let bind_md = M.bind_mode md in 115 | let term = bind bindings term in 116 | let tp = bind bindings tp in 117 | Check.check_tp ~size ~env:check_env ~term:tp ~m:bind_md; 118 | let sem_env = Check.env_to_sem_env check_env in 119 | let sem_tp = Nbe.eval tp sem_env in 120 | Check.check ~size ~env:check_env ~term ~tp:sem_tp ~m:bind_md; 121 | let sem_term = Nbe.eval term sem_env in 122 | let norm_term = Nbe.read_back_nf 0 (D.Normal {term = sem_term; tp = sem_tp}) in 123 | NF_term (term, norm_term) 124 | | CS.Axiom {name; tp; md} -> 125 | let bound_md = M.bind_mode md in 126 | let tp = bind bindings tp in 127 | Check.check_tp ~size ~env:check_env ~term:tp ~m:bound_md; 128 | let sem_env = Check.env_to_sem_env check_env in 129 | let sem_tp = Nbe.eval tp sem_env in 130 | let new_entry = Check.TopLevel {term = D.Neutral {tp = sem_tp; term = D.Axiom (name, sem_tp)}; tp = sem_tp; md = bound_md} in 131 | NoOutput (Env {size = size + 1; check_env = new_entry :: check_env; bindings = name :: bindings }) 132 | | CS.Quit -> Quit 133 | 134 | let rec process_sign ?env = function 135 | | [] -> () 136 | | d :: ds -> 137 | let env = match env with 138 | None -> initial_env 139 | | Some e -> e in 140 | let o = process_decl env d in 141 | output env o; 142 | process_sign ?env:(Some (update_env env o)) ds 143 | -------------------------------------------------------------------------------- /src/lib/guarded_mode_theory1.ml: -------------------------------------------------------------------------------- 1 | open Sexplib 2 | module C = Concrete_syntax 3 | module SMap = Map.Make(String) 4 | 5 | exception Modality_error of string 6 | let error_m str = raise (Modality_error str) 7 | 8 | type mode = 9 | | S 10 | | T 11 | 12 | let equal_mode m n = 13 | match m, n with 14 | | S, S -> true 15 | | T, T -> true 16 | | _ -> false 17 | 18 | type m_constr = 19 | | L 20 | | D 21 | | G 22 | | Box 23 | 24 | (* In this implementation the concatenation is the wrong way around, i.e. mu :: nu = nu o mu. 25 | This is corrected in the compm function 26 | *) 27 | (* In particular: [m1 :: m2 :: m3 ...] is parsed as m3 o m2 o m1, this turns out this way because of the binding routine*) 28 | 29 | type m = m_constr list 30 | 31 | let equal_m mu nu = 32 | match mu, nu with 33 | | L, L -> true 34 | | D, D -> true 35 | | G, G -> true 36 | | Box, Box -> true 37 | | _ -> false 38 | 39 | let idm = [] 40 | let compm (mu, nu) = List.append nu mu 41 | 42 | let dom_m_constr mu = 43 | match mu with 44 | | L -> T 45 | | D -> S 46 | | G -> T 47 | | Box -> T 48 | 49 | let dom_mod mu mode = 50 | match mu with 51 | | [] -> mode 52 | | mu :: _ -> 53 | dom_m_constr mu 54 | 55 | let cod_m_constr mu = 56 | match mu with 57 | | L -> T 58 | | D -> T 59 | | G -> S 60 | | Box -> T 61 | 62 | let rec cod_mod mu mode = 63 | match mu with 64 | | [] -> mode 65 | | mu :: tail -> 66 | cod_mod tail (cod_m_constr mu) 67 | 68 | 69 | let eq_mode m1 m2 = 70 | match m1, m2 with 71 | | S, S -> true 72 | | T, T -> true 73 | | _, _ -> false 74 | 75 | (* A small NbE algorithm to evaluate modalities to normal forms *) 76 | (* L = Later, B = Box, D = Delta, G = Gamma *) 77 | (* Due to the rewriting system of the bowling pin mode theory our normal forms should be of the form *) 78 | 79 | type nf_m = 80 | | Sem_L of int 81 | | LB of int 82 | | LD of int 83 | | Sem_G 84 | 85 | (* Sem_L 0 is the identity modality for any mode. we do not need to consider the modes for normalization, here we may assume that the modalities are already well formed *) 86 | let sem_id = Sem_L 0 87 | 88 | let nf_eq mu nu = 89 | match mu, nu with 90 | | Sem_L n , Sem_L m -> Int.equal n m 91 | | LB n , LB m -> Int.equal n m 92 | | LD n , LD m -> Int.equal n m 93 | | Sem_G , Sem_G -> true 94 | | _ -> false 95 | 96 | let nf_leq mu nu = 97 | match mu, nu with 98 | | Sem_L n , Sem_L m -> n <= m 99 | | LB n , LB m -> n <= m 100 | | LD n , LD m -> n <= m 101 | | LB n , Sem_L m -> n <= m 102 | | Sem_G , Sem_G -> true 103 | | _ -> false 104 | 105 | let eval_m_constr mu = 106 | match mu with 107 | | L -> Sem_L 1 108 | | D -> LD 0 109 | | G -> Sem_G 110 | | Box -> LB 0 111 | 112 | (* Composition of Normal form with modality constructor. Again composition is the wrong way around, so that we can use fold_left... *) 113 | (* nf_comp Sem_L G == G o Sem_L *) 114 | let nf_comp nf mu = 115 | match nf , mu with 116 | | Sem_L n , L -> Sem_L (n + 1) 117 | | Sem_L _ , G -> Sem_G 118 | | Sem_L _ , Box -> LB 0 119 | | LB n , L -> LB (n + 1) 120 | | LB _ , G -> Sem_G 121 | | LB _ , Box -> LB 0 122 | | Sem_L 0 , D -> LD 0 123 | | LD n , L -> LD (n + 1) 124 | | LD _ , G -> sem_id 125 | | LD _ , Box -> LD 0 126 | | Sem_G , D -> LB 0 127 | | _ -> error_m "Not well defined composition of modalities or mistake in normal form algorithm, check nf_comp in mode theory implementation" 128 | 129 | let eval mu = List.fold_left nf_comp sem_id mu 130 | 131 | let leq mu nu = nf_leq (eval mu) (eval nu) 132 | 133 | let eq_mod mu nu = nf_eq (eval mu) (eval nu) 134 | 135 | (* We only have the identity and compositions of it. 136 | Hence if the domain of the cells are equal, there is no flex. 137 | *) 138 | 139 | let mode_to_sexp = function 140 | | S -> Sexp.Atom "s" 141 | | T -> Sexp.Atom "t" 142 | 143 | let mode_pp m = mode_to_sexp m |> Sexp.to_string_hum 144 | 145 | let m_constr_sexp mu = 146 | match mu with 147 | | L -> Sexp.Atom "l" 148 | | D -> Sexp.Atom "d" 149 | | G -> Sexp.Atom "g" 150 | | Box -> Sexp.Atom "box" 151 | 152 | let mod_to_sexp mu = 153 | let rec rec_helper mu = 154 | match List.rev mu with 155 | | [] -> [] 156 | | mu :: tail -> m_constr_sexp mu :: rec_helper tail in 157 | Sexp.List (rec_helper mu) 158 | 159 | let mod_pp mu = mod_to_sexp mu |> Sexp.to_string_hum 160 | 161 | (* Maps for binding modalities, cells and modes *) 162 | 163 | let mode_smap = [("s", S); ("S", S); ("t", T); ("T", T)] |> List.to_seq |> SMap.of_seq 164 | 165 | let m_smap = [("l", L); ("d", D); ("g", G); ("box", Box)] |> List.to_seq |> SMap.of_seq 166 | 167 | (*let m_macros = [("box", "g" :: ["d"])] |> List.to_seq |> SMap.of_seq *) 168 | 169 | let cell_smap = [("dg_id", ([G; D], [])); ("id_l", ([], [L]))] |> List.to_seq |> SMap.of_seq 170 | 171 | let bind_mode str = 172 | match SMap.find_opt str mode_smap with 173 | | Some v -> v 174 | | None -> error_m (str ^ " is not a mode of the bowling pin") 175 | 176 | let find_mod str = 177 | match SMap.find_opt str m_smap with 178 | | Some v -> v 179 | | None -> error_m (str ^ " is not a modality of bowling pin") 180 | 181 | let find_cell str = 182 | match SMap.find_opt str cell_smap with 183 | | Some v -> v 184 | | None -> error_m (str ^ " is not a 2-cell of the bowling pin") 185 | 186 | (* Macros should be expand during the bind process, so that the constructors are not part of the backend *) 187 | (*let rec expand_macros mu = 188 | match mu with 189 | | [] -> [] 190 | | str :: tail -> 191 | let new_tail = expand_macros tail in 192 | match SMap.find_opt str m_macros with 193 | | Option.Some lst -> List.append lst new_tail 194 | | Option.None -> str :: new_tail 195 | *) 196 | 197 | let rec bind_m mu = 198 | match mu with 199 | | [] -> [] 200 | | str :: tail -> 201 | let bound_mod = (find_mod str) in 202 | let bound_tail = bind_m tail in 203 | if equal_mode (cod_m_constr bound_mod) (dom_mod bound_tail (cod_m_constr bound_mod)) then bound_mod :: bound_tail 204 | else error_m (mod_pp (bound_mod :: bound_tail) ^ " is not well-formed") 205 | -------------------------------------------------------------------------------- /src/lib/check.ml: -------------------------------------------------------------------------------- 1 | module D = Domain 2 | module Syn = Syntax 3 | open Mode_theory 4 | 5 | (* The mode is the domain of the modality mu. This is needed because the implementation of modalities is ambiguous for identity modalitities.*) 6 | type env_entry = 7 | Term of {term : D.t; mu : m; tp : D.t; md : mode} 8 | | TopLevel of {term : D.t; tp : D.t; md : mode} 9 | | M of m 10 | type env = env_entry list 11 | 12 | let add_term ~md ~term ~mu ~tp env = Term {term; mu; tp; md} :: env 13 | 14 | type error = 15 | Cannot_synth_term of Syn.t 16 | | Type_mismatch of Syn.t * Syn.t * Syn.t 17 | | Term_or_Type_mismatch of Syn.t * Syn.t 18 | | Expecting_universe of Syn.t 19 | | Modality_mismatch of m * m * Syn.t * Syn.t 20 | | Mode_mismatch of mode * mode * Syn.t 21 | | Cell_fail of m * m * Syn.t * Syn.t 22 | | Misc of string 23 | 24 | let d_pp size v = Nbe.read_back_tp size v |> Syn.pp 25 | let dnf_pp size v = Nbe.read_back_nf size v |> Syn.pp 26 | 27 | let pp_error = function 28 | | Cannot_synth_term t -> "Cannot synthesize the type of:\n" ^ Syn.pp t 29 | | Type_mismatch (t1, t2, term) -> 30 | "Conversion mistake: Type-checking the subterm\n"^ Syn.pp term ^ "\nfailed. Cannot equate synthesized type\n" ^ (Syn.pp t1) ^ "\nwith expected type\n" ^ (Syn.pp t2) 31 | | Term_or_Type_mismatch (t1, t2) -> 32 | "Equality Type: Cannot equate\n" ^ (Syn.pp t1) ^ "\nwith\n" ^ (Syn.pp t2) 33 | | Expecting_universe d -> "Expected some universe for type found\n" ^ Syn.pp d 34 | | Modality_mismatch (mu, nu, tm1, tm2) -> "The modalities " ^ mod_pp mu ^" and " ^ mod_pp nu ^ "\nin the terms\n" ^ Syn.pp tm1 ^ "\nand\n" ^ Syn.pp tm2 ^ "\ndo not match." 35 | | Mode_mismatch (m, n, tm1) -> "The modes " ^ mode_pp m ^ " and " ^ mode_pp n ^ "\nin the derivation of the subterm\n" ^ Syn.pp tm1 ^ "\ndo not match." 36 | | Cell_fail (mu, nu, tm, tp) -> "Cannot derive that" ^ mod_pp mu ^ "<=" ^ mod_pp nu ^ "\nand therefore\n" ^ Syn.pp tm ^"\ncannot access the type\n" ^ Syn.pp tp 37 | | Misc s -> s 38 | 39 | exception Type_error of error 40 | 41 | let tp_error e = raise (Type_error e) 42 | 43 | let env_to_sem_env = 44 | List.map 45 | (function 46 | | TopLevel {term; _} -> D.Val term 47 | | Term {term; mu = _; tp = _} -> D.Val term 48 | | M mu -> D.M mu) 49 | 50 | let rec nth_lockless lst i = 51 | match lst with 52 | | [] -> tp_error (Misc "nth_lockless should not reach the empty list") 53 | | head :: lst -> 54 | match head with 55 | | Term {term; mu; tp; md} -> if Int.equal i 0 then (Term {term ; mu; tp; md} , idm) 56 | else if i > 0 then nth_lockless lst (i - 1) 57 | else tp_error (Misc "nth_lockless does not accept negativ Input") 58 | | TopLevel {term ; tp; md} -> if Int.equal i 0 then (TopLevel {term ; tp; md} , idm) 59 | else if i > 0 then nth_lockless lst (i - 1) 60 | else tp_error (Misc "nth_lockless does not accept negativ Input") 61 | | M mu -> let (tm, nu) = nth_lockless lst i in 62 | (tm , compm (nu, mu)) 63 | 64 | let nth_tm lst i = fst (nth_lockless lst i) 65 | let nth_cell lst i = snd (nth_lockless lst i) 66 | 67 | let get_var env n = match nth_tm env n with 68 | | Term {term = _; mu; tp; md} -> (Some mu, tp, md) 69 | | TopLevel {tp; term = _; md} -> (None, tp, md) 70 | | _ -> raise (Type_error (Misc "This case of get_var should not be reached")) 71 | 72 | let assert_subtype m size t1 t2 term = 73 | if Nbe.check_tp m ~subtype:true size t1 t2 74 | then () 75 | else tp_error (Type_mismatch (Nbe.read_back_tp size t1, Nbe.read_back_tp size t2, term)) 76 | 77 | let assert_equal m size t1 t2 tp = 78 | let nf1 = D.Normal {tp; term = t1} in 79 | let nf2 = D.Normal {tp; term = t2} in 80 | if Nbe.check_nf m size nf1 nf2 81 | then () 82 | else tp_error (Term_or_Type_mismatch (Nbe.read_back_nf size nf1, Nbe.read_back_nf size nf2)) 83 | 84 | let check_mode m n tm = 85 | match eq_mode m n with 86 | | true -> () 87 | | false -> tp_error (Mode_mismatch(m, n, tm)) 88 | 89 | let check_mod mu nu tm tp = 90 | match eq_mod mu nu with 91 | | true -> () 92 | | false -> tp_error (Modality_mismatch (mu, nu, tm, tp)) 93 | 94 | let check_cell mu nu tm tp = 95 | match leq mu nu with 96 | | true -> () 97 | | false -> tp_error (Cell_fail (mu, nu, tm, tp)) 98 | 99 | let rec check ~env ~size ~term ~tp ~m = 100 | match term with 101 | | Syn.Let (def, body) -> 102 | let def_tp = synth ~env ~size ~term:def ~m in 103 | let def_val = Nbe.eval def (env_to_sem_env env) in 104 | check ~env:(add_term ~md:m ~term:def_val ~mu:idm ~tp:def_tp env) ~size:(size + 1) ~term:body ~tp ~m 105 | | Syn.Nat -> 106 | begin 107 | match tp with 108 | | D.Uni _ -> () 109 | | p -> tp_error (Expecting_universe (Nbe.read_back_tp size p)) 110 | end 111 | | Syn.Sig (l, r) -> 112 | check ~env ~size ~term:l ~tp ~m; 113 | let l_sem = Nbe.eval l (env_to_sem_env env) in 114 | let var = D.mk_var l_sem size in 115 | check ~env:(add_term ~md:m ~term:var ~mu:idm ~tp:l_sem env) ~size ~term:r ~tp ~m 116 | | Syn.Pi (mu, l, r) -> 117 | check_mode (cod_mod mu m) m term; 118 | let new_env = M mu :: env in 119 | let new_mode = dom_mod mu m in 120 | check ~env:new_env ~size ~term:l ~tp ~m:new_mode; 121 | let l_sem = Nbe.eval l (env_to_sem_env new_env) in 122 | let var = D.mk_var l_sem size in 123 | check ~env:(add_term ~md:new_mode ~term:var ~mu:mu ~tp:l_sem env) ~size ~term:r ~tp ~m 124 | | Syn.Lam f -> 125 | begin 126 | match tp with 127 | | D.Pi (mu, src , dest) -> 128 | let new_mode = dom_mod mu m in 129 | let var = D.mk_var src size in 130 | let dest_tp = Nbe.do_clos dest var in 131 | check ~env:(add_term ~md:new_mode ~term:var ~tp:src ~mu:mu env) ~size:(size + 1) ~term:f ~tp:dest_tp ~m ; 132 | | t -> tp_error (Misc ("Expecting Pi but found\n" ^ d_pp size t)) 133 | end 134 | | Syn.Pair (left, right) -> 135 | begin 136 | match tp with 137 | | D.Sig (left_tp, right_tp) -> 138 | check ~env ~size ~term:left ~tp:left_tp ~m; 139 | let left_sem = Nbe.eval left (env_to_sem_env env) in 140 | check ~env ~size ~term:right ~tp:(Nbe.do_clos right_tp left_sem) ~m 141 | | t -> tp_error (Misc ("Expecting Sig but found\n" ^ d_pp size t)) 142 | end 143 | | Syn.Uni i -> 144 | begin 145 | match tp with 146 | | Uni j when i < j -> () 147 | | t -> 148 | let msg = 149 | "Expecting universe over " ^ string_of_int i ^ " but found\n" ^ d_pp size t in 150 | tp_error (Misc msg) 151 | end 152 | | Syn.TyMod (mu, a) -> 153 | check_mode (cod_mod mu m) m term; 154 | let new_env = M mu :: env in 155 | let new_mode = dom_mod mu m in 156 | check ~env:new_env ~size ~term:a ~tp ~m:new_mode; 157 | | Syn.Mod (mu, tm) -> 158 | check_mode (cod_mod mu m) m term; 159 | begin 160 | match tp with 161 | | D.Tymod (nu, tp1) -> 162 | begin 163 | match eq_mod mu nu with 164 | | true -> 165 | let new_env = M nu :: env in 166 | let new_mode = dom_mod nu m in 167 | check ~env:new_env ~size ~term:tm ~tp:tp1 ~m:new_mode; 168 | | false -> tp_error (Modality_mismatch(mu, nu, (Syn.Mod (mu,tm)), Nbe.read_back_tp size tp)) 169 | end 170 | | _ -> tp_error (Misc ("A subterm requires a modal type with modality "^ mod_pp mu ^ " but found \n" ^ d_pp size tp)) 171 | end 172 | | Id (tp', l, r) -> 173 | begin 174 | match tp with 175 | | D.Uni _ -> 176 | check ~env ~size ~term:tp' ~tp ~m; 177 | let tp' = Nbe.eval tp' (env_to_sem_env env) in 178 | check ~env ~size ~term:l ~tp:tp' ~m; 179 | check ~env ~size ~term:r ~tp:tp' ~m 180 | | t -> tp_error (Expecting_universe (Nbe.read_back_tp size t)) 181 | end 182 | | Refl term -> 183 | begin 184 | match tp with 185 | | D.Id (tp, left, right) -> 186 | check ~env ~size ~term ~tp ~m; 187 | let term = Nbe.eval term (env_to_sem_env env) in 188 | assert_equal m size term left tp; 189 | assert_equal m size term right tp 190 | | t -> tp_error (Misc ("Expecting Id but found\n" ^ d_pp size t)) 191 | end 192 | | term -> assert_subtype m size (synth ~env ~size ~term ~m) tp term; 193 | 194 | and synth ~env ~size ~term ~m = 195 | match term with 196 | | Syn.Var id -> 197 | let (mu, tp, md) = get_var env id in 198 | let locks = nth_cell env id in 199 | (* Verify whether the toplevel definitions are used at the correct 0-cell, 200 | (we also check terms, but they should be fine anyways) 201 | * It also validates that mu has the correct boundary, since we only allow entries where md is the domain of mu *) 202 | check_mode md m term; 203 | begin 204 | match mu with 205 | | Some mu -> 206 | begin 207 | (* Verify whether a cell exists that allows us to access the variable*) 208 | check_cell mu locks term (Nbe.read_back_tp size tp); 209 | end 210 | | None -> () 211 | end; 212 | tp 213 | | Syn.Let (def, body) -> 214 | let def_tp = synth ~env ~size ~term:def ~m in 215 | let def_val = Nbe.eval def (env_to_sem_env env) in 216 | synth ~env:(add_term ~md:m ~term:def_val ~mu:idm ~tp:def_tp env) ~size:(size + 1) ~term:body ~m 217 | | Syn.Check (term, tp') -> 218 | let tp = Nbe.eval tp' (env_to_sem_env env) in 219 | check ~env ~size ~term ~tp ~m; 220 | tp 221 | | Syn.Zero -> D.Nat 222 | | Syn.Suc term -> check ~env ~size ~term ~tp:Nat ~m; D.Nat 223 | | Syn.Fst p -> 224 | begin 225 | match (synth ~env ~size ~term:p ~m) with 226 | | Sig (left_tp, _) -> left_tp 227 | | t -> tp_error (Misc ("Expecting Sig but found\n" ^ d_pp size t)) 228 | end 229 | | Syn.Snd p -> 230 | begin 231 | match (synth ~env ~size ~term:p ~m) with 232 | | Sig (_, right_tp) -> 233 | let proj = Nbe.eval (Fst p) (env_to_sem_env env) in 234 | Nbe.do_clos right_tp proj 235 | | t -> tp_error (Misc ("Expecting Sig but found\n" ^ d_pp size t)) 236 | end 237 | | Syn.Ap (mu, f, a) -> 238 | begin 239 | check_mode (cod_mod mu m) m term; 240 | match (synth ~env ~size ~term:f ~m) with 241 | | D.Pi (nu , src , dest) -> 242 | check_mod mu nu term (Nbe.read_back_tp size (D.Pi (nu , src , dest))); 243 | let new_env = (M mu :: env) in 244 | let new_mode = dom_mod mu m in 245 | check ~env:new_env ~size ~term:a ~tp:src ~m:new_mode; 246 | let a_sem = Nbe.eval a (env_to_sem_env new_env) in 247 | Nbe.do_clos dest a_sem 248 | | t -> tp_error (Misc ("Expecting Pi but found\n" ^ d_pp size t)) 249 | end 250 | | Syn.NRec (mot, zero, suc, n) -> 251 | check ~env ~size ~term:n ~tp:Nat ~m; 252 | let var = D.mk_var Nat size in 253 | check_tp ~env:(add_term ~md:m ~term:var ~mu:idm ~tp:Nat env) ~size:(size + 1) ~term:mot ~m; 254 | let sem_env = env_to_sem_env env in 255 | let zero_tp = Nbe.eval mot ((D.Val Zero) :: sem_env) in 256 | let ih_tp = Nbe.eval mot ((D.Val var) :: sem_env) in 257 | let ih_var = D.mk_var ih_tp (size + 1) in 258 | let suc_tp = Nbe.eval mot (Val (Suc var) :: sem_env) in 259 | check ~env ~size ~term:zero ~tp:zero_tp ~m; 260 | check 261 | ~env:(add_term ~md:m ~term:var ~mu:idm ~tp:Nat env |> add_term ~md:m ~term:ih_var ~mu:idm ~tp:ih_tp) 262 | ~size:(size + 2) 263 | ~term:suc 264 | ~tp:suc_tp 265 | ~m ; 266 | Nbe.eval mot (Val (Nbe.eval n sem_env) :: sem_env) 267 | | Syn.Letmod (mu, nu, mot, deptm, tm) -> 268 | begin 269 | let cod_mu = m in 270 | let dom_mu = dom_mod mu m in 271 | check_mode cod_mu m term; 272 | let new_env = M mu :: env in 273 | let new_mode = dom_mu in 274 | let tp1 = synth ~env:new_env ~size ~term:tm ~m:new_mode in 275 | match tp1 with 276 | | D.Tymod (nu1, tp) -> 277 | check_mod nu nu1 tm (Nbe.read_back_tp size tp1) ; 278 | let new_head = Term {term = D.mk_var (D.Tymod (nu1, tp)) size; mu = mu; tp = D.Tymod (nu1, tp); md = new_mode} in 279 | let mot_env = new_head :: env in 280 | check_tp ~env:mot_env ~size:(size + 1) ~term:mot ~m; 281 | let deptm_env = Term {term = D.mk_var tp size; mu = compm (mu, nu1); tp = tp; md = dom_mod (compm (mu, nu1)) m} :: env in 282 | let base_sem_env = env_to_sem_env env in 283 | let sem_env = D.Val (D.Mod (nu1, D.mk_var tp size)) :: base_sem_env in 284 | let sem_deptm_ty = Nbe.eval mot sem_env in 285 | check ~env:deptm_env ~size:(size + 1) ~term:deptm ~tp:sem_deptm_ty ~m; 286 | let final_tp_env = D.Val (Nbe.eval tm base_sem_env) :: base_sem_env in 287 | Nbe.eval mot final_tp_env 288 | | _ -> tp_error (Misc ("Expecting Modal Type with"^ mod_pp nu ^ "but found \n" ^ d_pp size tp1)) 289 | end 290 | | Syn.J (mot, refl, eq) -> 291 | let eq_tp = synth ~env ~size ~term:eq ~m in 292 | begin 293 | let sem_env = env_to_sem_env env in 294 | match eq_tp with 295 | | D.Id (tp', left, right) -> 296 | let mot_var1 = D.mk_var tp' size in 297 | let mot_var2 = D.mk_var tp' (size + 1) in 298 | let mot_var3 = D.mk_var (D.Id (tp', mot_var1, mot_var2)) (size + 1) in 299 | let mot_env = 300 | add_term ~md:m ~term:mot_var1 ~mu:idm ~tp:tp' env 301 | |> add_term ~md:m ~term:mot_var2 ~mu:idm ~tp:tp' 302 | |> add_term ~md:m ~term:mot_var3 ~mu:idm ~tp:(D.Id (tp', mot_var1, mot_var2)) in 303 | check_tp ~env:mot_env ~size:(size + 3) ~term:mot ~m; 304 | let refl_var = D.mk_var tp' size in 305 | let refl_tp = Nbe.eval mot (D.Val (D.Refl refl_var) :: D.Val refl_var :: D.Val refl_var :: sem_env) in 306 | check ~env:(add_term ~md:m ~term:refl_var ~mu:idm ~tp:tp' env) ~size:(size + 1) ~term:refl ~tp:refl_tp ~m; 307 | Nbe.eval mot (D.Val (Nbe.eval eq sem_env) :: D.Val right :: D.Val left :: sem_env) 308 | | t -> tp_error (Misc ("Expecting Id but found\n" ^ d_pp size t)) 309 | end 310 | | Syn.Axiom (_, tp) -> Nbe.eval tp (env_to_sem_env env) 311 | | _ -> tp_error (Cannot_synth_term term) 312 | 313 | and check_tp ~env ~size ~term ~m = 314 | match term with 315 | | Syn.Nat -> () 316 | | Syn.Uni _ -> () 317 | | Syn.Pi (mu, src, dest) -> 318 | check_mode (cod_mod mu m) m term; 319 | let new_env = M mu :: env in 320 | let new_mode = dom_mod mu m in 321 | check_tp ~env:new_env ~size ~term:src ~m:new_mode; 322 | let l_sem = Nbe.eval src (env_to_sem_env new_env) in 323 | let var = D.mk_var l_sem size in 324 | check_tp ~env:(add_term ~md:new_mode ~term:var ~mu:mu ~tp:l_sem env) ~size:(size + 1) ~term:dest ~m 325 | | Syn.Sig (l, r) -> check_tp ~env ~size ~term:l ~m; 326 | let l_sem = Nbe.eval l (env_to_sem_env env) in 327 | let var = D.mk_var l_sem size in 328 | check_tp ~env:(add_term ~md:m ~term:var ~mu:idm ~tp:l_sem env) ~size:(size + 1) ~term:r ~m 329 | | Syn.Let (def, body) -> 330 | let def_tp = synth ~env ~size ~term:def ~m in 331 | let def_val = Nbe.eval def (env_to_sem_env env) in 332 | check_tp ~env:(add_term ~md:m ~term:def_val ~mu:idm ~tp:def_tp env) ~size:(size + 1) ~term:body ~m 333 | | Syn.TyMod (mu, tp) -> 334 | check_mode (cod_mod mu m) m term; 335 | let new_env = M mu :: env in 336 | let new_mode = dom_mod mu m in 337 | check_tp ~env:new_env ~size ~term:tp ~m:new_mode; 338 | | Syn.Id (tp, l, r) -> 339 | check_tp ~env ~size ~term:tp ~m; 340 | let tp = Nbe.eval tp (env_to_sem_env env) in 341 | check ~env ~size ~term:l ~tp ~m; 342 | check ~env ~size ~term:r ~tp ~m 343 | | term -> 344 | begin 345 | match (synth ~env ~size ~term ~m) with 346 | | D.Uni _ -> () 347 | | t -> tp_error (Expecting_universe (Nbe.read_back_tp size t)) 348 | end 349 | -------------------------------------------------------------------------------- /test/guarded_rec.tt: -------------------------------------------------------------------------------- 1 | ;; Guarded Rec 2 | ;; g 3 | ;; --> 4 | ;; l < T S 5 | ;; <--- 6 | ;; d 7 | ;; id_l : id -> l 8 | ;; dg_id: d o g -> id 9 | ;; box := d o g 10 | 11 | ;; -------- Find some interesting evaluations at the bottom, uncomment to execute ------------- 12 | 13 | ;; USAGE of LETMOD: 14 | ;; let example : {mu | << nu | Nat >>} -> << rho | Nat >> @ M 15 | ;; fun x0 -> letmod mu (fun z -> A(z)) mod nu (x1) <- x0 in (mod rho x1) 16 | 17 | ;; EXPLANATION: 18 | ;; 1. mu denotes the framing modality of the type we want to eliminate 19 | ;; 2. (fun z -> A(z)) denotes the (potentially dependent) type we eliminate into. In this example A(z) = << rho | Nat >> 20 | ;; 3. nu denotes the modality of the modal type 21 | ;; 4. "mod nu (x1) <- x0" means that in the body of the letmod expression we may assume that x0 is of the form mod nu (x1) 22 | ;; and thus we can use "x1 : {mu . nu | Nat}" instead 23 | ;; 5. "mod rho x1" is the body of the function. It silently requires that nu . mu <= rho in your mode theory. Otherwise, 24 | ;; type checkin will fail with "cannot derive (mu . nu) <= rho" 25 | ;; 6. @ M is the mode where the term is formed. It has to be the case that codomain(rho) = codomain(mu) = M 26 | 27 | 28 | ;; AXIOMS 29 | ;; We can axiomatize constants at any mode, for instance: 30 | ;; axiom lob : (A : U<0>) -> ({l | A} -> A) -> A @ T 31 | ;; These will break canonicity but type checking still works. Equational reasoning (working with identity types) becomes 32 | ;; very difficult. 33 | 34 | ;;-------------- EQUALITY AXIOM and LEMMA --------------------- 35 | 36 | let inv_eq1 : (A : U<0>) -> (B : U<0>) -> (Id U<0> A B) -> Id U<0> B A @ T = 37 | fun A B eq -> 38 | match eq at x y q -> (Id U<0> y x) with 39 | | refl x -> refl x 40 | 41 | 42 | let happly : (A : U<0>) -> (B : U<0>) -> (f : A -> B) -> (g : A -> B) -> (p : Id (A -> B) f g) -> (a : A) -> Id B (f a) (g a) @ T = 43 | fun A B f g eq a -> 44 | match eq at x y p -> Id B (x a) (y a) with 45 | | refl x -> refl (x a) 46 | 47 | let ap : (A : U<0>) -> (B : U<0>) -> (f : A -> B) -> (a : A) -> (b : A) -> (Id A a b) -> Id B (f a) (f b) @ S = 48 | fun A B f a b eq -> 49 | match eq at x y p -> Id B (f x) (f y) with 50 | | refl x -> refl (f x) 51 | 52 | let ap_prod_1 : (A : U<0>) -> (B : U<0>) -> (p : A * B) -> (q : A * B) -> (Id (A * B) p q) -> Id A (fst p) (fst q) @ T = 53 | fun A B p1 p2 eq -> 54 | match eq at x y q -> Id A (fst x) (fst y) with 55 | | refl x -> refl (fst x) 56 | 57 | let ap_prod_2 : (A : U<0>) -> (B : U<0>) -> (p : A * B) -> (q : A * B) -> (Id (A * B) p q) -> Id B (snd p) (snd q) @ T = 58 | fun A B p1 p2 eq -> 59 | match eq at x y q -> Id B (snd x) (snd y) with 60 | | refl x -> refl (snd x) 61 | 62 | 63 | let transport1 : (A : U<0>) -> (B : U<0>) -> (Id U<0> A B) -> A -> B @ T = 64 | fun A B eq -> 65 | match eq at x y p -> x -> y with 66 | | refl z -> fun x -> x 67 | 68 | let transport1_inv : (A : U<0>) -> (B : U<0>) -> (Id U<0> A B) -> B -> A @ T = 69 | fun A B eq -> 70 | match eq at x y p -> y -> x with 71 | | refl z -> fun x -> x 72 | 73 | 74 | let trans_eq : (A : U<0>) -> (B : U<0>) -> (eq : Id U<0> A B) -> Id (A -> A) (fun a -> transport1_inv A B eq (transport1 A B eq a)) (fun a -> a) @ T = 75 | fun A B eq -> 76 | match eq at x y p -> Id (x -> x) (fun a -> transport1_inv x y p (transport1 x y p a)) (fun a -> a) with 77 | | refl z -> refl (fun x -> x) 78 | 79 | let trans_eq_inv : (A : U<0>) -> (B : U<0>) -> (eq : Id U<0> A B) -> Id (B -> B) (fun b -> transport1 A B eq (transport1_inv A B eq b)) (fun b -> b) @ T = 80 | fun A B eq -> 81 | match eq at x y p -> Id (y -> y) (fun a -> transport1 x y p (transport1_inv x y p a)) (fun a -> a) with 82 | | refl z -> refl (fun x -> x) 83 | 84 | let trans_eq1 : (A : U<0>) -> (B : U<0>) -> (eq : Id U<0> A B) -> (a : A) -> Id A (transport1_inv A B eq (transport1 A B eq a)) a @ T = 85 | fun A B eq a -> happly A 86 | A 87 | (fun a -> transport1_inv A B eq (transport1 A B eq a)) 88 | (fun a -> a) 89 | (trans_eq A B eq) 90 | a 91 | 92 | let trans_eq_inv1 : (A : U<0>) -> (B : U<0>) -> (eq : Id U<0> A B) -> (b : B) -> Id B (transport1 A B eq (transport1_inv A B eq b)) b @ T = 93 | fun A B eq b -> happly B 94 | B 95 | (fun x -> transport1 A B eq (transport1_inv A B eq x)) 96 | (fun x -> x) 97 | (trans_eq_inv A B eq) 98 | b 99 | 100 | ;; ------------------------ Crisp induction -------------------------------- 101 | axiom crisp_g : (A : {g | U<0>}) -> (a : {g | A}) -> (b : {g | A}) -> {g | Id A a b} -> Id (<< g | A >>) (mod g a) (mod g b) @ S 102 | 103 | ;; ------------------- Box is an idempotant comonad ------------------------ 104 | let dup_inv : (A : {box . box | U<0>}) -> << box | << box | A >> >> -> << box | A >> @ T = 105 | fun A -> fun x -> 106 | letmod idm (fun z -> << box | A >>) mod box (y) <- x in 107 | letmod box (fun z -> << box | A >>) mod box (z) <- y in 108 | mod (box . box) z 109 | 110 | normalize dup_inv {box . box, Nat} at << box | << box | Nat >> >> -> << box | Nat >> @ T 111 | 112 | 113 | ;; ------------------- Modal elimination tests ---------------------- 114 | let triv : (A : U<0>) -> (x : A) -> <> @ S = 115 | fun A -> fun x -> mod idm x 116 | 117 | ;; -------------- The next function for the later modality, next1 is defined over the universe ----------- 118 | let next : (A : U<0>) -> A -> << l | A >> @ T = 119 | fun A -> fun x -> mod l x 120 | 121 | 122 | let next1 : U<0> -> << l | U<0> >> @ T = 123 | fun x -> mod l x 124 | 125 | let coe : (A : U<0>) -> A -> << l | A >> @ T = 126 | fun A x -> mod l x 127 | 128 | let l-apply : (A : {l | U<0>}) -> (B : {l | U<0>}) -> << l | A -> B >> -> << l | A >> -> << l | B >> @ T = 129 | fun A B f a -> letmod idm (fun _ -> << l | B >>) mod l (g) <- f in 130 | letmod idm (fun _ -> << l | B >>) mod l (b) <- a in 131 | mod l (g b) 132 | ;; -------------------- AXIOMS for Guarded Rec ------------- 133 | 134 | axiom lob : (A : U<0>) -> ({l | A} -> A) -> A @ T 135 | axiom lob1 : ({l | U<0>} -> U<0>) -> U<0> @ T 136 | axiom lob_beta : 137 | (A : U<0>) -> 138 | (f : {l | A} -> A) -> 139 | Id A (lob A f) (letmod idm (fun z -> A) mod l (x) <- next A (lob A f) in f {l, x}) 140 | @ T 141 | axiom lob1_beta : 142 | (f : {l | U<0>} -> U<0>) -> 143 | Id U<0> (lob1 f) (letmod idm (fun z -> U<0>) mod l (x) <- next1 (lob1 f) in f {l, x}) 144 | @ T 145 | 146 | ;; -------------- Guarded Streams ----------------------- 147 | 148 | let gstream : (A : U<0>) -> U<0> @ T = 149 | fun A -> lob1 (fun x -> A * << l | x >>) 150 | 151 | let gstream_fun : (A : U<0>) -> {l | U<0>} -> U<0> @ T = 152 | fun A s -> A * << l | s >> 153 | 154 | ;; ------- Note that 155 | ;; letmod idm (fun z -> U<0>) mod l (x) <- next1 (gstream A) in (gstream_fun A) {l, x} 156 | ;; -------> A * << l | gstream A >> 157 | 158 | let unfold : (A : U<0>) -> (gstream A) -> A * << l | gstream A >> 159 | @ T = 160 | fun A str -> 161 | transport1 162 | (gstream A) 163 | (A * << l | gstream A >>) 164 | (lob1_beta (gstream_fun A)) 165 | str 166 | 167 | ;;let fold : (A : U<0>) -> (A * << l | gstream A >>) -> gstream A @ T = 168 | ;; fun A str -> 169 | ;; transport1 170 | ;; (A * << l | gstream A >>) 171 | ;; (gstream A) 172 | ;; (inv_eq1 173 | ;; (gstream A) 174 | ;; (A * << l | gstream A >>) 175 | ;; (lob1_beta (gstream_fun A))) 176 | ;; str 177 | 178 | let fold : (A : U<0>) -> (A * << l | gstream A >>) -> gstream A @ T = 179 | fun A str -> 180 | transport1_inv 181 | (gstream A) 182 | (A * << l | gstream A >>) 183 | (lob1_beta (gstream_fun A)) 184 | str 185 | 186 | let fold_unfold : (A : U<0>) -> (s : gstream A) -> Id (gstream A) (fold A (unfold A s)) s @ T = 187 | fun A s -> trans_eq1 (gstream A) (A * << l | gstream A >>) (lob1_beta (gstream_fun A)) s 188 | 189 | let unfold_fold : (A : U<0>) -> (p : A * << l | gstream A >>) -> Id (A * << l | gstream A >>) (unfold A (fold A p)) p @ T = 190 | fun A p -> trans_eq_inv1 (gstream A) (A * << l | gstream A >>) (lob1_beta (gstream_fun A)) p 191 | ;; ------------- 192 | 193 | let ghead : (A : U<0>) -> (gstream A) -> A @ T = 194 | fun A lst -> fst (unfold A lst) 195 | 196 | let gtail : (A : U<0>) -> (gstream A) -> << l | gstream A >> @ T = 197 | fun A str -> snd (unfold A str) 198 | 199 | let gcons : (A : U<0>) -> A -> << l | gstream A >> -> gstream A @ T = 200 | fun A head tail -> fold A (pair (head , tail)) 201 | 202 | let ghead_eq : (A : U<0>) -> (a : A) -> (s : << l | gstream A >>) -> Id A (ghead A (gcons A a s)) a @ T = 203 | fun A head tail -> ap_prod_1 A (<< l | gstream A >>) (unfold A (fold A (pair (head, tail)))) (pair (head, tail)) 204 | (unfold_fold A (pair (head, tail))) 205 | 206 | let gtail_eq : (A : U<0>) -> (a : A) -> (s : << l | gstream A >>) -> Id (<< l | gstream A >>) (gtail A (gcons A a s)) s @ T = 207 | fun A head tail -> ap_prod_2 A (<< l | gstream A >>) (unfold A (fold A (pair (head, tail)))) (pair (head, tail)) 208 | (unfold_fold A (pair (head, tail))) 209 | 210 | let gcons_eq : (A : U<0>) -> (s : gstream A) -> Id (gstream A) (gcons A (ghead A s) (gtail A s)) s @ T = 211 | fun A s -> fold_unfold A s 212 | 213 | ;; ------------- Now one could try to prove things like stream = gcons (ghead stream , gtail stream) 214 | ;; ------------- Equational reasoning is however very difficult in a system without function extensionality 215 | 216 | ;; ------------- Some MTT functions needed to work around the fact that << idm | A >> =/= A and ----------------- 217 | ;; -------------- << g | << d | A >> >> =/= << g . d | A >> = << idm | A >> ------------------------ 218 | 219 | let triv_S : (A : U<0>) -> << idm | A >> -> A @ S = 220 | fun A x -> letmod idm (fun z -> A) mod idm (y) <- x in y 221 | 222 | let triv_T : (A : U<0>) -> << idm | A >> -> A @ T = 223 | fun A x -> letmod idm (fun z -> A) mod idm (y) <- x in y 224 | 225 | let comp_g-d : (A : U<0>) -> << g | << d | A >> >> -> A @ S = 226 | fun A x -> letmod idm (fun z -> A) mod g (y) <- x in 227 | letmod g (fun z -> A) mod d (z) <- y in 228 | triv_S A (mod (g . d) z) 229 | 230 | let comp_g-l : (A : { g | U<0>}) -> << g | << l | A >> >> -> << g | A >> @ S = 231 | fun A x -> letmod idm (fun z -> << g | A >>) mod g (y) <- x in 232 | letmod g (fun z -> << g | A >>) mod l (z) <- y in 233 | mod (g . l) z 234 | 235 | ;; ----------------------------- Streams Basics -------------------------- 236 | ;; ----------- Here I define head, tail and cons for streams ------------- 237 | ;; ----------- Type of constant naturals at T --------------------- 238 | 239 | let NatD : U<0> @ T = << d | Nat >> 240 | 241 | let stream : (A : U<0>) -> U<0> @ S = 242 | fun A -> << g | gstream << d | A >> >> 243 | 244 | 245 | let head : (A : U<0>) -> (stream A) -> A @ S = 246 | fun A str -> letmod idm (fun z -> A) mod g (gstr) <- str in 247 | comp_g-d A (mod g (ghead (<< d | A >>) gstr)) 248 | 249 | let tail : (A : U<0>) -> (stream A) -> stream A @ S = 250 | fun A str -> letmod idm (fun z -> stream A) mod g (gstr) <- str in 251 | comp_g-l {g , (gstream << d | A >>)} (mod g (gtail (<< d | A >>) gstr)) 252 | 253 | let cons : (A : U<0>) -> A -> (stream A) -> stream A @ S = 254 | fun A a str -> letmod idm (fun z -> stream A) mod g (gstr) <- str in 255 | mod g (gcons << d | A >> (mod d a) (next (gstream << d | A >>) gstr)) 256 | 257 | let stream_uni_helper : (A : {d | U<0>}) -> (S : {d | U<0>}) -> (f : {d | (S -> A * S)}) -> (<< d | S >>) -> gstream (<< d | A >>) @ T = 258 | fun A S f -> lob ((<< d | S >>) -> gstream (<< d | A >>)) 259 | (fun g s -> letmod idm (fun z -> gstream << d | A >>) mod d (t) <- s in 260 | gcons (<< d | A >>) 261 | (mod d (fst (f t))) 262 | (mod l (g (mod d (snd (f t))))) 263 | ) 264 | let stream_uni : (A : U<0>) -> (S : U<0>) -> (f : (S -> A * S)) -> S -> stream A @ S = 265 | fun A S f s -> mod g (stream_uni_helper {d , A} {d , S} {d , f} (mod d s)) 266 | 267 | ;; Not sure what is failing here... 268 | ;;let cons_eq : (A : U<0>) -> (s : stream A) -> Id (stream A) (cons A (head A s) (tail A s)) s @ S = 269 | ;; fun A str -> letmod idm (fun s -> Id (stream A) (cons A (head A s) (tail A s)) s) mod g (gstr) <- str in 270 | ;; crisp_g {g , gstream << d | A >>} 271 | ;; {g , gcons << d | A >> (ghead << d | A >> gstr) (gtail << d | A >> gstr)} 272 | ;; {g , gstr} 273 | ;; {g , gcons_eq (<< d | A >>) (gstr)} 274 | 275 | 276 | 277 | let head_eq : (A : U<0>) -> (a : A) -> (s : stream A) -> Id A (head A (cons A a s)) a @ S = 278 | fun A a str -> letmod idm (fun s -> Id A (head A (cons A a s)) a) mod g (gstr) <- str in 279 | ap (<< g | << d | A >> >>) 280 | A 281 | (comp_g-d A) 282 | (mod g (ghead (<< d | A >>) (gcons (<< d | A >>) (mod d a)(mod l gstr)))) 283 | (mod g (mod d a)) 284 | (crisp_g {g , << d | A >>} 285 | {g , ghead (<< d | A >>) (gcons (<< d | A >>) (mod d a) (mod l gstr))} 286 | {g , mod d a} 287 | {g , ghead_eq (<< d | A >>) (mod d a) (mod l gstr)}) 288 | 289 | let tail_eq : (A : U<0>) -> (a : A) -> (s : stream A) -> Id (stream A) (tail A (cons A a s)) s @ S = 290 | fun A a str -> letmod idm (fun s -> Id (stream A) (tail A (cons A a s)) s) mod g (gstr) <- str in 291 | ap (<< g | << l | (gstream << d | A >>) >> >>) 292 | (stream A) 293 | (comp_g-l {g, gstream << d | A >>}) 294 | (mod g (gtail (<< d | A >>) (gcons (<< d | A >>) (mod d a)(mod l gstr)))) 295 | (mod g (mod l gstr)) 296 | (crisp_g {g , << l | gstream << d | A >> >>} 297 | {g , gtail (<< d | A >>) (gcons (<< d | A >>) (mod d a) (mod l gstr))} 298 | {g , mod l gstr} 299 | {g , gtail_eq (<< d | A >>) (mod d a) (mod l gstr)}) 300 | 301 | 302 | let nth : Nat -> (stream Nat) -> Nat @ S = 303 | fun n -> 304 | rec n at _ -> (stream Nat) -> Nat with 305 | | zero -> (fun str -> head Nat str) 306 | | suc _ , p -> (fun str -> p (tail Nat str)) 307 | 308 | 309 | let map : (A : U<0>) -> (A -> A) -> (gstream A) -> gstream A @ T = 310 | fun A g -> lob ((gstream A) -> gstream A) 311 | (fun f -> 312 | fun gstr -> gcons A (g (ghead A gstr)) 313 | (mod l (f gstr))) 314 | 315 | ;; ---------------- observe that f : {l | gstream Nat -> gstream Nat} and gstr : gstream Nat --------- 316 | ;; ---------------- but the 2-cell 1<= l is elaborated, so actually the term is (f {gstr, 1<= l}) 317 | 318 | ;; ----------------------------- Stream Examples -------------------------- 319 | ;; --------------------- Stream constantly 0 ------------------------------ 320 | 321 | let zeros : stream Nat @ S = 322 | mod g (lob (gstream << d | Nat >>) (fun gstr -> gcons (<< d | Nat >>) (mod d 0) (mod l gstr))) 323 | 324 | 325 | 326 | ;; ---------------- Stream of all natural numbers ---------------------- 327 | let nats : stream Nat @ S = 328 | mod g (lob (gstream << d | Nat >>) 329 | (fun gstr -> gcons (<< d | Nat >>) (mod d 0) (mod l (map (<< d | Nat >>) 330 | (fun x -> letmod idm (fun z -> << d | Nat >>) mod d (y) <- x in mod d (suc y)) 331 | gstr)))) 332 | 333 | ;; ----------------- Stream toggling 0 and 1 -------------------------------- 334 | let toggle : gstream NatD @ T = 335 | lob (gstream NatD) 336 | (fun gstr -> gcons NatD 337 | (mod d 1) 338 | (next (gstream NatD) (gcons NatD (mod d 0) (mod l gstr) ))) 339 | 340 | 341 | let interleave : (gstream NatD) -> { l | (gstream NatD) } -> gstream NatD @ T = 342 | lob ((gstream NatD) -> { l | (gstream NatD) } -> gstream NatD ) 343 | (fun inleave -> (fun gstr1 gstr2 -> gcons NatD 344 | (ghead NatD gstr1) 345 | (letmod idm (fun z -> << l | gstream NatD >>) mod l (open) <- (gtail NatD gstr1) in (mod l (inleave gstr2 {l , open}))))) 346 | 347 | let paperfold : gstream NatD @ T = 348 | lob (gstream NatD) (fun gstr -> interleave toggle {l , gstr}) 349 | 350 | ;; ------------------ Coinductive streams, in particular acausal definitions that cannot be done only using later ------------------------------- 351 | 352 | 353 | let every2nd : (A : {d | U<0>}) -> {d | stream A} -> (gstream << d | A >>) @ T = 354 | fun A -> lob ({d | stream A} -> (gstream << d | A >>)) (fun f str -> gcons (<< d | A>>) (mod d (head A str)) (mod l (f {d , (tail A (tail A str))}))) 355 | 356 | let every2nd_nat : (stream Nat) -> stream Nat @ S = 357 | fun str -> mod g (every2nd {d, Nat} {d, str}) 358 | 359 | let evens : stream Nat @ S = every2nd_nat nats 360 | 361 | 362 | ;; --------------------NORMAL FORMS OF UNCANONICAL TERMS INTRODUCED BY LÖB --------------------------------------- 363 | ;; -------------------- Note: We cannot compute löb if we want to have decidable type checking! ------------------ 364 | 365 | ;; -------------------- Theoretically: head Nat zeros = zero ------------------------------- 366 | ;; normalize (head Nat zeros) at Nat @ S 367 | 368 | ;; ------------------- Uncomment if you want to see some truely horrible expression for the number 8 --------------------- 369 | ;; normalize (nth 5 evens) at Nat @ S 370 | -------------------------------------------------------------------------------- /src/lib/nbe.ml: -------------------------------------------------------------------------------- 1 | module Syn = Syntax 2 | 3 | module D = Domain 4 | open Mode_theory 5 | 6 | exception Nbe_failed of string 7 | 8 | let rec clos_mod (D.Clos {term; env}) mu = D.Clos {term = term; env = D.M mu :: env} 9 | 10 | and gen_do_clos (D.Clos {term; env}) a = eval term (a :: env) 11 | and do_clos clos a = gen_do_clos clos (D.Val a) 12 | 13 | and gen_do_clos2 (D.Clos2 {term; env}) a1 a2 = eval term ( a2 :: a1 :: env) 14 | and do_clos2 clos a1 a2 = gen_do_clos2 clos (Val a1) (Val a2) 15 | 16 | and gen_do_clos3 (D.Clos3 {term; env}) a1 a2 a3 = eval term (a3 :: a2 :: a1 :: env) 17 | and do_clos3 clos a1 a2 a3 = gen_do_clos3 clos (Val a1) (Val a2) (Val a3) 18 | 19 | and do_rec tp zero suc n = 20 | match n with 21 | | D.Zero -> zero 22 | | D.Suc m -> do_clos2 suc m (do_rec tp zero suc m) 23 | | D.Neutral {term = e; _} -> 24 | let final_tp = do_clos tp n in 25 | D.Neutral {tp = final_tp; term = D.NRec (tp, zero, suc, e)} 26 | | _ -> raise (Nbe_failed "Not a number") 27 | 28 | and do_fst p = 29 | match p with 30 | | D.Pair (p1, _) -> p1 31 | | D.Neutral {tp; term = ne} -> 32 | begin 33 | match tp with 34 | | D.Sig (t, _) -> D.Neutral {tp = t; term = D.Fst ne} 35 | | _ -> raise (Nbe_failed "Couldn't fst argument in do_fst") 36 | end 37 | | _ -> raise (Nbe_failed "Couldn't fst argument in do_fst") 38 | 39 | and do_snd p = 40 | match p with 41 | | D.Pair (_, p2) -> p2 42 | | D.Neutral {tp; term = ne} -> 43 | begin 44 | match tp with 45 | | D.Sig (_, clo) -> 46 | let fst = do_fst p in 47 | D.Neutral {tp = do_clos clo fst; term = D.Snd ne} 48 | | _ -> raise (Nbe_failed "Couldn't snd argument in do_snd") 49 | end 50 | | _ -> raise (Nbe_failed "Couldn't snd argument in do_snd") 51 | 52 | 53 | and do_ap f a = 54 | match f with 55 | | D.Lam clos -> do_clos clos a 56 | | D.Neutral {tp; term = e} -> 57 | begin 58 | match tp with 59 | | D.Pi (mu, src, dst) -> 60 | let dst = do_clos dst a in 61 | D.Neutral {tp = dst; term = D.Ap (mu, e, D.Normal {tp = src; term = a})} 62 | | _ -> raise (Nbe_failed "Not a Pi in do_ap") 63 | end 64 | | _ -> raise (Nbe_failed "Not a function in do_ap") 65 | 66 | and do_j mot refl eq = 67 | match eq with 68 | | D.Refl t -> Some (do_clos refl t) 69 | | D.Neutral {tp; term} -> 70 | begin 71 | match tp with 72 | | D.Id (tp, left, right) -> 73 | Some (D.Neutral 74 | { tp = do_clos3 mot left right eq; 75 | term = D.J (mot, refl, tp, left, right, term) }) 76 | | _ -> raise (Nbe_failed "Not an Id in do_j") 77 | end 78 | | _ -> None 79 | 80 | and do_mod nu tyclos body def = 81 | match def with 82 | | D.Mod (_, tm1) -> do_clos body tm1 83 | | D.Neutral {tp; term = e} -> 84 | begin 85 | match tp with 86 | | D.Tymod (mu, argtp) -> 87 | let tp2 = do_clos tyclos (D.Neutral {tp = D.Tymod (mu, argtp); term = e}) in 88 | D.Neutral {tp = tp2; term = D.Letmod (mu, nu, tyclos, body, argtp, e)} 89 | | _ -> raise (Nbe_failed "Not a TyMod in do_mod") 90 | end 91 | | _ -> raise (Nbe_failed "Not a Mod or Neutral in do_mod") 92 | 93 | and eval t (env : D.env) = 94 | match t with 95 | | Syn.Var id -> D.env_val env id 96 | | Syn.Let (def, body) -> eval body ((D.Val (eval def env)) :: env) 97 | | Syn.Check (term, _) -> eval term env 98 | | Syn.Nat -> D.Nat 99 | | Syn.Zero -> D.Zero 100 | | Syn.Suc t -> D.Suc (eval t env) 101 | | Syn.NRec (tp, zero, suc, n) -> 102 | do_rec 103 | (Clos {term = tp; env}) 104 | (eval zero env) 105 | (Clos2 {term = suc; env}) 106 | (eval n env) 107 | | Syn.Pi (mu, src, dest) -> D.Pi (mu, (eval src (D.M mu :: env)), (Clos {term = dest; env})) 108 | | Syn.Lam t -> D.Lam (Clos {term = t; env}) 109 | | Syn.Ap (mu, t1, t2) -> do_ap (eval t1 env) (eval t2 (D.M mu :: env)) 110 | | Syn.Uni i -> D.Uni i 111 | | Syn.Sig (t1, t2) -> D.Sig (eval t1 env, (Clos {term = t2; env})) 112 | | Syn.Pair (t1, t2) -> D.Pair (eval t1 env, eval t2 env) 113 | | Syn.Fst t -> do_fst (eval t env) 114 | | Syn.Snd t -> do_snd (eval t env) 115 | | Syn.Refl t -> D.Refl (eval t env) 116 | | Syn.Id (tp, left, right) -> D.Id (eval tp env, eval left env, eval right env) 117 | | Syn.J (mot, refl, eq) -> 118 | begin 119 | match do_j (D.Clos3 {term = mot; env}) (D.Clos {term = refl; env}) (eval eq env) with 120 | | Some (v) -> v 121 | | None -> raise (Nbe_failed ("Not a refl or neutral in do_j \n Eqtm: " ^ Syn.pp eq)) 122 | end 123 | | Syn.TyMod (mu, t) -> 124 | let new_env = D.M mu :: env in 125 | D.Tymod (mu, eval t new_env) 126 | | Syn.Mod (mu, t) -> 127 | let new_env = D.M mu :: env in 128 | D.Mod (mu, eval t new_env) 129 | | Syn.Letmod (_ ,nu ,tyfam , body , def) -> 130 | do_mod nu (D.Clos {term = tyfam; env = env}) (D.Clos {term = body; env = env}) (eval def env) 131 | | Syn.Axiom (str, tp) -> D.Neutral {tp = eval tp env; term = D.Axiom (str, eval tp env)} 132 | 133 | (* Nested matching necessary. We cannot match just on nf, since we need to push tp before *) 134 | let rec read_back_nf size nf = 135 | match nf with 136 | (* Functions *) 137 | | D.Normal {tp; term = v} -> 138 | match tp with 139 | | Pi (_, src, dest) -> 140 | let arg = D.mk_var src size in 141 | let nf = D.Normal {tp = do_clos dest arg; term = do_ap v arg} in 142 | Syn.Lam (read_back_nf (size + 1) nf) 143 | (* Pairs *) 144 | | D.Sig (fst, snd) -> 145 | let fst' = do_fst v in 146 | let snd = do_clos snd fst' in 147 | let snd' = do_snd v in 148 | Syn.Pair 149 | (read_back_nf size (D.Normal { tp = fst; term = fst'}), 150 | read_back_nf size (D.Normal { tp = snd; term = snd'})) 151 | (* Numbers *) 152 | | D.Nat -> 153 | begin 154 | match v with 155 | | D.Zero -> Syn.Zero 156 | | D.Suc nf -> 157 | Syn.Suc (read_back_nf size (D.Normal {tp = D.Nat; term = nf})) 158 | | D.Neutral {term = ne; _} -> read_back_ne size ne 159 | | _ -> raise (Nbe_failed "Natural number expected in read_back_nf") 160 | end 161 | (* Types *) 162 | | D.Uni i -> 163 | begin 164 | match v with 165 | | D.Nat -> Syn.Nat 166 | | D.Pi (mu, src, dest) -> 167 | let var = D.mk_var src size in 168 | Syn.Pi (mu, 169 | read_back_nf size (D.Normal {tp = D.Uni i; term = src}), 170 | read_back_nf (size + 1) (D.Normal {tp = D.Uni i; term = do_clos dest var})) 171 | | D.Sig (fst, snd) -> 172 | let var = D.mk_var fst size in 173 | Syn.Sig 174 | (read_back_nf size (D.Normal {tp = D.Uni i; term = fst}), 175 | read_back_nf (size + 1) (D.Normal {tp = D.Uni i; term = do_clos snd var})) 176 | | D.Uni j -> Syn.Uni j 177 | | D.Id (tp, le, ri) -> 178 | Syn.Id ( 179 | read_back_nf size (D.Normal {tp = D.Uni i; term = tp}), 180 | read_back_nf size (D.Normal {tp = tp; term = le}), 181 | read_back_nf size (D.Normal {tp = tp; term = ri}) 182 | ) 183 | | D.Tymod (mu, tp) -> Syn.TyMod (mu, read_back_nf size (D.Normal {tp = D.Uni i; term = tp })) 184 | | D.Neutral {term = ne; _} -> read_back_ne size ne 185 | | _ -> raise (Nbe_failed ("element of universe expected in read_back_nf\n False term: ")) 186 | end 187 | | D.Neutral _ -> 188 | begin 189 | match v with 190 | | D.Neutral {term = ne; _} -> read_back_ne size ne 191 | | _ -> raise (Nbe_failed "Neutral expected for Neutral Type in read_back_nf") 192 | end 193 | (* Id *) 194 | | D.Id (tp, _, _) -> 195 | begin 196 | match v with 197 | | D.Refl term -> 198 | Syn.Refl (read_back_nf size (D.Normal {tp; term})) 199 | | D.Neutral {term; _} -> 200 | read_back_ne size term 201 | | _ -> raise (Nbe_failed "No Refl or Neutral in read_back_nf") 202 | end 203 | 204 | (* Modal types *) 205 | | D.Tymod (_, tp1) -> 206 | begin 207 | match v with 208 | | D.Mod (mu, w) -> Syn.Mod (mu, read_back_nf size (D.Normal {tp = tp1; term = w })) 209 | | D.Neutral {term = ne; _} -> read_back_ne size ne 210 | | _ -> raise (Nbe_failed "element of modal type expected in read_back_nf") 211 | end 212 | | _ -> raise (Nbe_failed "Ill-typed read_back_nf") 213 | 214 | 215 | and read_back_tp size d = 216 | match d with 217 | | D.Neutral {term; _} -> read_back_ne size term 218 | | D.Nat -> Syn.Nat 219 | | D.Pi (mu, src, dest) -> 220 | let var = D.mk_var src size in 221 | Syn.Pi (mu, read_back_tp size src, read_back_tp (size + 1) (do_clos dest var)) 222 | | D.Sig (fst, snd) -> 223 | let var = D.mk_var fst size in 224 | Syn.Sig (read_back_tp size fst, read_back_tp (size + 1) (do_clos snd var)) 225 | | D.Id (tp, left, right) -> 226 | Syn.Id 227 | (read_back_tp size tp, 228 | read_back_nf size (D.Normal {tp; term = left}), 229 | read_back_nf size (D.Normal {tp; term = right})) 230 | | D.Uni k -> Syn.Uni k 231 | | D.Tymod (mu, tp) -> Syn.TyMod (mu, read_back_tp size tp) 232 | | _ -> raise (Nbe_failed "Not a type in read_back_tp") 233 | 234 | and read_back_ne size ne = 235 | match ne with 236 | | D.Var x -> Syn.Var (size - (x + 1)) 237 | | D.Ap (mu, ne, arg) -> Syn.Ap (mu, read_back_ne size ne, read_back_nf size arg) 238 | | D.NRec (tp, zero, suc, n) -> 239 | let tp_var = D.mk_var D.Nat size in 240 | let applied_tp = do_clos tp tp_var in 241 | let zero_tp = do_clos tp D.Zero in 242 | let applied_suc_tp = do_clos tp (D.Suc tp_var) in 243 | let tp' = read_back_tp (size + 1) applied_tp in 244 | let suc_var = D.mk_var applied_tp (size + 1) in 245 | let applied_suc = do_clos2 suc tp_var suc_var in 246 | let suc' = 247 | read_back_nf (size + 2) (D.Normal {tp = applied_suc_tp; term = applied_suc}) in 248 | Syn.NRec 249 | (tp', 250 | read_back_nf size (D.Normal {tp = zero_tp; term = zero}), 251 | suc', 252 | read_back_ne size n) 253 | | D.Fst ne -> Syn.Fst (read_back_ne size ne) 254 | | D.Snd ne -> Syn.Snd (read_back_ne size ne) 255 | | D.Letmod (mu, nu, tyfam, clos, argtp, ne) -> 256 | let tp = do_clos tyfam (D.Tymod (mu, D.mk_var argtp size)) in 257 | let tm = D.Normal {tp = tp; term = do_clos clos (D.mk_var argtp size)} in 258 | Syn.Letmod (mu, nu, read_back_tp (size + 1) tp, read_back_nf (size + 1) tm, read_back_ne size ne) 259 | | D.J (mot, refl, tp, _, _, eq) -> 260 | let mot_var1 = D.mk_var tp size in 261 | let mot_var2 = D.mk_var tp (size + 1) in 262 | let mot_var3 = D.mk_var (D.Id (tp, mot_var1, mot_var2)) (size + 2) in 263 | let mot_syn = read_back_tp (size + 3) (do_clos3 mot mot_var1 mot_var2 mot_var3) in 264 | let refl_var = D.mk_var tp size in 265 | let refl_syn = 266 | read_back_nf 267 | (size + 1) 268 | (D.Normal {term = do_clos refl refl_var; tp = do_clos3 mot refl_var refl_var (D.Refl refl_var)}) in 269 | let eq_syn = read_back_ne size eq in 270 | Syn.J (mot_syn, refl_syn, eq_syn) 271 | | D.Axiom (str, tp) -> Syn.Axiom (str, read_back_tp size tp) 272 | 273 | 274 | 275 | let rec check_nf m size nf1 nf2 = 276 | match nf1, nf2 with 277 | (* Functions *) 278 | | D.Normal {tp = D.Pi (mu, src1, dest1); term = f1}, 279 | D.Normal {tp = D.Pi (nu, _, dest2); term = f2} -> 280 | let arg = D.mk_var src1 size in 281 | let nf1 = D.Normal {tp = do_clos dest1 arg; term = do_ap f1 arg} in 282 | let nf2 = D.Normal {tp = do_clos dest2 arg; term = do_ap f2 arg} in 283 | eq_mod mu nu && check_nf m (size + 1) nf1 nf2 284 | (* Pairs *) 285 | | D.Normal {tp = D.Sig (fst1, snd1); term = p1}, 286 | D.Normal {tp = D.Sig (fst2, snd2); term = p2} -> 287 | let p11, p21 = do_fst p1, do_fst p2 in 288 | let snd1 = do_clos snd1 p11 in 289 | let snd2 = do_clos snd2 p21 in 290 | let p12, p22 = do_snd p1, do_snd p2 in 291 | check_nf m size (D.Normal {tp = fst1; term = p11}) (D.Normal {tp = fst2; term = p21}) 292 | && check_nf m size (D.Normal {tp = snd1; term = p12}) (D.Normal {tp = snd2; term = p22}) 293 | (* Numbers *) 294 | | D.Normal {tp = D.Nat; term = D.Zero}, 295 | D.Normal {tp = D.Nat; term = D.Zero} -> true 296 | | D.Normal {tp = D.Nat; term = D.Suc nf1}, 297 | D.Normal {tp = D.Nat; term = D.Suc nf2} -> 298 | check_nf m size (D.Normal {tp = D.Nat; term = nf1}) (D.Normal {tp = D.Nat; term = nf2}) 299 | | D.Normal {tp = D.Nat; term = D.Neutral {term = ne1; _}}, 300 | D.Normal {tp = D.Nat; term = D.Neutral {term = ne2; _}}-> check_ne m size ne1 ne2 301 | (* Modalities *) 302 | | D.Normal {tp = D.Tymod (_, tp); term = D.Mod (mu, tm)}, 303 | D.Normal {tp = D.Tymod (_, tp1); term = D.Mod (nu, tm1)} -> 304 | eq_mod mu nu && 305 | let new_m = dom_mod mu m in 306 | check_nf new_m size (D.Normal {tp = tp; term = tm}) (D.Normal {tp = tp1; term = tm1}) 307 | | D.Normal {tp = D.Tymod (mu, tp); term = D.Neutral {term = ne1; _}}, 308 | D.Normal {tp = D.Tymod (nu, tp1); term = D.Neutral {term = ne2; _}} -> 309 | eq_mod mu nu && 310 | let new_m = dom_mod mu m in 311 | check_tp new_m ~subtype:false size tp tp1 && check_ne new_m size ne1 ne2 312 | (* Id *) 313 | | D.Normal {tp = D.Id (tp, _, _); term = D.Refl term1}, 314 | D.Normal {tp = D.Id (_, _, _); term = D.Refl term2} -> 315 | check_nf m size (D.Normal {tp; term = term1}) (D.Normal {tp; term = term2}) 316 | | D.Normal {tp = D.Id _; term = D.Neutral {term = term1; _}}, 317 | D.Normal {tp = D.Id _; term = D.Neutral {term = term2; _}} -> 318 | check_ne m size term1 term2 319 | (* Types *) 320 | | D.Normal {tp = D.Uni _; term = D.Nat}, 321 | D.Normal {tp = D.Uni _; term = D.Nat} -> true 322 | | D.Normal {tp = D.Uni i; term = D.Pi (mu, src1, dest1)}, 323 | D.Normal {tp = D.Uni j; term = D.Pi (nu, src2, dest2)} -> 324 | let var = D.mk_var src1 size in 325 | eq_mod mu nu && 326 | let new_m = dom_mod mu m in 327 | check_nf new_m size (D.Normal {tp = D.Uni i; term = src1}) (D.Normal {tp = D.Uni j; term = src2}) 328 | && check_nf m (size + 1) (D.Normal {tp = D.Uni i; term = do_clos dest1 var}) 329 | (D.Normal {tp = D.Uni j; term = do_clos dest2 var}) 330 | | D.Normal {tp = D.Uni i; term = D.Sig (src1, dest1)}, 331 | D.Normal {tp = D.Uni j; term = D.Sig (src2, dest2)} -> 332 | let var = D.mk_var src1 size in 333 | check_nf m size (D.Normal {tp = D.Uni i; term = src1}) (D.Normal {tp = D.Uni j; term = src2}) 334 | && check_nf m (size + 1) (D.Normal {tp = D.Uni i; term = do_clos dest1 var}) 335 | (D.Normal {tp = D.Uni j; term = do_clos dest2 var}) 336 | | D.Normal {tp = D.Uni i; term = D.Tymod (mu, tp)}, 337 | D.Normal {tp = D.Uni j; term = D.Tymod (nu, tp1)} -> 338 | eq_mod mu nu && 339 | let new_m = dom_mod mu m in 340 | check_nf new_m size (D.Normal {tp = D.Uni i; term = tp}) (D.Normal {tp = D.Uni j; term = tp1}) 341 | | D.Normal {tp = D.Uni _; term = D.Uni j}, 342 | D.Normal {tp = D.Uni _; term = D.Uni j'} -> j = j' 343 | | D.Normal {tp = D.Uni _; term = D.Neutral {term = ne1; _}}, 344 | D.Normal {tp = D.Uni _; term = D.Neutral {term = ne2; _}} -> check_ne m size ne1 ne2 345 | | D.Normal {tp = D.Neutral _; term = D.Neutral {term = ne1; _}}, 346 | D.Normal {tp = D.Neutral _; term = D.Neutral {term = ne2; _}} -> check_ne m size ne1 ne2 347 | | _ -> false 348 | 349 | and check_ne m size ne1 ne2 = 350 | match ne1, ne2 with 351 | | D.Var x, D.Var y -> x = y 352 | | D.Ap (_, ne1, arg1), D.Ap (_, ne2, arg2) -> 353 | check_ne m size ne1 ne2 && check_nf m size arg1 arg2 354 | | D.NRec (tp1, zero1, suc1, n1), D.NRec (tp2, zero2, suc2, n2) -> 355 | let tp_var = D.mk_var D.Nat size in 356 | let applied_tp1, applied_tp2 = do_clos tp1 tp_var, do_clos tp2 tp_var in 357 | let zero_tp = do_clos tp1 D.Zero in 358 | let applied_suc_tp = do_clos tp1 (D.Suc tp_var) in 359 | let suc_var1 = D.mk_var applied_tp1 (size + 1) in 360 | let suc_var2 = D.mk_var applied_tp2 (size + 1) in 361 | let applied_suc1 = do_clos2 suc1 tp_var suc_var1 in 362 | let applied_suc2 = do_clos2 suc2 tp_var suc_var2 in 363 | check_tp m ~subtype:false (size + 1) applied_tp1 applied_tp2 364 | && check_nf m size (D.Normal {tp = zero_tp; term = zero1}) (D.Normal {tp = zero_tp; term = zero2}) 365 | && check_nf m (size + 2) (D.Normal {tp = applied_suc_tp; term = applied_suc1}) 366 | (D.Normal {tp = applied_suc_tp; term = applied_suc2}) 367 | && check_ne m size n1 n2 368 | | D.Fst ne1, D.Fst ne2 -> check_ne m size ne1 ne2 369 | | D.Snd ne1, D.Snd ne2 -> check_ne m size ne1 ne2 370 | | D.Letmod (mu, nu, tyclos, clos, argty, ne), 371 | D.Letmod (mu1, nu1, tyclos1, clos1, _, ne1) -> 372 | let arg = D.mk_var argty size in 373 | let applied_ty = do_clos tyclos (D.Mod (mu, arg)) in 374 | let applied_ty1 = do_clos tyclos1 (D.Mod (mu, arg)) in 375 | let applied_tm = do_clos clos arg in 376 | let applied_tm1 = do_clos clos1 arg in 377 | eq_mod mu mu1 && eq_mod nu nu1 && 378 | check_nf m (size + 1) (D.Normal {tp = applied_ty; term = applied_tm}) (D.Normal {tp = applied_ty1; term = applied_tm1}) 379 | && let new_m = dom_mod mu m in 380 | check_ne new_m size ne ne1 381 | | D.J (mot1, refl1, tp1, left1, right1, eq1), 382 | D.J (mot2, refl2, tp2, left2, right2, eq2) -> 383 | check_tp m ~subtype:false size tp1 tp2 && 384 | check_nf m size (D.Normal {tp = tp1; term = left1}) (D.Normal {tp = tp2; term = left2}) && 385 | check_nf m size (D.Normal {tp = tp1; term = right1}) (D.Normal {tp = tp2; term = right2}) && 386 | let mot_var1 = D.mk_var tp1 size in 387 | let mot_var2 = D.mk_var tp1 (size + 1) in 388 | let mot_var3 = D.mk_var (D.Id (tp1, left1, right1)) (size + 2) in 389 | check_tp m ~subtype:false (size + 3) (do_clos3 mot1 mot_var1 mot_var2 mot_var3) (do_clos3 mot2 mot_var1 mot_var2 mot_var3) && 390 | let refl_var = D.mk_var tp1 size in 391 | check_nf 392 | m 393 | (size + 1) 394 | (D.Normal {term = do_clos refl1 refl_var; tp = do_clos3 mot1 refl_var refl_var (D.Refl refl_var)}) 395 | (D.Normal {term = do_clos refl2 refl_var; tp = do_clos3 mot2 refl_var refl_var (D.Refl refl_var)}) && 396 | check_ne m size eq1 eq2 397 | | D.Axiom (str1, _), D.Axiom (str2, _) -> String.equal str1 str2 398 | | _ -> false 399 | 400 | and check_tp m ~subtype size d1 d2 = 401 | match d1, d2 with 402 | | D.Neutral {term = term1; _}, D.Neutral {term = term2; _} -> 403 | check_ne m size term1 term2 404 | | D.Nat, D.Nat -> true 405 | | D.Pi (mu, src, dest), D.Pi (nu, src', dest') -> 406 | let var = D.mk_var src' size in 407 | let new_m = dom_mod mu m in 408 | eq_mod mu nu && check_tp new_m ~subtype size src' src && 409 | check_tp m ~subtype (size + 1) (do_clos dest var) (do_clos dest' var) 410 | | D.Sig (fst, snd), D.Sig (fst', snd') -> 411 | let var = D.mk_var fst size in 412 | check_tp m ~subtype size fst fst' && 413 | check_tp m ~subtype (size + 1) (do_clos snd var) (do_clos snd' var) 414 | | D.Id (tp1, left1, right1), D.Id (tp2, left2, right2) -> 415 | check_tp m ~subtype size tp1 tp2 && 416 | check_nf m size (D.Normal {tp = tp1; term = left1}) (D.Normal {tp = tp1; term = left2}) && 417 | check_nf m size (D.Normal {tp = tp1; term = right1}) (D.Normal {tp = tp1; term = right2}) 418 | | D.Uni k, D.Uni j -> if subtype then k <= j else k = j 419 | | D.Tymod (mu, tp), D.Tymod (nu, tp1) -> 420 | let new_m = dom_mod mu m in 421 | eq_mod mu nu && check_tp new_m ~subtype size tp tp1 422 | | _ -> false 423 | 424 | (* To normalize an arbitrary term G |- M : A we need to reflect the context G in an initial environment. We include this for completeness, though the function "normalize" is in fact not used. For equality checking we use the more efficient "check_nf" resp. "check_np" functions. 425 | * Furthermore, toplevel definitions are handled a bit differently (see proc_decl in the driver.ml) 426 | * Otherwise, the type checker doesn't let the user specify open terms. *) 427 | let rec initial_env env = 428 | match env with 429 | | [] -> [] 430 | | Syn.Ty t :: env -> 431 | let env' = initial_env env in 432 | let d = D.mk_var (eval t env') (Syn.env_length env) in 433 | (D.Val d) :: env' 434 | | Syn.Mo mu :: env -> 435 | D.M mu :: initial_env env 436 | 437 | let normalize ~env ~term ~tp = 438 | let env' = initial_env env in 439 | let tp' = eval tp env' in 440 | let term' = eval term env' in 441 | read_back_nf (List.length env') (D.Normal {tp = tp'; term = term'}) 442 | --------------------------------------------------------------------------------