├── dune-project ├── typed-meta ├── dune ├── MetaContext.ml ├── Lexer.mll ├── Syntax.ml ├── Normalize.ml ├── Parser.mly ├── typedMetaTest.ml ├── Pretty.ml ├── README.md ├── Typecheck.ml └── Unify.ml ├── untyped-meta ├── dune ├── MetaContext.ml ├── Lexer.mll ├── Syntax.ml ├── Normalize.ml ├── Parser.mly ├── untypedMetaTest.ml ├── Pretty.ml ├── Typecheck.ml ├── Unify.ml └── README.md ├── generalized-eta ├── dune ├── MetaContext.ml ├── Lexer.mll ├── Syntax.ml ├── Normalize.ml ├── Parser.mly ├── Pretty.ml ├── generalizedEtaTest.ml ├── Typecheck.ml ├── README.md └── Unify.ml ├── .gitignore ├── LICENSE └── README.md /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | -------------------------------------------------------------------------------- /typed-meta/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typedMeta) 3 | (modules Syntax MetaContext Normalize Unify Typecheck Pretty Parser Lexer)) 4 | 5 | (ocamlyacc Parser) 6 | (ocamllex Lexer) 7 | 8 | 9 | (test 10 | (name typedMetaTest) 11 | (libraries typedMeta) 12 | (modules typedMetaTest)) 13 | -------------------------------------------------------------------------------- /untyped-meta/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name untypedMeta) 3 | (modules Syntax MetaContext Normalize Unify Typecheck Pretty Parser Lexer)) 4 | 5 | (ocamlyacc Parser) 6 | (ocamllex Lexer) 7 | 8 | 9 | (test 10 | (name untypedMetaTest) 11 | (libraries untypedMeta) 12 | (modules untypedMetaTest)) 13 | -------------------------------------------------------------------------------- /generalized-eta/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name generalizedEta) 3 | (modules Syntax MetaContext Normalize Unify Typecheck Pretty Parser Lexer)) 4 | 5 | (ocamlyacc Parser) 6 | (ocamllex Lexer) 7 | 8 | 9 | (test 10 | (name generalizedEtaTest) 11 | (libraries generalizedEta) 12 | (modules generalizedEtaTest)) 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # Merlin configuring file for Vim and Emacs 23 | .merlin 24 | 25 | # Dune generated files 26 | *.install 27 | 28 | # Local OPAM switch 29 | _opam/ 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted. 2 | 3 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 4 | WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 5 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, 6 | DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, 7 | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 8 | -------------------------------------------------------------------------------- /untyped-meta/MetaContext.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | module MetaMap = Map.Make(Int) 5 | 6 | 7 | let meta_count = ref 0 8 | let metas : Value.meta_info MetaMap.t ref = ref (MetaMap.empty) 9 | 10 | 11 | let reset () = 12 | meta_count := 0; 13 | metas := MetaMap.empty 14 | 15 | 16 | 17 | let fresh_meta () = 18 | let m = !meta_count in 19 | incr meta_count; 20 | metas := MetaMap.add m Value.Free !metas; 21 | m 22 | 23 | let find_meta m = MetaMap.find m !metas 24 | 25 | let solve_meta m v = 26 | let metas' = !metas |> MetaMap.update m @@ function 27 | | Some(Value.Solved _) -> failwith("meta ?" ^ string_of_int m ^ " already solved") 28 | | Some Value.Free -> Some(Value.Solved v) 29 | | None -> failwith("unbound meta ?" ^ string_of_int m) 30 | in 31 | metas := metas' 32 | -------------------------------------------------------------------------------- /typed-meta/MetaContext.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | module MetaMap = Map.Make(Int) 5 | 6 | 7 | let meta_count = ref 0 8 | let metas : Value.meta_info MetaMap.t ref = ref (MetaMap.empty) 9 | 10 | 11 | let reset () = 12 | meta_count := 0; 13 | metas := MetaMap.empty 14 | 15 | 16 | 17 | let fresh_meta typ = 18 | let m = !meta_count in 19 | incr meta_count; 20 | metas := MetaMap.add m (Value.Free typ) !metas; 21 | m 22 | 23 | let find_meta m = MetaMap.find m !metas 24 | 25 | let solve_meta m v = 26 | let metas' = !metas |> MetaMap.update m @@ function 27 | | Some(Value.Solved _) -> failwith("meta ?" ^ string_of_int m ^ " already solved") 28 | | Some Value.Free _ -> Some(Value.Solved v) 29 | | None -> failwith("unbound meta ?" ^ string_of_int m) 30 | in 31 | metas := metas' 32 | -------------------------------------------------------------------------------- /generalized-eta/MetaContext.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | module MetaMap = Map.Make(Int) 5 | 6 | 7 | let meta_count = ref 0 8 | let metas : Value.meta_info MetaMap.t ref = ref (MetaMap.empty) 9 | 10 | 11 | let reset () = 12 | meta_count := 0; 13 | metas := MetaMap.empty 14 | 15 | 16 | 17 | let fresh_meta typ = 18 | let m = !meta_count in 19 | incr meta_count; 20 | metas := MetaMap.add m (Value.Free typ) !metas; 21 | m 22 | 23 | let find_meta m = MetaMap.find m !metas 24 | 25 | let solve_meta m v = 26 | let metas' = !metas |> MetaMap.update m @@ function 27 | | Some(Value.Solved _) -> failwith("meta ?" ^ string_of_int m ^ " already solved") 28 | | Some Value.Free _ -> Some(Value.Solved v) 29 | | None -> failwith("unbound meta ?" ^ string_of_int m) 30 | in 31 | metas := metas' 32 | -------------------------------------------------------------------------------- /typed-meta/Lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | 4 | let keyword_table = Hashtbl.of_seq @@ List.to_seq 5 | [ "Type" , TOK_KW_TYPE 6 | ; "forall", TOK_KW_FORALL 7 | ; "fun" , TOK_KW_FUN 8 | ; "let" , TOK_KW_LET 9 | ; "in" , TOK_KW_IN 10 | ; "unify" , TOK_KW_UNIFY ] 11 | } 12 | 13 | let dex_digit = ['0'-'9'] 14 | let lowercase = ['a'-'z'] 15 | let uppercase = ['A'-'Z'] 16 | let other_name_char = ['_' '-' '\'' '*' '+'] 17 | let name_head = other_name_char | lowercase | uppercase 18 | let name_char = name_head | dex_digit 19 | 20 | let blank = [' ' '\t'] 21 | let newline = ['\n'] 22 | 23 | 24 | rule token = parse 25 | | eof { TOK_EOF } 26 | | blank+ { token lexbuf } 27 | | newline { Lexing.new_line lexbuf; token lexbuf } 28 | | '(' { TOK_LPAREN } 29 | | ')' { TOK_RPAREN } 30 | | '{' { TOK_LBRACE } 31 | | '}' { TOK_RBRACE } 32 | | "->" { TOK_MINUS_GT } 33 | | ':' { TOK_COLON } 34 | | '=' { TOK_EQ } 35 | | '_' { TOK_UNDERSCORE } 36 | | dex_digit+ 37 | { TOK_INT(int_of_string (Lexing.lexeme lexbuf)) } 38 | | (name_head)(name_char*) 39 | { let name = Lexing.lexeme lexbuf in 40 | try Hashtbl.find keyword_table name with Not_found -> TOK_NAME name } 41 | -------------------------------------------------------------------------------- /generalized-eta/Lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | 4 | let keyword_table = Hashtbl.of_seq @@ List.to_seq 5 | [ "Type" , TOK_KW_TYPE 6 | ; "forall", TOK_KW_FORALL 7 | ; "fun" , TOK_KW_FUN 8 | ; "let" , TOK_KW_LET 9 | ; "in" , TOK_KW_IN 10 | ; "unify" , TOK_KW_UNIFY ] 11 | } 12 | 13 | let dex_digit = ['0'-'9'] 14 | let lowercase = ['a'-'z'] 15 | let uppercase = ['A'-'Z'] 16 | let other_name_char = ['_' '-' '\'' '*' '+'] 17 | let name_head = other_name_char | lowercase | uppercase 18 | let name_char = name_head | dex_digit 19 | 20 | let blank = [' ' '\t'] 21 | let newline = ['\n'] 22 | 23 | 24 | rule token = parse 25 | | eof { TOK_EOF } 26 | | blank+ { token lexbuf } 27 | | newline { Lexing.new_line lexbuf; token lexbuf } 28 | | '(' { TOK_LPAREN } 29 | | ')' { TOK_RPAREN } 30 | | '{' { TOK_LBRACE } 31 | | '}' { TOK_RBRACE } 32 | | "->" { TOK_MINUS_GT } 33 | | ':' { TOK_COLON } 34 | | '=' { TOK_EQ } 35 | | '_' { TOK_UNDERSCORE } 36 | | dex_digit+ 37 | { TOK_INT(int_of_string (Lexing.lexeme lexbuf)) } 38 | | (name_head)(name_char*) 39 | { let name = Lexing.lexeme lexbuf in 40 | try Hashtbl.find keyword_table name with Not_found -> TOK_NAME name } 41 | -------------------------------------------------------------------------------- /untyped-meta/Lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | 4 | let keyword_table = Hashtbl.of_seq @@ List.to_seq 5 | [ "Type" , TOK_KW_TYPE 6 | ; "forall", TOK_KW_FORALL 7 | ; "fun" , TOK_KW_FUN 8 | ; "let" , TOK_KW_LET 9 | ; "in" , TOK_KW_IN 10 | ; "unify" , TOK_KW_UNIFY ] 11 | } 12 | 13 | let dex_digit = ['0'-'9'] 14 | let lowercase = ['a'-'z'] 15 | let uppercase = ['A'-'Z'] 16 | let other_name_char = ['_' '-' '\'' '*' '+'] 17 | let name_head = other_name_char | lowercase | uppercase 18 | let name_char = name_head | dex_digit 19 | 20 | let blank = [' ' '\t'] 21 | let newline = ['\n'] 22 | 23 | 24 | rule token = parse 25 | | eof { TOK_EOF } 26 | | blank+ { token lexbuf } 27 | | newline { Lexing.new_line lexbuf; token lexbuf } 28 | | '(' { TOK_LPAREN } 29 | | ')' { TOK_RPAREN } 30 | | '{' { TOK_LBRACE } 31 | | '}' { TOK_RBRACE } 32 | | "->" { TOK_MINUS_GT } 33 | | ':' { TOK_COLON } 34 | | '=' { TOK_EQ } 35 | | '_' { TOK_UNDERSCORE } 36 | | dex_digit+ 37 | { TOK_INT(int_of_string (Lexing.lexeme lexbuf)) } 38 | | (name_head)(name_char*) 39 | { let name = Lexing.lexeme lexbuf in 40 | try Hashtbl.find keyword_table name with Not_found -> TOK_NAME name } 41 | -------------------------------------------------------------------------------- /untyped-meta/Syntax.ml: -------------------------------------------------------------------------------- 1 | 2 | type meta = int 3 | type level = int 4 | 5 | module Value = struct 6 | type value = 7 | | Stuck of head * spine 8 | | Type 9 | (* The strings are variable names, used for pretty printing only *) 10 | | TyFun of string * value * (value -> value) 11 | | Fun of string * (value -> value) 12 | 13 | and head = 14 | (* de Bruijn level *) 15 | | Lvl of level 16 | | Meta of meta 17 | 18 | and spine = 19 | | EmptySp 20 | | App of spine * value 21 | 22 | let stuck_local lvl = Stuck(Lvl lvl, EmptySp) 23 | 24 | 25 | type meta_info = 26 | | Free 27 | | Solved of value 28 | 29 | type env = 30 | | Empty 31 | | Bound of env * string * value 32 | | Defined of env * string * value * value 33 | end 34 | 35 | 36 | module Core = struct 37 | type expr = 38 | (* de Bruijn index *) 39 | | Idx of int 40 | (* The strings are variable names, used for pretty printing only *) 41 | | Let of string * expr * expr 42 | | Type 43 | | TyFun of string * expr * expr 44 | | Fun of string * expr 45 | | App of expr * expr 46 | | Meta of meta 47 | end 48 | 49 | 50 | module Surface = struct 51 | type expr = 52 | (* surface syntax uses named variables *) 53 | | Var of string 54 | | Let of string * expr * expr 55 | | Ann of expr * expr 56 | | Type 57 | | TyFun of string * expr * expr 58 | | Fun of string * expr option * expr 59 | | App of expr * expr 60 | | Hole 61 | | Unify of expr * expr 62 | end 63 | -------------------------------------------------------------------------------- /typed-meta/Syntax.ml: -------------------------------------------------------------------------------- 1 | 2 | type meta = int 3 | type level = int 4 | 5 | module Value = struct 6 | type value = 7 | | Stuck of head * spine 8 | | Type 9 | (* The strings are variable names, used for pretty printing only *) 10 | | TyFun of string * value * (value -> value) 11 | | Fun of string * (value -> value) 12 | 13 | and head = 14 | (* de Bruijn level *) 15 | | Lvl of level 16 | | Meta of meta 17 | 18 | and spine = 19 | | EmptySp 20 | | App of spine * value 21 | 22 | let stuck_local lvl = Stuck(Lvl lvl, EmptySp) 23 | 24 | 25 | type meta_info = 26 | | Free of value 27 | | Solved of value 28 | 29 | type env = 30 | | Empty 31 | | Bound of env * string * value 32 | | Defined of env * string * value * value 33 | 34 | let rec lookup_idx idx env = 35 | match idx, env with 36 | | _, Empty -> raise Not_found 37 | | 0, (Bound(_, _, typ) | Defined(_, _, typ, _)) -> typ 38 | | n, (Bound(env', _, _) | Defined(env', _, _, _)) -> lookup_idx (n - 1) env' 39 | end 40 | 41 | 42 | module Core = struct 43 | type expr = 44 | (* de Bruijn index *) 45 | | Idx of int 46 | (* The strings are variable names, used for pretty printing only *) 47 | | Let of string * expr * expr 48 | | Type 49 | | TyFun of string * expr * expr 50 | | Fun of string * expr 51 | | App of expr * expr 52 | | Meta of meta 53 | end 54 | 55 | 56 | module Surface = struct 57 | type expr = 58 | (* surface syntax uses named variables *) 59 | | Var of string 60 | | Let of string * expr * expr 61 | | Ann of expr * expr 62 | | Type 63 | | TyFun of string * expr * expr 64 | | Fun of string * expr option * expr 65 | | App of expr * expr 66 | | Hole 67 | | Unify of expr * expr 68 | end 69 | -------------------------------------------------------------------------------- /generalized-eta/Syntax.ml: -------------------------------------------------------------------------------- 1 | 2 | type meta = int 3 | type level = int 4 | 5 | module Value = struct 6 | type value = 7 | | Stuck of head * spine 8 | | Type 9 | (* The strings are variable names, used for pretty printing only *) 10 | | TyFun of string * value * (value -> value) 11 | | Fun of string * (value -> value) 12 | 13 | and head = 14 | (* de Bruijn level *) 15 | | Lvl of level 16 | | Meta of meta 17 | 18 | and spine = 19 | | EmptySp 20 | | App of spine * value 21 | 22 | let stuck_local lvl = Stuck(Lvl lvl, EmptySp) 23 | 24 | 25 | type meta_info = 26 | | Free of value 27 | | Solved of value 28 | 29 | type env = 30 | | Empty 31 | | Bound of env * string * value 32 | | Defined of env * string * value * value 33 | 34 | let rec lookup_idx idx env = 35 | match idx, env with 36 | | _, Empty -> raise Not_found 37 | | 0, (Bound(_, _, typ) | Defined(_, _, typ, _)) -> typ 38 | | n, (Bound(env', _, _) | Defined(env', _, _, _)) -> lookup_idx (n - 1) env' 39 | end 40 | 41 | 42 | module Core = struct 43 | type expr = 44 | (* de Bruijn index *) 45 | | Idx of int 46 | (* The strings are variable names, used for pretty printing only *) 47 | | Let of string * expr * expr 48 | | Type 49 | | TyFun of string * expr * expr 50 | | Fun of string * expr 51 | | App of expr * expr 52 | | Meta of meta 53 | end 54 | 55 | 56 | module Surface = struct 57 | type expr = 58 | (* surface syntax uses named variables *) 59 | | Var of string 60 | | Let of string * expr * expr 61 | | Ann of expr * expr 62 | | Type 63 | | TyFun of string * expr * expr 64 | | Fun of string * expr option * expr 65 | | App of expr * expr 66 | | Hole 67 | | Unify of expr * expr 68 | end 69 | -------------------------------------------------------------------------------- /typed-meta/Normalize.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | 5 | 6 | let apply vf va = 7 | match vf with 8 | | Value.Fun(_, f) -> f va 9 | | Value.Stuck(h, sp) -> Value.Stuck(h, Value.App(sp, va)) 10 | | _ -> failwith "runtime error: not a function" 11 | 12 | let rec apply_spine vf = function 13 | | Value.EmptySp -> vf 14 | | Value.App(sp', argv) -> apply (apply_spine vf sp') argv 15 | 16 | 17 | let rec force value = 18 | match value with 19 | | Value.Stuck(Meta m, args) -> 20 | begin match MetaContext.find_meta m with 21 | | Free _ -> value 22 | | Solved v -> force (apply_spine v args) 23 | end 24 | | _ -> 25 | value 26 | 27 | let rec eval env = function 28 | | Core.Idx idx -> List.nth env idx 29 | | Core.Let(_, rhs, body) -> eval (eval env rhs :: env) body 30 | | Core.Type -> Value.Type 31 | | Core.TyFun(name, a, b) -> Value.TyFun(name, eval env a, fun v -> eval (v :: env) b) 32 | | Core.Fun(name, body) -> Value.Fun(name, fun v -> eval (v :: env) body) 33 | | Core.App(vf, va) -> apply (eval env vf) (eval env va) 34 | | Core.Meta meta -> 35 | match MetaContext.find_meta meta with 36 | | Value.Free _ -> Value.(Stuck(Meta meta, EmptySp)) 37 | | Value.Solved v -> v 38 | | exception Not_found -> failwith("unbound meta ?" ^ string_of_int meta) 39 | 40 | 41 | 42 | let rec quote level value = 43 | match force value with 44 | | Value.Stuck(head, sp) -> 45 | quote_spine level (quote_head level head) sp 46 | | Value.Type -> 47 | Core.Type 48 | | Value.TyFun(name, a, b) -> 49 | Core.TyFun(name, quote level a, quote (level + 1) @@ b @@ Value.stuck_local level) 50 | | Value.Fun(name, f) -> 51 | Core.Fun(name, quote (level + 1) @@ f @@ Value.stuck_local level) 52 | 53 | and quote_head level = function 54 | | Value.Lvl lvl -> Core.Idx(level - lvl - 1) 55 | | Value.Meta meta -> Core.Meta meta 56 | 57 | and quote_spine level headC = function 58 | | Value.EmptySp -> headC 59 | | Value.App(sp', argv) -> Core.App(quote_spine level headC sp', quote level argv) 60 | -------------------------------------------------------------------------------- /generalized-eta/Normalize.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | 5 | 6 | let apply vf va = 7 | match vf with 8 | | Value.Fun(_, f) -> f va 9 | | Value.Stuck(h, sp) -> Value.Stuck(h, Value.App(sp, va)) 10 | | _ -> failwith "runtime error: not a function" 11 | 12 | let rec apply_spine vf = function 13 | | Value.EmptySp -> vf 14 | | Value.App(sp', argv) -> apply (apply_spine vf sp') argv 15 | 16 | 17 | let rec force value = 18 | match value with 19 | | Value.Stuck(Meta m, args) -> 20 | begin match MetaContext.find_meta m with 21 | | Free _ -> value 22 | | Solved v -> force (apply_spine v args) 23 | end 24 | | _ -> 25 | value 26 | 27 | let rec eval env = function 28 | | Core.Idx idx -> List.nth env idx 29 | | Core.Let(_, rhs, body) -> eval (eval env rhs :: env) body 30 | | Core.Type -> Value.Type 31 | | Core.TyFun(name, a, b) -> Value.TyFun(name, eval env a, fun v -> eval (v :: env) b) 32 | | Core.Fun(name, body) -> Value.Fun(name, fun v -> eval (v :: env) body) 33 | | Core.App(vf, va) -> apply (eval env vf) (eval env va) 34 | | Core.Meta meta -> 35 | match MetaContext.find_meta meta with 36 | | Value.Free _ -> Value.(Stuck(Meta meta, EmptySp)) 37 | | Value.Solved v -> v 38 | | exception Not_found -> failwith("unbound meta ?" ^ string_of_int meta) 39 | 40 | 41 | 42 | let rec quote level value = 43 | match force value with 44 | | Value.Stuck(head, sp) -> 45 | quote_spine level (quote_head level head) sp 46 | | Value.Type -> 47 | Core.Type 48 | | Value.TyFun(name, a, b) -> 49 | Core.TyFun(name, quote level a, quote (level + 1) @@ b @@ Value.stuck_local level) 50 | | Value.Fun(name, f) -> 51 | Core.Fun(name, quote (level + 1) @@ f @@ Value.stuck_local level) 52 | 53 | and quote_head level = function 54 | | Value.Lvl lvl -> Core.Idx(level - lvl - 1) 55 | | Value.Meta meta -> Core.Meta meta 56 | 57 | and quote_spine level headC = function 58 | | Value.EmptySp -> headC 59 | | Value.App(sp', argv) -> Core.App(quote_spine level headC sp', quote level argv) 60 | -------------------------------------------------------------------------------- /untyped-meta/Normalize.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | 5 | 6 | let apply vf va = 7 | match vf with 8 | | Value.Fun(_, f) -> f va 9 | | Value.Stuck(h, sp) -> Value.Stuck(h, Value.App(sp, va)) 10 | | _ -> failwith "runtime error: not a function" 11 | 12 | let rec apply_spine vf = function 13 | | Value.EmptySp -> vf 14 | | Value.App(sp', argv) -> apply (apply_spine vf sp') argv 15 | 16 | 17 | let rec force value = 18 | match value with 19 | | Value.Stuck(Meta m, args) -> 20 | begin match MetaContext.find_meta m with 21 | | Free -> value 22 | | Solved v -> force (apply_spine v args) 23 | end 24 | | _ -> 25 | value 26 | 27 | let rec eval env = function 28 | | Core.Idx idx -> List.nth env idx 29 | | Core.Let(_, rhs, body) -> eval (eval env rhs :: env) body 30 | | Core.Type -> Value.Type 31 | | Core.TyFun(name, a, b) -> Value.TyFun(name, eval env a, fun v -> eval (v :: env) b) 32 | | Core.Fun(name, body) -> Value.Fun(name, fun v -> eval (v :: env) body) 33 | | Core.App(vf, va) -> apply (eval env vf) (eval env va) 34 | | Core.Meta meta -> 35 | match MetaContext.find_meta meta with 36 | | Value.Free -> Value.(Stuck(Meta meta, EmptySp)) 37 | | Value.Solved v -> v 38 | | exception Not_found -> failwith("unbound meta ?" ^ string_of_int meta) 39 | 40 | 41 | 42 | let rec quote level value = 43 | match force value with 44 | | Value.Stuck(head, sp) -> 45 | quote_spine level (quote_head level head) sp 46 | | Value.Type -> 47 | Core.Type 48 | | Value.TyFun(name, a, b) -> 49 | Core.TyFun(name, quote level a, quote (level + 1) @@ b @@ Value.stuck_local level) 50 | | Value.Fun(name, f) -> 51 | Core.Fun(name, quote (level + 1) @@ f @@ Value.stuck_local level) 52 | 53 | and quote_head level = function 54 | | Value.Lvl lvl -> Core.Idx(level - lvl - 1) 55 | | Value.Meta meta -> Core.Meta meta 56 | 57 | and quote_spine level headC = function 58 | | Value.EmptySp -> headC 59 | | Value.App(sp', argv) -> Core.App(quote_spine level headC sp', quote level argv) 60 | -------------------------------------------------------------------------------- /typed-meta/Parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | open Surface 4 | %} 5 | 6 | %token TOK_EOF 7 | %token TOK_LPAREN TOK_RPAREN TOK_LBRACE TOK_RBRACE 8 | %token TOK_MINUS_GT 9 | %token TOK_EQ 10 | %token TOK_COLON 11 | %token TOK_UNDERSCORE 12 | 13 | %token TOK_NAME 14 | %token TOK_INT 15 | %token TOK_KW_TYPE TOK_KW_FORALL 16 | %token TOK_KW_FUN TOK_KW_LET TOK_KW_IN 17 | %token TOK_KW_UNIFY 18 | 19 | 20 | 21 | %right TOK_MINUS_GT 22 | %left TOK_COLON 23 | 24 | 25 | %type single_expr 26 | %start single_expr 27 | 28 | %% 29 | 30 | single_expr : 31 | | expr TOK_EOF { $1 } 32 | ; 33 | 34 | expr : 35 | | binop_expr 36 | { $1 } 37 | 38 | | TOK_KW_LET TOK_NAME TOK_EQ expr TOK_KW_IN expr 39 | { Let($2, $4, $6) } 40 | 41 | | TOK_KW_FORALL param_list TOK_MINUS_GT expr 42 | { List.fold_right (fun (name, typ) body -> TyFun(name, typ, body)) $2 $4 } 43 | 44 | | binop_expr TOK_MINUS_GT expr 45 | { TyFun("", $1, $3) } 46 | 47 | | TOK_KW_FUN param_list_opt_ann TOK_MINUS_GT expr 48 | { List.fold_right (fun (name, typ) body -> Fun(name, typ, body)) $2 $4 } 49 | 50 | | error 51 | { failwith "expecting expression" } 52 | ; 53 | 54 | binop_expr: 55 | | app_expr 56 | { $1 } 57 | 58 | | TOK_KW_UNIFY atom_expr atom_expr 59 | { Unify($2, $3) } 60 | 61 | | binop_expr TOK_COLON binop_expr 62 | { Ann($1, $3) } 63 | ; 64 | 65 | app_expr: 66 | | atom_expr 67 | { $1 } 68 | 69 | | app_expr atom_expr 70 | { App($1, $2) } 71 | ; 72 | 73 | atom_expr : 74 | | TOK_LPAREN expr TOK_RPAREN 75 | { $2 } 76 | 77 | | TOK_NAME 78 | { Var $1 } 79 | 80 | | TOK_KW_TYPE 81 | { Type } 82 | 83 | | TOK_UNDERSCORE 84 | { Hole } 85 | ; 86 | 87 | 88 | param_list : 89 | | param_decl 90 | { $1 } 91 | | param_decl param_list 92 | { $1 @ $2 } 93 | | error 94 | { failwith "expected function parameter" } 95 | ; 96 | 97 | 98 | param_list_opt_ann : 99 | | param_decl_opt_ann 100 | { $1 } 101 | | param_decl_opt_ann param_list_opt_ann 102 | { $1 @ $2 } 103 | | error 104 | { failwith "expected function parameter" } 105 | ; 106 | 107 | 108 | 109 | param_decl : 110 | | TOK_LPAREN name_list_nonempty TOK_COLON expr TOK_RPAREN 111 | { List.map (fun name -> (name, $4)) $2 } 112 | ; 113 | 114 | param_decl_opt_ann : 115 | | TOK_LPAREN name_list_nonempty TOK_COLON expr TOK_RPAREN 116 | { List.map (fun name -> (name, Some $4)) $2 } 117 | | TOK_NAME 118 | { [$1, None] } 119 | ; 120 | 121 | name_list_nonempty : 122 | | TOK_NAME { [$1] } 123 | | TOK_NAME name_list_nonempty { $1 :: $2 } 124 | ; 125 | -------------------------------------------------------------------------------- /untyped-meta/Parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | open Surface 4 | %} 5 | 6 | %token TOK_EOF 7 | %token TOK_LPAREN TOK_RPAREN TOK_LBRACE TOK_RBRACE 8 | %token TOK_MINUS_GT 9 | %token TOK_EQ 10 | %token TOK_COLON 11 | %token TOK_UNDERSCORE 12 | 13 | %token TOK_NAME 14 | %token TOK_INT 15 | %token TOK_KW_TYPE TOK_KW_FORALL 16 | %token TOK_KW_FUN TOK_KW_LET TOK_KW_IN 17 | %token TOK_KW_UNIFY 18 | 19 | 20 | 21 | %right TOK_MINUS_GT 22 | %left TOK_COLON 23 | 24 | 25 | %type single_expr 26 | %start single_expr 27 | 28 | %% 29 | 30 | single_expr : 31 | | expr TOK_EOF { $1 } 32 | ; 33 | 34 | expr : 35 | | binop_expr 36 | { $1 } 37 | 38 | | TOK_KW_LET TOK_NAME TOK_EQ expr TOK_KW_IN expr 39 | { Let($2, $4, $6) } 40 | 41 | | TOK_KW_FORALL param_list TOK_MINUS_GT expr 42 | { List.fold_right (fun (name, typ) body -> TyFun(name, typ, body)) $2 $4 } 43 | 44 | | binop_expr TOK_MINUS_GT expr 45 | { TyFun("", $1, $3) } 46 | 47 | | TOK_KW_FUN param_list_opt_ann TOK_MINUS_GT expr 48 | { List.fold_right (fun (name, typ) body -> Fun(name, typ, body)) $2 $4 } 49 | 50 | | error 51 | { failwith "expecting expression" } 52 | ; 53 | 54 | binop_expr: 55 | | app_expr 56 | { $1 } 57 | 58 | | TOK_KW_UNIFY atom_expr atom_expr 59 | { Unify($2, $3) } 60 | 61 | | binop_expr TOK_COLON binop_expr 62 | { Ann($1, $3) } 63 | ; 64 | 65 | app_expr: 66 | | atom_expr 67 | { $1 } 68 | 69 | | app_expr atom_expr 70 | { App($1, $2) } 71 | ; 72 | 73 | atom_expr : 74 | | TOK_LPAREN expr TOK_RPAREN 75 | { $2 } 76 | 77 | | TOK_NAME 78 | { Var $1 } 79 | 80 | | TOK_KW_TYPE 81 | { Type } 82 | 83 | | TOK_UNDERSCORE 84 | { Hole } 85 | ; 86 | 87 | 88 | param_list : 89 | | param_decl 90 | { $1 } 91 | | param_decl param_list 92 | { $1 @ $2 } 93 | | error 94 | { failwith "expected function parameter" } 95 | ; 96 | 97 | 98 | param_list_opt_ann : 99 | | param_decl_opt_ann 100 | { $1 } 101 | | param_decl_opt_ann param_list_opt_ann 102 | { $1 @ $2 } 103 | | error 104 | { failwith "expected function parameter" } 105 | ; 106 | 107 | 108 | 109 | param_decl : 110 | | TOK_LPAREN name_list_nonempty TOK_COLON expr TOK_RPAREN 111 | { List.map (fun name -> (name, $4)) $2 } 112 | ; 113 | 114 | param_decl_opt_ann : 115 | | TOK_LPAREN name_list_nonempty TOK_COLON expr TOK_RPAREN 116 | { List.map (fun name -> (name, Some $4)) $2 } 117 | | TOK_NAME 118 | { [$1, None] } 119 | ; 120 | 121 | name_list_nonempty : 122 | | TOK_NAME { [$1] } 123 | | TOK_NAME name_list_nonempty { $1 :: $2 } 124 | ; 125 | -------------------------------------------------------------------------------- /generalized-eta/Parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | open Surface 4 | %} 5 | 6 | %token TOK_EOF 7 | %token TOK_LPAREN TOK_RPAREN TOK_LBRACE TOK_RBRACE 8 | %token TOK_MINUS_GT 9 | %token TOK_EQ 10 | %token TOK_COLON 11 | %token TOK_UNDERSCORE 12 | 13 | %token TOK_NAME 14 | %token TOK_INT 15 | %token TOK_KW_TYPE TOK_KW_FORALL 16 | %token TOK_KW_FUN TOK_KW_LET TOK_KW_IN 17 | %token TOK_KW_UNIFY 18 | 19 | 20 | 21 | %right TOK_MINUS_GT 22 | %left TOK_COLON 23 | 24 | 25 | %type single_expr 26 | %start single_expr 27 | 28 | %% 29 | 30 | single_expr : 31 | | expr TOK_EOF { $1 } 32 | ; 33 | 34 | expr : 35 | | binop_expr 36 | { $1 } 37 | 38 | | TOK_KW_LET TOK_NAME TOK_EQ expr TOK_KW_IN expr 39 | { Let($2, $4, $6) } 40 | 41 | | TOK_KW_FORALL param_list TOK_MINUS_GT expr 42 | { List.fold_right (fun (name, typ) body -> TyFun(name, typ, body)) $2 $4 } 43 | 44 | | binop_expr TOK_MINUS_GT expr 45 | { TyFun("", $1, $3) } 46 | 47 | | TOK_KW_FUN param_list_opt_ann TOK_MINUS_GT expr 48 | { List.fold_right (fun (name, typ) body -> Fun(name, typ, body)) $2 $4 } 49 | 50 | | error 51 | { failwith "expecting expression" } 52 | ; 53 | 54 | binop_expr: 55 | | app_expr 56 | { $1 } 57 | 58 | | TOK_KW_UNIFY atom_expr atom_expr 59 | { Unify($2, $3) } 60 | 61 | | binop_expr TOK_COLON binop_expr 62 | { Ann($1, $3) } 63 | ; 64 | 65 | app_expr: 66 | | atom_expr 67 | { $1 } 68 | 69 | | app_expr atom_expr 70 | { App($1, $2) } 71 | ; 72 | 73 | atom_expr : 74 | | TOK_LPAREN expr TOK_RPAREN 75 | { $2 } 76 | 77 | | TOK_NAME 78 | { Var $1 } 79 | 80 | | TOK_KW_TYPE 81 | { Type } 82 | 83 | | TOK_UNDERSCORE 84 | { Hole } 85 | ; 86 | 87 | 88 | param_list : 89 | | param_decl 90 | { $1 } 91 | | param_decl param_list 92 | { $1 @ $2 } 93 | | error 94 | { failwith "expected function parameter" } 95 | ; 96 | 97 | 98 | param_list_opt_ann : 99 | | param_decl_opt_ann 100 | { $1 } 101 | | param_decl_opt_ann param_list_opt_ann 102 | { $1 @ $2 } 103 | | error 104 | { failwith "expected function parameter" } 105 | ; 106 | 107 | 108 | 109 | param_decl : 110 | | TOK_LPAREN name_list_nonempty TOK_COLON expr TOK_RPAREN 111 | { List.map (fun name -> (name, $4)) $2 } 112 | ; 113 | 114 | param_decl_opt_ann : 115 | | TOK_LPAREN name_list_nonempty TOK_COLON expr TOK_RPAREN 116 | { List.map (fun name -> (name, Some $4)) $2 } 117 | | TOK_NAME 118 | { [$1, None] } 119 | ; 120 | 121 | name_list_nonempty : 122 | | TOK_NAME { [$1] } 123 | | TOK_NAME name_list_nonempty { $1 :: $2 } 124 | ; 125 | -------------------------------------------------------------------------------- /typed-meta/typedMetaTest.ml: -------------------------------------------------------------------------------- 1 | 2 | open TypedMeta 3 | 4 | let expr_of_string label src = 5 | let lexbuf = Lexing.from_string src in 6 | Lexing.set_filename lexbuf label; 7 | Parser.single_expr Lexer.token lexbuf 8 | 9 | 10 | let tests = ref [] 11 | 12 | let run_test () = 13 | let total = List.length !tests in 14 | let passed = ref 0 in 15 | Format.printf "@["; 16 | List.rev !tests |> List.iter begin fun (label, expected, src) -> 17 | MetaContext.reset (); 18 | let expr = expr_of_string label src in 19 | let result = 20 | try ignore (Typecheck.infer Typecheck.empty_ctx expr); None with 21 | Failure msg -> Some msg 22 | in 23 | let pp_result fmt = function 24 | | None -> Format.fprintf fmt "well typed" 25 | | Some msg -> Format.fprintf fmt "error: %s" msg 26 | in 27 | if result = expected 28 | then begin 29 | incr passed; 30 | Format.printf "test %s passed@ " label 31 | end 32 | else begin 33 | Format.printf "test %s failed:@ " label; 34 | Format.printf "@[expected:@ %a@]@ " pp_result expected; 35 | Format.printf "@[actual:@ %a@]@ " pp_result result; 36 | end 37 | end; 38 | Format.printf "summary: %d of %d tests passed@ " !passed total; 39 | Format.printf "@]"; 40 | if !passed <> total then 41 | failwith "test failed" 42 | 43 | let register_test label expected src = 44 | tests := (label, expected, src) :: !tests 45 | ;; 46 | 47 | 48 | 49 | register_test "basic" None " 50 | fun (A : Type) (B : A -> Type) (f : forall (a : A) -> B a) (a : A) -> f a 51 | " ;; 52 | 53 | register_test "hole.infer" None " 54 | fun (A : Type) (f : A -> A) (a : _) -> f a 55 | " ;; 56 | 57 | register_test "hole.check" None " 58 | fun (A : Type) (B : A -> Type) (f : forall (a : A) -> B a) (a0 : A) -> 59 | (f _ : B a0) 60 | " ;; 61 | 62 | 63 | register_test "unify.context.1" None " 64 | fun (A : Type) -> 65 | let M = _ : Type in 66 | fun (a : A) -> 67 | unify M A 68 | " ;; 69 | 70 | register_test "unify.context.2" (Some "variable may escape its scope") " 71 | fun (A : Type) -> 72 | let M = _ : A in 73 | fun (a : A) -> 74 | unify M a 75 | " ;; 76 | 77 | 78 | register_test "unify.app.1" None " 79 | let f = _ : (Type -> Type) in 80 | fun (A : Type) -> 81 | unify (f A) A 82 | " ;; 83 | 84 | register_test "unify.app.2" None " 85 | fun (A : Type) -> 86 | let f = _ : (A -> (A -> Type) -> Type) in 87 | fun (B : A -> Type) (a0 : A) -> 88 | unify (f a0 B) (B a0) 89 | " ;; 90 | 91 | 92 | register_test "unify.let.1" None " 93 | fun (A : Type) -> 94 | let T = A in 95 | let M = _ : Type in 96 | unify M T 97 | " ;; 98 | 99 | register_test "unify.let.2" None " 100 | fun (A : Type) -> 101 | let M = _ : Type in 102 | let T = A in 103 | unify M T 104 | " ;; 105 | 106 | 107 | let _ = run_test () 108 | -------------------------------------------------------------------------------- /untyped-meta/untypedMetaTest.ml: -------------------------------------------------------------------------------- 1 | 2 | open UntypedMeta 3 | 4 | let expr_of_string label src = 5 | let lexbuf = Lexing.from_string src in 6 | Lexing.set_filename lexbuf label; 7 | Parser.single_expr Lexer.token lexbuf 8 | 9 | 10 | let tests = ref [] 11 | 12 | let run_test () = 13 | let total = List.length !tests in 14 | let passed = ref 0 in 15 | Format.printf "@["; 16 | List.rev !tests |> List.iter begin fun (label, expected, src) -> 17 | MetaContext.reset (); 18 | let expr = expr_of_string label src in 19 | let result = 20 | try ignore (Typecheck.infer Typecheck.empty_ctx expr); None with 21 | Failure msg -> Some msg 22 | in 23 | let pp_result fmt = function 24 | | None -> Format.fprintf fmt "well typed" 25 | | Some msg -> Format.fprintf fmt "error: %s" msg 26 | in 27 | if result = expected 28 | then begin 29 | incr passed; 30 | Format.printf "test %s passed@ " label 31 | end 32 | else begin 33 | Format.printf "test %s failed:@ " label; 34 | Format.printf "@[expected:@ %a@]@ " pp_result expected; 35 | Format.printf "@[actual:@ %a@]@ " pp_result result; 36 | end 37 | end; 38 | Format.printf "summary: %d of %d tests passed@ " !passed total; 39 | Format.printf "@]"; 40 | if !passed <> total then 41 | failwith "test failed" 42 | 43 | let register_test label expected src = 44 | tests := (label, expected, src) :: !tests 45 | ;; 46 | 47 | 48 | 49 | register_test "basic" None " 50 | fun (A : Type) (B : A -> Type) (f : forall (a : A) -> B a) (a : A) -> f a 51 | " ;; 52 | 53 | register_test "hole.infer" None " 54 | fun (A : Type) (f : A -> A) (a : _) -> f a 55 | " ;; 56 | 57 | register_test "hole.check" None " 58 | fun (A : Type) (B : A -> Type) (f : forall (a : A) -> B a) (a0 : A) -> 59 | (f _ : B a0) 60 | " ;; 61 | 62 | 63 | register_test "unify.context.1" None " 64 | fun (A : Type) -> 65 | let M = _ : Type in 66 | fun (a : A) -> 67 | unify M A 68 | " ;; 69 | 70 | register_test "unify.context.2" (Some "variable may escape its scope") " 71 | fun (A : Type) -> 72 | let M = _ : A in 73 | fun (a : A) -> 74 | unify M a 75 | " ;; 76 | 77 | 78 | register_test "unify.app.1" None " 79 | let f = _ : (Type -> Type) in 80 | fun (A : Type) -> 81 | unify (f A) A 82 | " ;; 83 | 84 | register_test "unify.app.2" None " 85 | fun (A : Type) -> 86 | let f = _ : (A -> (A -> Type) -> Type) in 87 | fun (B : A -> Type) (a0 : A) -> 88 | unify (f a0 B) (B a0) 89 | " ;; 90 | 91 | 92 | register_test "unify.let.1" None " 93 | fun (A : Type) -> 94 | let T = A in 95 | let M = _ : Type in 96 | unify M T 97 | " ;; 98 | 99 | register_test "unify.let.2" None " 100 | fun (A : Type) -> 101 | let M = _ : Type in 102 | let T = A in 103 | unify M T 104 | " ;; 105 | 106 | 107 | let _ = run_test () 108 | -------------------------------------------------------------------------------- /typed-meta/Pretty.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Format 4 | 5 | 6 | let prec_binder = 10 7 | let prec_app = 20 8 | 9 | 10 | type pp_context = 11 | { names : string list 12 | ; level : int 13 | ; prec : int } 14 | 15 | 16 | let add_var name ctx = 17 | let name = if List.mem name ctx.names then "" else name in 18 | ( name, { ctx with names = name :: ctx.names; level = ctx.level + 1 }) 19 | 20 | let pp_name fmt (name, lvl) = 21 | if name = "" 22 | then fprintf fmt "$%d" lvl 23 | else fprintf fmt "%s" name 24 | 25 | 26 | let incr_prec ctx = { ctx with prec = ctx.prec + 1 } 27 | 28 | 29 | let rec pp_core ctx fmt core = 30 | match core with 31 | | Core.Idx idx -> 32 | pp_name fmt (List.nth ctx.names idx, ctx.level - idx - 1) 33 | 34 | | Core.Let(name, rhs, body) when ctx.prec <= prec_binder -> 35 | let name, ctx' = add_var name ctx in 36 | fprintf fmt "@[@[let %s =@ %a@]@ in@ %a@]" 37 | name (pp_core { ctx with prec = prec_binder }) rhs 38 | (pp_core { ctx' with prec = prec_binder }) body 39 | 40 | | Core.Type -> 41 | fprintf fmt "Type" 42 | 43 | | Core.TyFun(name, a, b) when ctx.prec <= prec_binder -> 44 | fprintf fmt "@[forall %a@]" 45 | (pp_core_tyfun { ctx with prec = prec_binder }) (name, a, b) 46 | 47 | | Core.Fun(name, body) when ctx.prec <= prec_binder -> 48 | fprintf fmt "@[fun %a@]" 49 | (pp_core_fun { ctx with prec = prec_binder }) (name, body) 50 | 51 | | Core.App(f, a) when ctx.prec <= prec_app -> 52 | fprintf fmt "@[%a@]" (pp_core_app { ctx with prec = prec_app }) (f, a) 53 | 54 | | Core.Meta meta -> 55 | fprintf fmt "?%d" meta 56 | 57 | | _ -> 58 | fprintf fmt "(%a)" (pp_core { ctx with prec = 0 }) core 59 | 60 | 61 | and pp_core_tyfun ctx fmt (name, a, b) = 62 | let name, ctx' = add_var name ctx in 63 | fprintf fmt "(%a : %a)" 64 | pp_name (name, ctx.level) 65 | (pp_core @@ incr_prec ctx) a; 66 | match b with 67 | | Core.TyFun(name', a', b') -> fprintf fmt "@ %a" (pp_core_tyfun ctx') (name', a', b') 68 | | _ -> fprintf fmt " ->@ %a" (pp_core ctx') b 69 | 70 | 71 | and pp_core_fun ctx fmt (name, body) = 72 | let name, ctx' = add_var name ctx in 73 | fprintf fmt "%a" pp_name (name, ctx.level); 74 | match body with 75 | | Core.Fun(name', body') -> fprintf fmt "@ %a" (pp_core_fun ctx') (name', body') 76 | | _ -> fprintf fmt " ->@ %a" (pp_core ctx') body 77 | 78 | 79 | and pp_core_app ctx fmt (f, a) = 80 | begin match f with 81 | | Core.App(f', a') -> pp_core_app ctx fmt (f', a') 82 | | _ -> pp_core ctx fmt f 83 | end; 84 | fprintf fmt "@ %a" (pp_core @@ incr_prec ctx) a 85 | 86 | 87 | 88 | let rec names_of_env = function 89 | | Value.Empty -> [] 90 | | Value.Bound(env', name, _) | Value.Defined(env', name, _, _) -> name :: names_of_env env' 91 | 92 | let pp_core names = 93 | pp_core { names; level = List.length names; prec = 0 } 94 | -------------------------------------------------------------------------------- /generalized-eta/Pretty.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Format 4 | 5 | 6 | let prec_binder = 10 7 | let prec_app = 20 8 | 9 | 10 | type pp_context = 11 | { names : string list 12 | ; level : int 13 | ; prec : int } 14 | 15 | 16 | let add_var name ctx = 17 | let name = if List.mem name ctx.names then "" else name in 18 | ( name, { ctx with names = name :: ctx.names; level = ctx.level + 1 }) 19 | 20 | let pp_name fmt (name, lvl) = 21 | if name = "" 22 | then fprintf fmt "$%d" lvl 23 | else fprintf fmt "%s" name 24 | 25 | 26 | let incr_prec ctx = { ctx with prec = ctx.prec + 1 } 27 | 28 | 29 | let rec pp_core ctx fmt core = 30 | match core with 31 | | Core.Idx idx -> 32 | pp_name fmt (List.nth ctx.names idx, ctx.level - idx - 1) 33 | 34 | | Core.Let(name, rhs, body) when ctx.prec <= prec_binder -> 35 | let name, ctx' = add_var name ctx in 36 | fprintf fmt "@[@[let %s =@ %a@]@ in@ %a@]" 37 | name (pp_core { ctx with prec = prec_binder }) rhs 38 | (pp_core { ctx' with prec = prec_binder }) body 39 | 40 | | Core.Type -> 41 | fprintf fmt "Type" 42 | 43 | | Core.TyFun(name, a, b) when ctx.prec <= prec_binder -> 44 | fprintf fmt "@[forall %a@]" 45 | (pp_core_tyfun { ctx with prec = prec_binder }) (name, a, b) 46 | 47 | | Core.Fun(name, body) when ctx.prec <= prec_binder -> 48 | fprintf fmt "@[fun %a@]" 49 | (pp_core_fun { ctx with prec = prec_binder }) (name, body) 50 | 51 | | Core.App(f, a) when ctx.prec <= prec_app -> 52 | fprintf fmt "@[%a@]" (pp_core_app { ctx with prec = prec_app }) (f, a) 53 | 54 | | Core.Meta meta -> 55 | fprintf fmt "?%d" meta 56 | 57 | | _ -> 58 | fprintf fmt "(%a)" (pp_core { ctx with prec = 0 }) core 59 | 60 | 61 | and pp_core_tyfun ctx fmt (name, a, b) = 62 | let name, ctx' = add_var name ctx in 63 | fprintf fmt "(%a : %a)" 64 | pp_name (name, ctx.level) 65 | (pp_core @@ incr_prec ctx) a; 66 | match b with 67 | | Core.TyFun(name', a', b') -> fprintf fmt "@ %a" (pp_core_tyfun ctx') (name', a', b') 68 | | _ -> fprintf fmt " ->@ %a" (pp_core ctx') b 69 | 70 | 71 | and pp_core_fun ctx fmt (name, body) = 72 | let name, ctx' = add_var name ctx in 73 | fprintf fmt "%a" pp_name (name, ctx.level); 74 | match body with 75 | | Core.Fun(name', body') -> fprintf fmt "@ %a" (pp_core_fun ctx') (name', body') 76 | | _ -> fprintf fmt " ->@ %a" (pp_core ctx') body 77 | 78 | 79 | and pp_core_app ctx fmt (f, a) = 80 | begin match f with 81 | | Core.App(f', a') -> pp_core_app ctx fmt (f', a') 82 | | _ -> pp_core ctx fmt f 83 | end; 84 | fprintf fmt "@ %a" (pp_core @@ incr_prec ctx) a 85 | 86 | 87 | 88 | let rec names_of_env = function 89 | | Value.Empty -> [] 90 | | Value.Bound(env', name, _) | Value.Defined(env', name, _, _) -> name :: names_of_env env' 91 | 92 | let pp_core names = 93 | pp_core { names; level = List.length names; prec = 0 } 94 | -------------------------------------------------------------------------------- /untyped-meta/Pretty.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Format 4 | 5 | 6 | let prec_binder = 10 7 | let prec_app = 20 8 | 9 | 10 | type pp_context = 11 | { names : string list 12 | ; level : int 13 | ; prec : int } 14 | 15 | 16 | let add_var name ctx = 17 | let name = if List.mem name ctx.names then "" else name in 18 | ( name, { ctx with names = name :: ctx.names; level = ctx.level + 1 }) 19 | 20 | let pp_name fmt (name, lvl) = 21 | if name = "" 22 | then fprintf fmt "$%d" lvl 23 | else fprintf fmt "%s" name 24 | 25 | 26 | let incr_prec ctx = { ctx with prec = ctx.prec + 1 } 27 | 28 | 29 | let rec pp_core ctx fmt core = 30 | match core with 31 | | Core.Idx idx -> 32 | pp_name fmt (List.nth ctx.names idx, ctx.level - idx - 1) 33 | 34 | | Core.Let(name, rhs, body) when ctx.prec <= prec_binder -> 35 | let name, ctx' = add_var name ctx in 36 | fprintf fmt "@[@[let %s =@ %a@]@ in@ %a@]" 37 | name (pp_core { ctx with prec = prec_binder }) rhs 38 | (pp_core { ctx' with prec = prec_binder }) body 39 | 40 | | Core.Type -> 41 | fprintf fmt "Type" 42 | 43 | | Core.TyFun(name, a, b) when ctx.prec <= prec_binder -> 44 | fprintf fmt "@[forall %a@]" 45 | (pp_core_tyfun { ctx with prec = prec_binder }) (name, a, b) 46 | 47 | | Core.Fun(name, body) when ctx.prec <= prec_binder -> 48 | fprintf fmt "@[fun %a@]" 49 | (pp_core_fun { ctx with prec = prec_binder }) (name, body) 50 | 51 | | Core.App(f, a) when ctx.prec <= prec_app -> 52 | fprintf fmt "@[%a@]" (pp_core_app { ctx with prec = prec_app }) (f, a) 53 | 54 | | Core.Meta meta -> 55 | fprintf fmt "?%d" meta 56 | 57 | | _ -> 58 | fprintf fmt "(%a)" (pp_core { ctx with prec = 0 }) core 59 | 60 | 61 | and pp_core_tyfun ctx fmt (name, a, b) = 62 | let name, ctx' = add_var name ctx in 63 | fprintf fmt "(%a : %a)" 64 | pp_name (name, ctx.level) 65 | (pp_core @@ incr_prec ctx) a; 66 | match b with 67 | | Core.TyFun(name', a', b') -> fprintf fmt "@ %a" (pp_core_tyfun ctx') (name', a', b') 68 | | _ -> fprintf fmt " ->@ %a" (pp_core ctx') b 69 | 70 | 71 | and pp_core_fun ctx fmt (name, body) = 72 | let name, ctx' = add_var name ctx in 73 | fprintf fmt "%a" pp_name (name, ctx.level); 74 | match body with 75 | | Core.Fun(name', body') -> fprintf fmt "@ %a" (pp_core_fun ctx') (name', body') 76 | | _ -> fprintf fmt " ->@ %a" (pp_core ctx') body 77 | 78 | 79 | and pp_core_app ctx fmt (f, a) = 80 | begin match f with 81 | | Core.App(f', a') -> pp_core_app ctx fmt (f', a') 82 | | _ -> pp_core ctx fmt f 83 | end; 84 | fprintf fmt "@ %a" (pp_core @@ incr_prec ctx) a 85 | 86 | 87 | 88 | let rec names_of_env = function 89 | | Value.Empty -> [] 90 | | Value.Bound(env', name, _) | Value.Defined(env', name, _, _) -> name :: names_of_env env' 91 | 92 | let pp_core names = 93 | pp_core { names; level = List.length names; prec = 0 } 94 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pruning-tutor 2 | a tutorial implementation on an elaborator of a dependently typed language with pruning 3 | 4 | ## Overview 5 | 6 | This is a tutorial implementation of elaborators for a simple dependently language with: 7 | 8 | - Normalization by Evaluation (NBE) 9 | - higher order pattern unification with *pruning* 10 | 11 | There are two parts in this tutorial: 12 | 13 | - `untyped-meta` is the most basic setting. It uses untyped NBE, conversion and meta. 14 | - `typed-meta` features *typed* conversion and meta. It turns out that this has non-trivial interaction with unification. 15 | - `generalized-eta` implements a generalized inversion algorithm that covers η-contraction 16 | 17 | Each part assumes basic understanding of the contents in the previous parts. 18 | So it is recommended to read these parts in order. 19 | The directory of each part holds a README for the technical details and source code reading guide of that part. 20 | You can find a brief introduction of the general topic of elaboration and pattern unification below. 21 | 22 | 23 | ## Introduction 24 | 25 | Elaboration is an important part of dependent type checking, 26 | where source terms with a convenient surface syntax is elaborated 27 | into a more explicit, restrictive yet simple core calculus. 28 | 29 | Elaboration is usually type directed, 30 | so type checking must be done during elaboration too, 31 | which involves normalizing terms in order to compare them, 32 | making the elaboration process very complex. 33 | 34 | A very important concept in elaboration is *meta variables* or *existential variables*, 35 | which are special variables that stand for some unknown expression, 36 | and may be solved and replaced by the elaborator during type checking. 37 | Metas are used to implement holes, 38 | where the program can leave out some part of an expression 39 | and let the type checker infer it automatically, 40 | as well as functions with implicit arguments. 41 | 42 | To solve meta variables during type checking, 43 | it is necessary to support *unification* of terms. 44 | For a dependently typed language, this unification process is *higher order*, 45 | as it must take the semantic of terms (e.g. β and η equality) into account. 46 | 47 | Unfortunately, general higher order unification is undecidable. 48 | Fortunately though, there is a famous decidable fragment called *higher order patterns*, 49 | where all meta variables are applied to a list of *distinct* bound variables, e.g. `?M x y z`. 50 | In this case, equations concerning meta variables can be directly read as a definition. 51 | For example, the equation `?M x y z = x + (y * (z + x))` 52 | has a most general solution `?M = \x. \y. \z. x + (y * (z + x))`. 53 | 54 | While pattern unification with various variants and extensions 55 | have been studied extensively in the literature, 56 | *implementing* it in a actual elaborator is a completely different story. 57 | In research papers, the unification algorithm is usually presented as a series of rewrite rules, 58 | which is convenient for proving properties of the algorithm, 59 | but difficult/inefficient to implement directly. 60 | Besides, research papers usually prefer a named term representation for convenience, 61 | but in implementation, de Bruijn index/level may be more desirable. 62 | 63 | Yet another layer of complexity is introduced, 64 | by the use of *normalization by evaluation* (NBE). 65 | Normalization by evaluation is an efficient way to evaluate and normalize terms, 66 | it is orders of magnitude faster than small-step βη reduction with capture-avoiding substitution. 67 | However, the interaction between NBE and pattern unification is non trivial, 68 | and requires special cares during implementation. 69 | -------------------------------------------------------------------------------- /generalized-eta/generalizedEtaTest.ml: -------------------------------------------------------------------------------- 1 | 2 | open GeneralizedEta 3 | 4 | let expr_of_string label src = 5 | let lexbuf = Lexing.from_string src in 6 | Lexing.set_filename lexbuf label; 7 | Parser.single_expr Lexer.token lexbuf 8 | 9 | 10 | let tests = ref [] 11 | 12 | let run_test () = 13 | let total = List.length !tests in 14 | let passed = ref 0 in 15 | Format.printf "@["; 16 | List.rev !tests |> List.iter begin fun (label, expected, src) -> 17 | MetaContext.reset (); 18 | let expr = expr_of_string label src in 19 | let result = 20 | try ignore (Typecheck.infer Typecheck.empty_ctx expr); None with 21 | Failure msg -> Some msg 22 | in 23 | let pp_result fmt = function 24 | | None -> Format.fprintf fmt "well typed" 25 | | Some msg -> Format.fprintf fmt "error: %s" msg 26 | in 27 | if result = expected 28 | then begin 29 | incr passed; 30 | Format.printf "test %s passed@ " label 31 | end 32 | else begin 33 | Format.printf "test %s failed:@ " label; 34 | Format.printf "@[expected:@ %a@]@ " pp_result expected; 35 | Format.printf "@[actual:@ %a@]@ " pp_result result; 36 | end 37 | end; 38 | Format.printf "summary: %d of %d tests passed@ " !passed total; 39 | Format.printf "@]"; 40 | if !passed <> total then 41 | failwith "test failed" 42 | 43 | let register_test label expected src = 44 | tests := (label, expected, src) :: !tests 45 | ;; 46 | 47 | 48 | 49 | register_test "basic" None " 50 | fun (A : Type) (B : A -> Type) (f : forall (a : A) -> B a) (a : A) -> f a 51 | " ;; 52 | 53 | register_test "hole.infer" None " 54 | fun (A : Type) (f : A -> A) (a : _) -> f a 55 | " ;; 56 | 57 | register_test "hole.check" None " 58 | fun (A : Type) (B : A -> Type) (f : forall (a : A) -> B a) (a0 : A) -> 59 | (f _ : B a0) 60 | " ;; 61 | 62 | 63 | register_test "unify.context.1" None " 64 | fun (A : Type) -> 65 | let M = _ : Type in 66 | fun (a : A) -> 67 | unify M A 68 | " ;; 69 | 70 | register_test "unify.context.2" (Some "variable may escape its scope") " 71 | fun (A : Type) -> 72 | let M = _ : A in 73 | fun (a : A) -> 74 | unify M a 75 | " ;; 76 | 77 | 78 | register_test "unify.app.1" None " 79 | let f = _ : (Type -> Type) in 80 | fun (A : Type) -> 81 | unify (f A) A 82 | " ;; 83 | 84 | register_test "unify.app.2" None " 85 | fun (A : Type) -> 86 | let f = _ : (A -> (A -> Type) -> Type) in 87 | fun (B : A -> Type) (a0 : A) -> 88 | unify (f a0 B) (B a0) 89 | " ;; 90 | 91 | 92 | register_test "unify.let.1" None " 93 | fun (A : Type) -> 94 | let T = A in 95 | let M = _ : Type in 96 | unify M T 97 | " ;; 98 | 99 | register_test "unify.let.2" None " 100 | fun (A : Type) -> 101 | let M = _ : Type in 102 | let T = A in 103 | unify M T 104 | " ;; 105 | 106 | 107 | register_test "unify.eta.1" None " 108 | fun (A : Type) -> 109 | let M = _ : ((A -> A) -> (A -> A)) in 110 | fun (f : A -> A) -> 111 | let whatever = unify f (M (fun x -> f x)) in 112 | unify M (fun (f : A -> A) -> f) 113 | " ;; 114 | 115 | 116 | register_test "unify.eta.2" None " 117 | fun (A : Type) -> 118 | let M = _ : ((A -> A -> A) -> (A -> A -> A)) in 119 | fun (f : A -> A -> A) -> 120 | let whatever = unify f (M (fun x y -> f y x)) in 121 | unify M (fun (g : A -> A -> A) -> fun (y : A) (x : A) -> g x y) 122 | " ;; 123 | 124 | register_test "unify.eta.3" (Some "arguments of meta not invertible") " 125 | fun (A : Type) -> 126 | let M = _ : ((A -> A) -> (A -> A)) in 127 | fun (f : A -> A) (a : A) -> 128 | unify f (M (fun x -> f a)) 129 | " ;; 130 | 131 | register_test "unify.eta.4" (Some "arguments of meta not invertible") " 132 | fun (A : Type) -> 133 | let M = _ : ((A -> A -> A) -> (A -> A -> A)) in 134 | fun (f : A -> A -> A) -> 135 | unify f (M (fun (x y : A) -> f x x)) 136 | " ;; 137 | 138 | register_test "unify.eta.5" (Some "arguments of meta not invertible") " 139 | fun (A : Type) -> 140 | let M = _ : ((A -> A -> A) -> A -> A -> A) in 141 | fun (f : A -> A) -> 142 | unify (M (fun x y -> f x)) (fun (x y : A) -> f x) 143 | " ;; 144 | 145 | 146 | register_test "unify.eta.nested.1" None " 147 | fun (A : Type) -> 148 | let T = (A -> A) -> A in 149 | let M = _ : (T -> T) in 150 | fun (g : T) -> 151 | let whatever = unify (M (fun (f : A -> A) -> g (fun (x : A) -> f x))) g in 152 | unify M (fun (g : T) -> g) 153 | " ;; 154 | 155 | register_test "unify.eta.nested.2" None " 156 | fun (A : Type) -> 157 | let T = (A -> A -> A) -> (A -> A -> A) -> A in 158 | let M = _ : (T -> T) in 159 | fun (h : T) -> 160 | let whatever = unify 161 | (M 162 | (fun (f g : A -> A -> A) -> 163 | h (fun (x y : A) -> f x y) (fun (x y : A) -> g y x))) 164 | h 165 | in 166 | unify M (fun (h : T) -> fun (f g : A -> A -> A) -> h f (fun (y x : A) -> g x y)) 167 | " ;; 168 | 169 | 170 | let _ = run_test () 171 | -------------------------------------------------------------------------------- /untyped-meta/Typecheck.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Value 4 | open Normalize 5 | 6 | 7 | type context = 8 | { level : int 9 | ; venv : value list 10 | ; tenv : Value.env } 11 | 12 | let empty_ctx = 13 | { level = 0 14 | ; venv = [] 15 | ; tenv = Empty } 16 | 17 | let add_bound name typ ctx = 18 | { level = ctx.level + 1 19 | ; venv = stuck_local ctx.level :: ctx.venv 20 | ; tenv = Bound(ctx.tenv, name, typ) } 21 | 22 | let add_defined name typ value ctx = 23 | { level = ctx.level + 1 24 | ; venv = value :: ctx.venv 25 | ; tenv = Defined(ctx.tenv, name, typ, value) } 26 | 27 | 28 | let find_var name ctx = 29 | let rec loop idx env = 30 | match env with 31 | | Empty -> 32 | failwith("unbound variable " ^ name) 33 | | Bound(env', name', typ) | Defined(env', name', typ, _) -> 34 | if name' = name 35 | then idx, typ 36 | else loop (idx + 1) env' 37 | in 38 | loop 0 ctx.tenv 39 | 40 | 41 | let rec infer ctx expr = 42 | match expr with 43 | | Surface.Var name -> 44 | let idx, typ = find_var name ctx in 45 | typ, Core.Idx idx 46 | 47 | | Surface.Let(name, rhs, body) -> 48 | let rhs_typ , rhsC = infer ctx rhs in 49 | let body_typ, bodyC = infer (add_defined name rhs_typ (eval ctx.venv rhsC) ctx) body in 50 | body_typ, Core.Let(name, rhsC, bodyC) 51 | 52 | | Surface.Ann(expr', ann) -> 53 | let annC = check_typ ctx ann in 54 | let typ = eval ctx.venv annC in 55 | let exprC = check ctx typ expr' in 56 | typ, exprC 57 | 58 | | Surface.Type -> 59 | (* type-in-type, for simplicity *) 60 | Type, Core.Type 61 | 62 | | Surface.TyFun(name, a, b) -> 63 | let aC = check_typ ctx a in 64 | let aV = eval ctx.venv aC in 65 | let bC = check_typ (add_bound name aV ctx) b in 66 | Type, Core.TyFun(name, aC, bC) 67 | 68 | | Surface.Fun(name, ann, body) -> 69 | let arg_typ = 70 | match ann with 71 | | Some ann -> 72 | let annC = check_typ ctx ann in 73 | eval ctx.venv annC 74 | | None -> 75 | let meta = MetaContext.fresh_meta () in 76 | Stuck(Meta meta, Unify.boundvars_to_spine ctx.level ctx.tenv) 77 | in 78 | let ret_typ, bodyC = infer (add_bound name arg_typ ctx) body in 79 | let ret_typC = quote (ctx.level + 1) ret_typ in 80 | TyFun(name, arg_typ, fun v -> eval (v :: ctx.venv) ret_typC), Core.Fun(name, bodyC) 81 | 82 | | Surface.App(func, arg) -> 83 | let func_typ, funcC = infer ctx func in 84 | begin match force func_typ with 85 | | TyFun(_, a, b) -> 86 | let argC = check ctx a arg in 87 | b (eval ctx.venv argC), Core.App(funcC, argC) 88 | | _ -> 89 | failwith "function expected" 90 | end 91 | 92 | | Surface.Hole -> 93 | let typ_meta = MetaContext.fresh_meta () in 94 | let hole_meta = MetaContext.fresh_meta () in 95 | let sp = Unify.boundvars_to_spine ctx.level ctx.tenv in 96 | Stuck(Meta typ_meta, sp), quote ctx.level @@ Stuck(Meta hole_meta, sp) 97 | 98 | | Surface.Unify(lhs, rhs) -> 99 | let lhs_typ, lhsC = infer ctx lhs in 100 | let rhs_typ, rhsC = infer ctx rhs in 101 | Unify.unify ctx.level lhs_typ rhs_typ; 102 | Unify.unify ctx.level (eval ctx.venv lhsC) (eval ctx.venv rhsC); 103 | lhs_typ, lhsC 104 | 105 | 106 | and check_typ ctx expr = 107 | let typ, core = infer ctx expr in 108 | match Unify.unify ctx.level typ Type with 109 | | () -> core 110 | | exception _ -> failwith "type expected" 111 | 112 | 113 | and check ctx typ expr = 114 | match force typ, expr with 115 | | typ, Surface.Let(name, rhs, body) -> 116 | let rhs_typ, rhsC = infer ctx rhs in 117 | let bodyC = check (add_defined name rhs_typ (eval ctx.venv rhsC) ctx) typ body in 118 | Core.Let(name, rhsC, bodyC) 119 | 120 | | TyFun(_, a, b), Surface.Fun(name, ann, body) -> 121 | let arg_typ = 122 | match ann with 123 | | Some ann -> 124 | let annC = check_typ ctx ann in 125 | let annV = eval ctx.venv annC in 126 | Unify.unify ctx.level annV a; 127 | annV 128 | | None -> 129 | a 130 | in 131 | let bodyC = check (add_bound name arg_typ ctx) (b @@ stuck_local ctx.level) body in 132 | Core.Fun(name, bodyC) 133 | 134 | | _, Surface.Hole -> 135 | let hole_meta = MetaContext.fresh_meta () in 136 | quote ctx.level @@ Stuck(Meta hole_meta, Unify.boundvars_to_spine ctx.level ctx.tenv) 137 | 138 | | typ, Surface.Unify(lhs, rhs) -> 139 | let lhsC = check ctx typ lhs in 140 | let rhsC = check ctx typ rhs in 141 | Unify.unify ctx.level (eval ctx.venv lhsC) (eval ctx.venv rhsC); 142 | lhsC 143 | 144 | | _ -> 145 | let typ', core = infer ctx expr in 146 | Unify.unify ctx.level typ typ'; 147 | core 148 | -------------------------------------------------------------------------------- /typed-meta/README.md: -------------------------------------------------------------------------------- 1 | # Typed conversion and meta 2 | 3 | ## Introduction 4 | 5 | This part is just a slight extension to the previous part (`untyped-meta`). 6 | It features a *typed* conversion algorithm, 7 | that is, two values are always checked for convertibility at some specified type. 8 | Typed conversion can be used to implement `η` rules. 9 | However, as in `untyped-meta` and `03-hole` of [[1]](#ref1), 10 | η-conversion can be implemented *without* explicitly passing types, too. 11 | However, more sophiscated type-directed conversion principles, 12 | such as definitionally proof-irrelevant types, 13 | cannot be handled without types. 14 | 15 | There are two ways to implement typed conversion: 16 | 17 | 1. the "Tait's Yoga" style, where values are annotated with types. 18 | (More specifically, the embedding `neutral -> value`, 19 | as well as the arguments of a bound variable in a neutral term, 20 | are annotated with types). 21 | 22 | 1. use untyped value representation and untyped normalization, 23 | only pass the types around during conversion. 24 | 25 | Here I will take the latter approach, 26 | because the former will require *much*, *much more* bookkeeping during unification. 27 | 28 | Another design choice is whether normalization should produce η-expanded terms. 29 | The only place we need η is conversion. 30 | However, conversion can be implemented on values directly. 31 | So there's no need to produce η-long normal forms in normalization. 32 | 33 | Actually, producing η-expanded terms in normalization has bad interaction with pattern unifcation. 34 | Recall that in pattern unification, 35 | the arguments of a meta variable must be a list of distinct bound variables. 36 | However, if these variables are η-expanded, 37 | the pattern condition will be violated syntactically, 38 | and it is algorithmcally difficult (though possible) to invert the η-expansion. 39 | 40 | Due to the above reasons, the final design of the type system in this part features: 41 | 42 | 1. untyped value representation 43 | 1. untyped normalization that does not perform any η-expansion 44 | 1. typed conversion 45 | 46 | To implement typed conversion, 47 | metas must be typed, otherwise there won't be enough type information. 48 | So meta variables are typed in this part. 49 | 50 | 51 | ## Source code structure and reading guide 52 | 53 | The source code structure is identical to `untyped-meta`: 54 | 55 | - `Syntax.ml`: definition of core syntax, surface syntax and semantic values 56 | - `MetaContext.ml`: context that maintains a global list of metas 57 | - `Normalize.ml`: a simple untyped NBE algorithm 58 | - `Unify.ml`: the main pattern unification algorithm with pruning 59 | - `Typecheck.ml`: a simple bidirectional type checker 60 | - `Pretty.ml`, `Parser.mly` and `Lexer.mll`: boring utilities 61 | - `typedMetaTest.ml`: tests for the implementation. You can find some example programs here 62 | 63 | Meta variables are now typed, 64 | which requires some slight modification in `Syntax.ml`, `MetaContext.ml` and `Normalize.ml`. 65 | However, the only interesting difference lies `Unify.ml`. 66 | 67 | 68 | ## Adapt for typed meta 69 | 70 | For the unification algorithm, 71 | the major effect of switching to typed meta happens at fresh meta allocation: 72 | a type is now needed. 73 | There are two sources of meta allocation in our unification algorithm: 74 | 75 | 1. Holes in surface syntax. 76 | Assume we encounter a hole at context `Γ` with type `A`, 77 | the corresponding meta should have type `Γ -> A`. 78 | There's a pitfall here, though: *let-defined variables in* `Γ` *should not be added*. 79 | See `env_to_tyfun` in `Unify.ml` for the implementation of this operation. 80 | 81 | 1. Flex-flex case in unification. 82 | Assume we are applying a partial substitution `ρ` to a meta-headed term `?M x y`, 83 | and the variable `x` should be pruned, then we need to allocate a fresh meta variable `?M'`, 84 | and solve `?M` with `\$1. \$2. ?M' $2`. 85 | What should be the type of `?M'`, then? 86 | Assume the type of `?M` is `(x : X) -> (y : Y) -> Z`, 87 | then `?M'` should have type `(y : Y) -> Z`. 88 | But notice that we are working with a *dependently typed* theory, so `Y` may depend on `x`! 89 | If `Y` indeed depend on `X`, then the equation will be ill-typed. 90 | But even when `Y` does *not* depend on `X`, since we are using de Bruijin index/level, 91 | `Y` lives in a context with `x` included, and we have to adjust its context. 92 | 93 | ## Handling type of meta in flex-flex 94 | 95 | To properly handle the type of new metas in flex-flex case, 96 | a new operation, `prune_tyfun` is implemented in `Unify.ml`. 97 | It receives a pruning `pr` and a type `typ` (which is expected to be a function type), 98 | prune away the arguments of `typ` according to `pr`, 99 | and return the pruned, scope-safe type. 100 | 101 | `prune_tyfun` reuses the partial substitution operation. 102 | It maintains a partial substitution that forgets the pruned variables, 103 | and applies it to the processed type all along the way. 104 | See the `prune_tyfun` function in `Unify.ml` for more details. 105 | 106 | 107 | ## References 108 | 109 | [1] 110 | 111 | -------------------------------------------------------------------------------- /typed-meta/Typecheck.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Value 4 | open Normalize 5 | 6 | 7 | type context = 8 | { level : int 9 | ; venv : value list 10 | ; tenv : Value.env } 11 | 12 | let empty_ctx = 13 | { level = 0 14 | ; venv = [] 15 | ; tenv = Empty } 16 | 17 | let add_bound name typ ctx = 18 | { level = ctx.level + 1 19 | ; venv = stuck_local ctx.level :: ctx.venv 20 | ; tenv = Bound(ctx.tenv, name, typ) } 21 | 22 | let add_defined name typ value ctx = 23 | { level = ctx.level + 1 24 | ; venv = value :: ctx.venv 25 | ; tenv = Defined(ctx.tenv, name, typ, value) } 26 | 27 | 28 | let find_var name ctx = 29 | let rec loop idx env = 30 | match env with 31 | | Empty -> 32 | failwith("unbound variable " ^ name) 33 | | Bound(env', name', typ) | Defined(env', name', typ, _) -> 34 | if name' = name 35 | then idx, typ 36 | else loop (idx + 1) env' 37 | in 38 | loop 0 ctx.tenv 39 | 40 | 41 | let rec infer ctx expr = 42 | match expr with 43 | | Surface.Var name -> 44 | let idx, typ = find_var name ctx in 45 | typ, Core.Idx idx 46 | 47 | | Surface.Let(name, rhs, body) -> 48 | let rhs_typ , rhsC = infer ctx rhs in 49 | let body_typ, bodyC = infer (add_defined name rhs_typ (eval ctx.venv rhsC) ctx) body in 50 | body_typ, Core.Let(name, rhsC, bodyC) 51 | 52 | | Surface.Ann(expr', ann) -> 53 | let annC = check_typ ctx ann in 54 | let typ = eval ctx.venv annC in 55 | let exprC = check ctx typ expr' in 56 | typ, exprC 57 | 58 | | Surface.Type -> 59 | (* type-in-type, for simplicity *) 60 | Type, Core.Type 61 | 62 | | Surface.TyFun(name, a, b) -> 63 | let aC = check_typ ctx a in 64 | let aV = eval ctx.venv aC in 65 | let bC = check_typ (add_bound name aV ctx) b in 66 | Type, Core.TyFun(name, aC, bC) 67 | 68 | | Surface.Fun(name, ann, body) -> 69 | let arg_typ = 70 | match ann with 71 | | Some ann -> 72 | let annC = check_typ ctx ann in 73 | eval ctx.venv annC 74 | | None -> 75 | let meta = MetaContext.fresh_meta (Unify.env_to_tyfun ctx.tenv Type) in 76 | Stuck(Meta meta, Unify.boundvars_to_spine ctx.level ctx.tenv) 77 | in 78 | let ret_typ, bodyC = infer (add_bound name arg_typ ctx) body in 79 | let ret_typC = quote (ctx.level + 1) ret_typ in 80 | TyFun(name, arg_typ, fun v -> eval (v :: ctx.venv) ret_typC), Core.Fun(name, bodyC) 81 | 82 | | Surface.App(func, arg) -> 83 | let func_typ, funcC = infer ctx func in 84 | begin match force func_typ with 85 | | TyFun(_, a, b) -> 86 | let argC = check ctx a arg in 87 | b (eval ctx.venv argC), Core.App(funcC, argC) 88 | | _ -> 89 | failwith "function expected" 90 | end 91 | 92 | | Surface.Hole -> 93 | let typ_meta = MetaContext.fresh_meta (Unify.env_to_tyfun ctx.tenv Type) in 94 | let sp = Unify.boundvars_to_spine ctx.level ctx.tenv in 95 | let typ = Stuck(Meta typ_meta, sp) in 96 | let hole_meta = MetaContext.fresh_meta typ in 97 | typ, quote ctx.level @@ Stuck(Meta hole_meta, sp) 98 | 99 | | Surface.Unify(lhs, rhs) -> 100 | let lhs_typ, lhsC = infer ctx lhs in 101 | let rhs_typ, rhsC = infer ctx rhs in 102 | Unify.unify ctx.level ctx.tenv Type lhs_typ rhs_typ; 103 | Unify.unify ctx.level ctx.tenv lhs_typ (eval ctx.venv lhsC) (eval ctx.venv rhsC); 104 | lhs_typ, lhsC 105 | 106 | 107 | and check_typ ctx expr = 108 | let typ, core = infer ctx expr in 109 | match Unify.unify ctx.level ctx.tenv Type typ Type with 110 | | () -> core 111 | | exception _ -> failwith "type expected" 112 | 113 | 114 | and check ctx typ expr = 115 | match force typ, expr with 116 | | typ, Surface.Let(name, rhs, body) -> 117 | let rhs_typ, rhsC = infer ctx rhs in 118 | let bodyC = check (add_defined name rhs_typ (eval ctx.venv rhsC) ctx) typ body in 119 | Core.Let(name, rhsC, bodyC) 120 | 121 | | TyFun(_, a, b), Surface.Fun(name, ann, body) -> 122 | let arg_typ = 123 | match ann with 124 | | Some ann -> 125 | let annC = check_typ ctx ann in 126 | let annV = eval ctx.venv annC in 127 | Unify.unify ctx.level ctx.tenv Type annV a; 128 | annV 129 | | None -> 130 | a 131 | in 132 | let bodyC = check (add_bound name arg_typ ctx) (b @@ stuck_local ctx.level) body in 133 | Core.Fun(name, bodyC) 134 | 135 | | typ, Surface.Hole -> 136 | let hole_meta = MetaContext.fresh_meta (Unify.env_to_tyfun ctx.tenv typ) in 137 | quote ctx.level @@ Stuck(Meta hole_meta, Unify.boundvars_to_spine ctx.level ctx.tenv) 138 | 139 | | typ, Surface.Unify(lhs, rhs) -> 140 | let lhsC = check ctx typ lhs in 141 | let rhsC = check ctx typ rhs in 142 | Unify.unify ctx.level ctx.tenv typ (eval ctx.venv lhsC) (eval ctx.venv rhsC); 143 | lhsC 144 | 145 | | _ -> 146 | let typ', core = infer ctx expr in 147 | Unify.unify ctx.level ctx.tenv Type typ typ'; 148 | core 149 | -------------------------------------------------------------------------------- /generalized-eta/Typecheck.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Value 4 | open Normalize 5 | 6 | 7 | type context = 8 | { level : int 9 | ; venv : value list 10 | ; tenv : Value.env } 11 | 12 | let empty_ctx = 13 | { level = 0 14 | ; venv = [] 15 | ; tenv = Empty } 16 | 17 | let add_bound name typ ctx = 18 | { level = ctx.level + 1 19 | ; venv = stuck_local ctx.level :: ctx.venv 20 | ; tenv = Bound(ctx.tenv, name, typ) } 21 | 22 | let add_defined name typ value ctx = 23 | { level = ctx.level + 1 24 | ; venv = value :: ctx.venv 25 | ; tenv = Defined(ctx.tenv, name, typ, value) } 26 | 27 | 28 | let find_var name ctx = 29 | let rec loop idx env = 30 | match env with 31 | | Empty -> 32 | failwith("unbound variable " ^ name) 33 | | Bound(env', name', typ) | Defined(env', name', typ, _) -> 34 | if name' = name 35 | then idx, typ 36 | else loop (idx + 1) env' 37 | in 38 | loop 0 ctx.tenv 39 | 40 | 41 | let rec infer ctx expr = 42 | match expr with 43 | | Surface.Var name -> 44 | let idx, typ = find_var name ctx in 45 | typ, Core.Idx idx 46 | 47 | | Surface.Let(name, rhs, body) -> 48 | let rhs_typ , rhsC = infer ctx rhs in 49 | let body_typ, bodyC = infer (add_defined name rhs_typ (eval ctx.venv rhsC) ctx) body in 50 | body_typ, Core.Let(name, rhsC, bodyC) 51 | 52 | | Surface.Ann(expr', ann) -> 53 | let annC = check_typ ctx ann in 54 | let typ = eval ctx.venv annC in 55 | let exprC = check ctx typ expr' in 56 | typ, exprC 57 | 58 | | Surface.Type -> 59 | (* type-in-type, for simplicity *) 60 | Type, Core.Type 61 | 62 | | Surface.TyFun(name, a, b) -> 63 | let aC = check_typ ctx a in 64 | let aV = eval ctx.venv aC in 65 | let bC = check_typ (add_bound name aV ctx) b in 66 | Type, Core.TyFun(name, aC, bC) 67 | 68 | | Surface.Fun(name, ann, body) -> 69 | let arg_typ = 70 | match ann with 71 | | Some ann -> 72 | let annC = check_typ ctx ann in 73 | eval ctx.venv annC 74 | | None -> 75 | let meta = MetaContext.fresh_meta (Unify.env_to_tyfun ctx.tenv Type) in 76 | Stuck(Meta meta, Unify.boundvars_to_spine ctx.level ctx.tenv) 77 | in 78 | let ret_typ, bodyC = infer (add_bound name arg_typ ctx) body in 79 | let ret_typC = quote (ctx.level + 1) ret_typ in 80 | TyFun(name, arg_typ, fun v -> eval (v :: ctx.venv) ret_typC), Core.Fun(name, bodyC) 81 | 82 | | Surface.App(func, arg) -> 83 | let func_typ, funcC = infer ctx func in 84 | begin match force func_typ with 85 | | TyFun(_, a, b) -> 86 | let argC = check ctx a arg in 87 | b (eval ctx.venv argC), Core.App(funcC, argC) 88 | | _ -> 89 | failwith "function expected" 90 | end 91 | 92 | | Surface.Hole -> 93 | let typ_meta = MetaContext.fresh_meta (Unify.env_to_tyfun ctx.tenv Type) in 94 | let sp = Unify.boundvars_to_spine ctx.level ctx.tenv in 95 | let typ = Stuck(Meta typ_meta, sp) in 96 | let hole_meta = MetaContext.fresh_meta typ in 97 | typ, quote ctx.level @@ Stuck(Meta hole_meta, sp) 98 | 99 | | Surface.Unify(lhs, rhs) -> 100 | let lhs_typ, lhsC = infer ctx lhs in 101 | let rhs_typ, rhsC = infer ctx rhs in 102 | Unify.unify ctx.level ctx.tenv Type lhs_typ rhs_typ; 103 | Unify.unify ctx.level ctx.tenv lhs_typ (eval ctx.venv lhsC) (eval ctx.venv rhsC); 104 | lhs_typ, lhsC 105 | 106 | 107 | and check_typ ctx expr = 108 | let typ, core = infer ctx expr in 109 | match Unify.unify ctx.level ctx.tenv Type typ Type with 110 | | () -> core 111 | | exception _ -> failwith "type expected" 112 | 113 | 114 | and check ctx typ expr = 115 | match force typ, expr with 116 | | typ, Surface.Let(name, rhs, body) -> 117 | let rhs_typ, rhsC = infer ctx rhs in 118 | let bodyC = check (add_defined name rhs_typ (eval ctx.venv rhsC) ctx) typ body in 119 | Core.Let(name, rhsC, bodyC) 120 | 121 | | TyFun(_, a, b), Surface.Fun(name, ann, body) -> 122 | let arg_typ = 123 | match ann with 124 | | Some ann -> 125 | let annC = check_typ ctx ann in 126 | let annV = eval ctx.venv annC in 127 | Unify.unify ctx.level ctx.tenv Type annV a; 128 | annV 129 | | None -> 130 | a 131 | in 132 | let bodyC = check (add_bound name arg_typ ctx) (b @@ stuck_local ctx.level) body in 133 | Core.Fun(name, bodyC) 134 | 135 | | typ, Surface.Hole -> 136 | let hole_meta = MetaContext.fresh_meta (Unify.env_to_tyfun ctx.tenv typ) in 137 | quote ctx.level @@ Stuck(Meta hole_meta, Unify.boundvars_to_spine ctx.level ctx.tenv) 138 | 139 | | typ, Surface.Unify(lhs, rhs) -> 140 | let lhsC = check ctx typ lhs in 141 | let rhsC = check ctx typ rhs in 142 | Unify.unify ctx.level ctx.tenv typ (eval ctx.venv lhsC) (eval ctx.venv rhsC); 143 | lhsC 144 | 145 | | _ -> 146 | let typ', core = infer ctx expr in 147 | Unify.unify ctx.level ctx.tenv Type typ typ'; 148 | core 149 | -------------------------------------------------------------------------------- /generalized-eta/README.md: -------------------------------------------------------------------------------- 1 | # Typed conversion and meta 2 | 3 | ## Introduction 4 | 5 | This part extends the previous part (`typed-meta`) 6 | with a generalization of η-contraction. 7 | It allow the arguments of meta variables to be not only bound variables, 8 | but also "invertible" values, such as `\x. \y. f y x` where `f` is a bound variable. 9 | The idea comes from [[1]](#ref1)[[2]](#ref2). 10 | But the implementation in [[2]](#ref2) seems undocumented. 11 | 12 | **WARING: this implementation is experimental, 13 | even the idea is not guaranteed to be correct.** 14 | 15 | 16 | ## Source code structure and reading guide 17 | 18 | The source code structure is identical to `typed-meta`: 19 | 20 | - `Syntax.ml`: definition of core syntax, surface syntax and semantic values 21 | - `MetaContext.ml`: context that maintains a global list of metas 22 | - `Normalize.ml`: a simple untyped NBE algorithm 23 | - `Unify.ml`: the main pattern unification algorithm with pruning 24 | - `Typecheck.ml`: a simple bidirectional type checker 25 | - `Pretty.ml`, `Parser.mly` and `Lexer.mll`: boring utilities 26 | - `generalizedEtaTest.ml`: tests for the implementation. You can find some example programs here 27 | 28 | The only file different from `typed-meta` is `Unify.ml`. 29 | 30 | 31 | 32 | ## What is and why not η-contraction 33 | 34 | In pattern unification, arguments of a meta variable must be distinct bound variables. 35 | But since we are working with a dependently typed system, 36 | the predicate of "being a bound variable" is not entirely trivial. 37 | For example, `(\x. x) y` should be considered a bound variable, too. 38 | 39 | Fortunately, normalization can help us decide this. 40 | If a term is β-equivalent to a bound variable, 41 | then the normalization algorithm will normalize it to a syntactic bound variable. 42 | So as long as we are working with normal forms, there's no need to worry about β. 43 | 44 | Unfortunately, for η the story is not so simple. 45 | NBE can handle η-equivalence by providing η-**expanded** normal forms, 46 | but bound variables are η-short, 47 | so eta expansion can only drive us away from getting a bound variable. 48 | 49 | In pattern unification literatures, 50 | the standard method to handle η in checking pattern condition is *η-contraction*, 51 | which is the inverse of η-expansion: it takes `\x. f x` to `f` when `x` does not occur in `f`. 52 | However, η-contraction is hard to implement with NBE. 53 | Values in NBE don't support such occurence check under binder, 54 | and we have to convert the values back to terms 55 | and perform the η-contraction syntactically by rewriting. 56 | 57 | Besides, η-contraction is not general enough. 58 | There is no essential difference in handling `\x. \y. f x y` and `\x. \y. f y x`, 59 | but η-contraction can only handle thi first one. 60 | 61 | 62 | ## Generalized η-contraction 63 | 64 | In this part, a generalized version of η-contraction is implemented. 65 | It can not only handle `\x. \y. f x y`, but also `\x. \y. f y x`. 66 | 67 | To grasp the idea of the implementation, 68 | recall *why* the pattern condition is necessary. 69 | When we are dealing with an equation `?M ts = u`, 70 | we want to calculate a invert substitution `ts⁻¹` such that `ts⁻¹ . ts = id`, 71 | so that we can obtain to `?M` by applying `ts⁻¹` to `u`. 72 | 73 | Calculating a principal inverse substitution for arbitary `ts` is impossible. 74 | However, when `ts` is a list of distinct bound variables `xs`, 75 | `xs⁻¹` can be easily computed: that's why we need the pattern condition. 76 | 77 | Now, since our ultimate goal is to find the inverse substitution, 78 | we may generalize bound variables in pattern condition to 79 | any value that are "invertible" in some sense. 80 | For example, `\x. f x` is invertible. 81 | A substitution `g := \x. f x` can be inverted to `f := \x. g x`. 82 | `\x. \y. f y x` is invertible, too. 83 | A substitution `g := \x. \y. f y x` can be inverted to `f := \y. \x. g x y`. 84 | 85 | So, the core of the this part is to 86 | implement a suitable function that inverts a value. 87 | This value inversion function can cover the case of η-contraction, 88 | as well as other cases such as `\x. \y. f y x`. 89 | 90 | ## How to invert a value 91 | 92 | Assume we are inverting a substitution `g := t`. 93 | If `t` is neither a bound variable or a function, e.g. `A -> B`, 94 | then this substitution is not invertible. 95 | So, we only need to deal with the case where `g := \xs. f ts`, 96 | where `f` is a bound variable and does not occur in `xs`. 97 | 98 | Not all such substitutions are invertible, though: 99 | 100 | - the substitution `g := \x. f a`, where `a` is a constructor, is not invertible. 101 | Because we need to map `f` to some `\y. t` such that `t[y :=a] = g x`, 102 | which is impossible as `x` will escape its scope. 103 | 104 | - the substitution `g := \x. f x x`, while invertible, 105 | don't have a principal inversion: 106 | both `f := \x. \y. g x` and `f := \x. \y. g y` are its inversion. 107 | So we should not invert this substitution, 108 | otherwise principality of unification will be lost. 109 | 110 | - the substitution `g := \x. f g x`, while invertible, 111 | don't have a principal inversion too: 112 | both `f := \h. \x. g x` and `f := \h. \x. h x` are inversions of it. 113 | 114 | It turns out that, to make `g := \xs. f ts` (principally) invertible, 115 | `ts` should satisfy some constraint highly similar to the pattern condition: 116 | 117 | - every variable in `xs` must occur in `ts` 118 | - `ts` should be a list of distinct bound variables 119 | - `ts` should only contain variables in `xs` 120 | 121 | Of course, when deciding "is this a bound variable?", we need to take βη into concern. 122 | So we can recursively try to invert `ts`, and apply `ts⁻¹` to `xs`. 123 | If these steps succeed, then the substitution is invertible, 124 | with principal inversion `f := \ys. g (xs[ts⁻¹])`. 125 | 126 | Note that the inversion operation in ordinary pattern unification cannot be reused directly, though. 127 | Because value inversion above impose an extra constraint: 128 | `ts` can only mention variables in `xs`. 129 | We generalize the operation of inversion, 130 | to allow specifying a allowed range of variables. 131 | Variables falling outside this allowed range will be rejected. 132 | 133 | ## Implementation 134 | 135 | To implement the above process properly, 136 | we must also take into account NBE and de Bruijn index/level. 137 | Refer to `Unify.ml` for more details. 138 | The inversion operation above is implemented in `invert_spine` and `invert_value`. 139 | The rest of the implementation is unchanged, compared to the previous part (`typed-meta`). 140 | 141 | 142 | ## References 143 | 144 | [1] 145 | Swapping arguments of variables in higher-order pattern unification 146 | 147 | [2] 148 | 149 | -------------------------------------------------------------------------------- /untyped-meta/Unify.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Value 4 | open Normalize 5 | 6 | 7 | 8 | (* some utilities *) 9 | let rec make_fun n body = 10 | if n = 0 11 | then body 12 | else make_fun (n - 1) (Core.Fun("", body)) 13 | 14 | let rec level_to_spine = function 15 | | 0 -> EmptySp 16 | | n -> App(level_to_spine (n - 1), stuck_local (n - 1)) 17 | 18 | 19 | (* A [psubst] is a partial substitution, such that all values in it are bound variables. 20 | Here: 21 | - [dom] is (the length of) the domain of the partial substitution 22 | - [cod] is (the length of) the codomain of the partial substitution 23 | - [map] is a parial mapping from variables in [dom] to variables in [cod], 24 | represented as an association list *) 25 | type psubst = 26 | { dom : level 27 | ; cod : level 28 | ; map : (level * level) list } 29 | 30 | 31 | let empty_psubst = 32 | { dom = 0 33 | ; cod = 0 34 | ; map = [] } 35 | 36 | 37 | (* Add a new bound variable to a partial substitution [psub]. 38 | Assume: 39 | Γ |- psub : Δ 40 | then: 41 | Γ, x : A[psub] |- add_boundvar psub : Δ, x : A 42 | such that: 43 | x[add_boundvar psub] = x *) 44 | let add_boundvar psub = 45 | { dom = psub.dom + 1 46 | ; cod = psub.cod + 1 47 | ; map = (psub.dom, psub.cod) :: psub.map } 48 | 49 | 50 | 51 | (* Calculate the inverse substitution of a list of arguments. 52 | The list of arguments [sp] should live in a context with length [level]. 53 | That is, assume: 54 | Γ(level) |- sp : Δ 55 | we should have: 56 | Δ |- invert_spine level sp : Γ *) 57 | let rec invert_spine level sp = 58 | match sp with 59 | | EmptySp -> 60 | { empty_psubst with dom = level } 61 | | App(sp', Stuck(Lvl lvl, EmptySp)) -> 62 | (* We are now processing the [psub.cod]-th argument, 63 | it should correspond to the [psub.cod]-th bound variable 64 | in the codomain of the inverse substitution *) 65 | let psub = invert_spine level sp' in 66 | if List.mem_assoc lvl psub.map 67 | then failwith "the same variable occurs twice in arguments of meta" 68 | else { psub with cod = psub.cod + 1; map = (lvl, psub.cod) :: psub.map } 69 | | _ -> 70 | failwith "arguments of meta not a bound variable" 71 | 72 | 73 | 74 | (* A [pruning] is a series of instruction indicating which arguments to discard. 75 | Note that syntactically, pruning is in reverse order of argument lists. 76 | See [prune_spine] below for their relationship. *) 77 | type pruning = 78 | | EmptyPr 79 | | Keep of pruning 80 | | Skip of pruning 81 | 82 | let rec pruning_length = function 83 | | EmptyPr -> (0, 0) 84 | | Keep pr' -> let (tot, rem) = pruning_length pr' in (tot + 1, rem + 1) 85 | | Skip pr' -> let (tot, rem) = pruning_length pr' in (tot + 1, rem) 86 | 87 | 88 | (* [prune_spine pr sp] drop the arguments that should be pruned in [sp], 89 | according to [pr]. *) 90 | let rec prune_spine pr sp = 91 | match pr, sp with 92 | | EmptyPr , EmptySp -> EmptySp 93 | | Keep pr', App(sp', v) -> App(prune_spine pr' sp', v) 94 | | Skip pr', App(sp', _) -> prune_spine pr' sp' 95 | | _ -> failwith "runtime error" 96 | 97 | 98 | (* Let [sp] be a list of bound variables, 99 | [spine_to_pruning pr sp] calculates a pruning that prune away those variables in [sp] 100 | that do not fall in the domain of [psub]. *) 101 | let rec spine_to_pruning psub = function 102 | | EmptySp -> 103 | EmptyPr 104 | | App(sp', Stuck(Lvl lvl, EmptySp)) -> 105 | if List.mem_assoc lvl psub.map 106 | then Keep (spine_to_pruning psub sp') 107 | else Skip (spine_to_pruning psub sp') 108 | | _ -> 109 | failwith "arguments of meta not a bound variable" 110 | 111 | 112 | (* [intersect_spine sp1 sp2] calculates a pruning that prune away those arguments 113 | that differ in [sp1] and [sp2]. *) 114 | let rec intersect_spine sp1 sp2 = 115 | match sp1, sp2 with 116 | | EmptySp, EmptySp -> 117 | EmptyPr 118 | | App(sp1', Stuck(Lvl lvl1, EmptySp)) 119 | , App(sp2', Stuck(Lvl lvl2, EmptySp)) -> 120 | if lvl1 = lvl2 121 | then Keep (intersect_spine sp1' sp2') 122 | else Skip (intersect_spine sp1' sp2') 123 | | _ -> 124 | failwith "runtime error" 125 | 126 | 127 | (* [discard_defined env] discards the defined variables in [env]. *) 128 | let rec discard_defined env : pruning = 129 | match env with 130 | | Empty -> EmptyPr 131 | | Bound(env', _, _) -> Keep (discard_defined env') 132 | | Defined(env', _, _, _) -> Skip (discard_defined env') 133 | 134 | 135 | (* [boundvars_to_spine level env] returns the list of all bound variables in [env] 136 | (of length [level]). *) 137 | let boundvars_to_spine level env = 138 | prune_spine (discard_defined env) (level_to_spine level) 139 | 140 | 141 | 142 | 143 | (* [apply_psubst m psub v] apply the partial substitution [psub] to value [v], 144 | checking for occurence of [m] at the same time. 145 | [v] should live in [psub.dom], and the result should live in [psub.cod], i.e.: 146 | 147 | Γ(psub.cod) |- psub : Δ(psub.dom) 148 | Δ(psub.dom) |- v : A 149 | -------------------------------------- 150 | Γ(psub.cod) |- apply_psubst m psub v : A[psub] 151 | 152 | Since [apply_psubst] must recurse down the structure of [v], 153 | the result is a core expression, similar to quoting in NBE. 154 | 155 | When no occurs check need to be performed, [m] can be set to [-1]. *) 156 | let rec apply_psubst m psub value = 157 | match force value with 158 | | Stuck(Lvl lvl, sp) -> 159 | begin match List.assoc lvl psub.map with 160 | | lvl' -> 161 | apply_psubst_spine m psub (Core.Idx(psub.cod - lvl' - 1)) sp 162 | | exception Not_found -> 163 | failwith "variable may escape its scope" 164 | end 165 | 166 | (* Failed occurs check *) 167 | | Stuck(Meta m', _) when m' = m -> 168 | failwith("meta ?" ^ string_of_int m ^ " occurs recursively in its solution") 169 | 170 | (* Substituting a meta differnt from [m]. 171 | This is the so-called "pruning" operation 172 | and corresponds to the flex-flex case of the rewrite rules. *) 173 | | Stuck(Meta m', sp) -> 174 | let pr = spine_to_pruning psub sp in 175 | let (sp_len, pruned_len) = pruning_length pr in 176 | if sp_len = pruned_len 177 | then apply_psubst_spine m psub (Core.Meta m') sp 178 | else 179 | let new_meta = MetaContext.fresh_meta () in 180 | let solution = 181 | Stuck(Meta new_meta, prune_spine pr @@ level_to_spine sp_len) 182 | |> Normalize.quote sp_len 183 | |> make_fun sp_len 184 | |> Normalize.eval [] 185 | in 186 | let _ = MetaContext.solve_meta m' solution in 187 | apply_psubst_spine m psub (Core.Meta new_meta) (prune_spine pr sp) 188 | 189 | | Type -> 190 | Core.Type 191 | | TyFun(name, a, b) -> 192 | Core.TyFun(name, apply_psubst m psub a, apply_psubst m (add_boundvar psub) @@ b @@ stuck_local psub.dom) 193 | | Fun(name, f) -> 194 | Core.Fun(name, apply_psubst m (add_boundvar psub) @@ f @@ stuck_local psub.dom) 195 | 196 | 197 | and apply_psubst_spine m psub headC = function 198 | | EmptySp -> headC 199 | | App(sp', argv) -> Core.App(apply_psubst_spine m psub headC sp', apply_psubst m psub argv) 200 | 201 | 202 | let rec unify level v1 v2 = 203 | match force v1, force v2 with 204 | | Type, Type -> 205 | () 206 | 207 | | TyFun(_, a1, b1), TyFun(_, a2, b2) -> 208 | unify level a1 a2; 209 | let var = stuck_local level in 210 | unify (level + 1) (b1 var) (b2 var) 211 | 212 | (* Performs η expansion if necessary, 213 | so that the conversion check respects η *) 214 | | Fun(_, _), _ 215 | | _, Fun(_, _) -> 216 | let var = stuck_local level in 217 | unify (level + 1) (apply v1 var) (apply v2 var) 218 | 219 | (* flex-flex case with same meta *) 220 | | Stuck(Meta m1, sp1), Stuck(Meta m2, sp2) when m1 = m2 -> 221 | let pr = intersect_spine sp1 sp2 in 222 | let (sp_len, rem_len) = pruning_length pr in 223 | if sp_len = rem_len then 224 | let new_meta = MetaContext.fresh_meta () in 225 | let solution = 226 | Stuck(Meta new_meta, prune_spine pr @@ level_to_spine sp_len) 227 | |> Normalize.quote level 228 | |> make_fun sp_len 229 | |> Normalize.eval [] 230 | in 231 | MetaContext.solve_meta m1 solution 232 | 233 | (* flex-rigid or flex-flex with different metas *) 234 | | Stuck(Meta m, sp), v 235 | | v, Stuck(Meta m, sp) -> 236 | let psub = invert_spine level sp in 237 | let solution = 238 | apply_psubst m psub v 239 | |> make_fun psub.cod 240 | |> eval [] 241 | in 242 | MetaContext.solve_meta m solution 243 | 244 | | Stuck(Lvl lvl1, sp1), Stuck(Lvl lvl2, sp2) when lvl1 = lvl2 -> 245 | unify_spine level sp1 sp2 246 | 247 | | _ -> 248 | failwith "unsolvable equation" 249 | 250 | 251 | and unify_spine level sp1 sp2 = 252 | match sp1, sp2 with 253 | | EmptySp, EmptySp -> () 254 | | App(sp1', v1), App(sp2', v2) -> unify level v1 v2; unify_spine level sp1' sp2' 255 | | _ -> failwith "unsolvable equation" 256 | -------------------------------------------------------------------------------- /typed-meta/Unify.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Value 4 | open Normalize 5 | 6 | 7 | 8 | (* some utilities *) 9 | let rec make_fun n body = 10 | if n = 0 11 | then body 12 | else make_fun (n - 1) (Core.Fun("", body)) 13 | 14 | let rec level_to_spine = function 15 | | 0 -> EmptySp 16 | | n -> App(level_to_spine (n - 1), stuck_local (n - 1)) 17 | 18 | 19 | (* A [psubst] is a partial substitution, such that all values in it are bound variables. 20 | Here: 21 | - [dom] is (the length of) the domain of the partial substitution 22 | - [cod] is (the length of) the codomain of the partial substitution 23 | - [map] is a parial mapping from variables in [dom] to variables in [cod], 24 | represented as an association list *) 25 | type psubst = 26 | { dom : level 27 | ; cod : level 28 | ; map : (level * level) list } 29 | 30 | 31 | let empty_psubst = 32 | { dom = 0 33 | ; cod = 0 34 | ; map = [] } 35 | 36 | 37 | (* Add a new bound variable to a partial substitution [psub]. 38 | Assume: 39 | Γ |- psub : Δ 40 | then: 41 | Γ, x : A[psub] |- add_boundvar psub : Δ, x : A 42 | such that: 43 | x[add_boundvar psub] = x *) 44 | let add_boundvar psub = 45 | { dom = psub.dom + 1 46 | ; cod = psub.cod + 1 47 | ; map = (psub.dom, psub.cod) :: psub.map } 48 | 49 | 50 | 51 | (* Calculate the inverse substitution of a list of arguments. 52 | The list of arguments [sp] should live in a context with length [level]. 53 | That is, assume: 54 | Γ(level) |- sp : Δ 55 | we should have: 56 | Δ |- invert_spine level sp : Γ *) 57 | let rec invert_spine level sp = 58 | match sp with 59 | | EmptySp -> 60 | { empty_psubst with dom = level } 61 | | App(sp', Stuck(Lvl lvl, EmptySp)) -> 62 | (* We are now processing the [psub.cod]-th argument, 63 | it should correspond to the [psub.cod]-th bound variable 64 | in the codomain of the inverse substitution *) 65 | let psub = invert_spine level sp' in 66 | if List.mem_assoc lvl psub.map 67 | then failwith "the same variable occurs twice in arguments of meta" 68 | else { psub with cod = psub.cod + 1; map = (lvl, psub.cod) :: psub.map } 69 | | _ -> 70 | failwith "arguments of meta not a bound variable" 71 | 72 | 73 | 74 | (* A [pruning] is a series of instruction indicating which arguments to discard. 75 | Note that syntactically, pruning is in reverse order of argument lists. 76 | See [prune_spine] below for their relationship. *) 77 | type pruning = 78 | | EmptyPr 79 | | Keep of pruning 80 | | Skip of pruning 81 | 82 | let rec pruning_length = function 83 | | EmptyPr -> (0, 0) 84 | | Keep pr' -> let (tot, rem) = pruning_length pr' in (tot + 1, rem + 1) 85 | | Skip pr' -> let (tot, rem) = pruning_length pr' in (tot + 1, rem) 86 | 87 | 88 | (* [prune_spine pr sp] drop the arguments that should be pruned in [sp], 89 | according to [pr]. *) 90 | let rec prune_spine pr sp = 91 | match pr, sp with 92 | | EmptyPr , EmptySp -> EmptySp 93 | | Keep pr', App(sp', v) -> App(prune_spine pr' sp', v) 94 | | Skip pr', App(sp', _) -> prune_spine pr' sp' 95 | | _ -> failwith "runtime error" 96 | 97 | 98 | (* Let [sp] be a list of bound variables, 99 | [spine_to_pruning pr sp] calculates a pruning that prune away those variables in [sp] 100 | that do not fall in the domain of [psub]. *) 101 | let rec spine_to_pruning psub = function 102 | | EmptySp -> 103 | EmptyPr 104 | | App(sp', Stuck(Lvl lvl, EmptySp)) -> 105 | if List.mem_assoc lvl psub.map 106 | then Keep (spine_to_pruning psub sp') 107 | else Skip (spine_to_pruning psub sp') 108 | | _ -> 109 | failwith "arguments of meta not a bound variable" 110 | 111 | 112 | (* [intersect_spine sp1 sp2] calculates a pruning that prune away those arguments 113 | that differ in [sp1] and [sp2]. *) 114 | let rec intersect_spine sp1 sp2 = 115 | match sp1, sp2 with 116 | | EmptySp, EmptySp -> 117 | EmptyPr 118 | | App(sp1', Stuck(Lvl lvl1, EmptySp)) 119 | , App(sp2', Stuck(Lvl lvl2, EmptySp)) -> 120 | if lvl1 = lvl2 121 | then Keep (intersect_spine sp1' sp2') 122 | else Skip (intersect_spine sp1' sp2') 123 | | _ -> 124 | failwith "runtime error" 125 | 126 | 127 | (* [discard_defined env] discards the defined variables in [env]. *) 128 | let rec discard_defined env : pruning = 129 | match env with 130 | | Empty -> EmptyPr 131 | | Bound(env', _, _) -> Keep (discard_defined env') 132 | | Defined(env', _, _, _) -> Skip (discard_defined env') 133 | 134 | 135 | (* [boundvars_to_spine level env] returns the list of all bound variables in [env] 136 | (of length [level]). *) 137 | let boundvars_to_spine level env = 138 | prune_spine (discard_defined env) (level_to_spine level) 139 | 140 | 141 | 142 | (* the following operations are mutually recursive. *) 143 | 144 | (* [prune_tyfun pr typ] prune away the arguments in [typ] (expected to be a function type) 145 | according to [pr]. *) 146 | let rec prune_tyfun pr typ = 147 | (* [psub] is the partial substitution that forgets those variables 148 | that are already pruned away. *) 149 | let rec loop psub pr typ = 150 | match pr, force typ with 151 | | EmptyPr, typ -> 152 | apply_psubst (-1) psub typ 153 | | Keep pr', TyFun(name, a, b) -> 154 | Core.TyFun( name 155 | , apply_psubst (-1) psub a 156 | , loop (add_boundvar psub) pr' (b @@ stuck_local psub.dom) ) 157 | | Skip pr', TyFun(_, _, b) -> 158 | loop { psub with dom = psub.dom + 1 } pr' (b @@ stuck_local psub.dom) 159 | | _ -> 160 | failwith "runtime error" 161 | in 162 | eval [] @@ loop empty_psubst pr typ 163 | 164 | 165 | (* [apply_psubst m psub v] apply the partial substitution [psub] to value [v], 166 | checking for occurence of [m] at the same time. 167 | [v] should live in [psub.dom], and the result should live in [psub.cod], i.e.: 168 | 169 | Γ(psub.cod) |- psub : Δ(psub.dom) 170 | Δ(psub.dom) |- v : A 171 | -------------------------------------- 172 | Γ(psub.cod) |- apply_psubst m psub v : A[psub] 173 | 174 | Since [apply_psubst] must recurse down the structure of [v], 175 | the result is a core expression, similar to quoting in NBE. 176 | 177 | When no occurs check need to be performed, [m] can be set to [-1]. *) 178 | and apply_psubst m psub value = 179 | match force value with 180 | | Stuck(Lvl lvl, sp) -> 181 | begin match List.assoc lvl psub.map with 182 | | lvl' -> 183 | apply_psubst_spine m psub (Core.Idx(psub.cod - lvl' - 1)) sp 184 | | exception Not_found -> 185 | failwith "variable may escape its scope" 186 | end 187 | 188 | (* Failed occurs check *) 189 | | Stuck(Meta m', _) when m' = m -> 190 | failwith("meta ?" ^ string_of_int m ^ " occurs recursively in its solution") 191 | 192 | (* Substituting a meta differnt from [m]. 193 | This is the so-called "pruning" operation 194 | and corresponds to the flex-flex case of the rewrite rules. *) 195 | | Stuck(Meta m', sp) -> 196 | let [@warning "-8"] (Free typ) = MetaContext.find_meta m' in 197 | let pr = spine_to_pruning psub sp in 198 | let (sp_len, pruned_len) = pruning_length pr in 199 | if sp_len = pruned_len 200 | then apply_psubst_spine m psub (Core.Meta m') sp 201 | else 202 | let new_meta = MetaContext.fresh_meta (prune_tyfun pr typ) in 203 | let solution = 204 | Stuck(Meta new_meta, prune_spine pr @@ level_to_spine sp_len) 205 | |> Normalize.quote sp_len 206 | |> make_fun sp_len 207 | |> Normalize.eval [] 208 | in 209 | let _ = MetaContext.solve_meta m' solution in 210 | apply_psubst_spine m psub (Core.Meta new_meta) (prune_spine pr sp) 211 | 212 | | Type -> 213 | Core.Type 214 | | TyFun(name, a, b) -> 215 | Core.TyFun(name, apply_psubst m psub a, apply_psubst m (add_boundvar psub) @@ b @@ stuck_local psub.dom) 216 | | Fun(name, f) -> 217 | Core.Fun(name, apply_psubst m (add_boundvar psub) @@ f @@ stuck_local psub.dom) 218 | 219 | 220 | and apply_psubst_spine m psub headC = function 221 | | EmptySp -> headC 222 | | App(sp', argv) -> Core.App(apply_psubst_spine m psub headC sp', apply_psubst m psub argv) 223 | 224 | 225 | 226 | let env_to_tyfun env typ = 227 | (* [loop env] returns a pair [(psub, add_args)], 228 | where [psub] is a partial substitution obtained by forgetting all the defined variables 229 | in [env], 230 | and [add_args : value -> value] is a function that, when applied to a type, 231 | prefix it with a [TyFun] for each variable in [env]. *) 232 | let rec loop env = 233 | match env with 234 | | Empty -> 235 | empty_psubst, Fun.id 236 | | Bound(env', name, a) -> 237 | let psub, add_args = loop env' in 238 | ( add_boundvar psub 239 | , fun ret_typ -> add_args @@ Core.TyFun(name, apply_psubst (-1) psub a, ret_typ) ) 240 | | Defined(env', _, _, _) -> 241 | let psub, add_args = loop env' in 242 | { psub with dom = psub.dom + 1 }, add_args 243 | in 244 | let psub, add_args = loop env in 245 | eval [] @@ add_args @@ apply_psubst (-1) psub typ 246 | 247 | 248 | 249 | 250 | let rec unify level env typ v1 v2 = 251 | match force typ, force v1, force v2 with 252 | | Type, Type, Type -> 253 | () 254 | 255 | | Type, TyFun(name, a1, b1), TyFun(_, a2, b2) -> 256 | unify level env typ a1 a2; 257 | let var = stuck_local level in 258 | unify (level + 1) (Bound(env, name, a1)) typ (b1 var) (b2 var) 259 | 260 | | TyFun(name, a, b), v1, v2 -> 261 | let var = stuck_local level in 262 | unify (level + 1) (Bound(env, name, a)) (b var) (apply v1 var) (apply v2 var) 263 | 264 | (* flex-flex case with same meta *) 265 | | _, Stuck(Meta m1, sp1), Stuck(Meta m2, sp2) when m1 = m2 -> 266 | let [@warning "-8"] (Free typ) = MetaContext.find_meta m1 in 267 | let pr = intersect_spine sp1 sp2 in 268 | let (sp_len, rem_len) = pruning_length pr in 269 | if sp_len = rem_len then 270 | let new_meta = MetaContext.fresh_meta (prune_tyfun pr typ) in 271 | let solution = 272 | Stuck(Meta new_meta, prune_spine pr @@ level_to_spine sp_len) 273 | |> Normalize.quote level 274 | |> make_fun sp_len 275 | |> Normalize.eval [] 276 | in 277 | MetaContext.solve_meta m1 solution 278 | 279 | (* flex-rigid or flex-flex with different metas *) 280 | | _, Stuck(Meta m, sp), v 281 | | _, v, Stuck(Meta m, sp) -> 282 | let psub = invert_spine level sp in 283 | let solution = 284 | apply_psubst m psub v 285 | |> make_fun psub.cod 286 | |> eval [] 287 | in 288 | MetaContext.solve_meta m solution 289 | 290 | | _, Stuck(Lvl lvl1, sp1), Stuck(Lvl lvl2, sp2) when lvl1 = lvl2 -> 291 | let head_typ = lookup_idx (level - lvl1 - 1) env in 292 | ignore (unify_spine level env head_typ sp1 sp2) 293 | 294 | | _ -> 295 | failwith "unsolvable equation" 296 | 297 | 298 | and unify_spine level env head_typ sp1 sp2 = 299 | match sp1, sp2 with 300 | | EmptySp, EmptySp -> 301 | head_typ 302 | | App(sp1', v1), App(sp2', v2) -> 303 | begin match force @@ unify_spine level env head_typ sp1' sp2' with 304 | | TyFun(_, a, b) -> 305 | unify level env a v1 v2; 306 | b v1 307 | | _ -> 308 | failwith "runtime error" 309 | end 310 | | _ -> 311 | failwith "unsolvable equation" 312 | -------------------------------------------------------------------------------- /untyped-meta/README.md: -------------------------------------------------------------------------------- 1 | # Untyped NBE + unification with pruning 2 | 3 | ## Source code structure and reading guide 4 | 5 | - `Syntax.ml`: definition of core syntax, surface syntax and semantic values 6 | - `MetaContext.ml`: context that maintains a global list of metas 7 | - `Normalize.ml`: a simple untyped NBE algorithm 8 | - `Unify.ml`: the main pattern unification algorithm with pruning 9 | - `Typecheck.ml`: a simple bidirectional type checker 10 | - `Pretty.ml`, `Parser.mly` and `Lexer.mll`: boring utilities 11 | - `untypedMetaTest.ml`: tests for the implementation. You can find some example programs here 12 | 13 | If you already have some experience with dependent type checking and NBE, 14 | all files except `Unify.ml` are standard. 15 | Core terms use de Bruijn index, and values use de Bruijn level. 16 | It is recommended to first read `Syntax.ml` for the definition of the syntax, 17 | then read `Unify.ml` for the unification algorithm, 18 | referring to other modules when you are not sure about the API. 19 | 20 | If you are not familiar with NBE and dependent type checking at all, 21 | it is recommended to refer to some other tutorials first, 22 | as this tutorial won't explain these concepts in detail. 23 | My personal recommendation is part 24 | `01-eval-closure-debruijn` and `02-typecheck-closure-debruijn` of [[1]](#ref1), 25 | as this tutorial uses de Bruijn index/level too. 26 | The first two chapters of [[2]](#ref2) is also a good reference 27 | for readers seeking a more formal presentation. 28 | 29 | ## Pattern unification 30 | 31 | A terms is said to be a *higher order pattren*, 32 | if all meta variables in it is applied to a *distinct* list of bound variables. 33 | Higher order unification problem of higher order patterns is decidable, 34 | and has most general solutions. 35 | 36 | Since we are dealing with higher order unification, 37 | terms have a non-trivial equation theory with βη equalities. 38 | From now on, we assume that all terms are in β-normal form. 39 | This can be achieved by always normalizing terms before unification/after substitution. 40 | In this tutorial NBE is used to achieve this. 41 | 42 | In this tutorial, metas are considered globally defined functions. 43 | For example, a meta variable `?M` defined in the context `Γ` with type `A` 44 | is considered a global function of type `Γ -> A`. 45 | To insert `?M` into the context `Γ`, the list of variables in `Γ` is applied to `?M`. 46 | 47 | As in the literatures, we will call terms of the form `?M xs` *flexible*, 48 | and other terms *rigid*. 49 | A rigid term is a constant/constructor or a free variable 50 | applied to a list of arguments, e.g. `A -> B` and `f x y`. 51 | 52 | Assume that we are trying to unify two terms `t` and `u` (in β-normal form). 53 | If `t` and `u` are both rigid, then we compare their head. 54 | If they haev different head (e.g. `(A -> B) = (\x. t)` or `f x = g y` with `f ≠ g`), 55 | then the problem is not solvable. 56 | If `t` and `u` have the same head constructor, we decompose the unification problem 57 | into smaller problems 58 | (e.g. `\x. t = \x. u` can be reduced to `t = u`, 59 | `f t₁ u₁ = f t₂ u₂` can be reduced to `t₁ = t₂` and `u₁ = u₂`). 60 | After performing these reductions, we are left with three possible cases: 61 | 62 | 1. *flex-rigid*, where one of `t` or `u` is a free variable applied to arguments, 63 | with the other being a meta variable applied to arguments. 64 | Without loss of generality, assume `t = ?M ts` and `u = x us`. 65 | Since we are dealing with *pattern* unification, `ts` 66 | must be a list of distinct bound variables `xs`. 67 | Since metas are global functions, they can only depend on their arguments. 68 | So it must be the case that `x ∊ xs`, otherwise the problem is unsolvable. 69 | If indeed `x ∊ xs`, we can now reduce the problem to `?Mᵢ xs = uᵢ`, 70 | where `us = u₁, ..., uₙ` and `?Mᵢ` are fresh meta variables, 71 | with `?M` solved to `\xs. x (?M₁ xs) ... (?Mₙ xs)`. 72 | To make sure that the algorithm terminates, 73 | we must also check that `?M` does not occur in `us`, 74 | otherwise the unification algorithm may loop forever. 75 | 76 | 1. *flex-flex*, same meta, where `t = ?M xs` and `u = ?M ys`. 77 | In this case, `?M` can only depend on its `i`-th arguments for those `i`s such that `xᵢ = yᵢ`. 78 | For example, if we have `?M x y = ?M x z`, and `?M = \$0 \$1. body`, 79 | then `$1` must not occur in `body`, because otherwise the `$1` occurence in `body` will be 80 | unequal for `?M x y` and `?M x z` (`y` v.s. `z`). 81 | Let `zs` be the list of variables that are "safe" to depend on, 82 | we can solve this equation by `?M = \xs. ?M' zs`, where `?M'` is a fresh meta variable. 83 | 84 | 1. *flex-flex*, different meta, where `t = ?M1 xs` and `u = ?M2 ys`, 85 | with `?M1` and `?M2` being different meta variables. 86 | Following a similar argument from the previous case, 87 | `?M1` and `?M2` can only depend on the variables in `xs ∩ ys`. 88 | Let `zs = xs ∩ ys`, then we can solve `?M1 xs = ?M2 ys` by 89 | `?M1 = \xs. ?M' zs` and `?M2 = \ys. ?M' zs`, where `?M'` is a frehs meta variable. 90 | 91 | In summary, the above four cases make up the following rules, 92 | of the form `e -> (E, σ)`, where `e` is a single equation, `E` is a list of equations 93 | and `σ` is a meta variable substitution: 94 | 95 | f ts = f us -> ({tᵢ = uᵢ}, ∅ ) 96 | where f is a constructor, a constant or a free variable 97 | 98 | ?M xs = x us or x us = ?M xs -> ({ ?Mᵢ xs = uᵢ }, [?M := \xs. x (?M₁ xs) ... (?Mₙ xs)] 99 | where ?M does not occur is us 100 | ?Mᵢ are fresh meta variables 101 | x ∊ xs 102 | 103 | ?M xs = ?M ys -> (∅ , [?M := \xs ?M' zs]) 104 | where zs = { xᵢ | xᵢ = yᵢ } 105 | ?M' is a fresh meta variable 106 | 107 | ?M1 xs = ?M2 ys -> (∅ , [?M1 := \xs ?M' zs, ?M2 := \xs. ?M' zs]) 108 | where ?M1 ≠ ?M2 109 | zs = xs ∩ ys 110 | ?M' is a fresh meta variable 111 | 112 | otherwise -> fail 113 | 114 | These four rules, together with the decomposition rules, 115 | make up a complete specification of a higher order pattern unification algorithm. 116 | 117 | ## From specification to algorithm 118 | 119 | The specification above can be proved to be correct, complete and terminating. 120 | However, it is hard to implement directly, and may be very inefficient in practice. 121 | For example, in the flex-rigid case, many new fresh metas are generated at each step. 122 | 123 | Following [[3]](#ref3), 124 | we want to transform the rewrite rules in the specification to a practical unification *algorithm*. 125 | Assume we have a equation `?M xs = t` to solve, where `t` is not of the form `?M ys` 126 | (so we are in either a flex-rigid case or a flex-flex case with different metas). 127 | Instead of generating a lot of fresh metas and new equations, 128 | we want to solve this equation in one single big step. 129 | 130 | Assume `?M : Γ -> A` and the equation happens in context `Δ`, 131 | now `xs` can be viewed as a substitution `Δ |- xs : Γ`, and `?M xs` and `t` have type `A[xs]`. 132 | Note that this view of `xs` as an explicit substitution is compatible with de Bruijn index/level too. 133 | Since `xs` is a list of distinct bound variables, 134 | we know that `xs` is injective, and has an inverse `Γ |- xs⁻¹ : Δ`. 135 | Now, applying `xs⁻¹` to `t`, we can obtain a term `Γ |- t[xs⁻¹] : A`, 136 | and solve `?M` with `\Γ. t[xs⁻¹]`. 137 | 138 | There are two extra things to note here. 139 | First, `xs` may not cover all variables in `Δ`, 140 | so `xs⁻¹` is only a *partial* substitution, and applying it to `t` may fail, 141 | which indicates that some variables in `t` may escape its scope through `?M`. 142 | For example, the equation `?M x y = z` should not be solvable, 143 | because `?M` can only depend on `x` and `y`. 144 | Second, we should also perform the occurence check when applying the partial substitution. 145 | If we encounters the meta variable `?M` during the application of `xs⁻¹`, 146 | the algorithm should fail due to recursive occurence of `?M`. 147 | 148 | Applying the ideas above, one can obtain a very simple implementation of pattern unification. 149 | `03-holes` of [[1]](#ref1) is one such implementation. 150 | The implementation here is also based on this simple implementation, 151 | but with an extra improvement: pruning. 152 | 153 | ## From flex-flex to pruning 154 | The above simple algorithm is not equivalent to the pattern unification rewrite system. 155 | In particular, it fails to handle the flex-flex case properly. 156 | Assume we have a equation `?M1 x y = ?M2 x z`, 157 | the inverse of `x, y` is `x := $0, y := $1`, 158 | but applying it to `?M2 x z` fails because `z` is not in the domain of the partial substitution. 159 | If we go the other way around and apply the inverse of `x, z` to `?M1 x y`, 160 | the algorithm will still fail due to `y` not belonging to `x, z`. 161 | 162 | Before diving into how we can solve this problem with pruning, 163 | let's first inspect the relation between the inverse substitution operation 164 | and the original rewrite rules. 165 | Actually, the operation of computing `t[xs⁻¹]` exactly corresponds to 166 | solving an equation `?M' xs = t`, with `?M'` not explicitly created. 167 | During the computation of `t[xs⁻¹]`, we may go through constructors and free variable applications, 168 | which corresponds exactly to a flex-rigid step in the rewrite rules. 169 | 170 | Now, what if we are trying to compute `(?M ys)[xs⁻¹]` for some flexible terms? 171 | If we follow the rewrite rules strictly, a flex-flex step with intersection should be performed here. 172 | However, in the näive implementation above, 173 | we simply treat `?M` as a free variables and apply `xs⁻¹` recursively on `ys`, 174 | which is the root of problem. 175 | 176 | So, to improve the algorithm and follow the rewrite rules strictly, 177 | we should perform an intersection as in the flex-flex case, 178 | when we encounter a flexible term during applying a partial substitution. 179 | This improvement is called *pruning*, 180 | as it will "prune away" dangerous variables from the arguments of a meta variable, 181 | so that the partial substitution will succeed. 182 | 183 | To perform a flex-flex case, we need to perform two steps: 184 | 185 | 1. decide which variables should be discarded 186 | 2. create a fresh meta that only depend on the "safe" variables, 187 | and solve the old meta with the new one 188 | 189 | In the actual code, 190 | these two steps are implemented using an intermediate data type called `pruning`. 191 | A `pruning` is a series of instructions indicating which arguments should be discarded. 192 | For example, assume we have an equation `?M1 x y = ?M2 x z`, 193 | the arguments of `?M1` give rise to a partial substitution `ρ = [x := $1, y := $2]`, 194 | and we are applying to `?M2 x z`. 195 | Now, we need to prune away the variables in `x z` that don't fall in the domain of `ρ`. 196 | This give rise to a pruning `keep; skip`, 197 | which indicate that the first argument (`x`) should be kept, 198 | while the second argument (`z`) should be pruned. 199 | 200 | Now that we have obtained a pruning `pr`, we may apply it to actually discard arguments. 201 | Continuing the example above, having `pr = keep; skip`, 202 | we now allocate a fresh meta variable `?M'` which depend on `x` only, 203 | and solve `?M2` with `?M2 := \$1. \$2. ?M' $1`. 204 | Here the arguments to `?M'` (`$1`) in the solution can be obtained by 205 | applying the pruning to `pr` to `$1 $2`. 206 | 207 | Notice that we are performing the above during a partial substitution operation. 208 | So we need to calculate the substituted term too, which is `(?M' x)[ρ]`. 209 | Here the arguments of `?M'`, `x` can be obtained by applying the pruning `pr` to `x y`. 210 | After that we apply `ρ` to the pruned arguments, and we are done! 211 | 212 | ## Flex-flex with the same meta 213 | There's only one case left to handle: flex-flex case where both sides have the same meta. 214 | This case *cannot* be handled using the partial substitution operation, 215 | because equations like `?M x = f (?M x)` are unsolvable, 216 | and a flex-flex case with the same meta on both sides can only occur at top level. 217 | 218 | When we do encounter such a case at top level, 219 | we can calculate the desired list of "safe" variables `{ xᵢ | xᵢ = yᵢ }` 220 | by iterating through the list of arguments on both sides, obtaining a pruning `pr`. 221 | The rest of work is identical to flex-flex with different metas: 222 | just allocate a fresh meta and apply `pr` to obtain the solution to the old meta. 223 | 224 | 225 | 226 | ## Integration with elaboration 227 | 228 | I have explained the pattern unification algorithm in details above. 229 | However, there are some extra cares to take when trying to integrate it with an elaborator 230 | for a dependently typed language. 231 | 232 | First, what should the unification operates on, in a NBE setting: core terms or values? 233 | Here, the unification algorithm itself operates on values, 234 | for easy semantic operations and normalization. 235 | However, some operations, such as applying a partial substitution, 236 | will convert values back to core terms. 237 | In this case, the resulting core terms may need to be evaluated back to values again. 238 | See `Unify.ml` for more details. 239 | 240 | Second, local `let` definitions have many non-trivial interactions with unification. 241 | Assume we are in a context with local `let`: `Γ = x : A, y = t, z : B`. 242 | Assume that we are type checking a hole in `Γ`. 243 | We have created a fresh meta `?M`, which is a globally defined function. 244 | Now we need to apply `ᴦ` to `?M` to obtain a well-typed term in `Γ`. 245 | But the defined local variable `y` should *not* be applied to `?M`. 246 | So we should apply only `x` and `z` to `?M`. 247 | 248 | 249 | ## References 250 | 251 | [1] 252 | 253 | 254 | [2] 255 | Normalization by Evaluation, Dependent Types and Impredicativity 256 | 257 | [3] 258 | Functional unification of higher-order patterns 259 | -------------------------------------------------------------------------------- /generalized-eta/Unify.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Value 4 | open Normalize 5 | 6 | 7 | 8 | (* some utilities *) 9 | let rec make_fun n body = 10 | if n = 0 11 | then body 12 | else make_fun (n - 1) (Core.Fun("", body)) 13 | 14 | let rec level_to_spine = function 15 | | 0 -> EmptySp 16 | | n -> App(level_to_spine (n - 1), stuck_local (n - 1)) 17 | 18 | 19 | (* A [psubst] is a partial substitution, such that all values in it are bound variables. 20 | Here: 21 | - [dom] is (the length of) the domain of the partial substitution 22 | - [cod] is (the length of) the codomain of the partial substitution 23 | - [map] is a parial mapping from variables in [dom] to variables in [cod], 24 | represented as an association list *) 25 | type psubst = 26 | { dom : level 27 | ; cod : level 28 | ; map : (level * value) list } 29 | 30 | 31 | let empty_psubst = 32 | { dom = 0 33 | ; cod = 0 34 | ; map = [] } 35 | 36 | 37 | (* Add a new bound variable to a partial substitution [psub]. 38 | Assume: 39 | Γ |- psub : Δ 40 | then: 41 | Γ, x : A[psub] |- add_boundvar psub : Δ, x : A 42 | such that: 43 | x[add_boundvar psub] = x *) 44 | let add_boundvar psub = 45 | { dom = psub.dom + 1 46 | ; cod = psub.cod + 1 47 | ; map = (psub.dom, stuck_local psub.cod) :: psub.map } 48 | 49 | 50 | 51 | 52 | 53 | (* A [pruning] is a series of instruction indicating which arguments to discard. 54 | Note that syntactically, pruning is in reverse order of argument lists. 55 | See [prune_spine] below for their relationship. *) 56 | type pruning = 57 | | EmptyPr 58 | | Keep of pruning 59 | | Skip of pruning 60 | 61 | let rec pruning_length = function 62 | | EmptyPr -> (0, 0) 63 | | Keep pr' -> let (tot, rem) = pruning_length pr' in (tot + 1, rem + 1) 64 | | Skip pr' -> let (tot, rem) = pruning_length pr' in (tot + 1, rem) 65 | 66 | 67 | (* [prune_spine pr sp] drop the arguments that should be pruned in [sp], 68 | according to [pr]. *) 69 | let rec prune_spine pr sp = 70 | match pr, sp with 71 | | EmptyPr , EmptySp -> EmptySp 72 | | Keep pr', App(sp', v) -> App(prune_spine pr' sp', v) 73 | | Skip pr', App(sp', _) -> prune_spine pr' sp' 74 | | _ -> failwith "runtime error" 75 | 76 | 77 | (* Let [sp] be a list of bound variables, 78 | [spine_to_pruning pr sp] calculates a pruning that prune away those variables in [sp] 79 | that do not fall in the domain of [psub]. *) 80 | let rec spine_to_pruning psub = function 81 | | EmptySp -> 82 | EmptyPr 83 | | App(sp', Stuck(Lvl lvl, EmptySp)) -> 84 | if List.mem_assoc lvl psub.map 85 | then Keep (spine_to_pruning psub sp') 86 | else Skip (spine_to_pruning psub sp') 87 | | _ -> 88 | failwith "arguments of meta not a bound variable" 89 | 90 | 91 | (* [intersect_spine sp1 sp2] calculates a pruning that prune away those arguments 92 | that differ in [sp1] and [sp2]. *) 93 | let rec intersect_spine sp1 sp2 = 94 | match sp1, sp2 with 95 | | EmptySp, EmptySp -> 96 | EmptyPr 97 | | App(sp1', Stuck(Lvl lvl1, EmptySp)) 98 | , App(sp2', Stuck(Lvl lvl2, EmptySp)) -> 99 | if lvl1 = lvl2 100 | then Keep (intersect_spine sp1' sp2') 101 | else Skip (intersect_spine sp1' sp2') 102 | | _ -> 103 | failwith "runtime error" 104 | 105 | 106 | (* [discard_defined env] discards the defined variables in [env]. *) 107 | let rec discard_defined env : pruning = 108 | match env with 109 | | Empty -> EmptyPr 110 | | Bound(env', _, _) -> Keep (discard_defined env') 111 | | Defined(env', _, _, _) -> Skip (discard_defined env') 112 | 113 | 114 | (* [boundvars_to_spine level env] returns the list of all bound variables in [env] 115 | (of length [level]). *) 116 | let boundvars_to_spine level env = 117 | prune_spine (discard_defined env) (level_to_spine level) 118 | 119 | 120 | 121 | 122 | (* the following operations are mutually recursive. *) 123 | 124 | (* [prune_tyfun pr typ] prune away the arguments in [typ] (expected to be a function type) 125 | according to [pr]. *) 126 | let rec prune_tyfun pr typ = 127 | (* [psub] is the partial substitution that forgets those variables 128 | that are already pruned away. *) 129 | let rec loop psub pr typ = 130 | match pr, force typ with 131 | | EmptyPr, typ -> 132 | apply_psubst (-1) psub typ 133 | | Keep pr', TyFun(name, a, b) -> 134 | Core.TyFun( name 135 | , apply_psubst (-1) psub a 136 | , loop (add_boundvar psub) pr' (b @@ stuck_local psub.dom) ) 137 | | Skip pr', TyFun(_, _, b) -> 138 | loop { psub with dom = psub.dom + 1 } pr' (b @@ stuck_local psub.dom) 139 | | _ -> 140 | failwith "runtime error" 141 | in 142 | eval [] @@ loop empty_psubst pr typ 143 | 144 | 145 | 146 | (* [invert_spine ?(base=0) level sp] calculate the inverse substitution of a list of arguments. 147 | The list of arguments [sp] should live in a context with length [level]. 148 | The range/destination of the inverse substitution starts from [base]. 149 | That is, assume: 150 | 151 | Γ₀(base),Γ(level - base) |- id(Γ₀),sp : Γ₀,Δ 152 | 153 | we should have: 154 | 155 | Γ₀,Δ |- invert_spine ~base level sp : Γ₀,Γ 156 | 157 | with the following properties: 158 | 1. all variables in Γ₀ are undefined in the domain of [invert_spine ~base level sp] 159 | 2. only variables in Γ (i.e. those [l] such that [base <= l < level]) can occur in [sp] 160 | 3. only variables in Δ can occur in [invert_spine ~base level sp] *) 161 | and invert_spine ?(base=0) level sp = 162 | match sp with 163 | | EmptySp -> 164 | { empty_psubst with dom = level; cod = base } 165 | | App(sp', value) -> 166 | (* We are now processing the [psub.cod]-th argument, 167 | it should correspond to the [psub.cod]-th bound variable 168 | in the codomain of the inverse substitution *) 169 | let psub = invert_spine ~base level sp' in 170 | invert_value base level value (stuck_local psub.cod) { psub with cod = psub.cod + 1 } 171 | 172 | 173 | 174 | (* [invert_value base level0 value dst psub] inverts the equation [dst := value] 175 | and adds the result to an existing partial substitution [psub]. 176 | We should have: 177 | 178 | Γ₀(base),Γ(level0 - base) |- value : A 179 | 180 | and: 181 | 182 | psub.cod |- psub : Γ₀,Γ 183 | psub.cod |- dst : A[psub] 184 | 185 | Now the result is: 186 | 187 | psub.cod, A[psub] |- invert_value base level0 value dst psub : Γ₀,Γ,A 188 | 189 | where only variables in Γ (i.e. those [l] such that [base <= l < level0]) 190 | can occur in [value]. *) 191 | and invert_value base level0 value dst psub = 192 | (* [loop level dst_sp value] inverts a equation: 193 | Γ₀,Γ,Δ(level - level0) |- dst (dst_sp[psub,id(Δ[psub])) := value 194 | where: 195 | Γ₀,Γ,Δ(level - level0) |- id(Γ₀,Γ),dst_sp : Γ₀,Γ,Δ *) 196 | let rec loop level dst_sp value = 197 | match force value with 198 | | Fun(_, f) -> 199 | (* Initially we have 200 | Γ₀,Γ,Δ |- dst dst_sp := \x. t 201 | We simplify this equation to 202 | Γ₀,Γ,Δ,x |- dst dst_sp x := t *) 203 | let var = stuck_local level in 204 | loop (level + 1) (App(dst_sp, var)) (f var) 205 | 206 | | Stuck(Lvl lvl, sp) when base <= lvl && lvl < level0 -> 207 | (* We have 208 | Γ₀,Γ,Δ |- dst dst_sp := lvl sp 209 | where [lvl ∊ Γ] (base <= lvl && lvl < level0) *) 210 | 211 | (* check for linearity of partial substitution *) 212 | if List.mem_assoc lvl psub.map then 213 | failwith "the same variable occurs twice in arguments of meta"; 214 | 215 | begin try 216 | (* We have: 217 | Γ₀,Γ,Δ |- id(Γ₀,Γ),sp : Γ₀,Γ,Δ' 218 | By definition of [invert_spine]: 219 | Γ₀,Γ,Δ' |- sp_inv : Γ₀,Γ,Δ *) 220 | let sp_inv = invert_spine ~base:level0 level sp in 221 | (* The correctness of [solution] is a bit tricky here. 222 | We should have: 223 | 224 | psub.cod |- solution : A[psub] 225 | 226 | But dst_sp[sp_inv] does not live in [psub.cod]: 227 | 228 | Γ₀,Γ,Δ' |- id(Γ₀,Γ),dst_sp[sp_inv] : Γ₀,Γ,Δ 229 | 230 | We should further apply to it [psub,id(Δ'[psub])]: 231 | 232 | psub.cod,Δ'[psub] |- id(psub.cod),dst_sp[sp_inv][psub] : psub.cod,Δ[psub] 233 | 234 | So the correct solution is 235 | 236 | \Δ'[psub]. dst ( dst_sp [sp_inv] [psub,id(Δ'[psub])] ) 237 | 238 | However, since [dst_sp[sp_inv]] is in [Core.expr] (de Bruijn index), 239 | and only variables in Δ' can occur in [dst_sp[sp_inv]] 240 | (by property 3 of [invert_spine]), 241 | we have the following nice property: 242 | 243 | dst_sp[sp_inv] = dst_sp[sp_inv][psub,id(Δ'[psub])] 244 | (in de Bruijn representation) 245 | 246 | Because only the id(Δ'[psub]) part of the substitution will take effect. 247 | So we can safely skip the [psub,id(Δ'[psub])] step. 248 | Notice that if we are using a typed value representation, 249 | then the extra substitution is necessary to obtain the correct type. *) 250 | let solution = 251 | (* [dst] lives in [psub.cod], 252 | and we have added (level - level0) extra bound variables (Δ), 253 | so [dst] should be quoted in [psub.cod + level - level0] *) 254 | apply_psubst_spine (-1) sp_inv 255 | (Normalize.quote (psub.cod + level - level0) dst) dst_sp 256 | |> make_fun (level - level0) 257 | (* evaluate with variables in [psub.cod] bound to themselves *) 258 | |> eval (List.init psub.cod (fun idx -> stuck_local (psub.cod - idx - 1))) 259 | in 260 | { psub with map = (lvl, solution) :: psub.map } 261 | with 262 | Failure _ -> failwith "arguments of meta not invertible" 263 | end 264 | 265 | | _ -> 266 | failwith "arguments of meta not invertible" 267 | in 268 | loop level0 EmptySp value 269 | 270 | 271 | 272 | 273 | (* [apply_psubst m psub v] apply the partial substitution [psub] to value [v], 274 | checking for occurence of [m] at the same time. 275 | [v] should live in [psub.dom], and the result should live in [psub.cod], i.e.: 276 | 277 | Γ(psub.cod) |- psub : Δ(psub.dom) 278 | Δ(psub.dom) |- v : A 279 | -------------------------------------- 280 | Γ(psub.cod) |- apply_psubst m psub v : A[psub] 281 | 282 | Since [apply_psubst] must recurse down the structure of [v], 283 | the result is a core expression, similar to quoting in NBE. 284 | 285 | When no occurs check need to be performed, [m] can be set to [-1]. *) 286 | and apply_psubst m psub value = 287 | match force value with 288 | | Stuck(Lvl lvl, sp) -> 289 | begin match List.assoc lvl psub.map with 290 | | value' -> 291 | apply_psubst_spine m psub (Normalize.quote psub.cod value') sp 292 | | exception Not_found -> 293 | failwith "variable may escape its scope" 294 | end 295 | 296 | (* Failed occurs check *) 297 | | Stuck(Meta m', _) when m' = m -> 298 | failwith("meta ?" ^ string_of_int m ^ " occurs recursively in its solution") 299 | 300 | (* Substituting a meta differnt from [m]. 301 | This is the so-called "pruning" operation 302 | and corresponds to the flex-flex case of the rewrite rules. *) 303 | | Stuck(Meta m', sp) -> 304 | let [@warning "-8"] (Free typ) = MetaContext.find_meta m' in 305 | let pr = spine_to_pruning psub sp in 306 | let (sp_len, pruned_len) = pruning_length pr in 307 | if sp_len = pruned_len 308 | then apply_psubst_spine m psub (Core.Meta m') sp 309 | else 310 | let new_meta = MetaContext.fresh_meta (prune_tyfun pr typ) in 311 | let solution = 312 | Stuck(Meta new_meta, prune_spine pr @@ level_to_spine sp_len) 313 | |> Normalize.quote sp_len 314 | |> make_fun sp_len 315 | |> Normalize.eval [] 316 | in 317 | let _ = MetaContext.solve_meta m' solution in 318 | apply_psubst_spine m psub (Core.Meta new_meta) (prune_spine pr sp) 319 | 320 | | Type -> 321 | Core.Type 322 | | TyFun(name, a, b) -> 323 | Core.TyFun(name, apply_psubst m psub a, apply_psubst m (add_boundvar psub) @@ b @@ stuck_local psub.dom) 324 | | Fun(name, f) -> 325 | Core.Fun(name, apply_psubst m (add_boundvar psub) @@ f @@ stuck_local psub.dom) 326 | 327 | 328 | and apply_psubst_spine m psub headC = function 329 | | EmptySp -> headC 330 | | App(sp', argv) -> Core.App(apply_psubst_spine m psub headC sp', apply_psubst m psub argv) 331 | 332 | 333 | 334 | let env_to_tyfun env typ = 335 | (* [loop env] returns a pair [(psub, add_args)], 336 | where [psub] is a partial substitution obtained by forgetting all the defined variables 337 | in [env], 338 | and [add_args : value -> value] is a function that, when applied to a type, 339 | prefix it with a [TyFun] for each variable in [env]. *) 340 | let rec loop env = 341 | match env with 342 | | Empty -> 343 | empty_psubst, Fun.id 344 | | Bound(env', name, a) -> 345 | let psub, add_args = loop env' in 346 | ( add_boundvar psub 347 | , fun ret_typ -> add_args @@ Core.TyFun(name, apply_psubst (-1) psub a, ret_typ) ) 348 | | Defined(env', _, _, _) -> 349 | let psub, add_args = loop env' in 350 | { psub with dom = psub.dom + 1 }, add_args 351 | in 352 | let psub, add_args = loop env in 353 | eval [] @@ add_args @@ apply_psubst (-1) psub typ 354 | 355 | 356 | 357 | 358 | let rec unify level env typ v1 v2 = 359 | match force typ, force v1, force v2 with 360 | | Type, Type, Type -> 361 | () 362 | 363 | | Type, TyFun(name, a1, b1), TyFun(_, a2, b2) -> 364 | unify level env typ a1 a2; 365 | let var = stuck_local level in 366 | unify (level + 1) (Bound(env, name, a1)) typ (b1 var) (b2 var) 367 | 368 | | TyFun(name, a, b), v1, v2 -> 369 | let var = stuck_local level in 370 | unify (level + 1) (Bound(env, name, a)) (b var) (apply v1 var) (apply v2 var) 371 | 372 | (* flex-flex case with same meta *) 373 | | _, Stuck(Meta m1, sp1), Stuck(Meta m2, sp2) when m1 = m2 -> 374 | let [@warning "-8"] (Free typ) = MetaContext.find_meta m1 in 375 | let pr = intersect_spine sp1 sp2 in 376 | let (sp_len, rem_len) = pruning_length pr in 377 | if sp_len = rem_len then 378 | let new_meta = MetaContext.fresh_meta (prune_tyfun pr typ) in 379 | let solution = 380 | Stuck(Meta new_meta, prune_spine pr @@ level_to_spine sp_len) 381 | |> Normalize.quote level 382 | |> make_fun sp_len 383 | |> Normalize.eval [] 384 | in 385 | MetaContext.solve_meta m1 solution 386 | 387 | (* flex-rigid or flex-flex with different metas *) 388 | | _, Stuck(Meta m, sp), v 389 | | _, v, Stuck(Meta m, sp) -> 390 | let psub = invert_spine level sp in 391 | let solution = 392 | apply_psubst m psub v 393 | |> make_fun psub.cod 394 | |> eval [] 395 | in 396 | MetaContext.solve_meta m solution 397 | 398 | | _, Stuck(Lvl lvl1, sp1), Stuck(Lvl lvl2, sp2) when lvl1 = lvl2 -> 399 | let head_typ = lookup_idx (level - lvl1 - 1) env in 400 | ignore (unify_spine level env head_typ sp1 sp2) 401 | 402 | | _ -> 403 | failwith "unsolvable equation" 404 | 405 | 406 | and unify_spine level env head_typ sp1 sp2 = 407 | match sp1, sp2 with 408 | | EmptySp, EmptySp -> 409 | head_typ 410 | | App(sp1', v1), App(sp2', v2) -> 411 | begin match force @@ unify_spine level env head_typ sp1' sp2' with 412 | | TyFun(_, a, b) -> 413 | unify level env a v1 v2; 414 | b v1 415 | | _ -> 416 | failwith "runtime error" 417 | end 418 | | _ -> 419 | failwith "unsolvable equation" 420 | --------------------------------------------------------------------------------