Septembre 2020 - Typer - mailman.iro.umontreal.ca

[Git][monnier/typer][master] 6 commits: * src/eval.ml: Add overflow checking to the Int builtin operators
by Jean-Alexandre Barszcz 27 Sep '20

27 Sep '20

Jean-Alexandre Barszcz pushed to branch master at Stefan / Typer Commits: d3a9e581 by Jean-Alexandre Barszcz at 2020-09-25T22:26:59-04:00 * src/eval.ml: Add overflow checking to the Int builtin operators * tests/eval_test.ml: Test that overflows cause runtime errors - - - - - 7e07d97d by Jean-Alexandre Barszcz at 2020-09-25T22:33:21-04:00 * src/sexp.ml (sexp): Use Zarith's big integers in sexps. * btl/builtins.typer: Add the builtin `Integer->Int`. * src/eval.ml: Implement it. (sexp_dispatch): Fix the value passed to the integer handler. - - - - - 043275cd by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 * btl/pervasive.typer (quote1): Fix quoting for literals - - - - - 8a7b7910 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 Add a macro for dependent elimination * btl/depelim.typer: New file, implements the macro. * btl/pervasive.typer: Load the new macro. * tests/elab_test.ml: Test it. - - - - - c722732e by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 * src/unification.ml: Clarify the order of the handlers Try and impose some logic on the order in which the various unification cases are handled. (unify'): Shuffle. (unify_*): Simplify accordingly. (unify_call): Handle calls of different length. * tests/unify_test.ml: Rewrite and enable the tests. - - - - - ad090c1f by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 * src/elab.ml (sform_lambda): Use unify instead of conv_p. (unify_or_error): New function, extracted from check_inferred. (check_inferred): Use it. - - - - - 13 changed files: - btl/builtins.typer - + btl/depelim.typer - btl/pervasive.typer - src/debug.ml - src/elab.ml - src/eval.ml - src/lexer.ml - src/lexp.ml - src/sexp.ml - src/unification.ml - tests/elab_test.ml - tests/eval_test.ml - tests/unify_test.ml Changes: ===================================== btl/builtins.typer ===================================== @@ -133,7 +133,15 @@ Int_>= = Built-in "Int.>=" : Int -> Int -> Bool; %% bitwise negation Int_not = Built-in "Int.not" : Int -> Int; +%% `Int` and `Integer` are conceptually isomorphic in that they both +%% represent unbounded integers, but in reality, both are bounded. +%% `Int` is implemented with `int` type in ocaml (31 or 63 bits), and +%% `Integer` is implemented with big integers (ultimately limited by +%% available memory). Both cause runtime errors at their limits, so no +%% overflows are allowed. Here are the functions that witness the +%% isomorphism: Int->Integer = Built-in "Int->Integer" : Int -> Integer; +Integer->Int = Built-in "Integer->Int" : Integer -> Int; Int->String = Built-in "Int->String" : Int -> String; ===================================== btl/depelim.typer ===================================== @@ -0,0 +1,110 @@ +%%% depelim --- A macro for dependent elimination + +%% Copyright (C) 2020 Free Software Foundation, Inc. +%% +%% Author: Jean-Alexandre Barszcz <jean-alexandre.barszcz(a)umontreal.ca> +%% Keywords: languages, lisp, dependent types. +%% +%% This file is part of Typer. +%% +%% Typer is free software; you can redistribute it and/or modify it under the +%% terms of the GNU General Public License as published by the Free Software +%% Foundation, either version 3 of the License, or (at your option) any +%% later version. +%% +%% Typer is distributed in the hope that it will be useful, but WITHOUT ANY +%% WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +%% FOR A PARTICULAR PURPOSE. See the GNU General Public License for +%% more details. +%% +%% You should have received a copy of the GNU General Public License along +%% with this program. If not, see <http://www.gnu.org/licenses/>. + +%%% Description +%% +%% In Typer, the branch bodies of a `case` expression must all have +%% the same type. In order to write proofs that depend the +%% constructor, Typer adds a proof in the environment of each branch: +%% the equality between the branch's head and the case target. This +%% equality can be eliminated in each branch using `Eq_cast` to go +%% from a branch-dependent type to a target-dependent type. The +%% following macro eases this process by eliminating the boilerplate. +%% +%% The macro extends the builtin `case` syntax to +%% `case_as_return_`. The `as` and `return` clauses are used to build +%% Eq_cast's `f` argument (a lambda). The `as` clause should contain a +%% symbol (the variable binding the case target or branch head), and +%% is optional if the target is itself a symbol. The `return` clause +%% is `f`'s body, i.e. the return type of the case, using the variable +%% from the `as` clause to refer to the target or branch head. + +%%% Example usage +%% +%% type Nat +%% | Z +%% | S Nat; +%% +%% Nat_induction : +%% (P : Nat -> Type_ ?l) ≡> +%% P Z -> +%% ((n : Nat) -> P n -> P (S n)) -> +%% ((n : Nat) -> P n); +%% Nat_induction base step n = +%% case n return (P n) %% <-- `as` clause omitted: the target is a var. +%% | Z => base +%% | S n' => (step n' (Nat_induction (P := P) base step n')); + +%%% Grammar +%% +%% This macro was written for the following operators (the precedence +%% level 42 is chosen to match that of the builtin case): +%% +%% define-operator "as" 42 42; +%% define-operator "return" 42 42; + +case_as_return_impl args = + let impl target_sexp var_sexp ret_and_branches_sexp = + case Sexp_wrap ret_and_branches_sexp + | node hd (cons ret_sexp branches) => + %% TODO Check that var_sexp is a variable. + %% TODO Check that hd is the symbol `_|_`. + let + on_branch branch_sexp = + case Sexp_wrap branch_sexp + | node arrow_sexp (cons head_sexp (cons body_sexp nil)) => + %% TODO Check that arrow_sexp is `=>`. + Sexp_node + arrow_sexp + (cons head_sexp + (cons (quote (##Eq\.cast + (x := uquote head_sexp) + (y := uquote target_sexp) + (p := ##DeBruijn 0) + (f := lambda (uquote var_sexp) -> + uquote ret_sexp) + (uquote body_sexp))) + nil)) + | _ => Sexp_error; %% FIXME Improve error reporting. + new_branches = List_map on_branch branches; + in %% We extend the builtin case, so nested patterns don't work. + quote (##case_ + (uquote (Sexp_node (Sexp_symbol "_|_") + (cons target_sexp new_branches)))) + | _ => Sexp_error; + in IO_return + case args + | cons target_sexp + (cons var_sexp + (cons ret_and_branches_sexp nil)) + => impl target_sexp var_sexp ret_and_branches_sexp + | cons target_sexp + (cons ret_and_branches_sexp nil) + => %% If the `as` clause is omitted, and the target is a + %% symbol, use it for `var_sexp` as well. + (case Sexp_wrap target_sexp + | symbol _ => impl target_sexp target_sexp ret_and_branches_sexp + | _ => Sexp_error) + | _ => Sexp_error; + +case_as_return_ = macro case_as_return_impl; +case_return_ = macro case_as_return_impl; ===================================== btl/pervasive.typer ===================================== @@ -203,21 +203,31 @@ K x y = x; %% which will construct an Sexp equivalent to `x` at run-time. %% This is basically *cross stage persistence* for Sexp. quote1 : Sexp -> Sexp; -quote1 x = let k = K x; +quote1 x = let qlist : List Sexp -> Sexp; qlist xs = case xs | nil => Sexp_symbol "nil" | cons x xs => Sexp_node (Sexp_symbol "cons") (cons (quote1 x) (cons (qlist xs) nil)); + make_app str sexp = + Sexp_node (Sexp_symbol str) (cons sexp nil); + node op y = case (Sexp_eq op (Sexp_symbol "uquote")) | true => List_head Sexp_error y | false => Sexp_node (Sexp_symbol "##Sexp.node") (cons (quote1 op) (cons (qlist y) nil)); - symbol s = Sexp_node (Sexp_symbol "##Sexp.symbol") - (cons (Sexp_string s) nil) - in Sexp_dispatch x node symbol k k k k; + symbol s = make_app "##Sexp.symbol" (Sexp_string s); + string s = make_app "##Sexp.string" (Sexp_string s); + integer i = make_app "##Sexp.integer" + (make_app "##Int->Integer" (Sexp_integer i)); + float f = make_app "##Sexp.float" (Sexp_float f); + block sxp = + %% FIXME ##Sexp.block takes a string (and prelexes + %% it) but we have a sexp, what should we do? + Sexp_symbol "<error FIXME block quoting>"; + in Sexp_dispatch x node symbol string integer float block; %% quote definition quote = macro (lambda x -> IO_return (quote1 (List_head Sexp_error x))); @@ -634,6 +644,17 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro; %% _|_ = let lib = load "btl/polyfun.typer" in lib._|_; +%% +%% case_as_return_, case_return_ +%% A `case` for dependent elimination +%% + +define-operator "as" 42 42; +define-operator "return" 42 42; +depelim = load "btl/depelim.typer"; +case_as_return_ = depelim.case_as_return_; +case_return_ = depelim.case_return_; + %%%% Unit tests function for doing file %% It's hard to do a primitive which execute test file ===================================== src/debug.ml ===================================== @@ -90,7 +90,7 @@ let rec debug_sexp_print sexp = print_string "\""; print_string str; print_string "\"" | Integer(loc, n) - -> print_info "Integer: " loc; print_int n + -> print_info "Integer: " loc; Z.print n | Float(loc, x) -> print_info "Float: " loc; print_float x ===================================== src/elab.ml ===================================== @@ -278,7 +278,7 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context = | [String (_, name); l; r] -> let level s = match s with | Symbol (_, "") -> None - | Integer (_, n) -> Some n + | Integer (_, n) -> Some (Z.to_int n) | _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in let (grm, a, b, c) = ctx in (SMap.add name (level l, level r) grm, a, b, c) @@ -694,6 +694,22 @@ and check (p : sexp) (t : ltype) (ctx : elab_context): lexp = | _ -> OL.get_type (ectx_to_lctx ctx) e in check_inferred ctx e inferred_t t +and unify_or_error lctx lxp ?lxp_name expect actual = + match Unif.unify expect actual lctx with + | ((ck, _ctx, t1, t2)::_) + -> lexp_error (lexp_location lxp) lxp + ("Type mismatch" + ^ (match ck with | Unif.CKimpossible -> "" + | Unif.CKresidual -> " (residue)") + ^ "! Context expected:\n " ^ lexp_string expect ^ "\nbut " + ^ (U.option_default "expression" lxp_name) ^ " has type:\n " + ^ lexp_string actual ^ "\ncan't unify:\n " + ^ lexp_string t1 + ^ "\nwith:\n " + ^ lexp_string t2); + assert (not (OL.conv_p lctx expect actual)) + | [] -> () + (* This is a crucial function: take an expression `e` of type `inferred_t` * and convert it into something of type `t`. Currently the only conversion * we use is to instantiate implicit arguments when needed, but we could/should @@ -704,20 +720,7 @@ and check_inferred ctx e inferred_t t = | Arrow ((Aerasable | Aimplicit), _, _, _, _) -> (e, inferred_t) | _ -> instantiate_implicit e inferred_t ctx in - (match Unif.unify inferred_t t (ectx_to_lctx ctx) with - | ((ck, _ctx, t1, t2)::_) - -> lexp_error (lexp_location e) e - ("Type mismatch(" - ^ (match ck with | Unif.CKimpossible -> "impossible" - | Unif.CKresidual -> "residue") - ^ ")! Context expected:\n " - ^ lexp_string t ^ "\nbut expression has type:\n " - ^ lexp_string inferred_t ^ "\ncan't unify:\n " - ^ lexp_string t1 - ^ "\nwith:\n " - ^ lexp_string t2); - assert (not (OL.conv_p (ectx_to_lctx ctx) inferred_t t)) - | [] -> ()); + unify_or_error (ectx_to_lctx ctx) e t inferred_t; e (* Lexp.case can sometimes be inferred, but we prefer to always check. *) @@ -1711,10 +1714,8 @@ let rec sform_lambda kind ctx loc sargs ot = -> (match olt1 with | None -> () | Some lt1' - -> if not (OL.conv_p (ectx_to_lctx ctx) lt1 lt1') - then lexp_error (lexp_location lt1') lt1' - ("Type mismatch! Context expected `" - ^ lexp_string lt1 ^ "`")); + -> unify_or_error (ectx_to_lctx ctx) lt1' + ~lxp_name:"parameter" lt1 lt1'); mklam lt1 (Some lt2) | Arrow (ak2, v, lt1, _, lt2) when kind = Anormal @@ -1803,7 +1804,7 @@ let sform_type ctx loc sargs ot = let sform_debruijn ctx loc sargs ot = match sargs with | [Integer (l,i)] - -> if i < 0 || i > get_size ctx then + -> let i = Z.to_int i in if i < 0 || i > get_size ctx then (sexp_error l "##DeBruijn index out of bounds"; sform_dummy_ret ctx loc) else ===================================== src/eval.ml ===================================== @@ -151,17 +151,68 @@ let add_binary_iop name f = | _ -> error loc ("`" ^ name ^ "` expects 2 Int arguments") in add_builtin_function name f 2 -let _ = add_binary_iop "+" (+); - add_binary_iop "-" (-); - add_binary_iop "*" ( * ); - add_binary_iop "/" (/); +let add_binary_iop_with_loc name f = + let name = "Int." ^ name in + let f loc (depth : eval_debug_info) (args_val: value_type list) = + match args_val with + | [Vint (v); Vint (w)] -> Vint (f loc v w) + | _ -> error loc ("`" ^ name ^ "` expects 2 Int arguments") in + add_builtin_function name f 2 + +let add_with_overflow loc a b = + let c = a + b in + (* Check that signs of both args are diff. OR sign of result is the + same as the sign of the args. *) + if (a lxor b) lor (a lxor (lnot c)) < 0 + then c + else error loc "Overflow in `Int.+`" + +let sub_with_overflow loc a b = + let c = a - b in + (* Check that signs of both args are the same OR sign of result is + the same as the sign of the first arg. *) + if (a lxor (lnot b)) lor (a lxor (lnot c)) < 0 + then c + else error loc "Overflow in `Int.-`" + +let mul_with_overflow loc a b = + let c = a * b in + if b = 0 || not (c = min_int && b = -1) && a = c / b (* Simple but slow *) + then c + else error loc "Overflow in `Int.*`" + +let div_with_overflow loc a b = + if not (a = min_int && b = -1) + then a / b + else error loc "Overflow in `Int./`" + +let lsl_with_shift_check loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.lsl`") + else a lsl b + +let lsr_with_shift_check loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.lsr`") + else a lsr b + +let asr_with_shift_check loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.asr`") + else a asr b + +let _ = add_binary_iop_with_loc "+" add_with_overflow; + add_binary_iop_with_loc "-" sub_with_overflow; + add_binary_iop_with_loc "*" mul_with_overflow; + add_binary_iop_with_loc "/" div_with_overflow; + + add_binary_iop_with_loc "lsl" lsl_with_shift_check; + add_binary_iop_with_loc "lsr" lsr_with_shift_check; + add_binary_iop_with_loc "asr" asr_with_shift_check; add_binary_iop "mod" (mod); add_binary_iop "and" (land); - add_binary_iop "or" (lor); - add_binary_iop "lsl" (lsl); - add_binary_iop "lsr" (lsr); - add_binary_iop "asr"(asr); + add_binary_iop "or" (lor); add_binary_iop "xor" (lxor) let add_binary_bool_iop name f = @@ -221,6 +272,16 @@ let _ = add_binary_bool_biop "<" BI.lt; -> match args_val with | [Vint v] -> Vinteger (BI.of_int v) | _ -> error loc ("`" ^ name ^ "` expects 1 Int argument")) + 1; + let name = "Integer->Int" in + add_builtin_function + name + (fun loc (depth : eval_debug_info) (args_val: value_type list) + -> match args_val with + | [Vinteger v] -> + (try Vint (BI.to_int v) with + | Z.Overflow -> error loc ("Overflow in `" ^ name ^ "`")) + | _ -> error loc ("`" ^ name ^ "` expects 1 Integer argument")) 1 (* Floating point numers. *) @@ -283,7 +344,7 @@ let make_string loc depth args_val = match args_val with | _ -> error loc "Sexp.string expects one string as argument" let make_integer loc depth args_val = match args_val with - | [Vinteger n] -> Vsexp (Integer (loc, BI.to_int n)) + | [Vinteger n] -> Vsexp (Integer (loc, n)) | _ -> error loc "Sexp.integer expects one integer as argument" let make_float loc depth args_val = match args_val with @@ -373,7 +434,7 @@ let rec eval lxp (ctx : Env.runtime_env) (trace : eval_debug_info): (value_type) match lxp with (* Leafs *) (* ---------------- *) - | Imm(Integer (_, i)) -> Vint i + | Imm(Integer (_, i)) -> Vint (Z.to_int i) | Imm(String (_, s)) -> Vstring s | Imm(Float (_, n)) -> Vfloat n | Imm(sxp) -> Vsexp sxp @@ -567,7 +628,7 @@ and sexp_dispatch loc depth args = | Node (op, s) -> eval_call nd [Vsexp op; o2v_list s] | Symbol (_ , s) -> eval_call sym [Vstring s] | String (_ , s) -> eval_call str [Vstring s] - | Integer (_ , i) -> eval_call it [Vint i] + | Integer (_ , i) -> eval_call it [Vinteger i] | Float (_ , f) -> eval_call flt [Vfloat f] | Block (_ , _, _) as b -> (* I think this code breaks what Blocks are. *) ===================================== src/lexer.ml ===================================== @@ -58,7 +58,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos if bp >= String.length name then ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), @@ -75,7 +75,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos | _ -> ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), ===================================== src/lexp.ml ===================================== @@ -962,7 +962,7 @@ and lexp_str ctx (exp : lexp) : string = match lexp_lexp' exp with | Imm(value) -> (match value with | String (_, s) -> tval ("\"" ^ s ^ "\"") - | Integer(_, s) -> tval (string_of_int s) + | Integer(_, s) -> tval (Z.to_string s) | Float (_, s) -> tval (string_of_float s) | e -> sexp_string e) ===================================== src/sexp.ml ===================================== @@ -27,16 +27,13 @@ open Grammar let sexp_error ?print_action loc msg = Log.log_error ~section:"SEXP" ?print_action ~loc msg -type integer = (* Num.num *) int +type integer = Z.t type symbol = location * string type sexp = (* Syntactic expression, kind of like Lisp. *) | Block of location * pretoken list * location | Symbol of symbol | String of location * string - (* FIXME: It would make a lof of sense to use a bigint here, but `compare` - * burps on Big_int objects, and `compare` is used for hash-consing of lexp - * objects which contain sexp objects as well. *) | Integer of location * integer | Float of location * float | Node of sexp * sexp list @@ -76,7 +73,7 @@ let rec sexp_string sexp = | Symbol(_, "") -> "()" (* Epsilon *) | Symbol(_, name) -> name | String(_, str) -> "\"" ^ str ^ "\"" - | Integer(_, n) -> string_of_int n + | Integer(_, n) -> Z.to_string n | Float(_, x) -> string_of_float x | Node(f, args) -> let str = "(" ^ (sexp_string f) in ===================================== src/unification.ml ===================================== @@ -171,10 +171,27 @@ let rec s_offset s = match s with (** Dispatch to the right unifier. - If (<code>unify_X X Y</code>) don't handle the case <b>(X, Y)</b>, it call (<code>unify Y X</code>) - - The metavar unifier is the end rule, it can't call unify with its parameter (changing their order) -*) + Unification has the side-effect of associating the metavariables + in a way that makes the Lexp arguments convertible, if possible. In + case of success, it returns the empty list. Otherwise, it returns + the cause of failure as a list of constraints of the following + kinds: + + 1. `CKimpossible` constraints: constraints that cannot be + satisfied, even if other metavars are associated, redexes are + reduced, and subtitutions are done. For example, an arrow could + never be unified with a lambda. + + 2. `CKresidual` constraints: pairs of subterms that cannot be + unified in the current context, but might eventually be sucessfully + unifiable. For instance, a pair of different variables cannot be + unified, unless another reduction eventually substitutes one for + the other. As another example, a metavariable could be used in the + head position of a call, blocking its reduction, but a later + instanciation might turn this metavariable into a lambda, thus + yielding a redex, possibly reducing the call to a term unifiable + with the other argument. + *) let rec unify (e1: lexp) (e2: lexp) (ctx : DB.lexp_context) : return_type = @@ -191,28 +208,45 @@ and unify' (e1: lexp) (e2: lexp) if changed && OL.set_member_p vs e1' e2' then [] else let vs' = if changed then OL.set_add vs e1' e2' else vs in match (lexp_lexp' e1', lexp_lexp' e2') with - | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _) - | (Var _, Var _)) + (* Both expressions are in WHNF: we don't have `Let`s nor `Susp`s. *) + + (* First, we handle the simple cases with no substructure. *) + | ((Imm _ | Builtin _), (Imm _ | Builtin _)) -> if OL.conv_p ctx e1' e2' then [] else [(CKimpossible, ctx, e1, e2)] + + (* Then, we handle metavariables (aka. flexible-flexible and + Flexible-Rigid Equations). Reminder: WHNF implies that the + metavariables are not already instanciated. *) | (_, Metavar (idx, s, _)) -> unify_metavar ctx idx s e2' e1' | (Metavar (idx, s, _), _) -> unify_metavar ctx idx s e1' e2' - | (_, Call _) -> unify_call e2' e1' ctx vs' - (* | (l, (Case _ as r)) -> unify_case r l subst *) - | (Arrow _ , _) -> unify_arrow e1' e2' ctx vs' - | (Lambda _, _) -> unify_lambda e1' e2' ctx vs' - | (Call _, _) -> unify_call e1' e2' ctx vs' - (* | (Case _ as l, r) -> unify_case l r subst *) - (* | (Inductive _ as l, r) -> unify_induct l r subst *) - | (Sort _, _) -> unify_sort e1' e2' ctx vs' - | (SortLevel _, _) -> unify_sortlvl e1' e2' ctx vs' - | (Inductive (_loc1, label1, args1, consts1), - Inductive (_loc2, label2, args2, consts2)) - -> (* print_string ("Unifying inductives " - * ^ snd label1 - * ^ " and " - * ^ snd label2 - * ^ "\n"); *) - unify_inductive ctx vs' args1 args2 consts1 consts2 e1 e2 + + (* Otherwise, the equation is rigid-rigid. Let's start with the + cases that can leave residuals: 1. Variables, since they could + be substituted with further reduction; 2. Calls, because they + might become redexes; 3. Case expressions, for the same + reason. *) + | (_, Var _) -> unify_var e2' e1' ctx vs' + | (Var _, _) -> unify_var e1' e2' ctx vs' + | (_, Call _) -> unify_call e2' e1' ctx vs' + | (Call _, _) -> unify_call e1' e2' ctx vs' + (* FIXME: Handle `Case` expressions. *) + + (* We are left with the cases that are not affected by + substitutions, thus should not immediately lead to residual + constraints. *) + | (_, Arrow _) -> unify_arrow e2' e1' ctx vs' + | (Arrow _, _) -> unify_arrow e1' e2' ctx vs' + | (_, Lambda _) -> unify_lambda e2' e1' ctx vs' + | (Lambda _, _) -> unify_lambda e1' e2' ctx vs' + | (_, Sort _) -> unify_sort e2' e1' ctx vs' + | (Sort _, _) -> unify_sort e1' e2' ctx vs' + | (_, SortLevel _) -> unify_sortlvl e2' e1' ctx vs' + | (SortLevel _, _) -> unify_sortlvl e1' e2' ctx vs' + | (_, Inductive _) -> unify_inductive e2' e1' ctx vs' + | (Inductive _, _) -> unify_inductive e1' e2' ctx vs' + | (_, Cons _) -> unify_cons e2' e1' ctx vs' + | (Cons _, _) -> unify_cons e1' e2' ctx vs' + | _ -> (if OL.conv_p ctx e1' e2' then [] else ((* print_string "Unification failure on default\n"; *) [(CKresidual, ctx, e1, e2)])) @@ -223,7 +257,6 @@ and unify' (e1: lexp) (e2: lexp) - (Arrow, Arrow) -> if var_kind = var_kind then unify ltype & lexp (Arrow (var_kind, _, ltype, lexp)) else None - - (Arrow, Var) -> Constraint - (_, _) -> None *) and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs @@ -236,19 +269,13 @@ and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs @(unify' lexp1 (srename v1 lexp2) (DB.lexp_ctx_cons ctx v1 Variable ltype1) (OL.set_shift vs)) - else [(CKimpossible, ctx, arrow, lxp)] - | (Arrow _, Imm _) -> [(CKimpossible, ctx, arrow, lxp)] - | (Arrow _, Var _) -> ([(CKresidual, ctx, arrow, lxp)]) - | (Arrow _, _) -> unify' lxp arrow ctx vs + else [(CKimpossible, ctx, arrow, lxp)] | (_, _) -> [(CKimpossible, ctx, arrow, lxp)] (** Unify a Lambda and a lexp if possible - - Lamda , Lambda -> if var_kind = var_kind + - Lambda , Lambda -> if var_kind = var_kind then UNIFY ltype & lxp else ERROR - - Lambda , Var -> CONSTRAINT - - Lambda , Call -> Constraint - - Lambda , Let -> Constraint - - Lambda , lexp -> unify lexp lambda subst + - Lambda , _ -> Impossible *) and unify_lambda (lambda: lexp) (lxp: lexp) ctx vs : return_type = match (lexp_lexp' lambda, lexp_lexp' lxp) with @@ -260,19 +287,12 @@ and unify_lambda (lambda: lexp) (lxp: lexp) ctx vs : return_type = (DB.lexp_ctx_cons ctx v1 Variable ltype1) (OL.set_shift vs)) else [(CKimpossible, ctx, lambda, lxp)] - | ((Lambda _, Var _) - | (Lambda _, Let _) - | (Lambda _, Call _)) -> [(CKresidual, ctx, lambda, lxp)] - | (Lambda _, Arrow _) - | (Lambda _, Imm _) -> [(CKimpossible, ctx, lambda, lxp)] - | (Lambda _, _) -> unify' lxp lambda ctx vs - | (_, _) -> [(CKimpossible, ctx, lambda, lxp)] + | (_, _) -> [(CKimpossible, ctx, lambda, lxp)] (** Unify a Metavar and a lexp if possible - - lexp , {metavar <-> none} -> UNIFY - - lexp , {metavar <-> lexp} -> UNFIFY lexp subst[metavar] - - metavar , metavar -> if Metavar = Metavar then OK else ERROR - - metavar , lexp -> OK + - metavar , metavar -> if Metavar = Metavar then intersect + - metavar , metavar -> inverse subst (try both sides) + - metavar , lexp -> inverse subst *) and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp) : return_type = @@ -384,6 +404,16 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp) | _ -> unif idx2 s2 lxp1) | _ -> unif idx s1 lxp2 +(** Unify a Var (var) and a lexp (lxp) + - Var , Var -> IF same var THEN ok ELSE constraint + - Var , lexp -> Constraint +*) +and unify_var (var: lexp) (lxp: lexp) ctx vs + : return_type = + match (lexp_lexp' var, lexp_lexp' lxp) with + | (Var _, Var _) when OL.conv_p ctx var lxp -> [] + | (_, _) -> [(CKresidual, ctx, var, lxp)] + (** Unify a Call (call) and a lexp (lxp) - Call , Call -> UNIFY - Call , lexp -> CONSTRAINT @@ -393,13 +423,15 @@ and unify_call (call: lexp) (lxp: lexp) ctx vs match (lexp_lexp' call, lexp_lexp' lxp) with | (Call (lxp_left, lxp_list1), Call (lxp_right, lxp_list2)) when OL.conv_p ctx lxp_left lxp_right - -> List.fold_left (fun op ((ak1, e1), (ak2, e2)) + -> (try List.fold_left (fun op ((ak1, e1), (ak2, e2)) -> if ak1 == ak2 then (unify' e1 e2 ctx vs)@op else [(CKimpossible, ctx, call, lxp)]) [] (List.combine lxp_list1 lxp_list2) - | (_, _) -> [(CKresidual, ctx, call, lxp)] + with Invalid_argument _ (* Lists of diff. length in combine. *) + -> [(CKresidual, ctx, call, lxp)]) + | (_, _) -> [(CKresidual, ctx, call, lxp)] (** Unify a Case with a lexp - Case, Case -> try to unify @@ -468,11 +500,10 @@ and unify_sortlvl (sortlvl: lexp) (lxp: lexp) ctx vs : return_type = * more "canonicalized" otherwise it's too restrictive! *) (unify' l11 l21 ctx vs)@(unify' l12 l22 ctx vs) | _, _ -> [(CKimpossible, ctx, sortlvl, lxp)]) - | _, _ -> [(CKresidual, ctx, sortlvl, lxp)] + | _, _ -> [(CKimpossible, ctx, sortlvl, lxp)] (** Unify a Sort and a lexp - Sort, Sort -> if Sort ~= Sort then OK else ERROR - - Sort, Var -> Constraint - Sort, lexp -> ERROR *) and unify_sort (sort_: lexp) (lxp: lexp) ctx vs : return_type = @@ -482,8 +513,7 @@ and unify_sort (sort_: lexp) (lxp: lexp) ctx vs : return_type = | StypeOmega, StypeOmega -> [] | StypeLevel, StypeLevel -> [] | _, _ -> [(CKimpossible, ctx, sort_, lxp)]) - | Sort _, Var _ -> [(CKresidual, ctx, sort_, lxp)] - | _, _ -> [(CKimpossible, ctx, sort_, lxp)] + | _, _ -> [(CKimpossible, ctx, sort_, lxp)] (************************ Helper function ************************************) @@ -533,7 +563,14 @@ and is_same arglist arglist2 = * | None -> test e subst) * ) None lst *) -and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 = +and unify_inductive lxp1 lxp2 ctx vs = + match lexp_lexp' lxp1, lexp_lexp' lxp2 with + | (Inductive (_loc1, label1, args1, consts1), + Inductive (_loc2, label2, args2, consts2)) + -> unify_inductive' ctx vs args1 args2 consts1 consts2 lxp1 lxp2 + | _, _ -> [(CKimpossible, ctx, lxp1, lxp2)] + +and unify_inductive' ctx vs args1 args2 consts1 consts2 e1 e2 = let unif_formals ctx vs args1 args2 = if not (List.length args1 == List.length args2) then (ctx, vs, [(CKimpossible, ctx, e1, e2)]) @@ -578,3 +615,8 @@ and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 = * | _, _ -> None * in test l1 l2 subst *) +and unify_cons lxp1 lxp2 ctx vs = + match lexp_lexp' lxp1, lexp_lexp' lxp2 with + | (Cons (it1, (_, l1)), Cons (it2, (_, l2))) when l1 = l2 + -> unify' it1 it2 ctx vs + | _, _ -> [(CKimpossible, ctx, lxp1, lxp2)] ===================================== tests/elab_test.ml ===================================== @@ -107,6 +107,24 @@ plus x y = Eq_refl); |} +let _ = add_elab_test_decl + "depelim macro" + {| +type Nat + | Z + | S Nat; + +Nat_induction : + (P : Nat -> Type_ ?l) ≡> + P Z -> + ((n : Nat) -> P n -> P (S n)) -> + ((n : Nat) -> P n); +Nat_induction base step n = + case n return (P n) + | Z => base + | S n' => (step n' (Nat_induction (P := P) base step n')); + |} + let _ = add_elab_test_decl "case conversion" {| ===================================== tests/eval_test.ml ===================================== @@ -445,4 +445,36 @@ nil≠l = |} "head l nil≠l" "0" +let _ = + add_test "EVAL" "int overflows" (fun () -> + let check_op op biop a b = + let a' = Z.of_int a in + let b' = Z.of_int b in + let expect' = biop a' b' in + let str = "(Int_" ^ op ^ " " ^ (string_of_int a) + ^ " " ^ (string_of_int b) ^ ")" in + let lxp = List.hd (Elab.lexp_expr_str str ectx) in + let elxp = OL.erase_type lxp in + assert (Log.error_count () == 0); + + if Z.fits_int expect' then + let actual = eval elxp rctx in + expect_equal_values [actual] [Vint (Z.to_int expect')] + else + (* The result should overflow *) + try let result = (eval elxp rctx) in + ut_string2 ("EXPECTED overflow for `" ^ str ^ "`\n"); + ut_string2 ("GOT: " ^ (value_string result) ^ "\n"); + failure + with + | Log.Internal_error _ -> Log.clear_log (); success in + let arith_ops = [("+", Z.add); ("-", Z.sub); ("*", Z.mul); ("/", Z.div)] in + let vals = [min_int; -1; 0; 1; max_int] in + let sum_for ls fn = List.fold_left (+) 0 (List.map fn ls) in + sum_for arith_ops (fun (op, biop) -> + sum_for vals (fun a -> + sum_for vals (fun b -> + if op = "/" && b = 0 then success else + check_op op biop a b)))) + let _ = run_all () ===================================== tests/unify_test.ml ===================================== @@ -21,21 +21,18 @@ * * -------------------------------------------------------------------------- *) -open Sexp -open Pexp + open Lexp open Unification -open Utest_lib - open Fmt +open Utest_lib -open Builtin -open Env - -open Str +module U = Util -open Debug +(* default environment *) +let ectx = Elab.default_ectx +let rctx = Elab.default_rctx type result = | Constraint @@ -43,10 +40,6 @@ type result = | Equivalent | Nothing -type unif_res = (result * (constraints) * lexp * lexp) - -type triplet = string * string * string - let string_of_result r = match r with | Constraint -> "Constraint" @@ -54,179 +47,97 @@ let string_of_result r = | Equivalent -> "Equivalent" | Nothing -> "Nothing" -let max_dim (lst: (string * string * string * string) list): (int * int * int *int) = - let max i l = max i (String.length l) - in List.fold_left - (fun (la, ca1, ca2, ra) (l, c1, c2, r) -> ((max la l), (max ca1 c1), (max ca2 c2), (max ra r))) - (0, 0, 0, 0) - lst - -let fmt (lst: (lexp * lexp * result * result) list): string list = - let str_lst = List.map - (fun (l1, l2, r1, r2) -> ((lexp_string l1), (lexp_string l2), (string_of_result r1), (string_of_result r2))) - lst - in let l, c1, c2, r = max_dim str_lst - in List.map (fun (l1, l2, r1, r2) -> (U.padding_right l1 l ' ') - ^ ", " - ^ (U.padding_right l2 c1 ' ') - ^ " -> got: " - ^ (U.padding_right r2 r ' ') - ^ " expected: " - ^ (U.padding_right r1 c2 ' ') - ) str_lst - -(* Inputs for the test *) -let str_induct = "Nat : Type; Nat = typecons (dNat) (zero) (succ Nat)" -let str_int_3 = "i = 3" -let str_int_4 = "i = 4" -let str_case = "i = case true -| true => 2 -| false => 42" -let str_case2 = "i = case nil(a := Int) -| nil => 12 -| _ => 24" -let str_let = "i = let a = 5 in a + 1" -let str_let2 = "j = let b = 5 in b" -let str_lambda = "sqr = lambda (x : Int) -> x * x;" -let str_lambda2 = "sqr = lambda (x : Int) -> x * x;" -let str_lambda3 = "sqr = lambda (x : Int) -> lambda (y : Int) -> x * y;" -let str_type = "i = let j = decltype(Type) in decltype(j);" -let str_type2 = "j = let i = Int -> Int in decltype(i);" - -let generate_ltype_from_str str = - List.hd ((fun (lst, _) -> - (List.map - (fun (_, _, ltype) -> ltype)) - (List.flatten lst)) - (Elab.lexp_decl_str str Elab.default_ectx)) - -let generate_lexp_from_str str = - List.hd ((fun (lst, _) -> - (List.map - (fun (_, lxp, _) -> lxp)) - (List.flatten lst)) - (Elab.lexp_decl_str str Elab.default_ectx)) - -let input_induct = generate_lexp_from_str str_induct -let input_int_4 = generate_lexp_from_str str_int_4 -let input_int_3 = generate_lexp_from_str str_int_3 -let input_case = generate_lexp_from_str str_case -let input_case2 = generate_lexp_from_str str_case2 -let input_let = generate_lexp_from_str str_let -let input_let2 = generate_lexp_from_str str_let -let input_lambda = generate_lexp_from_str str_lambda -let input_lambda2 = generate_lexp_from_str str_lambda2 -let input_lambda3 = generate_lexp_from_str str_lambda3 -let input_arrow = generate_ltype_from_str str_lambda -let input_arrow2 = generate_ltype_from_str str_lambda2 -let input_arrow3 = generate_ltype_from_str str_lambda3 -let input_type = generate_ltype_from_str str_type -let input_type_t = generate_ltype_from_str str_type2 - -let generate_testable (_: lexp list) : ((lexp * lexp * result) list) = - - ( mkLambda ((Anormal), - (Util.dummy_location, Some "L1"), - mkVar((Util.dummy_location, Some "z"), 3), - mkImm (Integer (Util.dummy_location, 3))), - mkLambda ((Anormal), - (Util.dummy_location, Some "L2"), - mkVar((Util.dummy_location, Some "z"), 4), - mkImm (Integer (Util.dummy_location, 3))), Nothing ) - - ::(input_induct , input_induct , Equivalent) (* 2 *) - ::(input_int_4 , input_int_4 , Equivalent) (* 3 *) - ::(input_int_3 , input_int_4 , Nothing) (* 4 *) - ::(input_case , input_int_4 , Constraint) (* 5 *) - ::(input_case , input_induct , Constraint) (* 6 *) - ::(input_case , input_case , Equivalent) (* 7 *) - ::(input_case , input_case2 , Nothing) (* 8 *) - - ::(input_let , input_induct , Constraint) (* 9 *) - ::(input_let , input_int_4 , Constraint) (* 10 *) - ::(input_let , input_case , Constraint) (* 11 *) - ::(input_let , input_let , Equivalent) (* 12 *) - ::(input_let2 , input_let , Equivalent) (* 13 *) - ::(input_let2 , input_let2 , Equivalent) (* 14 *) - - ::(input_lambda , input_int_4 , Nothing) (* 15 *) - ::(input_lambda , input_induct , Nothing) (* 16 *) - ::(input_lambda , input_case , Constraint) (* 17 *) - ::(input_lambda , input_case2 , Constraint) (* 18 *) - ::(input_lambda , input_let , Constraint) (* 19 *) - ::(input_lambda , input_induct , Nothing) (* 20 *) - ::(input_lambda , input_lambda , Equivalent) (* 21 *) - - ::(input_lambda2 , input_int_4 , Nothing) (* 22 *) - ::(input_lambda2 , input_induct , Nothing) (* 23 *) - ::(input_lambda2 , input_case , Constraint) (* 24 *) - ::(input_lambda2 , input_case2 , Constraint) (* 25 *) - ::(input_lambda2 , input_let , Constraint) (* 26 *) - ::(input_lambda2 , input_induct , Nothing) (* 27 *) - ::(input_lambda2 , input_lambda , Equivalent) (* 28 *) - ::(input_lambda2 , input_lambda2 , Equivalent) (* 29 *) - ::(input_lambda2 , input_lambda3 , Constraint) (* 30 *) - ::(input_lambda3 , input_lambda3 , Equivalent) (* 31 *) - - ::(input_arrow2 , input_int_4 , Unification) (* 32 *) - ::(input_arrow2 , input_induct , Unification) (* 33 *) - ::(input_arrow2 , input_case , Constraint) (* 34 *) - ::(input_arrow2 , input_case2 , Constraint) (* 35 *) - ::(input_arrow2 , input_let , Constraint) (* 36 *) - ::(input_arrow2 , input_induct , Unification) (* 37 *) - ::(input_arrow2 , input_lambda , Unification) (* 38 *) - ::(input_arrow2 , input_lambda2 , Unification) (* 39 *) - ::(input_arrow2 , input_arrow3 , Unification) (* 40 *) - ::(input_arrow3 , input_arrow , Unification) (* 41 *) - ::(input_arrow2 , input_arrow , Unification) (* 42 *) - ::(input_arrow3 , input_arrow3 , Equivalent) (* 43 *) - - ::(input_type , input_type_t , Equivalent) (* 44 *) - - ::(mkMetavar (0, S.identity, (Util.dummy_location, Some "M")), - mkVar ((Util.dummy_location, Some "x"), 3), Unification) (* 45 *) - - ::[] - -let test_input (lxp1: lexp) (lxp2: lexp): unif_res = +let unif_output (lxp1: lexp) (lxp2: lexp) ctx = let orig_subst = !metavar_table in - let res = unify lxp1 lxp2 Myers.nil in - match res with + let constraints = unify lxp1 lxp2 ctx in + match constraints with | [] -> let new_subst = !metavar_table in if orig_subst == new_subst - then (Equivalent, res, lxp1, lxp2) - else (Unification, res, lxp1, lxp2) - | (CKresidual, _, _, _)::_ -> (Constraint, res, lxp1, lxp2) - | (CKimpossible, _, _, _)::_ -> (Nothing, res, lxp1, lxp2) - -let check (lxp1: lexp) (lxp2: lexp) (res: result): bool = - let r, _, _, _ = test_input lxp1 lxp2 - in if r = res then true else false - -let test_if (input: lexp list) sample_generator checker : bool = - let rec test_if_ samples checker = - match samples with - | (l1, l2, res)::t -> if checker l1 l2 res then test_if_ t checker else false - | [] -> true - in test_if_ (sample_generator input) checker - -let unifications = List.map - (fun (l1, l2, res) -> - let r, _, _, _ = test_input l1 l2 - in (l1, l2, res, r)) - (* FIXME: Skip failure for now. *) - [] (* (generate_testable []) *) - -let idx = ref 0 -let _ = List.map - (fun (str, (l1, l2, expected, res)) -> - idx := !idx + 1; - add_test "UNIFICATION" - ((if !idx < 10 then "0" else "") ^ (string_of_int !idx) ^ " " ^ str ) - (fun () -> if expected = res then success else failure)) - (List.combine (fmt unifications) unifications ) + then (Equivalent, constraints) + else (Unification, constraints) + | (CKresidual, _, _, _)::_ -> (Constraint, constraints) + | (CKimpossible, _, _, _)::_ -> (Nothing, constraints) + +let add_unif_test name ?(ectx=ectx) lxp_a lxp_b expected = + add_test "UNIFICATION" name (fun () -> + let (r, cstrts) = unif_output lxp_a lxp_b (DB.ectx_to_lctx ectx) in + + if r = expected then + success + else ( + ut_string2 (red ^ "EXPECTED: " ^ reset ^ (string_of_result expected) ^ "\n"); + ut_string2 (red ^ "GOT: " ^ reset ^ (string_of_result r ) ^ "\n"); + ut_string2 ("During the unification of:\n\t" ^ (lexp_string lxp_a) + ^ "\nand\n\t" ^ (lexp_string lxp_b) ^ "\n"); + failure + )) + +let add_unif_test_s name ?(setup="") ?(ectx=ectx) input_a input_b expected = + let _, ectx = Elab.lexp_decl_str setup ectx in + + let lxp_a = List.hd (Elab.lexp_expr_str input_a ectx) in + let lxp_b = List.hd (Elab.lexp_expr_str input_b ectx) in + + add_unif_test name ~ectx lxp_a lxp_b expected + +let _ = + (* Let's have some variables in context to block the reduction of + elimination forms. The variables are manually added to the + context (and not given a value) to make sure that they cannot be + reduced. *) + let _, ectx = Elab.lexp_decl_str + {| type Nat + | Z + | S (Nat); |} ectx in + let dloc = U.dummy_location in + let nat = mkVar ((dloc, Some "Nat"), 2) in + let shift l i = mkSusp l (S.shift i) in + let ectx, _ = + List.fold_left + (fun (ectx, i) (name, lexp) -> + Elab.ctx_extend ectx (dloc, Some name) Variable (shift lexp i), i + 1) + (ectx, 0) + [("f", (mkArrow (Anormal, (dloc, None), nat, dloc, shift nat 1))); + ("g", (mkArrow (Anormal, (dloc, None), nat, dloc, shift nat 1))); + ("h", (mkArrow (Anormal, (dloc, Some "x"), nat, dloc, + mkArrow (Anormal, (dloc, Some "y"), shift nat 1, + dloc, shift nat 2)))); + ("a", nat); + ("b", nat)] in + + add_unif_test_s "same integer" "4" "4" Equivalent; + add_unif_test_s "diff. integers" "3" "4" Nothing; + add_unif_test_s "int and builtin" "3" "##Int" Nothing; + add_unif_test_s "same var" ~ectx "a" "a" Equivalent; + add_unif_test_s "diff. var" ~ectx "a" "b" Constraint; + add_unif_test_s "var and integer" ~ectx "a" "1" Constraint; + add_unif_test_s "same call" ~ectx "f a" "f a" Equivalent; + add_unif_test_s "calls with inconvertible heads" ~ectx "f a" "g a" Constraint; + add_unif_test_s "calls with diff. num. of args" ~ectx "h a" "h a b" Constraint; + add_unif_test_s "calls with residue in args" ~ectx "f a" "f b" Constraint; + add_unif_test_s "same case" ~ectx + "case a | Z => false | S n => true" + "case a | Z => false | S n => true" + Equivalent; + add_unif_test_s "diff. case" ~ectx + "case a | Z => false | S n => true" + "case a | Z => true | S n => false" + (* 'Nothing' would be a more accurate result here. This would + require implementing unification for case exprs. *) + Constraint; + + add_unif_test_s "datacons/inductive" ~ectx + "Z" + "(datacons (typecons Nat Z (S Nat)) Z)" + (* Not recursive! Refers to the previous def of Nat. *) + Equivalent; + + (* Metavariables *) + add_unif_test_s "same metavar" "?m" "?m" Equivalent; + add_unif_test_s "diff. metavar" "?m1" "?m2" Unification; + add_unif_test_s "metavar and int" "?m" "5" Unification; + + () let _ = run_all () - - View it on GitLab: https://gitlab.com/monnier/typer/-/compare/1fb4ed6c6db925f4667f404d624f860a… -- View it on GitLab: https://gitlab.com/monnier/typer/-/compare/1fb4ed6c6db925f4667f404d624f860a… You're receiving this email because of your account on gitlab.com.

1 0

[Git][monnier/typer][report/hmdup] Add an example
by Stefan 26 Sep '20

26 Sep '20

Stefan pushed to branch report/hmdup at Stefan / Typer Commits: 93e6993d by Stefan Monnier at 2020-09-26T20:41:16-04:00 Add an example - - - - - 1 changed file: - paper.tex Changes: ===================================== paper.tex ===================================== @@ -68,10 +68,13 @@ \DeclareUnicodeCharacter{2080}{\ensuremath{_0}} \DeclareUnicodeCharacter{2081}{\ensuremath{_1}} \DeclareUnicodeCharacter{2082}{\ensuremath{_2}} +\DeclareUnicodeCharacter{2113}{\ensuremath{\ell}} \DeclareUnicodeCharacter{21D2}{\ensuremath{\Rightarrow}} \DeclareUnicodeCharacter{21DB}{\ensuremath{\Rrightarrow}} \DeclareUnicodeCharacter{2200}{\ensuremath{\forall}} \DeclareUnicodeCharacter{2203}{\ensuremath{\exists}} +\DeclareUnicodeCharacter{2237}{:\ensuremath{\!}:} +\DeclareUnicodeCharacter{2254}{:\ensuremath{\!}=} \DeclareUnicodeCharacter{2261}{\ensuremath{\equiv}} \DeclareUnicodeCharacter{2980}{\ensuremath{|||}} \DeclareUnicodeCharacter{1D4B0}{\ensuremath{\mathcal{U}}} @@ -295,8 +298,8 @@ any program that can be typed by HM-inference should be accepted by our system without any need for type annotations either; (2) to preserve the let-polymorphism and automatic specialization of HM-inference; (3) to be simple and adaptable to most features of modern typed lambda calculi. -While the first two goals reduce the need for type annotations, -minimizing the amount of type annotations was secondary to the design. +%% While the first two goals reduce the need for type annotations, +%% minimizing the amount of type annotations was secondary to the design.. @@ -314,7 +317,8 @@ minimizing the amount of type annotations was secondary to the design. \newcommand \Meta [1] {#1} \newcommand \DArw [3] {\forall #1 \: #2 . #3} \newcommand \Let [3] {\kw{let}~#1=#2~\kw{in}~#3} -\newcommand \MDArw [2] {\forall \overrightarrow{#1} . #2} +\newcommand \CDArw [2] {\forall {#1} . #2} +\newcommand \MDArw [2] {\CDArw{\overrightarrow{#1}}{#2}} \newcommand \HasType [2] {#1 \: #2} \newcommand \Jcheck [3][\Gamma] {#1 \vdash #2 \Leftarrow #3} @@ -388,7 +392,7 @@ the fact that our types are not stratified into monomorphic types and type schemes. The use of explicit metavariables is not very important here, but it will play a bigger role once we adapt our system to more powerful type systems. Similarly, the lack of stratification does not make -a significant difference at this stage: the algorithm will still only infer +a significant difference at this stage: the algorithm will still infer only those types which can be represented in the traditional stratified system, but our later systems do not make use of such a stratification. @@ -456,7 +460,7 @@ $u_2$ was instantiated to. %% \label{fig:bidi-check} %% \end{figure} -Figure~\cite{fig:bidi-check} shows the traditional bidirectional rules to +Figure~\ref{fig:bidi-check} shows the traditional bidirectional rules to type check the $\lambda$-calculus. \begin{figure} @@ -508,7 +512,7 @@ type check the $\lambda$-calculus. \label{fig:bidi-infer} \end{figure} -Figure~\cite{fig:bidi-infer} shows how we can generalize them to the case +Figure~\ref{fig:bidi-infer} shows how we can generalize them to the case where we do type inference. The last rule is the one that lets us infer the type of a $\Lam{x}{e}$. It also makes the rules non-syntax directed, so it should only be used when $e$ is a ``checking expression'', in our case @@ -679,7 +683,7 @@ While we do not intend to require as few annotations as systems like existing type information to try and reduce the amount of annotations needed. To this end, we need to pay attention to the places where redundant type information can be better used. In the original Hindley-Milner -algorithm, we can see that the only place where we might ``burn off'' excess +algorithm, we can see that the main place where we might ``burn off'' excess information is in the \textsc{HM-App} rule, where the type $\tau_1$ of the argument might be inferred both from $e_2$ and from $e_1$. @@ -700,6 +704,16 @@ which we can just \emph{check} the type of $e_2$ against $\tau_1$. This is because in the vast majority of cases we already know the type of the function we're calling. +In HM, $\forall$-quantification can only appear in the context: it is introduced +when adding a variable to the context via \textsc{HM-Let} and it is then +systematically eliminated when referring to those variables via +\textsc{HM-Var}. + +To cover System-F, these constraints need to be relaxed such that +$\forall$-quantification can be introduced and eliminated virtually anywhere, +which intuitively explains why the problem is undecidable unless we require +the addition of explicit annotations. + The only change to the syntax of the language is the addition of the form $\HasType{e}{\tau}$. While the specific form of the type annotations is not a primary concern for us, we did want to avoid ``non-standard'' annotations @@ -827,6 +841,91 @@ incompatible with things like value polymorphism. \FIXME{Change the rules to avoid those extra eta-redexes} +\section{Examples} + +Fully annotated example: +%% type NList (ℓ ∷ Level) (t : Type ℓ) (n : Nat) +%% | nnil (n ≡ zero) +%% | ncons (n' ∷ Nat) (n = succ n') t (NList (ℓ ≔ ℓ) t n'); +\begin{verbatim} + type NList [ℓ : Level] (t : Type ℓ) (n : Nat) + | nnil : NList [ℓ] t zero + | ncons [n' : Nat] t (NList [ℓ] t n') + : NList [ℓ] t (succ n'); + + empty : [ℓ : Level] → [t : Type ℓ] → [n : Nat] + → NList [ℓ] t n → Bool; + empty = λ [ℓ : Level] [t : Type ℓ] [n : Nat] + (xs : NList [ℓ] t n) + → case xs + | nnil ⇒ true + | ncons [_] _ _ ⇒ false; + + append : [ℓ : Level] → [t : Type ℓ] → [n₁ : Nat] → [n₂ : Nat] + → NList [ℓ] t n₁ → NList [ℓ] t n₂ + → NList [ℓ] t (n₁ + n₂); + append = λ [ℓ : Level] [t : Type ℓ] [n₁ : Nat] [n₂ : Nat] + (xs₁ : NList [ℓ] t n₁) + (xs₂ : NList [ℓ] t n₂) + → case xs₁ + | nnil ⇒ xs₂ + | ncons [n'] x xs + ⇒ ncons [ℓ] [t] [n'] + x (append [ℓ] [t] [n'] [n₂] + xs xs₂); +\end{verbatim} + +Annotations where inference tries to fill implicit actual arguments, +type annotations, and use bidirectional type checking to infer implicit +formals: +\begin{verbatim} + type NList [ℓ] (t : Type ℓ) n + | nnil : NList t zero + | ncons [n'] t (NList t n') : NList t (succ n'); + + empty = λ [ℓ] [t : Type ℓ] [n] + (xs : NList t n) + → case xs + | nnil ⇒ true + | ncons _ _ ⇒ false; + + append : [ℓ] → [t : Type ℓ] → [n₁] → [n₂] + → NList t n₁ → NList t n₂ → NList t (n₁ + n₂); + append = λ xs₁ xs₂ + → case xs₁ + | nnil ⇒ xs₂ + | ncons x xs ⇒ ncons x (append xs xs₂); +\end{verbatim} +Notice how we still need the annotation ``\texttt{:~Type~ℓ}'' on the +\texttt{t} argument, even though the uses of \texttt{t} make it clear it +should be a type. Similarly, we still need the annotation +``\texttt{:~NList~t~n}'' on the \texttt{xs} argument of \texttt{empty} +because inference will clearly figure out that it should have the form +``\texttt{NList~?~?}'' but will not know to use the \texttt{t} and +\texttt{n} arguments that the programmer added specifically for +that purpose. + +Further reduction based on HM-style automatic generalisation: +\newpage +\begin{verbatim} + type NList t n + | nnil : NList t zero + | ncons t (NList t ?n') : NList t (succ ?n'); + + empty = λ xs → case xs + | nnil ⇒ true + | ncons _ _ ⇒ false; + + append : NList ?t ?n₁ → NList ?t ?n₂ → NList ?t (?n₁ + ?n₂); + append = λ xs₁ xs₂ → case xs₁ + | nnil ⇒ xs₂ + | ncons x xs ⇒ ncons x (append xs xs₂); +\end{verbatim} +Notice how the generalization not only allows the programmer to omit +writing the implicit formal arguments but it also allows the removal of the +type annotations ``\texttt{:~Type~ℓ}'' and ``\texttt{:~NList~t~n}''. + + \section{Elaboration} \FIXME{We should probably directly present the elaborating version of the @@ -1080,6 +1179,18 @@ our language is extended as follows: \cite{Mycroft84,Henglein93} +%% Crap! That's what this article was trying to do! +%% Differences I can see so far: +%% - Doesn't do HM-style let-generalization +%% - Focuses on automatic insertion of implicit +%% lambdas rather than implicit applications +%% - We want to deal with universe levels +\cite{Kovacs20} + +\cite{Laufer92} %Twelf-style elision of existential quantification in datatypes + +\cite{Odersky96} %System-F inference via type annotations + \section{Conclusion} View it on GitLab: https://gitlab.com/monnier/typer/-/commit/93e6993d295382988becca604d0f22b90… -- View it on GitLab: https://gitlab.com/monnier/typer/-/commit/93e6993d295382988becca604d0f22b90… You're receiving this email because of your account on gitlab.com.

1 0

[Git][monnier/typer][ja-barszcz] 16 commits: * src/eval.ml: Add overflow checking to the Int builtin operators
by Jean-Alexandre Barszcz 25 Sep '20

25 Sep '20

Jean-Alexandre Barszcz pushed to branch ja-barszcz at Stefan / Typer Commits: d3a9e581 by Jean-Alexandre Barszcz at 2020-09-25T22:26:59-04:00 * src/eval.ml: Add overflow checking to the Int builtin operators * tests/eval_test.ml: Test that overflows cause runtime errors - - - - - 7e07d97d by Jean-Alexandre Barszcz at 2020-09-25T22:33:21-04:00 * src/sexp.ml (sexp): Use Zarith's big integers in sexps. * btl/builtins.typer: Add the builtin `Integer->Int`. * src/eval.ml: Implement it. (sexp_dispatch): Fix the value passed to the integer handler. - - - - - 043275cd by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 * btl/pervasive.typer (quote1): Fix quoting for literals - - - - - 8a7b7910 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 Add a macro for dependent elimination * btl/depelim.typer: New file, implements the macro. * btl/pervasive.typer: Load the new macro. * tests/elab_test.ml: Test it. - - - - - c722732e by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 * src/unification.ml: Clarify the order of the handlers Try and impose some logic on the order in which the various unification cases are handled. (unify'): Shuffle. (unify_*): Simplify accordingly. (unify_call): Handle calls of different length. * tests/unify_test.ml: Rewrite and enable the tests. - - - - - ad090c1f by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 * src/elab.ml (sform_lambda): Use unify instead of conv_p. (unify_or_error): New function, extracted from check_inferred. (check_inferred): Use it. - - - - - baaf1bb3 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 [WIP] experiments with Decidable and proofs - - - - - ed9be0b5 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 [WIP] First draft of an instance search algorithm - - - - - 16dca693 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 [WIP] Add a syntax for records - - - - - 0475cc31 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 [WIP] Extend the Decidable sample with conjunction (dep on records) - - - - - 8500a992 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 Resolve instances in the REPL (since exprs. are not generalized) - - - - - 6fbb8054 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 Resolve instances for recursive definitions - - - - - 35e4183d by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 [WIP] Do the set_getenv IIRC these were missing to correctly handle the elab context for macro expansion and Elab_... primitives. Perhaps it would be simpler to call set_getenv once before macro expansion rather than everywhere where the context can change. Needs some experimentation and tests. - - - - - 7c8cfdb0 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 Num class example - - - - - 0bc46119 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 Num class (with records) - - - - - e29cd513 by Jean-Alexandre Barszcz at 2020-09-25T23:18:39-04:00 Algebra classes sample with proofs for the additive monoid for Nats - - - - - 24 changed files: - btl/builtins.typer - + btl/depelim.typer - btl/pervasive.typer - + btl/records.typer - + samples/alg_classes.typer - + samples/decidable.typer - + samples/num_class.typer - + samples/num_class_recs.typer - src/REPL.ml - src/debruijn.ml - src/debug.ml - src/elab.ml - src/eval.ml - + src/instances.ml - src/lexer.ml - src/lexp.ml - src/log.ml - src/myers.ml - src/opslexp.ml - src/sexp.ml - src/unification.ml - tests/elab_test.ml - tests/eval_test.ml - tests/unify_test.ml Changes: ===================================== btl/builtins.typer ===================================== @@ -133,7 +133,15 @@ Int_>= = Built-in "Int.>=" : Int -> Int -> Bool; %% bitwise negation Int_not = Built-in "Int.not" : Int -> Int; +%% `Int` and `Integer` are conceptually isomorphic in that they both +%% represent unbounded integers, but in reality, both are bounded. +%% `Int` is implemented with `int` type in ocaml (31 or 63 bits), and +%% `Integer` is implemented with big integers (ultimately limited by +%% available memory). Both cause runtime errors at their limits, so no +%% overflows are allowed. Here are the functions that witness the +%% isomorphism: Int->Integer = Built-in "Int->Integer" : Int -> Integer; +Integer->Int = Built-in "Integer->Int" : Integer -> Int; Int->String = Built-in "Int->String" : Int -> String; @@ -363,6 +371,12 @@ Elab_isbound = Built-in "Elab.isbound" : String -> Elab_Context -> Bool; Elab_isconstructor = Built-in "Elab.isconstructor" : String -> Elab_Context -> Bool; +%% +%% Check if a symbol is an inductive in a particular context +%% +Elab_isinductive = Built-in "Elab.isinductive" + : String -> Elab_Context -> Bool; + %% %% Check if the n'th field of a constructor is erasable %% If the constructor isn't defined it will always return false @@ -389,6 +403,20 @@ Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Int -> Elab_Context -> Strin %% Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Int; +%% +%% Get the position of a field in a constructor +%% It return -1 in case the field isn't defined +%% see pervasive.typer for a more convenient function +%% +Elab_ind-ctor-arg-pos' = Built-in "Elab.ind-ctor-arg-pos" : String -> String -> String -> Elab_Context -> Int; + +%% +%% Get the number of fields in a constructor +%% It return -1 in case the field isn't defined +%% see pervasive.typer for a more convenient function +%% +Elab_count-ctor-args' = Built-in "Elab.count-ctor-args" : String -> String -> Elab_Context -> Int; + %% %% Get the docstring associated with a symbol %% ===================================== btl/depelim.typer ===================================== @@ -0,0 +1,110 @@ +%%% depelim --- A macro for dependent elimination + +%% Copyright (C) 2020 Free Software Foundation, Inc. +%% +%% Author: Jean-Alexandre Barszcz <jean-alexandre.barszcz(a)umontreal.ca> +%% Keywords: languages, lisp, dependent types. +%% +%% This file is part of Typer. +%% +%% Typer is free software; you can redistribute it and/or modify it under the +%% terms of the GNU General Public License as published by the Free Software +%% Foundation, either version 3 of the License, or (at your option) any +%% later version. +%% +%% Typer is distributed in the hope that it will be useful, but WITHOUT ANY +%% WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +%% FOR A PARTICULAR PURPOSE. See the GNU General Public License for +%% more details. +%% +%% You should have received a copy of the GNU General Public License along +%% with this program. If not, see <http://www.gnu.org/licenses/>. + +%%% Description +%% +%% In Typer, the branch bodies of a `case` expression must all have +%% the same type. In order to write proofs that depend the +%% constructor, Typer adds a proof in the environment of each branch: +%% the equality between the branch's head and the case target. This +%% equality can be eliminated in each branch using `Eq_cast` to go +%% from a branch-dependent type to a target-dependent type. The +%% following macro eases this process by eliminating the boilerplate. +%% +%% The macro extends the builtin `case` syntax to +%% `case_as_return_`. The `as` and `return` clauses are used to build +%% Eq_cast's `f` argument (a lambda). The `as` clause should contain a +%% symbol (the variable binding the case target or branch head), and +%% is optional if the target is itself a symbol. The `return` clause +%% is `f`'s body, i.e. the return type of the case, using the variable +%% from the `as` clause to refer to the target or branch head. + +%%% Example usage +%% +%% type Nat +%% | Z +%% | S Nat; +%% +%% Nat_induction : +%% (P : Nat -> Type_ ?l) ≡> +%% P Z -> +%% ((n : Nat) -> P n -> P (S n)) -> +%% ((n : Nat) -> P n); +%% Nat_induction base step n = +%% case n return (P n) %% <-- `as` clause omitted: the target is a var. +%% | Z => base +%% | S n' => (step n' (Nat_induction (P := P) base step n')); + +%%% Grammar +%% +%% This macro was written for the following operators (the precedence +%% level 42 is chosen to match that of the builtin case): +%% +%% define-operator "as" 42 42; +%% define-operator "return" 42 42; + +case_as_return_impl args = + let impl target_sexp var_sexp ret_and_branches_sexp = + case Sexp_wrap ret_and_branches_sexp + | node hd (cons ret_sexp branches) => + %% TODO Check that var_sexp is a variable. + %% TODO Check that hd is the symbol `_|_`. + let + on_branch branch_sexp = + case Sexp_wrap branch_sexp + | node arrow_sexp (cons head_sexp (cons body_sexp nil)) => + %% TODO Check that arrow_sexp is `=>`. + Sexp_node + arrow_sexp + (cons head_sexp + (cons (quote (##Eq\.cast + (x := uquote head_sexp) + (y := uquote target_sexp) + (p := ##DeBruijn 0) + (f := lambda (uquote var_sexp) -> + uquote ret_sexp) + (uquote body_sexp))) + nil)) + | _ => Sexp_error; %% FIXME Improve error reporting. + new_branches = List_map on_branch branches; + in %% We extend the builtin case, so nested patterns don't work. + quote (##case_ + (uquote (Sexp_node (Sexp_symbol "_|_") + (cons target_sexp new_branches)))) + | _ => Sexp_error; + in IO_return + case args + | cons target_sexp + (cons var_sexp + (cons ret_and_branches_sexp nil)) + => impl target_sexp var_sexp ret_and_branches_sexp + | cons target_sexp + (cons ret_and_branches_sexp nil) + => %% If the `as` clause is omitted, and the target is a + %% symbol, use it for `var_sexp` as well. + (case Sexp_wrap target_sexp + | symbol _ => impl target_sexp target_sexp ret_and_branches_sexp + | _ => Sexp_error) + | _ => Sexp_error; + +case_as_return_ = macro case_as_return_impl; +case_return_ = macro case_as_return_impl; ===================================== btl/pervasive.typer ===================================== @@ -203,21 +203,31 @@ K x y = x; %% which will construct an Sexp equivalent to `x` at run-time. %% This is basically *cross stage persistence* for Sexp. quote1 : Sexp -> Sexp; -quote1 x = let k = K x; +quote1 x = let qlist : List Sexp -> Sexp; qlist xs = case xs | nil => Sexp_symbol "nil" | cons x xs => Sexp_node (Sexp_symbol "cons") (cons (quote1 x) (cons (qlist xs) nil)); + make_app str sexp = + Sexp_node (Sexp_symbol str) (cons sexp nil); + node op y = case (Sexp_eq op (Sexp_symbol "uquote")) | true => List_head Sexp_error y | false => Sexp_node (Sexp_symbol "##Sexp.node") (cons (quote1 op) (cons (qlist y) nil)); - symbol s = Sexp_node (Sexp_symbol "##Sexp.symbol") - (cons (Sexp_string s) nil) - in Sexp_dispatch x node symbol k k k k; + symbol s = make_app "##Sexp.symbol" (Sexp_string s); + string s = make_app "##Sexp.string" (Sexp_string s); + integer i = make_app "##Sexp.integer" + (make_app "##Int->Integer" (Sexp_integer i)); + float f = make_app "##Sexp.float" (Sexp_float f); + block sxp = + %% FIXME ##Sexp.block takes a string (and prelexes + %% it) but we have a sexp, what should we do? + Sexp_symbol "<error FIXME block quoting>"; + in Sexp_dispatch x node symbol string integer float block; %% quote definition quote = macro (lambda x -> IO_return (quote1 (List_head Sexp_error x))); @@ -394,7 +404,7 @@ BoolMod = (##datacons Pair = typecons (Pair (a : Type) (b : Type)) (pair (fst : a) (snd : b)); pair = datacons Pair pair; -__\.__ = +dot-impl = let mksel o f = let constructor = Sexp_node (Sexp_symbol "##datacons") (cons (Sexp_symbol "?") @@ -411,14 +421,15 @@ __\.__ = (cons (Sexp_node (Sexp_symbol "_|_") (cons o (cons branch nil))) nil) - in macro (lambda args - -> IO_return - case args - | cons o tail - => (case tail - | cons f _ => mksel o f - | nil => Sexp_error) - | nil => Sexp_error); + in (lambda args -> + IO_return case args + | cons o tail + => (case tail + | cons f _ => mksel o f + | nil => Sexp_error) + | nil => Sexp_error); + +__\.__ = macro dot-impl; %% Triplet (tuple with 3 values) type Triplet (a : Type) (b : Type) (c : Type) @@ -547,6 +558,32 @@ in case (Int_eq r (-1)) | true => (none) | false => (some r); +%% +%% If `Elab_ind-ctor-arg-pos'` returns (-1) it means: +%% A- The constructor isn't defined, or +%% B- The constructor has no argument named like this +%% +%% So in those case this function returns `none` +%% +Elab_ind-ctor-arg-pos a b c d = let + r = Elab_ind-ctor-arg-pos' a b c d; +in case (Int_eq r -1) + | true => (none) + | false => (some r); + +%% +%% If `Elab_count-ctor-args'` returns (-1) it means: +%% A- The constructor isn't defined, or +%% B- The constructor has no argument named like this +%% +%% So in those case this function returns `none` +%% +Elab_count-ctor-args a b c = let + r = Elab_count-ctor-args' a b c; +in case (Int_eq r -1) + | true => (none) + | false => (some r); + %%%% %%%% Common library %%%% @@ -634,6 +671,26 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro; %% _|_ = let lib = load "btl/polyfun.typer" in lib._|_; +%% +%% case_as_return_, case_return_ +%% A `case` for dependent elimination +%% + +define-operator "as" 42 42; +define-operator "return" 42 42; +depelim = load "btl/depelim.typer"; +case_as_return_ = depelim.case_as_return_; +case_return_ = depelim.case_return_; + +%% +%% records : a simple datatype when there is only one case +%% +define-operator "#" 200 (); +records = load "btl/records.typer"; +record = records.record; +__\.__ = records.__\.__; +_# = records._#; + %%%% Unit tests function for doing file %% It's hard to do a primitive which execute test file ===================================== btl/records.typer ===================================== @@ -0,0 +1,80 @@ +record-impl : List Sexp -> IO Sexp; +record-impl args = + let + %% Get a name (symbol) from a sexp + %% - (name t) -> name + %% - name -> name + get-name : Sexp -> Sexp; + get-name sxp = + case Sexp_wrap sxp + | node op _ => get-name op + | symbol _ => sxp + | _ => Sexp_error; + + %% head is (Sexp_node type-name (arg list)) + name-args = List_head Sexp_error args; + fields = List_tail args; + + type-name = get-name name-args; + + %% Create the inductive type definition. + inductive = Sexp_node (Sexp_symbol "typecons") + (cons name-args + (cons (Sexp_node (Sexp_symbol "rec") fields) + nil)); + + decl = make-decl type-name inductive; + + in IO_return decl; + +record = macro record-impl; + +record-get-impl : List Sexp -> IO Sexp; +record-get-impl args = + let + get tc f idx nargs ectx = + let arg_pats : Sexp -> Int -> Int -> List Sexp; + arg_pats s i n = + if (Int_eq n 0) then nil + else (if (Int_eq i 0) + then (cons s (arg_pats s (Int_- i 1) (Int_- n 1))) + else (cons (Sexp_symbol "_") (arg_pats s (Int_- i 1) (Int_- n 1)))); + + pat = (Sexp_node (quote (datacons (uquote (Sexp_symbol tc)) rec)) + (arg_pats (Sexp_symbol "v") idx nargs)); + + branch = (quote ((uquote pat) => v)); + in + (quote (lambda rec -> (##case_ (_|_ rec (uquote branch))))); + + try-rec-get : List Sexp -> Elab_Context -> Option Sexp; + try-rec-get arg ectx = + case args + | (cons tc (cons f nil)) => + (case (Sexp_wrap tc, Sexp_wrap f) + | (symbol tcstr, symbol fstr) => + (case (Elab_count-ctor-args tcstr "rec" ectx, + Elab_ind-ctor-arg-pos tcstr "rec" fstr ectx) + | (some nargs, some idx) => some (get tcstr fstr idx nargs ectx) + | _ => none) + | _ => none) + | _ => none; + in + do { + ectx <- Elab_getenv (); + case try-rec-get args ectx + | some sxp => IO_return sxp + | _ => dot-impl args; %% Fallback on default dot implementation + }; + +__\.__ = macro record-get-impl; + +record-make-impl : List Sexp -> IO Sexp; +record-make-impl args = + IO_return case args + | (cons tc nil) => (quote (datacons (uquote tc) rec)) + | _ => Sexp_error; + +_# = macro record-make-impl; + +record (Pair (a : Type) (b : Type)) (fst : a) (snd : a); ===================================== samples/alg_classes.typer ===================================== @@ -0,0 +1,88 @@ +case_ = ##case_; %% To ease debugging + +type Magma (α : Type) + | mkMagma (op : α -> α -> α); + +typeclass Magma; + +magma_op = + lambda magma_inst => + case magma_inst + | mkMagma op => op; + +Associativity (op : ?α -> ?α -> ?α) = + (x : ?α) -> (y : ?α) -> (z : ?α) -> Eq (op (op x y) z) (op x (op y z)); + +type Semigroup (α : Type) + | mkSemigroup (magma : Magma α) (assoc ::: Associativity magma_op); + +typeclass Semigroup; + +semigroup_magma = + lambda semigroup_inst => + case semigroup_inst + | mkSemigroup magma => magma; + +IsLeftIdentity (id : ?α) (op : ?α -> ?α -> ?α) = + (x : ?α) -> Eq (op id x) x; + +IsRightIdentity (id : ?α) (op : ?α -> ?α -> ?α) = + (x : ?α) -> Eq (op x id) x; + +IsIdentity (id : ?α) (op : ?α -> ?α -> ?α) = + (Pair (IsLeftIdentity id op) (IsRightIdentity id op)); + +type Monoid (α : Type) + | mkMonoid (semigroup : Semigroup α) + (identity : α) + (isIdent ::: IsIdentity identity magma_op); + +typeclass Monoid; + +type Nat + | Zero + | Succ Nat; + +plus : Nat -> Nat -> Nat; +plus x y = + case x + | Zero => y + | Succ x' => Succ (plus x' y); + +natAdditiveMagma = + mkMagma plus; + +Eq_cong : % not sure about levels here + (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡> + (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡> + (f : (t -> r)) -> (Eq (f x) (f y)); +Eq_cong f = + Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl; + +natPlusAssoc : Associativity plus; +natPlusAssoc x y z = + let + typeclass Eq + in + case x return (Eq (plus (plus x y) z) (plus x (plus y z))) + | Zero => Eq_refl + | Succ x' => (Eq_cong (p := natPlusAssoc x' y z) Succ); + +natAdditiveSemigroup : Semigroup Nat; +natAdditiveSemigroup = + mkSemigroup natAdditiveMagma (assoc := natPlusAssoc); + +zeroIsPlusLIdent : IsLeftIdentity Zero plus; +zeroIsPlusLIdent x = Eq_refl (x := x); + +zeroIsPlusRIdent : IsRightIdentity Zero plus; +zeroIsPlusRIdent x = + let + typeclass Eq; + in case x return (Eq (plus x Zero) x) + | Zero => Eq_refl + | Succ x' => (Eq_cong (p := zeroIsPlusRIdent x') Succ); + +natAdditiveMonoid : Monoid Nat; +natAdditiveMonoid = mkMonoid natAdditiveSemigroup Zero + (isIdent := pair zeroIsPlusLIdent zeroIsPlusRIdent); ===================================== samples/decidable.typer ===================================== @@ -0,0 +1,170 @@ +False = Void; +True = Unit; + +% FIXME improved "case" fails with no branches +exfalso : False -> ?a; +exfalso f = ##case_ f; + +%type Decidable (prop : Type) +% | yes (p ::: prop) +% | no (p ::: Not prop); +Decidable = typecons (Decidable (ℓ ::: TypeLevel) (prop : Type_ ℓ)) + (true (p ::: prop)) (false (p ::: Not prop)); +yes = datacons Decidable true; +no = datacons Decidable false; + +typeclass Decidable; + +Eq_trans : + (x : ?t) => (y : ?t) => (a : ?t) -> + (ax : Eq a x) => (ay : Eq a y) => Eq x y; +Eq_trans a = + lambda (ax : Eq a x) (ay : Eq a y) => + Eq_cast (f := lambda ax -> Eq ax y) ay; + +Eq_cong : % not sure about levels here + (t : (Type_ ?ℓ)) ≡> (r : (Type_ ?ℓ)) ≡> + (x : t) ≡> (y : t) ≡> (p : (Eq x y)) ≡> + (f : (t -> r)) -> (Eq (f x) (f y)); +Eq_cong f = + Eq_cast (p := p) (f := lambda xy -> Eq (f x) (f xy)) Eq_refl; + +discriminate_nocheck = + macro (lambda args -> + case args + | cons x (cons y nil) => + do { + sd <- gensym (); + sp <- gensym (); + IO_return + (quote ((lambda (uquote sp) -> + (Eq_cast (p := (uquote sp)) + (f := (lambda (uquote sd) -> + (case uquote sd + | (uquote x) => True + | _ => False))) + ())) : Not (Eq (uquote x) (uquote y)))) + } + | _ => IO_return Sexp_error); + +discriminate = + macro (lambda args -> + case args + | cons x (cons y nil) => + (case (Sexp_wrap x, Sexp_wrap y) + | (symbol sx, symbol sy) => % FIXME get the constructor even when its a call + do { + env <- Elab_getenv (); + if (and (Elab_isconstructor sx env) + (and (Elab_isconstructor sy env) + (not (Sexp_eq x y)))) + then + Macro_expand discriminate_nocheck args + else (IO_return Sexp_error) + } + | _ => IO_return Sexp_error) + | _ => IO_return Sexp_error); + +test : (Not (Eq true false)); +test = discriminate true false; + +absurd = + lambda (p : ?prop) -> + lambda (contra : (Not ?prop)) -> + contra p; + +% We can't (usefully) have a `Decidable Bool` because it's +% impossible to have a `Not Bool`. Instead, we can decide boolean +% equality: + +decideBoolEq : (a : Bool) => (b : Bool) => Decidable (Eq a b); +decideBoolEq = + lambda (a : Bool) (b : Bool) => + case (a, b) + | (false, false) => yes (p := Eq_trans false) + | (false, true) => no (p := lambda (p : Eq a b) -> + absurd (Eq_trans (ax := Eq_trans a) b) (discriminate false true)) + | (true, false) => no (p := lambda (p : Eq a b) -> + absurd (Eq_trans (ax := Eq_trans a) b) (discriminate true false)) + | (true, true) => yes (p := Eq_trans true); + +type Nat + | zero + | succ Nat; + +type even (a : Nat) + | eZ (p ::: Eq a zero) + | eSS (p :: even ?a) (pss ::: Eq a (succ (succ ?a))); + +decideEven : (a : Nat) => Decidable (even a); +decideEven = + lambda (a : Nat) => + case a + | zero => yes (p := eZ) + | succ zero => no (p := + lambda (p : even a) -> + case p + | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ zero)) + | eSS => absurd (Eq_trans a) (discriminate_nocheck (succ (succ ?)) (succ zero))) + | succ (succ a') => + case (decideEven : Decidable (even a')) + | yes => yes (p := eSS) + | no => no (p := + lambda (p : even a) -> + case p + | eZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ (succ ?))) + | eSS => absurd (? : even a') (? : Not (even a'))); + +type _<_ (a : Nat) (b : Nat) + | ltZ (pa ::: Eq a zero) (pb ::: Eq b (succ ?b)) + | ltS (p :: (?a < ?b)) (pa ::: Eq a (succ ?a)) (pb ::: Eq b (succ ?b)); + +decideLT : (a : Nat) => (b : Nat) => Decidable (a < b); +decideLT = + lambda a b => + case b + | zero => no (p := + lambda (p : (a < b)) -> + case p + | ltZ => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?)) + | ltS => absurd (Eq_trans b) (discriminate_nocheck zero (succ ?))) + | succ b' => + case a + | zero => yes (p := ltZ) + | succ a' => + case (decideLT : (Decidable (a' < b'))) + | yes => yes (p := ltS) + | no => no (p := + lambda (p : (a < b)) -> + case p + | ltZ => absurd (Eq_trans a) (discriminate_nocheck zero (succ ?)) + | ltS => absurd (? : (a' < b')) (? : Not (a' < b'))); + +define-operator "∧" 111 130; + +record ((a : Type) ∧ (b : Type)) (fst : a) (snd : b); + +decideAnd : (P : Type) ≡> (Q : Type) ≡> + (Decidable P) => (Decidable Q) => (Decidable (P ∧ Q)); +decideAnd = + lambda P Q ≡> + lambda (decP : Decidable P) (decQ : Decidable Q) => + case (decP, decQ) + | (yes (p := pP), yes (p := pQ)) => yes (p := _∧_ # pP pQ) + | (no (p := nP), _) => + no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.fst proofs) nP)) + | (_, no (p := nQ)) => + no (p := (lambda (proofs : P ∧ Q) -> absurd (_∧_.snd proofs) nQ)); + +if_then_else_ + = macro (lambda args -> + let e1 = List_nth 0 args Sexp_error; + e2 = List_nth 1 args Sexp_error; + e3 = List_nth 2 args Sexp_error; + in IO_return (quote (case (instance () : (Decidable (uquote e1))) + | yes => uquote e2 + | no => uquote e3))); + +test2 : Bool; +test2 = if ((even (succ zero)) ∧ (zero < zero)) then false else true; + ===================================== samples/num_class.typer ===================================== @@ -0,0 +1,39 @@ +type Num (α : Type) + | mkNum (Num_+ : α -> α -> α) + (Num_- : α -> α -> α) + (Num_* : α -> α -> α) + (Num_/ : α -> α -> α); + +typeclass Num; + +_+_ = lambda numInst => case numInst | mkNum _+_ _ _ _ => _+_; +_-_ = lambda numInst => case numInst | mkNum _ _-_ _ _ => _-_; +_*_ = lambda numInst => case numInst | mkNum _ _ _*_ _ => _*_; +_/_ = lambda numInst => case numInst | mkNum _ _ _ _/_ => _/_; + +IntNum : Num Int; +IntNum = + mkNum (Num_+ := Int_+) (Num_- := Int_-) (Num_* := Int_*) (Num_/ := Int_/); + +IntegerNum : Num Integer; +IntegerNum = + mkNum (Num_+ := Integer_+) (Num_- := Integer_-) + (Num_* := Integer_*) (Num_/ := Integer_/); + +FloatNum : Num Float; +FloatNum = + mkNum (Num_+ := Float_+) (Num_- := Float_-) + (Num_* := Float_*) (Num_/ := Float_/); + +type FromInt (α : Type) + | mkFromInt (FromInt_fromInt : Int -> α); + +typeclass FromInt; + +fromInt = lambda fromIntInst => case fromIntInst | mkFromInt fromInt => fromInt; + +IntFromInt : FromInt Int; +IntFromInt = mkFromInt (lambda x -> x); + +IntegerFromInt : FromInt Integer; +IntegerFromInt = mkFromInt Int->Integer; ===================================== samples/num_class_recs.typer ===================================== @@ -0,0 +1,33 @@ +record (Num (α : Type)) + (_+_ : α -> α -> α) + (_-_ : α -> α -> α) + (_*_ : α -> α -> α) + (_/_ : α -> α -> α); + +typeclass Num; + +_+_ = lambda numInst => Num._+_ numInst; +_-_ = lambda numInst => Num._-_ numInst; +_*_ = lambda numInst => Num._*_ numInst; +_/_ = lambda numInst => Num._/_ numInst; + +IntNum : Num Int; +IntNum = Num # Int_+ Int_- Int_* Int_/; + +IntegerNum : Num Integer; +IntegerNum = Num # Integer_+ Integer_- Integer_* Integer_/; + +FloatNum : Num Float; +FloatNum = Num # Float_+ Float_- Float_* Float_/; + +record (FromInt (α : Type)) (fromInt : Int -> α); + +typeclass FromInt; + +fromInt = lambda fromIntInst => FromInt.fromInt fromIntInst; + +IntFromInt : FromInt Int; +IntFromInt = FromInt # (lambda x -> x); + +IntegerFromInt : FromInt Integer; +IntegerFromInt = FromInt # Int->Integer; ===================================== src/REPL.ml ===================================== @@ -139,6 +139,7 @@ let ilexp_parse pexps lctx: ((ldecl list list * lexpr list) * elab_context) = unparsed tokens directly instead *) let ldecls, lctx = Elab.lexp_p_decls pdecls [] lctx in let lexprs = Elab.lexp_parse_all pexprs lctx in + List.iter Elab.resolve_instances lexprs; List.iter (fun lxp -> ignore (OL.check (ectx_to_lctx lctx) lxp)) lexprs; (ldecls, lexprs), lctx ===================================== src/debruijn.ml ===================================== @@ -145,26 +145,29 @@ type meta_scope * lctx_length (* Length of ctx when the scope is added. *) * (meta_id SMap.t ref) (* Metavars already known in this scope. *) +type typeclass_ctx + = (ltype * lctx_length) list (* FIXME make it a set of lexps ? *) + (* This is the *elaboration context* (i.e. a context that holds * a lexp context plus some side info. *) type elab_context - = Grammar.grammar * senv_type * lexp_context * meta_scope + = Grammar.grammar * senv_type * lexp_context * meta_scope * typeclass_ctx let get_size (ctx : elab_context) - = let (_, (n, _), lctx, _) = ctx in + = let (_, (n, _), lctx, _, _) = ctx in assert (n = M.length lctx); n let ectx_to_grm (ectx : elab_context) : Grammar.grammar = - let (grm,_, _, _) = ectx in grm + let (grm,_, _, _, _) = ectx in grm (* Extract the lexp context from the context used during elaboration. *) let ectx_to_lctx (ectx : elab_context) : lexp_context = - let (_,_, lctx, _) = ectx in lctx + let (_,_, lctx, _, _) = ectx in lctx -let ectx_to_scope_level ((_, _, _, (sl, _, _)) : elab_context) : scope_level +let ectx_to_scope_level ((_, _, _, (sl, _, _), _) : elab_context) : scope_level = sl -let ectx_local_scope_size ((_, (n, _), _, (_, slen, _)) as ectx) : int +let ectx_local_scope_size ((_, (n, _), _, (_, slen, _), _) as ectx) : int = get_size ectx - slen (* Public methods: DO USE @@ -175,7 +178,7 @@ let empty_lctx = M.nil let empty_elab_context : elab_context = (Grammar.default_grammar, empty_senv, empty_lctx, - (0, 0, ref SMap.empty)) + (0, 0, ref SMap.empty), []) (* senv_lookup caller were using Not_found exception *) exception Senv_Lookup_Fail of (string list) @@ -183,7 +186,7 @@ let senv_lookup_fail relateds = raise (Senv_Lookup_Fail relateds) (* Return its current DeBruijn index. *) let senv_lookup (name: string) (ctx: elab_context): int = - let (_, (n, map), _, _) = ctx in + let (_, (n, map), _, _, _) = ctx in try n - (SMap.find name map) - 1 with Not_found -> let get_related_names (n : db_ridx) name map = @@ -222,11 +225,11 @@ let lctx_extend (ctx : lexp_context) (def: vname) (v: varbind) (t: lexp) = let env_extend_rec (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) = let (loc, oname) = def in - let (grm, (n, map), env, sl) = ctx in + let (grm, (n, map), env, sl, tcctx) = ctx in let nmap = match oname with None -> map | Some name -> SMap.add name n map in (grm, (n + 1, nmap), lexp_ctx_cons env def v t, - sl) + sl, tcctx) let ectx_extend (ctx: elab_context) (def: vname) (v: varbind) (t: lexp) = env_extend_rec ctx def v t @@ -240,28 +243,33 @@ let lctx_extend_rec (ctx : lexp_context) (defs: (vname * lexp * ltype) list) = ctx let ectx_extend_rec (ctx: elab_context) (defs: (vname * lexp * ltype) list) = - let (grm, (n, senv), lctx, sl) = ctx in + let (grm, (n, senv), lctx, sl, tcctx) = ctx in let senv', _ = List.fold_left (fun (senv, i) ((_, oname), _, _) -> (match oname with None -> senv | Some name -> SMap.add name i senv), i + 1) (senv, n) defs in - (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl) + (grm, (n + List.length defs, senv'), lctx_extend_rec lctx defs, sl, tcctx) let ectx_new_scope (ectx : elab_context) : elab_context = - let (grm, senv, lctx, (scope, _, rmmap)) = ectx in - (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap))) + let (grm, senv, lctx, (scope, _, rmmap), tcctx) = ectx in + (grm, senv, lctx, (scope + 1, Myers.length lctx, ref (!rmmap)), tcctx) let ectx_get_scope (ectx : elab_context) : meta_scope = - let (_, _, _, sl) = ectx in sl + let (_, _, _, sl, _) = ectx in sl let ectx_get_grammar (ectx : elab_context) : Grammar.grammar = - let (grm, _, _, _) = ectx in grm + let (grm, _, _, _, _) = ectx in grm let env_lookup_by_index index (ctx: lexp_context): env_elem = Myers.nth index ctx +let env_add_typeclass (ectx : elab_context) (t : ltype) : elab_context = + let (grm, senv, lctx, sl, tcctx) = ectx in + let ntcctx = ((t, get_size ectx) :: tcctx) in + (grm, senv, lctx, sl, ntcctx) + (* Print context *) let print_lexp_ctx_n (ctx : lexp_context) start = let n = (M.length ctx) - 1 in ===================================== src/debug.ml ===================================== @@ -90,7 +90,7 @@ let rec debug_sexp_print sexp = print_string "\""; print_string str; print_string "\"" | Integer(loc, n) - -> print_info "Integer: " loc; print_int n + -> print_info "Integer: " loc; Z.print n | Float(loc, x) -> print_info "Float: " loc; print_float x ===================================== src/elab.ml ===================================== @@ -57,6 +57,7 @@ open Grammar module BI = Builtin module Unif = Unification +module Inst = Instances module OL = Opslexp module EL = Elexp @@ -257,6 +258,13 @@ let newMetavar (ctx : lexp_context) sl name t = let meta = Unif.create_metavar ctx sl t in mkMetavar (meta, S.identity, name) +let newInstanceMetavar (ctx : elab_context) name t = + let lctx = ectx_to_lctx ctx in + let sl = ectx_to_scope_level ctx in + let meta = Unif.create_metavar lctx sl t in + Inst.add_instance_metavar meta ctx (fst name); + mkMetavar (meta, S.identity, name) + let newMetalevel (ctx : lexp_context) sl loc = newMetavar ctx sl (loc, Some "ℓ") type_level @@ -278,10 +286,10 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context = | [String (_, name); l; r] -> let level s = match s with | Symbol (_, "") -> None - | Integer (_, n) -> Some n + | Integer (_, n) -> Some (Z.to_int n) | _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in - let (grm, a, b, c) = ctx in - (SMap.add name (level l, level r) grm, a, b, c) + let (grm, a, b, c, d) = ctx in + (SMap.add name (level l, level r) grm, a, b, c, d) | [o; _; _] -> sexp_error (sexp_location o) "Expecting a string"; ctx | _ @@ -626,12 +634,83 @@ and get_implicit_arg ctx loc oname t = and instantiate_implicit e t ctx = let rec instantiate t args = match OL.lexp'_whnf t (ectx_to_lctx ctx) with + | Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2) when Inst.is_typeclass ctx t1 + -> let arg = newInstanceMetavar ctx (lexp_location e, v) t1 in + instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args) | Arrow ((Aerasable | Aimplicit) as ak, (_, v), t1, _, t2) -> let arg = get_implicit_arg ctx (lexp_location e) v t1 in instantiate (mkSusp t2 (S.substitute arg)) ((ak, arg)::args) | _ -> (mkCall (e, List.rev args), t) in instantiate t [] +and myers_filter_map_index (f : int -> 'a -> 'b option) (m : 'a M.myers) + : ('b M.myers) + = snd (M.fold_right + (fun x (i, l') -> + match (f i x) with + | Some y -> (i - 1, M.cons y l') + | None -> (i - 1, l')) + m (M.length m - 1, M.nil)) + +and search_instance (ctx : elab_context) (loc : location) (t : ltype) : lexp option = + Log.log_debug ~loc ("Searching for t = `" ^ (lexp_string t) ^ "`"); + let ctx = ectx_new_scope ctx in + let lctx = (ectx_to_lctx ctx) in + let sl = (ectx_to_scope_level ctx) in + let env_elem_match (i : int) (elem : DB.env_elem) : (int * DB.env_elem * lexp * ltype) option = + let ((_, namopt), _, t') = elem in + let var = mkVar ((loc,namopt), i) in + let t' = mkSusp t' (S.shift (i + 1)) in + let (e, t') = instantiate_implicit var t' ctx in + (* All candidates should have a type that is a typeclass *) + if not (Inst.is_typeclass ctx t') then None else + match Inst.check_typeclass_match t t' lctx sl with + | (Impossible | Possible) -> None + (* | Possible -> None *) + | (Match) -> Some (i, elem, e, t') in + let candidates = + myers_filter_map_index env_elem_match lctx in + Log.log_debug ("Candidates for instance of type `" ^ lexp_string t ^ "`:") + ~print_action:(fun () -> + M.iter (fun (i, ((_, so),_,t'),_, _) -> + lalign_print_int i 4; + lalign_print_string (match so with | Some s -> s | None -> "<none>") 10; + print_endline (lexp_string t')) candidates); + match M.safe_car candidates with + | None -> None + | Some (i, (vname, _, t'),e,t) -> + let t' = mkSusp t' (S.shift (i + 1)) in + Log.log_debug ~loc + ("Found candidate at index " ^ (string_of_int i) ^ ": `" ^ + (lexp_string (mkVar (vname, i))) ^ " : " ^ (lexp_string t') ^ "`"); + Some e + +and resolve_instances e = + let (_, (fv_map, _)) = OL.fv e in + U.IMap.iter (fun i (sl, t, cl, vn) -> + match Inst.instance_metavar_lookup i with + | Some (ctx, loc) -> + (match search_instance ctx loc t with + | Some e -> Unif.associate i e; resolve_instances e + | None -> + error ~loc ("No instance found for type `" ^ (lexp_string t) ^ "`") + ) + | None -> () + ) fv_map + + +and resolve_instances_and_generalize ctx e = + resolve_instances e; + generalize ctx e + +and sdform_typeclass (ctx : elab_context) loc sargs _ot : elab_context = + match sargs with + | [se] -> + let (t, _) = infer se ctx in + Inst.add_typeclass ctx t + | _ + -> sexp_error loc "typeclass expects 1 argument"; ctx + and infer_type pexp ectx var = (* We could also use lexp_check with an argument of the form * Sort (?s), but in most cases the metavar would be allocated @@ -694,6 +773,23 @@ and check (p : sexp) (t : ltype) (ctx : elab_context): lexp = | _ -> OL.get_type (ectx_to_lctx ctx) e in check_inferred ctx e inferred_t t +and unify_or_error lctx lxp ?lxp_name expect actual = + match Unif.unify expect actual lctx with + | ((ck, _ctx, t1, t2)::_) + -> lexp_error (lexp_location lxp) lxp + ("Type mismatch" + ^ (match ck with | Unif.CKimpossible -> "" + | Unif.CKresidual -> " (residue)" + | _ -> failwith "impossible") + ^ "! Context expected:\n " ^ lexp_string expect ^ "\nbut " + ^ (U.option_default "expression" lxp_name) ^ " has type:\n " + ^ lexp_string actual ^ "\ncan't unify:\n " + ^ lexp_string t1 + ^ "\nwith:\n " + ^ lexp_string t2); + assert (not (OL.conv_p lctx expect actual)) + | [] -> () + (* This is a crucial function: take an expression `e` of type `inferred_t` * and convert it into something of type `t`. Currently the only conversion * we use is to instantiate implicit arguments when needed, but we could/should @@ -704,20 +800,7 @@ and check_inferred ctx e inferred_t t = | Arrow ((Aerasable | Aimplicit), _, _, _, _) -> (e, inferred_t) | _ -> instantiate_implicit e inferred_t ctx in - (match Unif.unify inferred_t t (ectx_to_lctx ctx) with - | ((ck, _ctx, t1, t2)::_) - -> lexp_error (lexp_location e) e - ("Type mismatch(" - ^ (match ck with | Unif.CKimpossible -> "impossible" - | Unif.CKresidual -> "residue") - ^ ")! Context expected:\n " - ^ lexp_string t ^ "\nbut expression has type:\n " - ^ lexp_string inferred_t ^ "\ncan't unify:\n " - ^ lexp_string t1 - ^ "\nwith:\n " - ^ lexp_string t2); - assert (not (OL.conv_p (ectx_to_lctx ctx) inferred_t t)) - | [] -> ()); + unify_or_error (ectx_to_lctx ctx) e t inferred_t; e (* Lexp.case can sometimes be inferred, but we prefer to always check. *) @@ -983,11 +1066,13 @@ and elab_call ctx (func, ltp) (sargs: sexp list) = (* Don't instantiate after the last explicit arg: the rest is done, * when needed in infer_and_check (via instantiate_implicit). *) when not (sargs = [] && SMap.is_empty pending) - -> let larg = get_implicit_arg - ctx (match sargs with - | [] -> loc - | sarg::_ -> sexp_location sarg) - v arg_type in + -> let larg = if Inst.is_typeclass ctx arg_type + then newInstanceMetavar ctx (loc, v) arg_type + else get_implicit_arg + ctx (match sargs with + | [] -> loc + | sarg::_ -> sexp_location sarg) + v arg_type in handle_fun_args ((ak, larg) :: largs) sargs pending (L.mkSusp ret_type (S.substitute larg)) | [], _ @@ -1033,7 +1118,7 @@ and lexp_parse_inductive ctors ctx = (fun (ak, n, t) aa -> mkArrow (ak, n, t, dummy_location, aa)) acc impossible in - let g = generalize nctx altacc in + let g = resolve_instances_and_generalize nctx altacc in let altacc' = g (fun _ne vname t l e -> mkArrow (Aerasable, vname, t, l, e)) altacc in @@ -1148,9 +1233,9 @@ and lexp_check_decls (ectx : elab_context) (* External context. *) (* FIXME: Generalize when/where possible, so things like `map` can be defined without type annotations! *) (* Preserve the new operators added to nctx. *) - let ectx = let (_, a, b, c) = ectx in - let (grm, _, _, _) = nctx in - (grm, a, b, c) in + let ectx = let (_, a, b, c, _) = ectx in + let (grm, _, _, _, tcctx) = nctx in + (grm, a, b, c, tcctx) in let (declmap, nctx) = List.fold_right (fun ((l, vname), pexp) (map, nctx) -> @@ -1160,10 +1245,11 @@ and lexp_check_decls (ectx : elab_context) (* External context. *) | (v', ForwardRef, t) -> let adjusted_t = push_susp t (S.shift (i + 1)) in let e = check pexp adjusted_t nctx in - let (grm, ec, lc, sl) = nctx in + resolve_instances e; + let (grm, ec, lc, sl, tcctx) = nctx in let d = (v', LetDef (i + 1, e), t) in (IMap.add i ((l, Some vname), e, t) map, - (grm, ec, Myers.set_nth i d lc, sl)) + (grm, ec, Myers.set_nth i d lc, sl, tcctx)) | _ -> Log.internal_error "Defining same slot!") defs (IMap.empty, nctx) in let decls = List.rev (List.map (fun (_, d) -> d) (IMap.bindings declmap)) in @@ -1201,7 +1287,7 @@ and infer_and_generalize_type (ctx : elab_context) se name = -> mkArrow (ak, v, t1, l, strip_rettype t2) | Sort _ | Metavar _ -> type0 (* Abritrary closed constant. *) | _ -> t in - let g = generalize nctx (strip_rettype t) in + let g = resolve_instances_and_generalize nctx (strip_rettype t) in g (fun _ne name t l e -> mkArrow (Aerasable, name, t, l, e)) t @@ -1209,7 +1295,7 @@ and infer_and_generalize_type (ctx : elab_context) se name = and infer_and_generalize_def (ctx : elab_context) se = let nctx = ectx_new_scope ctx in let (e,t) = infer se nctx in - let g = generalize nctx e in + let g = resolve_instances_and_generalize nctx e in let e' = g (fun ne vname t l e -> mkLambda ((if ne then Aimplicit else Aerasable), vname, t, e)) @@ -1341,6 +1427,10 @@ and lexp_decls_1 -> recur [] (sdform_define_operator nctx l args None) pending_decls pending_defs + | Some (Node (Symbol (l, "typeclass"), args)) + -> recur [] (sdform_typeclass nctx l args None) + pending_decls pending_defs + | Some (Node (Symbol ((l, _) as v), sargs)) -> (* expand macro and get the generated declarations *) let sdecl' = lexp_decls_macro v sargs nctx in @@ -1369,10 +1459,12 @@ and lexp_p_decls (sdecls : sexp list) (tokens : token list) (ctx : elab_context) impl sdecls tokens ctx and lexp_parse_all (p: sexp list) (ctx: elab_context) : lexp list = + Eval.set_getenv ctx; let res = List.map (fun pe -> let e, _ = infer pe ctx in e) p in (Log.stop_on_error (); res) and lexp_parse_sexp (ctx: elab_context) (e : sexp) : lexp = + Eval.set_getenv ctx; let e, _ = infer e ctx in (Log.stop_on_error (); e) (* -------------------------------------------------------------------------- @@ -1711,10 +1803,8 @@ let rec sform_lambda kind ctx loc sargs ot = -> (match olt1 with | None -> () | Some lt1' - -> if not (OL.conv_p (ectx_to_lctx ctx) lt1 lt1') - then lexp_error (lexp_location lt1') lt1' - ("Type mismatch! Context expected `" - ^ lexp_string lt1 ^ "`")); + -> unify_or_error (ectx_to_lctx ctx) lt1' + ~lxp_name:"parameter" lt1 lt1'); mklam lt1 (Some lt2) | Arrow (ak2, v, lt1, _, lt2) when kind = Anormal @@ -1803,7 +1893,7 @@ let sform_type ctx loc sargs ot = let sform_debruijn ctx loc sargs ot = match sargs with | [Integer (l,i)] - -> if i < 0 || i > get_size ctx then + -> let i = Z.to_int i in if i < 0 || i > get_size ctx then (sexp_error l "##DeBruijn index out of bounds"; sform_dummy_ret ctx loc) else @@ -1878,6 +1968,22 @@ let sform_load usr_elctx loc sargs ot = (tuple',Lazy) +(** + Draft of a special form "instance" that gets refers to a variable + of the requested type in the context. + **) +let sform_instance ctx loc sargs ot = + match sargs, ot with + | ([se; _], _) -> (* Dummy param to trigger the special form *) + let t = infer_type se ctx (loc, None) in + let mv = newInstanceMetavar ctx (loc, Some "instance") t in + (mv, Inferred t) + | ([_], Some t) -> (* Dummy param to trigger the special form *) + let mv = newInstanceMetavar ctx (loc, Some "instance") t in + (mv, Checked) + | _ -> (sexp_error loc "##instance expects a type argument if not checked"; + sform_dummy_ret ctx loc) + (* Register special forms. *) let register_special_forms () = List.iter add_special_form @@ -1907,6 +2013,7 @@ let register_special_forms () = (* FIXME: These should be functions! *) ("decltype", sform_decltype); ("declexpr", sform_declexpr); + ("instance", sform_instance); ] (* Default context with builtin types ===================================== src/eval.ml ===================================== @@ -151,17 +151,68 @@ let add_binary_iop name f = | _ -> error loc ("`" ^ name ^ "` expects 2 Int arguments") in add_builtin_function name f 2 -let _ = add_binary_iop "+" (+); - add_binary_iop "-" (-); - add_binary_iop "*" ( * ); - add_binary_iop "/" (/); +let add_binary_iop_with_loc name f = + let name = "Int." ^ name in + let f loc (depth : eval_debug_info) (args_val: value_type list) = + match args_val with + | [Vint (v); Vint (w)] -> Vint (f loc v w) + | _ -> error loc ("`" ^ name ^ "` expects 2 Int arguments") in + add_builtin_function name f 2 + +let add_with_overflow loc a b = + let c = a + b in + (* Check that signs of both args are diff. OR sign of result is the + same as the sign of the args. *) + if (a lxor b) lor (a lxor (lnot c)) < 0 + then c + else error loc "Overflow in `Int.+`" + +let sub_with_overflow loc a b = + let c = a - b in + (* Check that signs of both args are the same OR sign of result is + the same as the sign of the first arg. *) + if (a lxor (lnot b)) lor (a lxor (lnot c)) < 0 + then c + else error loc "Overflow in `Int.-`" + +let mul_with_overflow loc a b = + let c = a * b in + if b = 0 || not (c = min_int && b = -1) && a = c / b (* Simple but slow *) + then c + else error loc "Overflow in `Int.*`" + +let div_with_overflow loc a b = + if not (a = min_int && b = -1) + then a / b + else error loc "Overflow in `Int./`" + +let lsl_with_shift_check loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.lsl`") + else a lsl b + +let lsr_with_shift_check loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.lsr`") + else a lsr b + +let asr_with_shift_check loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.asr`") + else a asr b + +let _ = add_binary_iop_with_loc "+" add_with_overflow; + add_binary_iop_with_loc "-" sub_with_overflow; + add_binary_iop_with_loc "*" mul_with_overflow; + add_binary_iop_with_loc "/" div_with_overflow; + + add_binary_iop_with_loc "lsl" lsl_with_shift_check; + add_binary_iop_with_loc "lsr" lsr_with_shift_check; + add_binary_iop_with_loc "asr" asr_with_shift_check; add_binary_iop "mod" (mod); add_binary_iop "and" (land); - add_binary_iop "or" (lor); - add_binary_iop "lsl" (lsl); - add_binary_iop "lsr" (lsr); - add_binary_iop "asr"(asr); + add_binary_iop "or" (lor); add_binary_iop "xor" (lxor) let add_binary_bool_iop name f = @@ -221,6 +272,16 @@ let _ = add_binary_bool_biop "<" BI.lt; -> match args_val with | [Vint v] -> Vinteger (BI.of_int v) | _ -> error loc ("`" ^ name ^ "` expects 1 Int argument")) + 1; + let name = "Integer->Int" in + add_builtin_function + name + (fun loc (depth : eval_debug_info) (args_val: value_type list) + -> match args_val with + | [Vinteger v] -> + (try Vint (BI.to_int v) with + | Z.Overflow -> error loc ("Overflow in `" ^ name ^ "`")) + | _ -> error loc ("`" ^ name ^ "` expects 1 Integer argument")) 1 (* Floating point numers. *) @@ -283,7 +344,7 @@ let make_string loc depth args_val = match args_val with | _ -> error loc "Sexp.string expects one string as argument" let make_integer loc depth args_val = match args_val with - | [Vinteger n] -> Vsexp (Integer (loc, BI.to_int n)) + | [Vinteger n] -> Vsexp (Integer (loc, n)) | _ -> error loc "Sexp.integer expects one integer as argument" let make_float loc depth args_val = match args_val with @@ -373,7 +434,7 @@ let rec eval lxp (ctx : Env.runtime_env) (trace : eval_debug_info): (value_type) match lxp with (* Leafs *) (* ---------------- *) - | Imm(Integer (_, i)) -> Vint i + | Imm(Integer (_, i)) -> Vint (Z.to_int i) | Imm(String (_, s)) -> Vstring s | Imm(Float (_, n)) -> Vfloat n | Imm(sxp) -> Vsexp sxp @@ -567,7 +628,7 @@ and sexp_dispatch loc depth args = | Node (op, s) -> eval_call nd [Vsexp op; o2v_list s] | Symbol (_ , s) -> eval_call sym [Vstring s] | String (_ , s) -> eval_call str [Vstring s] - | Integer (_ , i) -> eval_call it [Vint i] + | Integer (_ , i) -> eval_call it [Vinteger i] | Float (_ , f) -> eval_call flt [Vfloat f] | Block (_ , _, _) as b -> (* I think this code breaks what Blocks are. *) @@ -743,6 +804,14 @@ let constructor_p name ectx = | _ -> false with Senv_Lookup_Fail _ -> false +let inductive_p name ectx = + try let idx = senv_lookup name ectx in + match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) + (ectx_to_lctx ectx) with + | Inductive _ -> true + | _ -> false + with Senv_Lookup_Fail _ -> false + let erasable_p name nth ectx = let is_erasable ctors = match (SMap.find_opt name ctors) with | (Some args) -> @@ -821,10 +890,43 @@ let ctor_arg_pos name arg ectx = | _ -> (-1) with Senv_Lookup_Fail _ -> (-1) +let ind_ctor_arg_pos indname ctorname arg ectx = + let rec find_opt xs n = match xs with + | [] -> None + | (_, (_, Some x), _)::xs -> if x = arg then Some n else find_opt xs (n + 1) + | _::xs -> find_opt xs (n + 1) in + try let idx = senv_lookup indname ectx in + match OL.lexp'_whnf (mkVar ((dummy_location, Some indname), idx)) + (ectx_to_lctx ectx) with + | Inductive (_, _, _, ctors) -> + (match SMap.find_opt ctorname ctors with + | (Some args) -> + (match (find_opt args 0) with + | None -> (-1) + | Some n -> n) + | _ -> (-1)) + | _ -> (-1) + with Senv_Lookup_Fail _ -> (-1) + +let count_ctor_args indname ctorname ectx = + try let idx = senv_lookup indname ectx in + match OL.lexp'_whnf (mkVar ((dummy_location, Some indname), idx)) + (ectx_to_lctx ectx) with + | Inductive (_,_,_,ctors) -> + (match SMap.find_opt ctorname ctors with + | Some args -> List.length args + | None -> (-1)) + | _ -> (-1) + with Senv_Lookup_Fail _ -> (-1) + let is_constructor loc depth args_val = match args_val with | [Vstring name; Velabctx ectx] -> o2v_bool (constructor_p name ectx) | _ -> error loc "Elab.isconstructor takes a String and an Elab_Context as arguments" +let is_inductive loc depth args_val = match args_val with + | [Vstring name; Velabctx ectx] -> o2v_bool (inductive_p name ectx) + | _ -> error loc "Elab.isinductive takes a String and an Elab_Context as arguments" + let is_nth_erasable loc depth args_val = match args_val with | [Vstring name; Vint nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name nth_arg ectx) | _ -> error loc "Elab.is-nth-erasable takes a String, an Int and an Elab_Context as arguments" @@ -841,6 +943,14 @@ let arg_pos loc depth args_val = match args_val with | [Vstring t; Vstring a; Velabctx ectx] -> Vint (ctor_arg_pos t a ectx) | _ -> error loc "Elab.arg-pos takes two String and an Elab_Context as arguments" +let ind_ctor_arg_pos loc depth args_val = match args_val with + | [Vstring ind; Vstring ctor; Vstring field; Velabctx ectx] -> Vint (ind_ctor_arg_pos ind ctor field ectx) + | _ -> error loc "Elab.ind-ctor-arg-pos takes three String and an Elab_Context as arguments" + +let count_ctor_args loc depth args_val = match args_val with + | [Vstring ind; Vstring ctor; Velabctx ectx] -> Vint (count_ctor_args ind ctor ectx) + | _ -> error loc "Elab.count-ctor-args takes two String and an Elab_Context as arguments" + let array_append loc depth args_val = match args_val with | [v; Varray a] -> Varray (Array.append (Array.map (fun v -> v) a) (Array.make 1 v)) @@ -996,10 +1106,13 @@ let register_builtin_functions () = ("Elab.debug-doc", debug_doc, 2); ("Elab.isbound" , is_bound, 2); ("Elab.isconstructor", is_constructor, 2); + ("Elab.isinductive", is_inductive, 2); ("Elab.is-nth-erasable", is_nth_erasable, 3); ("Elab.is-arg-erasable", is_arg_erasable, 3); ("Elab.nth-arg" , nth_arg, 3); ("Elab.arg-pos" , arg_pos, 3); + ("Elab.ind-ctor-arg-pos", ind_ctor_arg_pos, 4); + ("Elab.count-ctor-args", count_ctor_args, 3); ("Array.append" , array_append,2); ("Array.create" , array_create,2); ("Array.length" , array_length,1); ===================================== src/instances.ml ===================================== @@ -0,0 +1,53 @@ +module Unif = Unification +module U = Util +module DB = Debruijn +module L = Lexp +module S = Subst +module OL = Opslexp + +(* FIXME Is it possible to have multiple references to the same + instance metavar? It would break the following code *) +let instance_metavar_table = ref (U.IMap.empty : (DB.elab_context * U.location) U.IMap.t) +let instance_metavar_lookup (id : L.meta_id) : (DB.elab_context * U.location) option + = U.IMap.find_opt id (!instance_metavar_table) +let add_instance_metavar (id : L.meta_id) (ctx : DB.elab_context) (loc : U.location) : unit + = instance_metavar_table := U.IMap.add id (ctx, loc) !instance_metavar_table + +let env_is_typeclass (ectx : DB.elab_context) (t : L.ltype) : bool = + let (_, _, _, _, tcctx) = ectx in + let cl = DB.get_size ectx in + List.exists (fun (t', cl') -> + let i = cl - cl' in + let t' = L.mkSusp t' (S.shift i) in + OL.conv_p (DB.ectx_to_lctx ectx) t t' + (*(Unif.unify ~checking:(max_int (* FIXME *)) t t' (DB.ectx_to_lctx ectx)) = []*) + ) tcctx + + +let get_head (lctx : DB.lexp_context) (t : L.ltype) : L.ltype = + let whnft = OL.lexp_whnf t lctx in + match L.lexp_lexp' whnft with + | L.Call (head, _) -> head + | _ -> whnft + + +let is_typeclass (ctx : DB.elab_context) (t : L.ltype) = + let lctx = DB.ectx_to_lctx ctx in + let head = get_head lctx t in + env_is_typeclass ctx head + +let add_typeclass (ctx : DB.elab_context) (t : L.ltype) : DB.elab_context = + let lctx = DB.ectx_to_lctx ctx in + let head = get_head lctx t in + DB.env_add_typeclass ctx head + +type match_res = Impossible | Possible | Match + +let check_typeclass_match t1 t2 lctx sl = + match Unif.unify ~checking:sl t1 t2 lctx with + | [] -> Match + | constraints when List.exists (function | (Unif.CKimpossible,_,_,_) -> true + | _ -> false) + constraints -> Impossible + | _ -> Possible + ===================================== src/lexer.ml ===================================== @@ -58,7 +58,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos if bp >= String.length name then ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), @@ -75,7 +75,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos | _ -> ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), ===================================== src/lexp.ml ===================================== @@ -962,7 +962,7 @@ and lexp_str ctx (exp : lexp) : string = match lexp_lexp' exp with | Imm(value) -> (match value with | String (_, s) -> tval ("\"" ^ s ^ "\"") - | Integer(_, s) -> tval (string_of_int s) + | Integer(_, s) -> tval (Z.to_string s) | Float (_, s) -> tval (string_of_float s) | e -> sexp_string e) ===================================== src/log.ml ===================================== @@ -133,11 +133,13 @@ let print_entry entry = let log_entry (entry : log_entry) = if (entry.level <= typer_log_config.level) then ( - log_push entry; - if (typer_log_config.print_at_log) + if (typer_log_config.print_at_log || + entry.level >= Debug) then (print_entry entry; flush stdout) + else + log_push entry ) let count_msgs (lvlp : log_level -> bool) = ===================================== src/myers.ml ===================================== @@ -54,11 +54,21 @@ let car l = | Mnil -> raise Not_found | Mcons (x, _, _, _) -> x +let safe_car l = + match l with + | Mnil -> None + | Mcons (x, _, _, _) -> Some x + let cdr l = match l with | Mnil -> Mnil | Mcons (_, l, _, _) -> l +let safe_cdr l = + match l with + | Mnil -> None + | Mcons (_, l, _, _) -> Some l + let case l n c = match l with | Mnil -> n () @@ -136,3 +146,6 @@ let rec fold_right f l i = match l with let map f l = fold_right (fun x l' -> cons (f x) l') l nil let iteri f l = fold_left (fun i x -> f i x; i + 1) 0 l + +let iter (f : 'a -> unit) (l : 'a myers) : unit + = fold_left (fun _ x -> f x; ()) () l ===================================== src/opslexp.ml ===================================== @@ -874,6 +874,7 @@ and mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set and mv_set_erase (ms, _nes) = (ms, IMap.empty) and fv_memo = LMap.create 1000 +and fv_flush () = LMap.clear fv_memo and fv_empty = (DB.set_empty, mv_set_empty) and fv_union (fv1, mv1) (fv2, mv2) ===================================== src/sexp.ml ===================================== @@ -27,16 +27,13 @@ open Grammar let sexp_error ?print_action loc msg = Log.log_error ~section:"SEXP" ?print_action ~loc msg -type integer = (* Num.num *) int +type integer = Z.t type symbol = location * string type sexp = (* Syntactic expression, kind of like Lisp. *) | Block of location * pretoken list * location | Symbol of symbol | String of location * string - (* FIXME: It would make a lof of sense to use a bigint here, but `compare` - * burps on Big_int objects, and `compare` is used for hash-consing of lexp - * objects which contain sexp objects as well. *) | Integer of location * integer | Float of location * float | Node of sexp * sexp list @@ -76,7 +73,7 @@ let rec sexp_string sexp = | Symbol(_, "") -> "()" (* Epsilon *) | Symbol(_, name) -> name | String(_, str) -> "\"" ^ str ^ "\"" - | Integer(_, n) -> string_of_int n + | Integer(_, n) -> Z.to_string n | Float(_, x) -> string_of_float x | Node(f, args) -> let str = "(" ^ (sexp_string f) in ===================================== src/unification.ml ===================================== @@ -46,6 +46,7 @@ let create_metavar (ctx : DB.lexp_context) (sl : scope_level) (t : ltype) type constraint_kind = | CKimpossible (* Unification is simply impossible. *) | CKresidual (* We failed to find a unifier. *) + | CKassoc (* Couldn't associate because of checking mode *) (* FIXME: Each constraint should additionally come with a description of how it relates to its "top-level" or some other info which might let us fix the problem (e.g. by introducing coercions). *) @@ -54,8 +55,9 @@ type constraints = (constraint_kind * DB.lexp_context * lexp * lexp) list type return_type = constraints (** Alias for VMap.add*) -let associate (id: meta_id) (lxp: lexp) (subst: meta_subst) : meta_subst - = U.IMap.add id (MVal lxp) subst +let associate (id: meta_id) (lxp: lexp) : unit + = metavar_table := U.IMap.add id (MVal lxp) (!metavar_table); + OL.fv_flush () let occurs_in (id: meta_id) (e : lexp) : bool = match metavar_lookup id with | MVal _ -> Log.internal_error @@ -171,17 +173,36 @@ let rec s_offset s = match s with (** Dispatch to the right unifier. - If (<code>unify_X X Y</code>) don't handle the case <b>(X, Y)</b>, it call (<code>unify Y X</code>) - - The metavar unifier is the end rule, it can't call unify with its parameter (changing their order) -*) -let rec unify (e1: lexp) (e2: lexp) + Unification has the side-effect of associating the metavariables + in a way that makes the Lexp arguments convertible, if possible. In + case of success, it returns the empty list. Otherwise, it returns + the cause of failure as a list of constraints of the following + kinds: + + 1. `CKimpossible` constraints: constraints that cannot be + satisfied, even if other metavars are associated, redexes are + reduced, and subtitutions are done. For example, an arrow could + never be unified with a lambda. + + 2. `CKresidual` constraints: pairs of subterms that cannot be + unified in the current context, but might eventually be sucessfully + unifiable. For instance, a pair of different variables cannot be + unified, unless another reduction eventually substitutes one for + the other. As another example, a metavariable could be used in the + head position of a call, blocking its reduction, but a later + instanciation might turn this metavariable into a lambda, thus + yielding a redex, possibly reducing the call to a term unifiable + with the other argument. + *) +let rec unify ?checking + (e1: lexp) (e2: lexp) (ctx : DB.lexp_context) : return_type = - unify' e1 e2 ctx OL.set_empty + unify' e1 e2 ctx OL.set_empty checking and unify' (e1: lexp) (e2: lexp) (ctx : DB.lexp_context) (vs : OL.set_plexp) + (c : scope_level option) (* checking mode scope level *) : return_type = if e1 == e2 then [] else let e1' = OL.lexp_whnf e1 ctx in @@ -191,28 +212,45 @@ and unify' (e1: lexp) (e2: lexp) if changed && OL.set_member_p vs e1' e2' then [] else let vs' = if changed then OL.set_add vs e1' e2' else vs in match (lexp_lexp' e1', lexp_lexp' e2') with - | ((Imm _, Imm _) | (Cons _, Cons _) | (Builtin _, Builtin _) - | (Var _, Var _)) + (* Both expressions are in WHNF: we don't have `Let`s nor `Susp`s. *) + + (* First, we handle the simple cases with no substructure. *) + | ((Imm _ | Builtin _), (Imm _ | Builtin _)) -> if OL.conv_p ctx e1' e2' then [] else [(CKimpossible, ctx, e1, e2)] - | (_, Metavar (idx, s, _)) -> unify_metavar ctx idx s e2' e1' - | (Metavar (idx, s, _), _) -> unify_metavar ctx idx s e1' e2' - | (_, Call _) -> unify_call e2' e1' ctx vs' - (* | (l, (Case _ as r)) -> unify_case r l subst *) - | (Arrow _ , _) -> unify_arrow e1' e2' ctx vs' - | (Lambda _, _) -> unify_lambda e1' e2' ctx vs' - | (Call _, _) -> unify_call e1' e2' ctx vs' - (* | (Case _ as l, r) -> unify_case l r subst *) - (* | (Inductive _ as l, r) -> unify_induct l r subst *) - | (Sort _, _) -> unify_sort e1' e2' ctx vs' - | (SortLevel _, _) -> unify_sortlvl e1' e2' ctx vs' - | (Inductive (_loc1, label1, args1, consts1), - Inductive (_loc2, label2, args2, consts2)) - -> (* print_string ("Unifying inductives " - * ^ snd label1 - * ^ " and " - * ^ snd label2 - * ^ "\n"); *) - unify_inductive ctx vs' args1 args2 consts1 consts2 e1 e2 + + (* Then, we handle metavariables (aka. flexible-flexible and + Flexible-Rigid Equations). Reminder: WHNF implies that the + metavariables are not already instanciated. *) + | (_, Metavar (idx, s, _)) -> unify_metavar c ctx idx s e2' e1' + | (Metavar (idx, s, _), _) -> unify_metavar c ctx idx s e1' e2' + + (* Otherwise, the equation is rigid-rigid. Let's start with the + cases that can leave residuals: 1. Variables, since they could + be substituted with further reduction; 2. Calls, because they + might become redexes; 3. Case expressions, for the same + reason. *) + | (_, Var _) -> unify_var e2' e1' ctx vs' + | (Var _, _) -> unify_var e1' e2' ctx vs' + | (_, Call _) -> unify_call c e2' e1' ctx vs' + | (Call _, _) -> unify_call c e1' e2' ctx vs' + (* FIXME: Handle `Case` expressions. *) + + (* We are left with the cases that are not affected by + substitutions, thus should not immediately lead to residual + constraints. *) + | (_, Arrow _) -> unify_arrow c e2' e1' ctx vs' + | (Arrow _, _) -> unify_arrow c e1' e2' ctx vs' + | (_, Lambda _) -> unify_lambda c e2' e1' ctx vs' + | (Lambda _, _) -> unify_lambda c e1' e2' ctx vs' + | (_, Sort _) -> unify_sort c e2' e1' ctx vs' + | (Sort _, _) -> unify_sort c e1' e2' ctx vs' + | (_, SortLevel _) -> unify_sortlvl c e2' e1' ctx vs' + | (SortLevel _, _) -> unify_sortlvl c e1' e2' ctx vs' + | (_, Inductive _) -> unify_inductive c e2' e1' ctx vs' + | (Inductive _, _) -> unify_inductive c e1' e2' ctx vs' + | (_, Cons _) -> unify_cons c e2' e1' ctx vs' + | (Cons _, _) -> unify_cons c e1' e2' ctx vs' + | _ -> (if OL.conv_p ctx e1' e2' then [] else ((* print_string "Unification failure on default\n"; *) [(CKresidual, ctx, e1, e2)])) @@ -223,106 +261,96 @@ and unify' (e1: lexp) (e2: lexp) - (Arrow, Arrow) -> if var_kind = var_kind then unify ltype & lexp (Arrow (var_kind, _, ltype, lexp)) else None - - (Arrow, Var) -> Constraint - (_, _) -> None *) -and unify_arrow (arrow: lexp) (lxp: lexp) ctx vs +and unify_arrow (checking : scope_level option) (arrow: lexp) (lxp: lexp) ctx vs : return_type = match (lexp_lexp' arrow, lexp_lexp' lxp) with | (Arrow (var_kind1, v1, ltype1, _, lexp1), Arrow (var_kind2, _, ltype2, _, lexp2)) -> if var_kind1 = var_kind2 - then (unify' ltype1 ltype2 ctx vs) + then (unify' ltype1 ltype2 ctx vs checking) @(unify' lexp1 (srename v1 lexp2) (DB.lexp_ctx_cons ctx v1 Variable ltype1) - (OL.set_shift vs)) - else [(CKimpossible, ctx, arrow, lxp)] - | (Arrow _, Imm _) -> [(CKimpossible, ctx, arrow, lxp)] - | (Arrow _, Var _) -> ([(CKresidual, ctx, arrow, lxp)]) - | (Arrow _, _) -> unify' lxp arrow ctx vs + (OL.set_shift vs) checking) + else [(CKimpossible, ctx, arrow, lxp)] | (_, _) -> [(CKimpossible, ctx, arrow, lxp)] (** Unify a Lambda and a lexp if possible - - Lamda , Lambda -> if var_kind = var_kind + - Lambda , Lambda -> if var_kind = var_kind then UNIFY ltype & lxp else ERROR - - Lambda , Var -> CONSTRAINT - - Lambda , Call -> Constraint - - Lambda , Let -> Constraint - - Lambda , lexp -> unify lexp lambda subst + - Lambda , _ -> Impossible *) -and unify_lambda (lambda: lexp) (lxp: lexp) ctx vs : return_type = +and unify_lambda (checking : scope_level option) (lambda: lexp) (lxp: lexp) ctx vs : return_type = match (lexp_lexp' lambda, lexp_lexp' lxp) with | (Lambda (var_kind1, v1, ltype1, lexp1), Lambda (var_kind2, _, ltype2, lexp2)) -> if var_kind1 = var_kind2 - then (unify' ltype1 ltype2 ctx vs) + then (unify' ltype1 ltype2 ctx vs checking) @(unify' lexp1 lexp2 (DB.lexp_ctx_cons ctx v1 Variable ltype1) - (OL.set_shift vs)) + (OL.set_shift vs) checking) else [(CKimpossible, ctx, lambda, lxp)] - | ((Lambda _, Var _) - | (Lambda _, Let _) - | (Lambda _, Call _)) -> [(CKresidual, ctx, lambda, lxp)] - | (Lambda _, Arrow _) - | (Lambda _, Imm _) -> [(CKimpossible, ctx, lambda, lxp)] - | (Lambda _, _) -> unify' lxp lambda ctx vs - | (_, _) -> [(CKimpossible, ctx, lambda, lxp)] + | (_, _) -> [(CKimpossible, ctx, lambda, lxp)] (** Unify a Metavar and a lexp if possible - - lexp , {metavar <-> none} -> UNIFY - - lexp , {metavar <-> lexp} -> UNFIFY lexp subst[metavar] - - metavar , metavar -> if Metavar = Metavar then OK else ERROR - - metavar , lexp -> OK + - metavar , metavar -> if Metavar = Metavar then intersect + - metavar , metavar -> inverse subst (try both sides) + - metavar , lexp -> inverse subst *) -and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp) +and unify_metavar (checking : scope_level option) ctx idx s1 (lxp1: lexp) (lxp2: lexp) : return_type = let unif idx s lxp = - let t = match metavar_lookup idx with + let t, sl = match metavar_lookup idx with | MVal _ -> Log.internal_error "`lexp_whnf` returned an instantiated metavar!!" - | MVar (_, t, _) -> push_susp t s in + | MVar (_, t, sl) -> push_susp t s, sl in match Inverse_subst.apply_inv_subst lxp s with | exception Inverse_subst.Not_invertible - -> log_info ?loc:None ("Unification of metavar failed:\n " - ^ "?[" ^ subst_string s ^ "]" - ^ "\nAgainst:\n " - ^ lexp_string lxp ^ "\n"); + -> log_info ~loc:(lexp_location lxp) + ("Unification of metavar failed:\n " + ^ "?[" ^ subst_string s ^ "]" + ^ "\nAgainst:\n " + ^ lexp_string lxp ^ "\n"); [(CKresidual, ctx, lxp1, lxp2)] | lxp' when occurs_in idx lxp' -> [(CKimpossible, ctx, lxp1, lxp2)] | lxp' - -> metavar_table := associate idx lxp' (!metavar_table); - let type_unif_residue = - match unify t (OL.get_type ctx lxp) ctx with - | [] as r -> r - (* FIXME: Let's ignore the error for now. *) - | _ - -> log_info ?loc:None - ("Unification of metavar type failed:\n " - ^ lexp_string t ^ " != " - ^ lexp_string (OL.get_type ctx lxp) - ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n"); - [(CKresidual, ctx, lxp1, lxp2)] in - (* FIXME Here, we unify lxp1 with lxp2 again, because that - the metavariables occuring in the associated term might - have different substitutions from the corresponding - metavariables on the other side (due to subst inversion - not being a perfect inverse of subtitution application). - - For example, when unifying `?τ↑1[114]` with `(List[56] - ?ℓ↑0[117] ?a↑0[118])`, we associate the metavar ?τ[114] - with the lexp `(List[55] ?ℓ() · ↑0[117] ?a() · ↑0[118])` - (after applying the inverse substitution of ↑1), and the - lexp (?τ↑1[114]) becomes `(List[56] ?ℓ(↑1 () · ↑0)[117] - ?a(↑1 () · ↑0)[118])`, which is not exactly the same as - the right-hand side. My solution/kludge to this problem is - to do a second unification to fix the metavar - substitutions on the right-hand side, but there is - probably a cleaner way to solve this. *) - let second_unif_residue = unify lxp1 lxp2 ctx in - List.append type_unif_residue second_unif_residue in + -> match checking with + | Some l when l >= sl -> [(CKassoc, ctx, lxp1, lxp2)] + | _ -> ( + associate idx lxp'; + let type_unif_residue = + match unify t (OL.get_type ctx lxp) ctx with + | [] as r -> r + (* FIXME: Let's ignore the error for now. *) + | _ + -> log_info ?loc:None + ("Unification of metavar type failed:\n " + ^ lexp_string t ^ " != " + ^ lexp_string (OL.get_type ctx lxp) + ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n"); + [(CKresidual, ctx, lxp1, lxp2)] in + (* FIXME Here, we unify lxp1 with lxp2 again, because that + the metavariables occuring in the associated term might + have different substitutions from the corresponding + metavariables on the other side (due to subst inversion + not being a perfect inverse of subtitution application). + + For example, when unifying `?τ↑1[114]` with `(List[56] + ?ℓ↑0[117] ?a↑0[118])`, we associate the metavar ?τ[114] + with the lexp `(List[55] ?ℓ() · ↑0[117] ?a() · ↑0[118])` + (after applying the inverse substitution of ↑1), and the + lexp (?τ↑1[114]) becomes `(List[56] ?ℓ(↑1 () · ↑0)[117] + ?a(↑1 () · ↑0)[118])`, which is not exactly the same as + the right-hand side. My solution/kludge to this problem + is to do a second unification to fix the metavar + substitutions on the right-hand side, but there is + probably a cleaner way to solve this. *) + let second_unif_residue = unify lxp1 lxp2 ctx in + List.append type_unif_residue second_unif_residue) in match lexp_lexp' lxp2 with | Metavar (idx2, s2, name) - -> if idx = idx2 then + -> if idx = idx2 && checking == None then match common_subset ctx s1 s2 with | S.Identity 0 -> [] (* Optimization! *) (* ¡ s1 != s2 ! @@ -373,7 +401,7 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp) * ^ "\n =\n " * ^ subst_string (scompose s s2) * ^ "\n"); *) - metavar_table := associate idx lexp (!metavar_table); + associate idx lexp; assert (OL.conv_p ctx lxp1 lxp2); [] else @@ -384,22 +412,34 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp) | _ -> unif idx2 s2 lxp1) | _ -> unif idx s1 lxp2 +(** Unify a Var (var) and a lexp (lxp) + - Var , Var -> IF same var THEN ok ELSE constraint + - Var , lexp -> Constraint +*) +and unify_var (var: lexp) (lxp: lexp) ctx vs + : return_type = + match (lexp_lexp' var, lexp_lexp' lxp) with + | (Var _, Var _) when OL.conv_p ctx var lxp -> [] + | (_, _) -> [(CKresidual, ctx, var, lxp)] + (** Unify a Call (call) and a lexp (lxp) - Call , Call -> UNIFY - Call , lexp -> CONSTRAINT *) -and unify_call (call: lexp) (lxp: lexp) ctx vs +and unify_call (checking : scope_level option) (call: lexp) (lxp: lexp) ctx vs : return_type = match (lexp_lexp' call, lexp_lexp' lxp) with | (Call (lxp_left, lxp_list1), Call (lxp_right, lxp_list2)) when OL.conv_p ctx lxp_left lxp_right - -> List.fold_left (fun op ((ak1, e1), (ak2, e2)) + -> (try List.fold_left (fun op ((ak1, e1), (ak2, e2)) -> if ak1 == ak2 then - (unify' e1 e2 ctx vs)@op + (unify' e1 e2 ctx vs checking)@op else [(CKimpossible, ctx, call, lxp)]) [] (List.combine lxp_list1 lxp_list2) - | (_, _) -> [(CKresidual, ctx, call, lxp)] + with Invalid_argument _ (* Lists of diff. length in combine. *) + -> [(CKresidual, ctx, call, lxp)]) + | (_, _) -> [(CKresidual, ctx, call, lxp)] (** Unify a Case with a lexp - Case, Case -> try to unify @@ -458,32 +498,30 @@ and unify_call (call: lexp) (lxp: lexp) ctx vs - SortLevel, SortLevel -> if SortLevel ~= SortLevel then OK else ERROR - SortLevel, _ -> ERROR *) -and unify_sortlvl (sortlvl: lexp) (lxp: lexp) ctx vs : return_type = +and unify_sortlvl (checking : scope_level option) (sortlvl: lexp) (lxp: lexp) ctx vs : return_type = match lexp_lexp' sortlvl, lexp_lexp' lxp with | (SortLevel s, SortLevel s2) -> (match s, s2 with | SLz, SLz -> [] - | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs + | SLsucc l1, SLsucc l2 -> unify' l1 l2 ctx vs checking | SLlub (l11, l12), SLlub (l21, l22) -> (* FIXME: This SLlub representation needs to be * more "canonicalized" otherwise it's too restrictive! *) - (unify' l11 l21 ctx vs)@(unify' l12 l22 ctx vs) + (unify' l11 l21 ctx vs checking)@(unify' l12 l22 ctx vs checking) | _, _ -> [(CKimpossible, ctx, sortlvl, lxp)]) - | _, _ -> [(CKresidual, ctx, sortlvl, lxp)] + | _, _ -> [(CKimpossible, ctx, sortlvl, lxp)] (** Unify a Sort and a lexp - Sort, Sort -> if Sort ~= Sort then OK else ERROR - - Sort, Var -> Constraint - Sort, lexp -> ERROR *) -and unify_sort (sort_: lexp) (lxp: lexp) ctx vs : return_type = +and unify_sort (checking : scope_level option) (sort_: lexp) (lxp: lexp) ctx vs : return_type = match lexp_lexp' sort_, lexp_lexp' lxp with | (Sort (_, srt), Sort (_, srt2)) -> (match srt, srt2 with - | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs + | Stype lxp1, Stype lxp2 -> unify' lxp1 lxp2 ctx vs checking | StypeOmega, StypeOmega -> [] | StypeLevel, StypeLevel -> [] | _, _ -> [(CKimpossible, ctx, sort_, lxp)]) - | Sort _, Var _ -> [(CKresidual, ctx, sort_, lxp)] - | _, _ -> [(CKimpossible, ctx, sort_, lxp)] + | _, _ -> [(CKimpossible, ctx, sort_, lxp)] (************************ Helper function ************************************) @@ -533,7 +571,14 @@ and is_same arglist arglist2 = * | None -> test e subst) * ) None lst *) -and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 = +and unify_inductive (checking : scope_level option) lxp1 lxp2 ctx vs = + match lexp_lexp' lxp1, lexp_lexp' lxp2 with + | (Inductive (_loc1, label1, args1, consts1), + Inductive (_loc2, label2, args2, consts2)) + -> unify_inductive' (checking : scope_level option) ctx vs args1 args2 consts1 consts2 lxp1 lxp2 + | _, _ -> [(CKimpossible, ctx, lxp1, lxp2)] + +and unify_inductive' (checking : scope_level option) ctx vs args1 args2 consts1 consts2 e1 e2 = let unif_formals ctx vs args1 args2 = if not (List.length args1 == List.length args2) then (ctx, vs, [(CKimpossible, ctx, e1, e2)]) @@ -542,7 +587,7 @@ and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 = -> (DB.lexp_ctx_cons ctx v1 Variable t1, OL.set_shift vs, if not (ak1 == ak2) then [(CKimpossible, ctx, e1, e2)] - else (unify' t1 t2 ctx vs) @ residue)) + else (unify' t1 t2 ctx vs checking) @ residue)) (ctx, vs, []) (List.combine args1 args2) in let (ctx, vs, residue) = unif_formals ctx vs args1 args2 in @@ -578,3 +623,8 @@ and unify_inductive ctx vs args1 args2 consts1 consts2 e1 e2 = * | _, _ -> None * in test l1 l2 subst *) +and unify_cons (checking : scope_level option) lxp1 lxp2 ctx vs = + match lexp_lexp' lxp1, lexp_lexp' lxp2 with + | (Cons (it1, (_, l1)), Cons (it2, (_, l2))) when l1 = l2 + -> unify' it1 it2 ctx vs checking + | _, _ -> [(CKimpossible, ctx, lxp1, lxp2)] ===================================== tests/elab_test.ml ===================================== @@ -107,6 +107,24 @@ plus x y = Eq_refl); |} +let _ = add_elab_test_decl + "depelim macro" + {| +type Nat + | Z + | S Nat; + +Nat_induction : + (P : Nat -> Type_ ?l) ≡> + P Z -> + ((n : Nat) -> P n -> P (S n)) -> + ((n : Nat) -> P n); +Nat_induction base step n = + case n return (P n) + | Z => base + | S n' => (step n' (Nat_induction (P := P) base step n')); + |} + let _ = add_elab_test_decl "case conversion" {| ===================================== tests/eval_test.ml ===================================== @@ -445,4 +445,36 @@ nil≠l = |} "head l nil≠l" "0" +let _ = + add_test "EVAL" "int overflows" (fun () -> + let check_op op biop a b = + let a' = Z.of_int a in + let b' = Z.of_int b in + let expect' = biop a' b' in + let str = "(Int_" ^ op ^ " " ^ (string_of_int a) + ^ " " ^ (string_of_int b) ^ ")" in + let lxp = List.hd (Elab.lexp_expr_str str ectx) in + let elxp = OL.erase_type lxp in + assert (Log.error_count () == 0); + + if Z.fits_int expect' then + let actual = eval elxp rctx in + expect_equal_values [actual] [Vint (Z.to_int expect')] + else + (* The result should overflow *) + try let result = (eval elxp rctx) in + ut_string2 ("EXPECTED overflow for `" ^ str ^ "`\n"); + ut_string2 ("GOT: " ^ (value_string result) ^ "\n"); + failure + with + | Log.Internal_error _ -> Log.clear_log (); success in + let arith_ops = [("+", Z.add); ("-", Z.sub); ("*", Z.mul); ("/", Z.div)] in + let vals = [min_int; -1; 0; 1; max_int] in + let sum_for ls fn = List.fold_left (+) 0 (List.map fn ls) in + sum_for arith_ops (fun (op, biop) -> + sum_for vals (fun a -> + sum_for vals (fun b -> + if op = "/" && b = 0 then success else + check_op op biop a b)))) + let _ = run_all () ===================================== tests/unify_test.ml ===================================== @@ -21,21 +21,18 @@ * * -------------------------------------------------------------------------- *) -open Sexp -open Pexp + open Lexp open Unification -open Utest_lib - open Fmt +open Utest_lib -open Builtin -open Env - -open Str +module U = Util -open Debug +(* default environment *) +let ectx = Elab.default_ectx +let rctx = Elab.default_rctx type result = | Constraint @@ -43,10 +40,6 @@ type result = | Equivalent | Nothing -type unif_res = (result * (constraints) * lexp * lexp) - -type triplet = string * string * string - let string_of_result r = match r with | Constraint -> "Constraint" @@ -54,179 +47,98 @@ let string_of_result r = | Equivalent -> "Equivalent" | Nothing -> "Nothing" -let max_dim (lst: (string * string * string * string) list): (int * int * int *int) = - let max i l = max i (String.length l) - in List.fold_left - (fun (la, ca1, ca2, ra) (l, c1, c2, r) -> ((max la l), (max ca1 c1), (max ca2 c2), (max ra r))) - (0, 0, 0, 0) - lst - -let fmt (lst: (lexp * lexp * result * result) list): string list = - let str_lst = List.map - (fun (l1, l2, r1, r2) -> ((lexp_string l1), (lexp_string l2), (string_of_result r1), (string_of_result r2))) - lst - in let l, c1, c2, r = max_dim str_lst - in List.map (fun (l1, l2, r1, r2) -> (U.padding_right l1 l ' ') - ^ ", " - ^ (U.padding_right l2 c1 ' ') - ^ " -> got: " - ^ (U.padding_right r2 r ' ') - ^ " expected: " - ^ (U.padding_right r1 c2 ' ') - ) str_lst - -(* Inputs for the test *) -let str_induct = "Nat : Type; Nat = typecons (dNat) (zero) (succ Nat)" -let str_int_3 = "i = 3" -let str_int_4 = "i = 4" -let str_case = "i = case true -| true => 2 -| false => 42" -let str_case2 = "i = case nil(a := Int) -| nil => 12 -| _ => 24" -let str_let = "i = let a = 5 in a + 1" -let str_let2 = "j = let b = 5 in b" -let str_lambda = "sqr = lambda (x : Int) -> x * x;" -let str_lambda2 = "sqr = lambda (x : Int) -> x * x;" -let str_lambda3 = "sqr = lambda (x : Int) -> lambda (y : Int) -> x * y;" -let str_type = "i = let j = decltype(Type) in decltype(j);" -let str_type2 = "j = let i = Int -> Int in decltype(i);" - -let generate_ltype_from_str str = - List.hd ((fun (lst, _) -> - (List.map - (fun (_, _, ltype) -> ltype)) - (List.flatten lst)) - (Elab.lexp_decl_str str Elab.default_ectx)) - -let generate_lexp_from_str str = - List.hd ((fun (lst, _) -> - (List.map - (fun (_, lxp, _) -> lxp)) - (List.flatten lst)) - (Elab.lexp_decl_str str Elab.default_ectx)) - -let input_induct = generate_lexp_from_str str_induct -let input_int_4 = generate_lexp_from_str str_int_4 -let input_int_3 = generate_lexp_from_str str_int_3 -let input_case = generate_lexp_from_str str_case -let input_case2 = generate_lexp_from_str str_case2 -let input_let = generate_lexp_from_str str_let -let input_let2 = generate_lexp_from_str str_let -let input_lambda = generate_lexp_from_str str_lambda -let input_lambda2 = generate_lexp_from_str str_lambda2 -let input_lambda3 = generate_lexp_from_str str_lambda3 -let input_arrow = generate_ltype_from_str str_lambda -let input_arrow2 = generate_ltype_from_str str_lambda2 -let input_arrow3 = generate_ltype_from_str str_lambda3 -let input_type = generate_ltype_from_str str_type -let input_type_t = generate_ltype_from_str str_type2 - -let generate_testable (_: lexp list) : ((lexp * lexp * result) list) = - - ( mkLambda ((Anormal), - (Util.dummy_location, Some "L1"), - mkVar((Util.dummy_location, Some "z"), 3), - mkImm (Integer (Util.dummy_location, 3))), - mkLambda ((Anormal), - (Util.dummy_location, Some "L2"), - mkVar((Util.dummy_location, Some "z"), 4), - mkImm (Integer (Util.dummy_location, 3))), Nothing ) - - ::(input_induct , input_induct , Equivalent) (* 2 *) - ::(input_int_4 , input_int_4 , Equivalent) (* 3 *) - ::(input_int_3 , input_int_4 , Nothing) (* 4 *) - ::(input_case , input_int_4 , Constraint) (* 5 *) - ::(input_case , input_induct , Constraint) (* 6 *) - ::(input_case , input_case , Equivalent) (* 7 *) - ::(input_case , input_case2 , Nothing) (* 8 *) - - ::(input_let , input_induct , Constraint) (* 9 *) - ::(input_let , input_int_4 , Constraint) (* 10 *) - ::(input_let , input_case , Constraint) (* 11 *) - ::(input_let , input_let , Equivalent) (* 12 *) - ::(input_let2 , input_let , Equivalent) (* 13 *) - ::(input_let2 , input_let2 , Equivalent) (* 14 *) - - ::(input_lambda , input_int_4 , Nothing) (* 15 *) - ::(input_lambda , input_induct , Nothing) (* 16 *) - ::(input_lambda , input_case , Constraint) (* 17 *) - ::(input_lambda , input_case2 , Constraint) (* 18 *) - ::(input_lambda , input_let , Constraint) (* 19 *) - ::(input_lambda , input_induct , Nothing) (* 20 *) - ::(input_lambda , input_lambda , Equivalent) (* 21 *) - - ::(input_lambda2 , input_int_4 , Nothing) (* 22 *) - ::(input_lambda2 , input_induct , Nothing) (* 23 *) - ::(input_lambda2 , input_case , Constraint) (* 24 *) - ::(input_lambda2 , input_case2 , Constraint) (* 25 *) - ::(input_lambda2 , input_let , Constraint) (* 26 *) - ::(input_lambda2 , input_induct , Nothing) (* 27 *) - ::(input_lambda2 , input_lambda , Equivalent) (* 28 *) - ::(input_lambda2 , input_lambda2 , Equivalent) (* 29 *) - ::(input_lambda2 , input_lambda3 , Constraint) (* 30 *) - ::(input_lambda3 , input_lambda3 , Equivalent) (* 31 *) - - ::(input_arrow2 , input_int_4 , Unification) (* 32 *) - ::(input_arrow2 , input_induct , Unification) (* 33 *) - ::(input_arrow2 , input_case , Constraint) (* 34 *) - ::(input_arrow2 , input_case2 , Constraint) (* 35 *) - ::(input_arrow2 , input_let , Constraint) (* 36 *) - ::(input_arrow2 , input_induct , Unification) (* 37 *) - ::(input_arrow2 , input_lambda , Unification) (* 38 *) - ::(input_arrow2 , input_lambda2 , Unification) (* 39 *) - ::(input_arrow2 , input_arrow3 , Unification) (* 40 *) - ::(input_arrow3 , input_arrow , Unification) (* 41 *) - ::(input_arrow2 , input_arrow , Unification) (* 42 *) - ::(input_arrow3 , input_arrow3 , Equivalent) (* 43 *) - - ::(input_type , input_type_t , Equivalent) (* 44 *) - - ::(mkMetavar (0, S.identity, (Util.dummy_location, Some "M")), - mkVar ((Util.dummy_location, Some "x"), 3), Unification) (* 45 *) - - ::[] - -let test_input (lxp1: lexp) (lxp2: lexp): unif_res = +let unif_output (lxp1: lexp) (lxp2: lexp) ctx = let orig_subst = !metavar_table in - let res = unify lxp1 lxp2 Myers.nil in - match res with + let constraints = unify lxp1 lxp2 ctx in + match constraints with | [] -> let new_subst = !metavar_table in if orig_subst == new_subst - then (Equivalent, res, lxp1, lxp2) - else (Unification, res, lxp1, lxp2) - | (CKresidual, _, _, _)::_ -> (Constraint, res, lxp1, lxp2) - | (CKimpossible, _, _, _)::_ -> (Nothing, res, lxp1, lxp2) - -let check (lxp1: lexp) (lxp2: lexp) (res: result): bool = - let r, _, _, _ = test_input lxp1 lxp2 - in if r = res then true else false - -let test_if (input: lexp list) sample_generator checker : bool = - let rec test_if_ samples checker = - match samples with - | (l1, l2, res)::t -> if checker l1 l2 res then test_if_ t checker else false - | [] -> true - in test_if_ (sample_generator input) checker - -let unifications = List.map - (fun (l1, l2, res) -> - let r, _, _, _ = test_input l1 l2 - in (l1, l2, res, r)) - (* FIXME: Skip failure for now. *) - [] (* (generate_testable []) *) - -let idx = ref 0 -let _ = List.map - (fun (str, (l1, l2, expected, res)) -> - idx := !idx + 1; - add_test "UNIFICATION" - ((if !idx < 10 then "0" else "") ^ (string_of_int !idx) ^ " " ^ str ) - (fun () -> if expected = res then success else failure)) - (List.combine (fmt unifications) unifications ) + then (Equivalent, constraints) + else (Unification, constraints) + | (CKresidual, _, _, _)::_ -> (Constraint, constraints) + | (CKimpossible, _, _, _)::_ -> (Nothing, constraints) + | _ -> failwith "impossible" + +let add_unif_test name ?(ectx=ectx) lxp_a lxp_b expected = + add_test "UNIFICATION" name (fun () -> + let (r, cstrts) = unif_output lxp_a lxp_b (DB.ectx_to_lctx ectx) in + + if r = expected then + success + else ( + ut_string2 (red ^ "EXPECTED: " ^ reset ^ (string_of_result expected) ^ "\n"); + ut_string2 (red ^ "GOT: " ^ reset ^ (string_of_result r ) ^ "\n"); + ut_string2 ("During the unification of:\n\t" ^ (lexp_string lxp_a) + ^ "\nand\n\t" ^ (lexp_string lxp_b) ^ "\n"); + failure + )) + +let add_unif_test_s name ?(setup="") ?(ectx=ectx) input_a input_b expected = + let _, ectx = Elab.lexp_decl_str setup ectx in + + let lxp_a = List.hd (Elab.lexp_expr_str input_a ectx) in + let lxp_b = List.hd (Elab.lexp_expr_str input_b ectx) in + + add_unif_test name ~ectx lxp_a lxp_b expected + +let _ = + (* Let's have some variables in context to block the reduction of + elimination forms. The variables are manually added to the + context (and not given a value) to make sure that they cannot be + reduced. *) + let _, ectx = Elab.lexp_decl_str + {| type Nat + | Z + | S (Nat); |} ectx in + let dloc = U.dummy_location in + let nat = mkVar ((dloc, Some "Nat"), 2) in + let shift l i = mkSusp l (S.shift i) in + let ectx, _ = + List.fold_left + (fun (ectx, i) (name, lexp) -> + Elab.ctx_extend ectx (dloc, Some name) Variable (shift lexp i), i + 1) + (ectx, 0) + [("f", (mkArrow (Anormal, (dloc, None), nat, dloc, shift nat 1))); + ("g", (mkArrow (Anormal, (dloc, None), nat, dloc, shift nat 1))); + ("h", (mkArrow (Anormal, (dloc, Some "x"), nat, dloc, + mkArrow (Anormal, (dloc, Some "y"), shift nat 1, + dloc, shift nat 2)))); + ("a", nat); + ("b", nat)] in + + add_unif_test_s "same integer" "4" "4" Equivalent; + add_unif_test_s "diff. integers" "3" "4" Nothing; + add_unif_test_s "int and builtin" "3" "##Int" Nothing; + add_unif_test_s "same var" ~ectx "a" "a" Equivalent; + add_unif_test_s "diff. var" ~ectx "a" "b" Constraint; + add_unif_test_s "var and integer" ~ectx "a" "1" Constraint; + add_unif_test_s "same call" ~ectx "f a" "f a" Equivalent; + add_unif_test_s "calls with inconvertible heads" ~ectx "f a" "g a" Constraint; + add_unif_test_s "calls with diff. num. of args" ~ectx "h a" "h a b" Constraint; + add_unif_test_s "calls with residue in args" ~ectx "f a" "f b" Constraint; + add_unif_test_s "same case" ~ectx + "case a | Z => false | S n => true" + "case a | Z => false | S n => true" + Equivalent; + add_unif_test_s "diff. case" ~ectx + "case a | Z => false | S n => true" + "case a | Z => true | S n => false" + (* 'Nothing' would be a more accurate result here. This would + require implementing unification for case exprs. *) + Constraint; + + add_unif_test_s "datacons/inductive" ~ectx + "Z" + "(datacons (typecons Nat Z (S Nat)) Z)" + (* Not recursive! Refers to the previous def of Nat. *) + Equivalent; + + (* Metavariables *) + add_unif_test_s "same metavar" "?m" "?m" Equivalent; + add_unif_test_s "diff. metavar" "?m1" "?m2" Unification; + add_unif_test_s "metavar and int" "?m" "5" Unification; + + () let _ = run_all () - - View it on GitLab: https://gitlab.com/monnier/typer/-/compare/5b458959d3c5209c907ab368f96d82ca… -- View it on GitLab: https://gitlab.com/monnier/typer/-/compare/5b458959d3c5209c907ab368f96d82ca… You're receiving this email because of your account on gitlab.com.

1 0

[Git][monnier/typer][ja-barszcz] 47 commits: Add hash in Lexp's type (hash-consing).
by Jean-Alexandre Barszcz 24 Sep '20

24 Sep '20

Jean-Alexandre Barszcz pushed to branch ja-barszcz at Stefan / Typer Commits: 28d16874 by irradiee at 2020-08-14T05:59:20-04:00 Add hash in Lexp's type (hash-consing). Lexp: type lexp is now a pair int * lexp' (interchangeable), profiling: add compilation with ocamlc & ocamlopt, collisions: add %cl command to get stats of hash-consing, Lexp tests: add tests and getters for some Lexp - - - - - 68f25184 by irradiee at 2020-08-24T13:11:01-04:00 Add hash in Lexp's type (hash-consing). Lexp: type lexp is now a pair int * lexp' (interchangeable), profiling: add compilation with ocamlc & ocamlopt, collisions: add %cl command to get stats of hash-consing, Lexp tests: add tests and getters for some Lexp - - - - - 588b6327 by Jean-Alexandre Barszcz at 2020-09-04T23:06:53-04:00 Fix `lexp_whnf` for Case A substitution built with `cons`es happens all at once, in the sense that the terms in such a list are substituted independently, and thus should not be shifted one relative to another. This commit removes such a shift that was made by mistake in the computation of the WHNF of a `Case` redex. The shift caused debruijn indexing errors in the body of branches with multiple fields. Additionnally, this commit removes the arguments to the inductive type from the substitution applied to the branch, since they are not bound by the case. - - - - - 115d8b01 by Simon Génier at 2020-09-09T12:06:50-04:00 Make eval tests throw on a compilation failure. - - - - - e8257259 by Simon Génier at 2020-09-09T12:06:59-04:00 Remove commented eval test. - - - - - 940ade63 by Simon Génier at 2020-09-09T12:06:59-04:00 Do not print callstack of test handler. This line always print the same callstack, that of the handler, which gives no information about why the test failed. - - - - - 53c514f5 by Simon Génier at 2020-09-09T12:06:59-04:00 Actually record the backtrace of exceptions while testing. - - - - - e0d4964e by Simon Génier at 2020-09-09T12:06:59-04:00 Print compiler log on a compilation error in tests. - - - - - e290b701 by Simon Génier at 2020-09-09T12:06:59-04:00 Fix implicit arguments test. - - - - - 5f740bf1 by Simon Génier at 2020-09-09T12:06:59-04:00 Fix case test with generic types. - - - - - b6466a2b by Simon Génier at 2020-09-09T12:07:23-04:00 Fix the rest of the eval tests. - - - - - 2041b4dd by Simon Génier at 2020-09-09T12:07:34-04:00 Remove = at the end of the flags to the test driver. I think the intention was to have GNU style flags like --verbose=3, but that does not even work. - - - - - 56e4fbed by Simon Génier at 2020-09-09T13:24:41-04:00 Easier elaboration tests. I extracted these changes from another branch since I will need them for yet another. Ther should make elaboration tests easier to write. * New assertions reduce the amount of code to check the results. * Correctly restore state to be able to compare metavariables in two different code fragments. - - - - - 9d41029c by Simon Génier at 2020-09-09T13:24:48-04:00 Rework add_test to avoid warnings. - - - - - 10c27014 by Simon Génier at 2020-09-09T13:24:48-04:00 Make success and failure values. - - - - - 18f49df0 by Simon Génier at 2020-09-09T13:31:55-04:00 Make expected an optional argument in elaboration tests. - - - - - b7eb8f08 by Simon Génier at 2020-09-09T14:08:48-04:00 Fix safe head test. - - - - - a8e2af1a by Simon Génier at 2020-09-10T09:38:07-04:00 Oops: add back running tests in the order they were inserted. - - - - - a4540d14 by Simon Génier at 2020-09-10T15:47:53-04:00 Merge changes to elaboration and evaluation tests. - - - - - 4eac6264 by Simon Génier at 2020-09-10T16:05:31-04:00 Get rid of warning by using String.uppercase_ascii. This function is available since 4.03, and 4.05 is now on Debian stable so it is safe to use. - - - - - a5a05e7b by Simon Génier at 2020-09-11T17:22:08-04:00 Merge branch 'string-uppercase' into master. - - - - - c34d6d0c by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Fix an issue in the unification of metavariables The issue was that unification was not idempotent in certain cases. In particular, when unifying a metavar that has a non-identity substitution (let's say lxp1) with a term (let's say lxp2) that refers to some metavariables, the corresponding metavariable references in the associated term (thus in lxp1 after association) could have different substitutions from the same references in lxp2. See the added comment for a more detailed example. - - - - - 023ea461 by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Move the Eq builtin to debruijn.ml to make it available for elab. - - - - - b4d53239 by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Make Eq.refl available to the ocaml code * src/debruijn.ml : Add a definition of the lexp for Eq.refl * src/builtin.ml : Register the constant Eq.refl * btl/builtins.typer (Eq_refl) : Use the builtin variable ##Eq.refl instead of registering the builtin with the `Built-in` form. This ensures that we have the right variable and type, and might help to keep things in sync between the ocaml and typer code. - - - - - efe2032d by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Make the case elaboration code more consistent This commit doesn't substantially change the behavior of the case elaboration, but makes the code a bit more consistent and might save some unnecessary metavariables in some cases. - - - - - 4c632a1f by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Add dependent elimination This commit changes elaboration, conversion, typechecking, erasure, and the computation of free variables and WHNFs for case expressions, to account for the fact that the context of all the branches of case expressions is extended with a proof of equality between the branch's head and the case's target. Careful elimination of this equality proof with Eq_cast makes dependent elimination possible. - - - - - b082a329 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Conversion for metavariables - - - - - fd990da1 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Case conversion - - - - - eb1741eb by Simon Génier at 2020-09-16T09:21:42-04:00 Update the requirements for building typer. * Add tools and libraries. * Bump OCaml version to the latest one on Debian stable. - - - - - bcb53b2c by Simon Génier at 2020-09-16T09:21:42-04:00 Use Map.S.find_opt. - - - - - b36d30ac by Simon Génier at 2020-09-16T09:21:42-04:00 Oops: fix broken tests on OCaml 4.05.0. - - - - - 1fb4ed6c by Simon Génier at 2020-09-16T09:23:33-04:00 Merge branch 'update-requirements' into HEAD - - - - - 371c37d4 by Jean-Alexandre Barszcz at 2020-09-19T23:59:22-04:00 Big ints in sexps and for int literals * Change the sexp datatype to have Zarith big integers instead of plain Ocaml `int`s. * Change the type of integer literals to `Integer` instead of `Int`. * Add the `Integer->Int` builtin. * Add overflow checking to the `Int` builtin operators. - - - - - 12076610 by Jean-Alexandre Barszcz at 2020-09-20T00:01:57-04:00 Improve quoting - - - - - 695d98c7 by Jean-Alexandre Barszcz at 2020-09-20T00:01:57-04:00 Add a macro for dependent elimination - - - - - e4da0173 by Jean-Alexandre Barszcz at 2020-09-24T14:39:40-04:00 Clarify unification * Clarify the order of the handlers for different cases of unification. * Enable and rewrite unification tests. - - - - - b5106636 by Jean-Alexandre Barszcz at 2020-09-24T14:39:40-04:00 Unify instead of conv_p in sform_lambda - - - - - 04ad364a by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 [WIP] experiments with Decidable and proofs - - - - - 596ec34c by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 [WIP] First draft of an instance search algorithm - - - - - 34b2175f by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 [WIP] Add a syntax for records - - - - - c23a9b2f by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 [WIP] Extend the Decidable sample with conjunction (dep on records) - - - - - f3b767f9 by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 Resolve instances in the REPL (since exprs. are not generalized) - - - - - b34687eb by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 Resolve instances for recursive definitions - - - - - 2064b112 by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 [WIP] Do the set_getenv IIRC these were missing to correctly handle the elab context for macro expansion and Elab_... primitives. Perhaps it would be simpler to call set_getenv once before macro expansion rather than everywhere where the context can change. Needs some experimentation and tests. - - - - - d6991cfe by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 Num class example - - - - - 2900fa72 by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 Num class (with records) - - - - - 5b458959 by Jean-Alexandre Barszcz at 2020-09-24T14:40:17-04:00 Algebra classes sample with proofs for the additive monoid for Nats - - - - - 30 changed files: - GNUmakefile - README.md - btl/builtins.typer - btl/case.typer - + btl/depelim.typer - btl/do.typer - btl/list.typer - btl/pervasive.typer - btl/plain-let.typer - btl/polyfun.typer - + btl/records.typer - btl/tuple.typer - + samples/alg_classes.typer - + samples/decidable.typer - + samples/num_class.typer - + samples/num_class_recs.typer - src/REPL.ml - src/builtin.ml - src/debruijn.ml - src/debug.ml - src/elab.ml - src/eval.ml - + src/float.ml - + src/instances.ml - + src/int.ml - src/inverse_subst.ml - src/lexer.ml - src/lexp.ml - src/log.ml - src/myers.ml The diff was not included because it is too large. View it on GitLab: https://gitlab.com/monnier/typer/-/compare/7619fb6c2e74f82e3d688e402e55174e… -- View it on GitLab: https://gitlab.com/monnier/typer/-/compare/7619fb6c2e74f82e3d688e402e55174e… You're receiving this email because of your account on gitlab.com.

1 0

[Git][monnier/typer][depelim] 7 commits: Update the requirements for building typer.
by Jean-Alexandre Barszcz 20 Sep '20

20 Sep '20

Jean-Alexandre Barszcz pushed to branch depelim at Stefan / Typer Commits: eb1741eb by Simon Génier at 2020-09-16T09:21:42-04:00 Update the requirements for building typer. * Add tools and libraries. * Bump OCaml version to the latest one on Debian stable. - - - - - bcb53b2c by Simon Génier at 2020-09-16T09:21:42-04:00 Use Map.S.find_opt. - - - - - b36d30ac by Simon Génier at 2020-09-16T09:21:42-04:00 Oops: fix broken tests on OCaml 4.05.0. - - - - - 1fb4ed6c by Simon Génier at 2020-09-16T09:23:33-04:00 Merge branch 'update-requirements' into HEAD - - - - - 371c37d4 by Jean-Alexandre Barszcz at 2020-09-19T23:59:22-04:00 Big ints in sexps and for int literals * Change the sexp datatype to have Zarith big integers instead of plain Ocaml `int`s. * Change the type of integer literals to `Integer` instead of `Int`. * Add the `Integer->Int` builtin. * Add overflow checking to the `Int` builtin operators. - - - - - 12076610 by Jean-Alexandre Barszcz at 2020-09-20T00:01:57-04:00 Improve quoting - - - - - 695d98c7 by Jean-Alexandre Barszcz at 2020-09-20T00:01:57-04:00 Add a macro for dependent elimination - - - - - 26 changed files: - README.md - btl/builtins.typer - btl/case.typer - + btl/depelim.typer - btl/do.typer - btl/list.typer - btl/pervasive.typer - btl/plain-let.typer - btl/polyfun.typer - btl/tuple.typer - src/debug.ml - src/elab.ml - src/eval.ml - + src/float.ml - + src/int.ml - src/lexer.ml - src/lexp.ml - src/opslexp.ml - + src/option.ml - src/sexp.ml - src/util.ml - tests/elab_test.ml - tests/eval_test.ml - tests/macro_test.ml - tests/unify_test.ml - tests/utest_lib.ml Changes: ===================================== README.md ===================================== @@ -8,7 +8,11 @@ Status [![Build Status](https://travis-ci.org/Delaunay/typer.svg?branch=master)] ## Requirement -* Ocaml 4.01 +* Ocaml 4.05 +* Ocamlfind +* Ocamlbuild +* Findlib +* Zarith ## Build @@ -29,4 +33,3 @@ By default ocamlbuild creates a '_build' folder which holds all the compiled fil # Emacs files /typer-mode.el - ===================================== btl/builtins.typer ===================================== @@ -108,11 +108,6 @@ Int_- = Built-in "Int.-" : Int -> Int -> Int; Int_* = Built-in "Int.*" : Int -> Int -> Int; Int_/ = Built-in "Int./" : Int -> Int -> Int; -_+_ = Int_+; -_-_ = Int_-; -_*_ = Int_*; -_/_ = Int_/; - %% modulo Int_mod = Built-in "Int.mod" : Int -> Int -> Int; @@ -133,7 +128,15 @@ Int_>= = Built-in "Int.>=" : Int -> Int -> Bool; %% bitwise negation Int_not = Built-in "Int.not" : Int -> Int; +%% `Int` and `Integer` are conceptually isomorphic in that they both +%% represent unbounded integers, but in reality, both are bounded. +%% `Int` is implemented with `int` type in ocaml (31 or 63 bits), and +%% `Integer` is implemented with big integers (ultimately limited by +%% available memory). Both cause runtime errors at their limits, so no +%% overflows are allowed. Here are the functions that witness the +%% isomorphism: Int->Integer = Built-in "Int->Integer" : Int -> Integer; +Integer->Int = Built-in "Integer->Int" : Integer -> Int; Int->String = Built-in "Int->String" : Int -> String; @@ -142,6 +145,11 @@ Integer_- = Built-in "Integer.-" : Integer -> Integer -> Integer; Integer_* = Built-in "Integer.*" : Integer -> Integer -> Integer; Integer_/ = Built-in "Integer./" : Integer -> Integer -> Integer; +_+_ = Integer_+; +_-_ = Integer_-; +_*_ = Integer_*; +_/_ = Integer_/; + Integer_< = Built-in "Integer.<" : Integer -> Integer -> Bool; Integer_> = Built-in "Integer.>" : Integer -> Integer -> Bool; Integer_eq = Built-in "Integer.=" : Integer -> Integer -> Bool; ===================================== btl/case.typer ===================================== @@ -156,7 +156,7 @@ get-branches vars sexps = let to-case sexp = let tup-exprs : Sexp -> List Sexp; - tup-exprs sexp = if (Int_eq (List_length vars) 1) then + tup-exprs sexp = if (Int_eq (List_length vars) (Integer->Int 1)) then (cons (expand-tuple-ctor sexp) nil) else (List_map expand-tuple-ctor (get-tup-exprs sexp)); @@ -165,7 +165,7 @@ get-branches vars sexps = let (lambda s ss -> case (Sexp_eq (Sexp_symbol "_=>_") s) %% expecting a Sexp_node as second argument to _=>_ - | true => pair (tup-exprs (List_nth 0 ss Pat_error)) (List_nth 1 ss Code_error) + | true => pair (tup-exprs (List_nth (Integer->Int 0) ss Pat_error)) (List_nth (Integer->Int 1) ss Code_error) | false => pair (cons Pat_error nil) Code_error) perr perr perr perr perr; @@ -232,10 +232,11 @@ kinds pat = let mf : Elab_Context -> Sexp -> Int -> Bool; mf env arg i = Sexp_dispatch arg (lambda s ss -> if (Sexp_eq s (Sexp_symbol "_:=_")) then - ( if (Sexp_eq (List_nth 0 ss Sexp_error) dflt-var) then + ( if (Sexp_eq (List_nth (Integer->Int 0) ss Sexp_error) dflt-var) then (Elab_is-nth-erasable ctor i env) else - (Elab_is-arg-erasable ctor (str_of_sym (List_nth 0 ss Sexp_error)) env) ) + (Elab_is-arg-erasable ctor + (str_of_sym (List_nth (Integer->Int 0) ss Sexp_error)) env) ) else (false)) (lambda _ -> false) @@ -313,7 +314,7 @@ renamed-pat pat names = let %% I expect it to not compile... (Sexp_node sym ss) else - (Sexp_node sym (cons (List_nth 0 ss Sexp_error) (cons (List_nth i names Sexp_error) nil))) + (Sexp_node sym (cons (List_nth (Integer->Int 0) ss Sexp_error) (cons (List_nth i names Sexp_error) nil))) else if tup then %% tuples argument are all implicit so we must take special care of those (Sexp_node (Sexp_symbol "_:=_") @@ -407,7 +408,7 @@ introduced-vars pat = let %% %% error used in Sexp_dispatch %% - serr = lambda _ -> IO_return (pair 0 nil); + serr = lambda _ -> IO_return (pair (Integer->Int 0) nil); %% %% List of kind of pattern argument @@ -440,11 +441,12 @@ introduced-vars pat = let ks <- ks; if (Sexp_eq s (Sexp_symbol "_:=_")) then if (List_nth i ks false) then - (IO_return (pair (i + 1) (List_concat o (cons dflt-var nil)))) + (IO_return (pair (Int_+ i (Integer->Int 1)) (List_concat o (cons dflt-var nil)))) else - (IO_return (pair (i + 1) (List_concat o (cons (List_nth 1 ss Var_error) nil)))) + (IO_return (pair (Int_+ i (Integer->Int 1)) + (List_concat o (cons (List_nth (Integer->Int 1) ss Var_error) nil)))) else - (IO_return (pair (i + 1) (List_concat o (cons dflt-var nil)))); + (IO_return (pair (Int_+ i (Integer->Int 1)) (List_concat o (cons dflt-var nil)))); }) (lambda s -> do { o <- o; % bind @@ -452,15 +454,15 @@ introduced-vars pat = let sym <- IO_return (Sexp_symbol s); b <- is-pat sym; if (b) then - (IO_return (pair (i + 1) (List_concat o (cons dflt-var nil)))) + (IO_return (pair (Int_+ i (Integer->Int 1)) (List_concat o (cons dflt-var nil)))) else - (IO_return (pair (i + 1) (List_concat o (cons sym nil)))); + (IO_return (pair (Int_+ i (Integer->Int 1)) (List_concat o (cons sym nil)))); }) serr serr serr serr; in Sexp_dispatch pat (lambda _ ss -> do { - p <- (List_foldl ff (IO_return (pair 0 nil)) ss); + p <- (List_foldl ff (IO_return (pair (Integer->Int 0) nil)) ss); IO_return (case p | pair _ xs => xs); }) @@ -492,7 +494,7 @@ head-pats ps = let %% mf : Pair Pats Code -> Pat; mf p = case p - | pair pats _ => (List_nth 0 pats Pat_error); + | pair pats _ => (List_nth (Integer->Int 0) pats Pat_error); in List_map mf ps; @@ -681,7 +683,7 @@ partition-branches branches = let (List_concat tt (cons tail nil))) (ff parts p)) % This line sometimes produce too many patterns else - (if (similar? pat (List_nth 0 ps Pat_error)) then + (if (similar? pat (List_nth (Integer->Int 0) ps Pat_error)) then (case part | pair pp tt => cons (pair (List_concat pp (cons pat nil)) (List_concat tt (cons tail nil))) @@ -711,7 +713,7 @@ partition-branches branches = let mf : pre-part-type -> IO part-type; mf p = case p | pair pp tt => do { - pat <- IO_return (List_nth 0 pp Pat_error); + pat <- IO_return (List_nth (Integer->Int 0) pp Pat_error); ivars <- introduced-vars pat; rvars <- gen-vars ivars; rpat <- renamed-pat pat rvars; @@ -819,20 +821,20 @@ adjust-len branches = let else (n); - in List_foldl ff 0 branches; + in List_foldl ff (Integer->Int 0) branches; preppend-dflt : Int -> Pair Pats Code -> Pair Pats Code; preppend-dflt n branch = let sup : Int -> Pats; sup n = - if (Int_eq n 0) then + if (Int_eq n (Integer->Int 0)) then (nil) else - (cons dflt-var (sup (n - 1))); + (cons dflt-var (sup (Int_- n (Integer->Int 1)))); in case branch | pair pats code => - pair (List_concat (sup (n - (List_length pats))) pats) code; + pair (List_concat (sup (Int_- n (List_length pats))) pats) code; in List_map (preppend-dflt max-len) branches; @@ -852,7 +854,7 @@ in List_map (preppend-dflt max-len) branches; compile-case : List Var -> List (Pair Pats Code) -> IO Code; compile-case subjects branches = let - subject = (List_nth 0 subjects Var_error); + subject = (List_nth (Integer->Int 0) subjects Var_error); %% %% Get partition of branches @@ -1025,7 +1027,7 @@ case-impl args = let %% Expecting only one Sexp_node containing a case with arguments -in (Sexp_dispatch (List_nth 0 args Sexp_error) +in (Sexp_dispatch (List_nth (Integer->Int 0) args Sexp_error) case1 err err err err err); case-macro = macro case-impl; ===================================== btl/depelim.typer ===================================== @@ -0,0 +1,111 @@ +%%% depelim --- A macro for dependent elimination + +%% Copyright (C) 2020 Free Software Foundation, Inc. +%% +%% Author: Jean-Alexandre Barszcz <jean-alexandre.barszcz(a)umontreal.ca> +%% Keywords: languages, lisp, dependent types. +%% +%% This file is part of Typer. +%% +%% Typer is free software; you can redistribute it and/or modify it under the +%% terms of the GNU General Public License as published by the Free Software +%% Foundation, either version 3 of the License, or (at your option) any +%% later version. +%% +%% Typer is distributed in the hope that it will be useful, but WITHOUT ANY +%% WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +%% FOR A PARTICULAR PURPOSE. See the GNU General Public License for +%% more details. +%% +%% You should have received a copy of the GNU General Public License along +%% with this program. If not, see <http://www.gnu.org/licenses/>. + +%%% Description + +%% In Typer, the branch bodies of a `case` expression must all have +%% the same type. In order to write proofs that depend the +%% constructor, Typer adds a proof in the environment of each branch: +%% the equality between the branch's head and the case target. This +%% equality can be eliminated in each branch using `Eq_cast` to go +%% from a branch-dependent type to a target-dependent type. The +%% following macro eases this process by eliminating the boilerplate. + +%% The macro extends the builtin `case` syntax to +%% `case_as_return_`. The `as` and `return` clauses are used to build +%% Eq_cast's `f` argument (a lambda). The `as` clause should contain a +%% symbol (the variable binding the case target or branch head), and +%% is optional if the target is itself a symbol. The `return` clause +%% is `f`'s body, i.e. the return type of the case, using the variable +%% from the `as` clause to refer to the target or branch head. + +%%% Example usage + +%% type Nat +%% | Z +%% | S Nat; +%% +%% Nat_induction : +%% (P : Nat -> Type_ ?l) ≡> +%% P Z -> +%% ((n : Nat) -> P n -> P (S n)) -> +%% ((n : Nat) -> P n); +%% Nat_induction base step n = +%% case n return (P n) %% <-- `as` clause omitted: the target is a var.. +%% | Z => base +%% | S n' => (step n' (Nat_induction (P := P) base step n')); + +%%% Grammar + +%% This macro was written for the following operators (the precedence +%% level 42 is chosen to match that of the builtin case): +%% +%% define-operator "as" 42 42; +%% define-operator "return" 42 42; + +case_as_return_impl args = + let impl target_sexp var_sexp ret_and_branches_sexp = + case Sexp_wrap ret_and_branches_sexp + | node hd (cons ret_sexp branches) => + %% TODO Check that var_sexp is a variable. + %% TODO Check that hd is the symbol `_|_`. + let + on_branch branch_sexp = + case Sexp_wrap branch_sexp + | node arrow_sexp (cons head_sexp (cons body_sexp nil)) => + %% TODO Check that arrow_sexp is `=>`. + Sexp_node + arrow_sexp + (cons head_sexp + (cons (quote (##Eq\.cast + (x := uquote head_sexp) + (y := uquote target_sexp) + (p := ##DeBruijn 0) + (f := lambda (uquote var_sexp) -> + uquote ret_sexp) + (uquote body_sexp))) + nil)) + | _ => Sexp_error; %% FIXME improve error reporting + new_branches = List_map on_branch branches; + in %% We extend the builtin case, so nested patterns don't work + quote (##case_ + (uquote (Sexp_node (Sexp_symbol "_|_") + (cons target_sexp new_branches)))) + | _ => Sexp_error; + in IO_return + case args + | cons target_sexp + (cons var_sexp + (cons ret_and_branches_sexp nil)) + => impl target_sexp var_sexp ret_and_branches_sexp + | cons target_sexp + (cons ret_and_branches_sexp nil) + => %% If the `as` clause is omitted, and the target is a + %% symbol, use it for `var_sexp` as well. + (case Sexp_wrap target_sexp + | symbol _ => impl target_sexp target_sexp ret_and_branches_sexp + | _ => Sexp_error) + | _ => Sexp_error; + +case_as_return_ = macro case_as_return_impl; +case_return_ = macro case_as_return_impl; + ===================================== btl/do.typer ===================================== @@ -33,7 +33,7 @@ get-sym sexp = let in Sexp_dispatch sexp (lambda s ss -> if (Sexp_eq s assign) then - (List_nth 0 ss Sexp_error) + (List_nth (Integer->Int 0) ss Sexp_error) else (dflt-sym ())) dflt-sym dflt-sym dflt-sym @@ -57,7 +57,7 @@ get-op sexp = let helper = (lambda sexp -> Sexp_dispatch sexp ( lambda s ss -> if (Sexp_eq s assign) then - (Sexp_node (List_nth 1 ss Sexp_error) (List_tail (List_tail ss))) + (Sexp_node (List_nth (Integer->Int 1) ss Sexp_error) (List_tail (List_tail ss))) else (Sexp_node s ss) ) @@ -80,7 +80,7 @@ get-decl ctx args = let %% Expecting a Block of command separated by ";" - node = Sexp_dispatch (List_nth 0 args Sexp_error) + node = Sexp_dispatch (List_nth (Integer->Int 0) args Sexp_error) (K err) err err err err ===================================== btl/list.typer ===================================== @@ -28,15 +28,15 @@ %% helper : (a : Type) ≡> Int -> List a -> Int; %% helper len xs = case xs %% | nil => len -%% | cons hd tl => helper (len + 1) tl; -%% in helper 0 xs; +%% | cons hd tl => helper (Int_+ len (Integer->Int 1)) tl; +%% in helper (Integer->Int 0) xs; %% %% length : (a : Type) ≡> List a -> Int; length xs = case xs - | nil => 0 + | nil => (Integer->Int 0) | cons hd tl => - (1 + (length tl)); + (Int_+ (Integer->Int 1) (length tl)); %% %% ML's typical `head` function is not total, so can't be defined @@ -88,8 +88,8 @@ mapi = lambda f -> lambda xs -> let helper : (a -> Int -> b) -> Int -> List a -> List b; helper = lambda f -> lambda i -> lambda xs -> case xs | nil => nil - | cons x xs => cons (f x i) (helper f (i + 1) xs); -in helper f 0 xs; + | cons x xs => cons (f x i) (helper f (Int_+ i (Integer->Int 1)) xs); +in helper f (Integer->Int 0) xs; %% %% As `map` but with 2 list at the same time @@ -110,8 +110,8 @@ foldli = lambda f -> lambda o -> lambda xs -> let helper : (a -> b -> Int -> a) -> Int -> a -> List b -> a; helper = lambda f -> lambda i -> lambda o -> lambda xs -> case xs | nil => o - | cons x xs => helper f (i + 1) (f o x i) xs; -in helper f 0 o xs; + | cons x xs => helper f (Int_+ i (Integer->Int 1)) (f o x i) xs; +in helper f (Integer->Int 0) o xs; %% %% Fold 2 List as long as both List are non-empty @@ -148,9 +148,9 @@ nth : (a : Type) ≡> Int -> List a -> a -> a; nth = lambda n -> lambda xs -> lambda d -> case xs | nil => d | cons x xs - => case Int_<= n 0 + => case Int_<= n (Integer->Int 0) | true => x - | false => nth (n - 1) xs d; + | false => nth (Int_- n (Integer->Int 1)) xs d; %% %% Reverse the element of a list @@ -223,7 +223,7 @@ in map mf xs; empty? : (a : Type) ≡> List a -> Bool; %% %% O(N): -%% empty? = lambda xs -> Int_eq (length xs) 0; +%% empty? = lambda xs -> Int_eq (length xs) (Integer->Int 0); %% %% O(1): empty? = lambda xs -> case xs ===================================== btl/pervasive.typer ===================================== @@ -40,9 +40,9 @@ none = datacons Option none; List_length : List ?a -> Int; % Recursive defs aren't generalized :-( List_length xs = case xs - | nil => 0 + | nil => (Integer->Int 0) | cons hd tl => - (1 + (List_length tl)); + (Int_+ (Integer->Int 1) (List_length tl)); %% ML's typical `head` function is not total, so can't be defined %% as-is in Typer. There are several workarounds: @@ -80,9 +80,9 @@ List_nth : Int -> List ?a -> ?a -> ?a; List_nth = lambda n -> lambda xs -> lambda d -> case xs | nil => d | cons x xs - => case Int_<= n 0 + => case Int_<= n (Integer->Int 0) | true => x - | false => List_nth (n - 1) xs d; + | false => List_nth (Int_- n (Integer->Int 1)) xs d; %%%% A more flexible `lambda` @@ -155,8 +155,8 @@ List_mapi f xs = let helper : (a -> Int -> b) -> Int -> List a -> List b; helper f i xs = case xs | nil => nil - | cons x xs => cons (f x i) (helper f (i + 1) xs); -in helper f 0 xs; + | cons x xs => cons (f x i) (helper f (Int_+ i (Integer->Int 1)) xs); +in helper f (Integer->Int 0) xs; List_map2 : (?a -> ?b -> ?c) -> List ?a -> List ?b -> List ?c; List_map2 f xs ys = case xs @@ -175,7 +175,7 @@ List_fold2 f o xs ys = case xs %% Is argument List empty? List_empty : List ?a -> Bool; -List_empty xs = Int_eq (List_length xs) 0; +List_empty xs = Int_eq (List_length xs) (Integer->Int 0); %%% Good 'ol combinators @@ -203,21 +203,30 @@ K x y = x; %% which will construct an Sexp equivalent to `x` at run-time. %% This is basically *cross stage persistence* for Sexp. quote1 : Sexp -> Sexp; -quote1 x = let k = K x; +quote1 x = let qlist : List Sexp -> Sexp; qlist xs = case xs | nil => Sexp_symbol "nil" | cons x xs => Sexp_node (Sexp_symbol "cons") (cons (quote1 x) (cons (qlist xs) nil)); + make_app str sexp = + Sexp_node (Sexp_symbol str) (cons sexp nil); + node op y = case (Sexp_eq op (Sexp_symbol "uquote")) | true => List_head Sexp_error y | false => Sexp_node (Sexp_symbol "##Sexp.node") (cons (quote1 op) (cons (qlist y) nil)); - symbol s = Sexp_node (Sexp_symbol "##Sexp.symbol") - (cons (Sexp_string s) nil) - in Sexp_dispatch x node symbol k k k k; + symbol s = make_app "##Sexp.symbol" (Sexp_string s); + string s = make_app "##Sexp.string" (Sexp_string s); + integer i = make_app "##Sexp.integer" (Sexp_integer i); + float f = make_app "##Sexp.float" (Sexp_float f); + block sxp = + %% FIXME ##Sexp.block takes a string (and prelexes + %% it) but we have a sexp, what should we do? + Sexp_symbol "<error FIXME block quoting>"; + in Sexp_dispatch x node symbol string integer float block; %% quote definition quote = macro (lambda x -> IO_return (quote1 (List_head Sexp_error x))); @@ -302,7 +311,7 @@ type-impl = lambda (x : List Sexp) -> get-type sxp = Sexp_dispatch sxp (lambda s ss -> case (Sexp_eq s (Sexp_symbol "_:_")) - | true => List_nth 1 ss Sexp_error + | true => List_nth (Integer->Int 1) ss Sexp_error | false => sxp) (lambda _ -> sxp) (lambda _ -> Sexp_error) @@ -464,8 +473,8 @@ Decidable = typecons (Decidable (prop : Type_ ?ℓ)) %% Testing generalization in inductive type constructors. LList : Type -> Int -> Type; %FIXME: `LList : ?` should be sufficient! type LList (a : Type) (n : Int) - | vnil (p ::: Eq n 0) - | vcons a (LList a ?n1) (p ::: Eq n (?n1 + 1)); %FIXME: Unsound wraparound! + | vnil (p ::: Eq n (Integer->Int 0)) + | vcons a (LList a ?n1) (p ::: Eq n (Int_+ ?n1 (Integer->Int 1))); %%%% If @@ -475,9 +484,9 @@ define-operator "else" 1 66; if_then_else_ = macro (lambda args -> - let e1 = List_nth 0 args Sexp_error; - e2 = List_nth 1 args Sexp_error; - e3 = List_nth 2 args Sexp_error; + let e1 = List_nth (Integer->Int 0) args Sexp_error; + e2 = List_nth (Integer->Int 1) args Sexp_error; + e3 = List_nth (Integer->Int 2) args Sexp_error; in IO_return (quote (case uquote e1 | true => uquote e2 | false => uquote e3))); @@ -543,7 +552,7 @@ in case (String_eq r "_") %% Elab_arg-pos a b c = let r = Elab_arg-pos' a b c; -in case (Int_eq r (-1)) +in case (Int_eq r (Integer->Int -1)) | true => (none) | false => (some r); @@ -634,6 +643,17 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro; %% _|_ = let lib = load "btl/polyfun.typer" in lib._|_; +%% +%% case_as_return_, case_return_ +%% A `case` for dependent elimination +%% + +define-operator "as" 42 42; +define-operator "return" 42 42; +depelim = load "btl/depelim.typer"; +case_as_return_ = depelim.case_as_return_; +case_return_ = depelim.case_return_; + %%%% Unit tests function for doing file %% It's hard to do a primitive which execute test file @@ -656,7 +676,7 @@ Test_file = macro (lambda args -> let (cons (Sexp_symbol "unit") nil); %% Expecting a String and nothing else -in IO_return (Sexp_dispatch (List_nth 0 args Sexp_error) +in IO_return (Sexp_dispatch (List_nth (Integer->Int 0) args Sexp_error) (lambda _ _ -> ret) (lambda _ -> ret) %% `load` is a special form and takes a Sexp rather than a real `String` ===================================== btl/plain-let.typer ===================================== @@ -47,7 +47,7 @@ impl args = let in Sexp_dispatch arg (lambda s ss -> if (Sexp_eq s (Sexp_symbol "_=_")) then - (rename (List_nth 0 ss Sexp_error)) else + (rename (List_nth (Integer->Int 0) ss Sexp_error)) else (IO_return Sexp_error)) io-serr io-serr io-serr io-serr io-serr; @@ -55,7 +55,7 @@ impl args = let get-def : Sexp -> Sexp; get-def arg = Sexp_dispatch arg (lambda s ss -> if (Sexp_eq s (Sexp_symbol "_=_")) then - (List_nth 1 ss Sexp_error) else + (List_nth (Integer->Int 1) ss Sexp_error) else (Sexp_error)) serr serr serr serr serr; @@ -63,7 +63,7 @@ impl args = let get-var : Sexp -> Sexp; get-var arg = Sexp_dispatch arg (lambda s ss -> if (Sexp_eq s (Sexp_symbol "_=_")) then - (List_nth 0 ss Sexp_error) else + (List_nth (Integer->Int 0) ss Sexp_error) else (Sexp_error)) serr serr serr serr serr; @@ -138,8 +138,8 @@ impl args = let in do { %% get list of pair and use it to generate `plain-let` - defs <- IO_return (get-decls (List_nth 0 args Sexp_error)); - body <- IO_return (List_nth 1 args Sexp_error); + defs <- IO_return (get-decls (List_nth (Integer->Int 0) args Sexp_error)); + body <- IO_return (List_nth (Integer->Int 1) args Sexp_error); sym-def <- get-sym-def defs; sym-def <- IO_return (List_reverse (List_tail sym-def) nil); var-sym <- get-var-sym defs sym-def; ===================================== btl/polyfun.typer ===================================== @@ -40,7 +40,7 @@ fun-args decl = Sexp_dispatch decl mf arg = Sexp_dispatch arg (lambda s ss -> if (Sexp_eq s (Sexp_symbol "_:_")) then - (List_nth 0 ss Sexp_error) + (List_nth (Integer->Int 0) ss Sexp_error) else (Sexp_node s ss)) (lambda s -> Sexp_symbol s) @@ -64,7 +64,7 @@ fun-cases args = let in Sexp_dispatch arg (lambda s ss -> if (Sexp_eq s (Sexp_symbol "_=>_")) then - (pair (List_nth 0 ss Sexp_error) (List_nth 1 ss Sexp_error)) + (pair (List_nth (Integer->Int 0) ss Sexp_error) (List_nth (Integer->Int 1) ss Sexp_error)) else (err ())) err err err err err; @@ -84,14 +84,14 @@ cases-to-sexp vars cases = let (cons pat (cons body nil)); tup : Bool; - tup = Int_< 1 (List_length vars); + tup = Int_< (Integer->Int 1) (List_length vars); in Sexp_node (Sexp_symbol "case_") (cons (Sexp_node (Sexp_symbol "_|_") (cons (if tup then (Sexp_node (Sexp_symbol "_,_") vars) else - (List_nth 0 vars Sexp_error)) + (List_nth (Integer->Int 0) vars Sexp_error)) (List_map mf cases))) nil); %% @@ -103,7 +103,7 @@ _|_ = macro (lambda args -> let %% function with argument (e.g. `f x y`) decl : Sexp; - decl = List_nth 0 args Sexp_error; + decl = List_nth (Integer->Int 0) args Sexp_error; %% symbol to match fargs : List Sexp; ===================================== btl/tuple.typer ===================================== @@ -90,11 +90,11 @@ gen-deduce vars = List_map %% tuple-nth = macro (lambda args -> let - nerr = lambda _ -> (Int->Integer (-1)); + nerr = lambda _ -> (-1); %% argument `n` of this macro n : Integer; - n = Sexp_dispatch (List_nth 1 args Sexp_error) + n = Sexp_dispatch (List_nth (Integer->Int 1) args Sexp_error) (lambda _ _ -> nerr ()) nerr nerr (lambda n -> n) @@ -106,7 +106,7 @@ tuple-nth = macro (lambda args -> let %% tuple, argument of this macro tup : Sexp; - tup = List_nth 0 args Sexp_error; + tup = List_nth (Integer->Int 0) args Sexp_error; in IO_return (Sexp_node (Sexp_symbol "__.__") (cons tup (cons elem-sym nil))) ); @@ -145,8 +145,8 @@ assign-tuple = macro (lambda args -> let in do { IO_return (Sexp_node (Sexp_symbol "_;_") (List_mapi - (mf (List_nth 1 args Sexp_error)) - (get-tup-elem (List_nth 0 args Sexp_error)))); + (mf (List_nth (Integer->Int 1) args Sexp_error)) + (get-tup-elem (List_nth (Integer->Int 0) args Sexp_error)))); }); %% ===================================== src/debug.ml ===================================== @@ -90,7 +90,7 @@ let rec debug_sexp_print sexp = print_string "\""; print_string str; print_string "\"" | Integer(loc, n) - -> print_info "Integer: " loc; print_int n + -> print_info "Integer: " loc; Z.print n | Float(loc, x) -> print_info "Float: " loc; print_float x ===================================== src/elab.ml ===================================== @@ -278,7 +278,7 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context = | [String (_, name); l; r] -> let level s = match s with | Symbol (_, "") -> None - | Integer (_, n) -> Some n + | Integer (_, n) -> Some (Z.to_int n) | _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in let (grm, a, b, c) = ctx in (SMap.add name (level l, level r) grm, a, b, c) @@ -1596,7 +1596,7 @@ let sform_arrow kind ctx loc sargs ot = let sform_immediate ctx loc sargs ot = match sargs with | [(String _) as se] -> mkImm (se), Inferred DB.type_string - | [(Integer _) as se] -> mkImm (se), Inferred DB.type_int + | [(Integer _) as se] -> mkImm (se), Inferred DB.type_integer | [(Float _) as se] -> mkImm (se), Inferred DB.type_float | [Block (sl, pts, el)] -> let grm = ectx_get_grammar ctx in @@ -1803,7 +1803,7 @@ let sform_type ctx loc sargs ot = let sform_debruijn ctx loc sargs ot = match sargs with | [Integer (l,i)] - -> if i < 0 || i > get_size ctx then + -> let i = Z.to_int i in if i < 0 || i > get_size ctx then (sexp_error l "##DeBruijn index out of bounds"; sform_dummy_ret ctx loc) else ===================================== src/eval.ml ===================================== @@ -151,17 +151,68 @@ let add_binary_iop name f = | _ -> error loc ("`" ^ name ^ "` expects 2 Int arguments") in add_builtin_function name f 2 -let _ = add_binary_iop "+" (+); - add_binary_iop "-" (-); - add_binary_iop "*" ( * ); - add_binary_iop "/" (/); +let add_binary_iop_with_loc name f = + let name = "Int." ^ name in + let f loc (depth : eval_debug_info) (args_val: value_type list) = + match args_val with + | [Vint (v); Vint (w)] -> Vint (f loc v w) + | _ -> error loc ("`" ^ name ^ "` expects 2 Int arguments") in + add_builtin_function name f 2 + +let add_with_overflow loc a b = + let c = a + b in + (* Check that signs of both args are diff. OR sign of result is the + same as the sign of the args. *) + if (a lxor b) lor (a lxor (lnot c)) < 0 + then c + else error loc "Overflow in `Int.+`" + +let sub_with_overflow loc a b = + let c = a - b in + (* Check that signs of both args are the same OR sign of result is + the same as the sign of the first arg. *) + if (a lxor (lnot b)) lor (a lxor (lnot c)) < 0 + then c + else error loc "Overflow in `Int.-`" + +let mul_with_overflow loc a b = + let c = a * b in + if b = 0 || not (c = min_int && b = -1) && a = c / b (* Simple but slow *) + then c + else error loc "Overflow in `Int.*`" + +let div_with_overflow loc a b = + if not (a = min_int && b = -1) + then a / b + else error loc "Overflow in `Int./`" + +let lsl_with_overflow loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.lsl`") + else a lsl b + +let lsr_with_overflow loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.lsr`") + else a lsr b + +let asr_with_overflow loc a b = + if b < 0 || b > Sys.int_size + then error loc ("Invalid shift value `" ^ (string_of_int b) ^ "` in `Int.asr`") + else a asr b + +let _ = add_binary_iop_with_loc "+" add_with_overflow; + add_binary_iop_with_loc "-" sub_with_overflow; + add_binary_iop_with_loc "*" mul_with_overflow; + add_binary_iop_with_loc "/" div_with_overflow; + + add_binary_iop_with_loc "lsl" lsl_with_overflow; + add_binary_iop_with_loc "lsr" lsr_with_overflow; + add_binary_iop_with_loc "asr" asr_with_overflow; add_binary_iop "mod" (mod); add_binary_iop "and" (land); - add_binary_iop "or" (lor); - add_binary_iop "lsl" (lsl); - add_binary_iop "lsr" (lsr); - add_binary_iop "asr"(asr); + add_binary_iop "or" (lor); add_binary_iop "xor" (lxor) let add_binary_bool_iop name f = @@ -221,6 +272,16 @@ let _ = add_binary_bool_biop "<" BI.lt; -> match args_val with | [Vint v] -> Vinteger (BI.of_int v) | _ -> error loc ("`" ^ name ^ "` expects 1 Int argument")) + 1; + let name = "Integer->Int" in + add_builtin_function + name + (fun loc (depth : eval_debug_info) (args_val: value_type list) + -> match args_val with + | [Vinteger v] -> + (try Vint (BI.to_int v) with + | Z.Overflow -> error loc ("Overflow in `" ^ name ^ "`")) + | _ -> error loc ("`" ^ name ^ "` expects 1 Integer argument")) 1 (* Floating point numers. *) @@ -283,7 +344,7 @@ let make_string loc depth args_val = match args_val with | _ -> error loc "Sexp.string expects one string as argument" let make_integer loc depth args_val = match args_val with - | [Vinteger n] -> Vsexp (Integer (loc, BI.to_int n)) + | [Vinteger n] -> Vsexp (Integer (loc, n)) | _ -> error loc "Sexp.integer expects one integer as argument" let make_float loc depth args_val = match args_val with @@ -373,7 +434,7 @@ let rec eval lxp (ctx : Env.runtime_env) (trace : eval_debug_info): (value_type) match lxp with (* Leafs *) (* ---------------- *) - | Imm(Integer (_, i)) -> Vint i + | Imm(Integer (_, i)) -> Vinteger i | Imm(String (_, s)) -> Vstring s | Imm(Float (_, n)) -> Vfloat n | Imm(sxp) -> Vsexp sxp @@ -567,7 +628,7 @@ and sexp_dispatch loc depth args = | Node (op, s) -> eval_call nd [Vsexp op; o2v_list s] | Symbol (_ , s) -> eval_call sym [Vstring s] | String (_ , s) -> eval_call str [Vstring s] - | Integer (_ , i) -> eval_call it [Vint i] + | Integer (_ , i) -> eval_call it [Vinteger i] | Float (_ , f) -> eval_call flt [Vfloat f] | Block (_ , _, _) as b -> (* I think this code breaks what Blocks are. *) @@ -744,7 +805,7 @@ let constructor_p name ectx = with Senv_Lookup_Fail _ -> false let erasable_p name nth ectx = - let is_erasable ctors = match (smap_find_opt name ctors) with + let is_erasable ctors = match (SMap.find_opt name ctors) with | (Some args) -> if (nth < (List.length args) && nth >= 0) then ( match (List.nth args nth) with @@ -763,7 +824,7 @@ let erasable_p name nth ectx = let erasable_p2 t name ectx = let is_erasable ctors = - match (smap_find_opt t ctors) with + match (SMap.find_opt t ctors) with | Some args -> (List.exists (fun (k, oname, _) @@ -783,7 +844,7 @@ let erasable_p2 t name ectx = with Senv_Lookup_Fail _ -> false let nth_ctor_arg name nth ectx = - let find_nth ctors = match (smap_find_opt name ctors) with + let find_nth ctors = match (SMap.find_opt name ctors) with | Some args -> (match (List.nth args nth) with | (_, (_, Some n), _) -> n @@ -805,7 +866,7 @@ let ctor_arg_pos name arg ectx = | [] -> None | (_, (_, Some x), _)::xs -> if x = arg then Some n else find_opt xs (n + 1) | _::xs -> find_opt xs (n + 1) in - let find_arg ctors = match (smap_find_opt name ctors) with + let find_arg ctors = match (SMap.find_opt name ctors) with | (Some args) -> ( match (find_opt args 0) with | None -> (-1) ===================================== src/float.ml ===================================== @@ -0,0 +1,25 @@ +(* Copyright (C) 2020 Free Software Foundation, Inc. + * + * Author: Simon Génier <simon.genier(a)umontreal.ca> + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see <http://www.gnu.org/licenses/>. *) + +type t = float + +let equal (l : t) (r : t) : bool = l = r + +let compare (l : t) (r : t) : int = compare l r ===================================== src/int.ml ===================================== @@ -0,0 +1,25 @@ +(* Copyright (C) 2020 Free Software Foundation, Inc. + * + * Author: Simon Génier <simon.genier(a)umontreal.ca> + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see <http://www.gnu.org/licenses/>. *) + +type t = int + +let equal (l : t) (r : t) : bool = l = r + +let compare (l : t) (r : t) : int = compare l r ===================================== src/lexer.ml ===================================== @@ -58,7 +58,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos if bp >= String.length name then ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), @@ -75,7 +75,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos | _ -> ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), ===================================== src/lexp.ml ===================================== @@ -962,7 +962,7 @@ and lexp_str ctx (exp : lexp) : string = match lexp_lexp' exp with | Imm(value) -> (match value with | String (_, s) -> tval ("\"" ^ s ^ "\"") - | Integer(_, s) -> tval (string_of_int s) + | Integer(_, s) -> tval (Z.to_string s) | Float (_, s) -> tval (string_of_float s) | e -> sexp_string e) ===================================== src/opslexp.ml ===================================== @@ -566,7 +566,7 @@ and check'' erased ctx e = s in match lexp_lexp' e with | Imm (Float (_, _)) -> DB.type_float - | Imm (Integer (_, _)) -> DB.type_int + | Imm (Integer (_, _)) -> DB.type_integer | Imm (String (_, _)) -> DB.type_string | Imm (Block (_, _, _) | Symbol _ | Node (_, _)) -> (error_tc ~loc:(lexp_location e) "Unsupported immediate value!"; @@ -960,7 +960,7 @@ and fv (e : lexp) : (DB.set * mv_set) = and get_type ctx e = match lexp_lexp' e with | Imm (Float (_, _)) -> DB.type_float - | Imm (Integer (_, _)) -> DB.type_int + | Imm (Integer (_, _)) -> DB.type_integer | Imm (String (_, _)) -> DB.type_string | Imm (Block (_, _, _) | Symbol _ | Node (_, _)) -> DB.type_int | Builtin (_, t, _) -> t ===================================== src/option.ml ===================================== @@ -0,0 +1,27 @@ +(* Copyright (C) 2020 Free Software Foundation, Inc. + * + * Author: Simon Génier <simon.genier(a)umontreal.ca> + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see <http://www.gnu.org/licenses/>. *) + +type 'a t = 'a option + +let equal (inner_equal : 'a -> 'a -> bool) (l : 'a t) (r : 'a t) : bool = + match l, r with + | Some l, Some r -> inner_equal l r + | None, None -> true + | _ -> false ===================================== src/sexp.ml ===================================== @@ -27,16 +27,13 @@ open Grammar let sexp_error ?print_action loc msg = Log.log_error ~section:"SEXP" ?print_action ~loc msg -type integer = (* Num.num *) int +type integer = Z.t type symbol = location * string type sexp = (* Syntactic expression, kind of like Lisp. *) | Block of location * pretoken list * location | Symbol of symbol | String of location * string - (* FIXME: It would make a lof of sense to use a bigint here, but `compare` - * burps on Big_int objects, and `compare` is used for hash-consing of lexp - * objects which contain sexp objects as well. *) | Integer of location * integer | Float of location * float | Node of sexp * sexp list @@ -76,7 +73,7 @@ let rec sexp_string sexp = | Symbol(_, "") -> "()" (* Epsilon *) | Symbol(_, name) -> name | String(_, str) -> "\"" ^ str ^ "\"" - | Integer(_, n) -> string_of_int n + | Integer(_, n) -> Z.to_string n | Float(_, x) -> string_of_float x | Node(f, args) -> let str = "(" ^ (sexp_string f) in ===================================== src/util.ml ===================================== @@ -1,6 +1,6 @@ (* util.ml --- Misc definitions for Typer. -*- coding: utf-8 -*- -Copyright (C) 2011-2018 Free Software Foundation, Inc. +Copyright (C) 2011-2020 Free Software Foundation, Inc. Author: Stefan Monnier <monnier(a)iro.umontreal.ca> Keywords: languages, lisp, dependent types. @@ -20,12 +20,21 @@ more details. You should have received a copy of the GNU General Public License along with this program. If not, see <http://www.gnu.org/licenses/>. *) -module SMap = Map.Make (String) -(* Apparently OCaml-4.02 doesn't have find_opt and Debian stable still - * uses 4.02. *) -let smap_find_opt s m = try Some (SMap.find s m) with Not_found -> None - -module IMap = Map.Make (struct type t = int let compare = compare end) +(** Adds the update function to maps. This can be removed when we upgrade to + OCaml >= 4.06 *) +module UPDATABLE(Base : Map.S) = struct + include Base + + let update key f map = + let before = find_opt key map in + match before, f before with + | _, Some after -> add key after map + | Some before, None -> remove key map + | None, None -> map +end + +module SMap = UPDATABLE(Map.Make(String)) +module IMap = UPDATABLE(Map.Make(Int)) type charpos = int type bytepos = int ===================================== tests/elab_test.ml ===================================== @@ -51,7 +51,7 @@ let add_elab_test_decl = let _ = add_elab_test_expr "Instanciate implicit arguments" ~setup:{| -f : (i : Int) -> Eq i i -> Int; +f : (i : Integer) -> Eq i i -> Integer; f = lambda i -> lambda eq -> i; |} ~expected:"f 4 (Eq_refl (x := 4));" @@ -107,6 +107,24 @@ plus x y = Eq_refl); |} +let _ = add_elab_test_decl + "depelim macro" + {| +type Nat + | Z + | S Nat; + +Nat_induction : + (P : Nat -> Type_ ?l) ≡> + P Z -> + ((n : Nat) -> P n -> P (S n)) -> + ((n : Nat) -> P n); +Nat_induction base step n = + case n return (P n) + | Z => base + | S n' => (step n' (Nat_induction (P := P) base step n')); + |} + let _ = add_elab_test_decl "case conversion" {| ===================================== tests/eval_test.ml ===================================== @@ -112,7 +112,7 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Lambda" - "sqr : Int -> Int; + "sqr : Integer -> Integer; sqr = lambda x -> x * x;" "sqr 4;" (* == *) "16" @@ -120,10 +120,10 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Nested Lambda" - "sqr : Int -> Int; + "sqr : Integer -> Integer; sqr = lambda x -> x * x; - cube : Int -> Int; + cube : Integer -> Integer; cube = lambda x -> x * (sqr x);" "cube 4" (* == *) "64" @@ -148,7 +148,7 @@ let _ = test_eval_eqv_named b = (ctr2 (ctr2 ctr0)); z = 3; c = (ctr3 (ctr2 ctr0)); w = 4; - test_fun : idt -> Int; + test_fun : idt -> Integer; test_fun = lambda k -> case k | ctr1 l => 1 | ctr2 l => 2 @@ -166,7 +166,7 @@ let nat_decl = " zero = datacons Nat zero; succ = datacons Nat succ; - to-num : Nat -> Int; + to-num : Nat -> Integer; to-num = lambda (x : Nat) -> case x | (succ y) => (1 + (to-num y)) | zero => 0;" @@ -210,8 +210,8 @@ let _ = test_eval_eqv_named two = succ one; three = succ two; - even : Nat -> Int; - odd : Nat -> Int; + even : Nat -> Integer; + odd : Nat -> Integer; odd = lambda (n : Nat) -> case n | zero => 0 @@ -229,7 +229,7 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Partial Application" - "add : Int -> Int -> Int; + "add : Integer -> Integer -> Integer; add = lambda x y -> (x + y); inc1 = add 1; @@ -260,12 +260,12 @@ let _ = test_eval_eqv_named list.head my_list; list.head (list.tail my_list)" - "4; some 1; some 2" + "(Integer->Int 4); some 1; some 2" (* * Special forms *) -let _ = test_eval_eqv "w = 2" "decltype w" "Int" +let _ = test_eval_eqv "w = 2" "decltype w" "Integer" let _ = test_eval_eqv "w = 2" "declexpr w" "2" let _ = (add_test "EVAL" "Monads" (fun () -> @@ -288,9 +288,9 @@ let _ = (add_test "EVAL" "Monads" (fun () -> let _ = test_eval_eqv_named "Argument Reordering" - "fun = lambda (x : Int) => - lambda (y : Int) -> - lambda (z : Int) -> x * y + z;" + "fun = lambda (x : Integer) => + lambda (y : Integer) -> + lambda (z : Integer) -> x * y + z;" "fun (x := 3) 2 1; fun (x := 3) (z := 1) 4; @@ -312,7 +312,7 @@ let _ = test_eval_eqv_named "Metavars" let _ = test_eval_eqv_named "Explicit field patterns" "Triplet = typecons Triplet - (triplet (a ::: Int) (b :: Float) (c : String) (d :: Int)); + (triplet (a ::: Integer) (b :: Float) (c : String) (d :: Integer)); triplet = datacons Triplet triplet; t = triplet (b := 5.0) (a := 3) (d := 7) (c := \"hello\");" @@ -330,7 +330,7 @@ let _ = test_eval_eqv_named "Implicit Arguments" {| - fun = lambda (x : Int) => + fun = lambda (x : Integer) => lambda (p : Eq x x) -> x; |} @@ -344,7 +344,7 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Equalities" - "f : (α : Type) ≡> (p : Eq Int α) -> Int -> α; + "f : (α : Type) ≡> (p : Eq Integer α) -> Integer -> α; f = lambda α ≡> lambda p x -> Eq_cast (f := lambda v -> v) (p := p) x" @@ -364,7 +364,7 @@ let _ = test_eval_eqv_named Pair = typecons (Pair (a : Type) (b : Type)) (cons (x :: a) (y :: b)); - ptest : Pair Int String; + ptest : Pair Integer String; ptest = (##datacons Pair cons) (x := 4) (y := \"hello\"); px = case ptest | (##datacons ? cons) (x := v) => v; @@ -445,4 +445,36 @@ nil≠l = |} "head l nil≠l" "0" +let _ = + add_test "EVAL" "int overflows" (fun () -> + let check_op op biop a b = + let a' = Z.of_int a in + let b' = Z.of_int b in + let expect' = biop a' b' in + let str = "(Int_" ^ op ^ " (Integer->Int " ^ (string_of_int a) ^ ")" + ^ " (Integer->Int " ^ (string_of_int b) ^ "))" in + let lxp = List.hd (Elab.lexp_expr_str str ectx) in + let elxp = OL.erase_type lxp in + assert (Log.error_count () == 0); + + if Z.fits_int expect' then + let actual = eval elxp rctx in + expect_equal_values [actual] [Vint (Z.to_int expect')] + else + (* The result should overflow *) + try let result = (eval elxp rctx) in + ut_string2 ("EXPECTED overflow for `" ^ str ^ "`\n"); + ut_string2 ("GOT: " ^ (value_string result) ^ "\n"); + failure + with + | Log.Internal_error _ -> Log.clear_log (); success in + let arith_ops = [("+", Z.add); ("-", Z.sub); ("*", Z.mul); ("/", Z.div)] in + let vals = [min_int; -1; 0; 1; max_int] in + let sum_for ls fn = List.fold_left (+) 0 (List.map fn ls) in + sum_for arith_ops (fun (op, biop) -> + sum_for vals (fun a -> + sum_for vals (fun b -> + if op = "/" && b = 0 then success else + check_op op biop a b)))) + let _ = run_all () ===================================== tests/macro_test.ml ===================================== @@ -57,10 +57,10 @@ let _ = (add_test "MACROS" "macros base" (fun () -> let rctx, ectx = Elab.eval_decl_str dcode ectx rctx in - let ecode = "(lambda (x : Int) -> sqr 3) 5;" in + let ecode = "(lambda (x : Integer) -> sqr 3) 5;" in let ret = Elab.eval_expr_str ecode ectx rctx in - expect_equal_values ret [Vint(3 * 3)])) + expect_equal_values ret [Vinteger (Z.of_int (3 * 3))])) let _ = (add_test "MACROS" "macros decls" (fun () -> let dcode = " @@ -68,9 +68,9 @@ let _ = (add_test "MACROS" "macros decls" (fun () -> let chain-decl : Sexp -> Sexp -> Sexp; chain-decl a b = Sexp_node (Sexp_symbol \"_;_\") (cons a (cons b nil)) in - let make-decl : String -> Int -> Sexp; + let make-decl : String -> Integer -> Sexp; make-decl name val = - (Sexp_node (Sexp_symbol \"_=_\") (cons (Sexp_symbol name) (cons (Sexp_integer (Int->Integer val)) nil))) in + (Sexp_node (Sexp_symbol \"_=_\") (cons (Sexp_symbol name) (cons (Sexp_integer val) nil))) in let d1 = make-decl \"a\" 1 in let d2 = make-decl \"b\" 2 in @@ -85,7 +85,7 @@ let _ = (add_test "MACROS" "macros decls" (fun () -> let ecode = "a; b;" in let ret = Elab.eval_expr_str ecode ectx rctx in - expect_equal_values ret [Vint(1); Vint(2)])) + expect_equal_values ret [Vinteger(Z.of_int 1); Vinteger(Z.of_int 2)])) (* run all tests *) let _ = run_all () ===================================== tests/unify_test.ml ===================================== @@ -82,14 +82,14 @@ let str_int_4 = "i = 4" let str_case = "i = case true | true => 2 | false => 42" -let str_case2 = "i = case nil(a := Int) +let str_case2 = "i = case nil(a := Integer) | nil => 12 | _ => 24" let str_let = "i = let a = 5 in a + 1" let str_let2 = "j = let b = 5 in b" -let str_lambda = "sqr = lambda (x : Int) -> x * x;" -let str_lambda2 = "sqr = lambda (x : Int) -> x * x;" -let str_lambda3 = "sqr = lambda (x : Int) -> lambda (y : Int) -> x * y;" +let str_lambda = "sqr = lambda (x : Integer) -> x * x;" +let str_lambda2 = "sqr = lambda (x : Integer) -> x * x;" +let str_lambda3 = "sqr = lambda (x : Integer) -> lambda (y : Integer) -> x * y;" let str_type = "i = let j = decltype(Type) in decltype(j);" let str_type2 = "j = let i = Int -> Int in decltype(i);" @@ -128,11 +128,11 @@ let generate_testable (_: lexp list) : ((lexp * lexp * result) list) = ( mkLambda ((Anormal), (Util.dummy_location, Some "L1"), mkVar((Util.dummy_location, Some "z"), 3), - mkImm (Integer (Util.dummy_location, 3))), + mkImm (Integer (Util.dummy_location, Z.of_int 3))), mkLambda ((Anormal), (Util.dummy_location, Some "L2"), mkVar((Util.dummy_location, Some "z"), 4), - mkImm (Integer (Util.dummy_location, 3))), Nothing ) + mkImm (Integer (Util.dummy_location, Z.of_int 3))), Nothing ) ::(input_induct , input_induct , Equivalent) (* 2 *) ::(input_int_4 , input_int_4 , Equivalent) (* 3 *) ===================================== tests/utest_lib.ml ===================================== @@ -31,12 +31,10 @@ * --------------------------------------------------------------------------- *) open Fmt - -module StringMap = - Map.Make (struct type t = string let compare = String.compare end) +open Util type test_fun = unit -> int -type section = test_fun StringMap.t * string list +type section = test_fun SMap.t * string list let success = 0 let failure = -1 @@ -48,7 +46,7 @@ let failure = -1 * "Lambda" - "Base Case" * "Lambda" - "Nested" *) -let global_sections = ref StringMap.empty +let global_sections = ref SMap.empty let insertion_order = ref [] let ret_code = ref 0 let number_test = ref 0 @@ -201,21 +199,21 @@ let add_test section_name test_name test_fun = let update_sections section = let updated_entry = match section with | Some (tests, order) - -> StringMap.update test_name update_tests tests, test_name :: order + -> SMap.update test_name update_tests tests, test_name :: order | None -> (insertion_order := section_name :: !insertion_order; - StringMap.singleton test_name test_fun, [test_name]) + SMap.singleton test_name test_fun, [test_name]) in Some updated_entry in - global_sections := StringMap.update section_name update_sections !global_sections + global_sections := SMap.update section_name update_sections !global_sections (* sk : Section Key * tmap: test_name -> tmap * tk : Test Key *) let for_all_tests sk tmap tk = if (must_run_title tk) then ( - let tv = StringMap.find tk tmap in + let tv = SMap.find tk tmap in flush stdout; Log.clear_log (); try @@ -236,7 +234,7 @@ let for_all_tests sk tmap tk = unexpected_throw sk tk e) else () let for_all_sections sk = - let tmap, tst = StringMap.find sk (!global_sections) in + let tmap, tst = SMap.find sk (!global_sections) in let tst = List.rev tst in if must_run_section sk then ( View it on GitLab: https://gitlab.com/monnier/typer/-/compare/c21079e759d495ac1ae331ab0e58dadb… -- View it on GitLab: https://gitlab.com/monnier/typer/-/compare/c21079e759d495ac1ae331ab0e58dadb… You're receiving this email because of your account on gitlab.com.

1 0

Polymorphisme de niveau
by Génier Simon 17 Sep '20

17 Sep '20

Bonjour, Decidable est définit comme suit Decidable = typecons (Decidable (prop : Type_ ?ℓ)) (true (p ::: prop)) (false (p ::: Not prop)); Ce qui est élaboré en Decidable' = lambda (ℓ : TypeLevel) ≡> typecons (Decidable (prop : Type_ ?ℓ)) … C'est problématique parce que Typer n'élabore pas les lambda dans les datacons. Le code suivant est rejeté parce que Decidable n'est pas un type. yes = datacons Decidable true; Je propose le changement [0], qui instancie les arguments implicites dans les datacons, mais plus j'y pense, plus je me rends compte que ce n'est pas la bonne solution à ce problème. (Je pense quand même que ce changement est correct, mais pour d'autres circonstances.) Decidable ne devrait-il pas être définit comme Decidable'' = typecons (Decidable (ℓ ::: TypeLevel) (t : Type_ ℓ)) … Mes deux questions sont: - Quelle est la différence sémantique entre les deux formulations? - Si la première est incorrecte, est-ce que l'élaboration des typecons devrait être changé pour que l'élaboration du code le plus naturel donne "la bonne chose". Bon typage Simon [0]: https://gitlab.com/monnier/typer/-/commit/da12222203e536730456fefc0eaa2f246…

2 3

[Git][monnier/typer][master] 4 commits: Update the requirements for building typer.
by Simon Génier 16 Sep '20

16 Sep '20

Simon Génier pushed to branch master at Stefan / Typer Commits: eb1741eb by Simon Génier at 2020-09-16T09:21:42-04:00 Update the requirements for building typer. * Add tools and libraries. * Bump OCaml version to the latest one on Debian stable. - - - - - bcb53b2c by Simon Génier at 2020-09-16T09:21:42-04:00 Use Map.S.find_opt. - - - - - b36d30ac by Simon Génier at 2020-09-16T09:21:42-04:00 Oops: fix broken tests on OCaml 4.05.0. - - - - - 1fb4ed6c by Simon Génier at 2020-09-16T09:23:33-04:00 Merge branch 'update-requirements' into HEAD - - - - - 7 changed files: - README.md - src/eval.ml - + src/float.ml - + src/int.ml - + src/option.ml - src/util.ml - tests/utest_lib.ml Changes: ===================================== README.md ===================================== @@ -8,7 +8,11 @@ Status [![Build Status](https://travis-ci.org/Delaunay/typer.svg?branch=master)] ## Requirement -* Ocaml 4.01 +* Ocaml 4.05 +* Ocamlfind +* Ocamlbuild +* Findlib +* Zarith ## Build @@ -29,4 +33,3 @@ By default ocamlbuild creates a '_build' folder which holds all the compiled fil # Emacs files /typer-mode.el - ===================================== src/eval.ml ===================================== @@ -744,7 +744,7 @@ let constructor_p name ectx = with Senv_Lookup_Fail _ -> false let erasable_p name nth ectx = - let is_erasable ctors = match (smap_find_opt name ctors) with + let is_erasable ctors = match (SMap.find_opt name ctors) with | (Some args) -> if (nth < (List.length args) && nth >= 0) then ( match (List.nth args nth) with @@ -763,7 +763,7 @@ let erasable_p name nth ectx = let erasable_p2 t name ectx = let is_erasable ctors = - match (smap_find_opt t ctors) with + match (SMap.find_opt t ctors) with | Some args -> (List.exists (fun (k, oname, _) @@ -783,7 +783,7 @@ let erasable_p2 t name ectx = with Senv_Lookup_Fail _ -> false let nth_ctor_arg name nth ectx = - let find_nth ctors = match (smap_find_opt name ctors) with + let find_nth ctors = match (SMap.find_opt name ctors) with | Some args -> (match (List.nth args nth) with | (_, (_, Some n), _) -> n @@ -805,7 +805,7 @@ let ctor_arg_pos name arg ectx = | [] -> None | (_, (_, Some x), _)::xs -> if x = arg then Some n else find_opt xs (n + 1) | _::xs -> find_opt xs (n + 1) in - let find_arg ctors = match (smap_find_opt name ctors) with + let find_arg ctors = match (SMap.find_opt name ctors) with | (Some args) -> ( match (find_opt args 0) with | None -> (-1) ===================================== src/float.ml ===================================== @@ -0,0 +1,25 @@ +(* Copyright (C) 2020 Free Software Foundation, Inc. + * + * Author: Simon Génier <simon.genier(a)umontreal.ca> + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see <http://www.gnu.org/licenses/>. *) + +type t = float + +let equal (l : t) (r : t) : bool = l = r + +let compare (l : t) (r : t) : int = compare l r ===================================== src/int.ml ===================================== @@ -0,0 +1,25 @@ +(* Copyright (C) 2020 Free Software Foundation, Inc. + * + * Author: Simon Génier <simon.genier(a)umontreal.ca> + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see <http://www.gnu.org/licenses/>. *) + +type t = int + +let equal (l : t) (r : t) : bool = l = r + +let compare (l : t) (r : t) : int = compare l r ===================================== src/option.ml ===================================== @@ -0,0 +1,27 @@ +(* Copyright (C) 2020 Free Software Foundation, Inc. + * + * Author: Simon Génier <simon.genier(a)umontreal.ca> + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see <http://www.gnu.org/licenses/>. *) + +type 'a t = 'a option + +let equal (inner_equal : 'a -> 'a -> bool) (l : 'a t) (r : 'a t) : bool = + match l, r with + | Some l, Some r -> inner_equal l r + | None, None -> true + | _ -> false ===================================== src/util.ml ===================================== @@ -1,6 +1,6 @@ (* util.ml --- Misc definitions for Typer. -*- coding: utf-8 -*- -Copyright (C) 2011-2018 Free Software Foundation, Inc. +Copyright (C) 2011-2020 Free Software Foundation, Inc. Author: Stefan Monnier <monnier(a)iro.umontreal.ca> Keywords: languages, lisp, dependent types. @@ -20,12 +20,21 @@ more details. You should have received a copy of the GNU General Public License along with this program. If not, see <http://www.gnu.org/licenses/>. *) -module SMap = Map.Make (String) -(* Apparently OCaml-4.02 doesn't have find_opt and Debian stable still - * uses 4.02. *) -let smap_find_opt s m = try Some (SMap.find s m) with Not_found -> None - -module IMap = Map.Make (struct type t = int let compare = compare end) +(** Adds the update function to maps. This can be removed when we upgrade to + OCaml >= 4.06 *) +module UPDATABLE(Base : Map.S) = struct + include Base + + let update key f map = + let before = find_opt key map in + match before, f before with + | _, Some after -> add key after map + | Some before, None -> remove key map + | None, None -> map +end + +module SMap = UPDATABLE(Map.Make(String)) +module IMap = UPDATABLE(Map.Make(Int)) type charpos = int type bytepos = int ===================================== tests/utest_lib.ml ===================================== @@ -31,12 +31,10 @@ * --------------------------------------------------------------------------- *) open Fmt - -module StringMap = - Map.Make (struct type t = string let compare = String.compare end) +open Util type test_fun = unit -> int -type section = test_fun StringMap.t * string list +type section = test_fun SMap.t * string list let success = 0 let failure = -1 @@ -48,7 +46,7 @@ let failure = -1 * "Lambda" - "Base Case" * "Lambda" - "Nested" *) -let global_sections = ref StringMap.empty +let global_sections = ref SMap.empty let insertion_order = ref [] let ret_code = ref 0 let number_test = ref 0 @@ -201,21 +199,21 @@ let add_test section_name test_name test_fun = let update_sections section = let updated_entry = match section with | Some (tests, order) - -> StringMap.update test_name update_tests tests, test_name :: order + -> SMap.update test_name update_tests tests, test_name :: order | None -> (insertion_order := section_name :: !insertion_order; - StringMap.singleton test_name test_fun, [test_name]) + SMap.singleton test_name test_fun, [test_name]) in Some updated_entry in - global_sections := StringMap.update section_name update_sections !global_sections + global_sections := SMap.update section_name update_sections !global_sections (* sk : Section Key * tmap: test_name -> tmap * tk : Test Key *) let for_all_tests sk tmap tk = if (must_run_title tk) then ( - let tv = StringMap.find tk tmap in + let tv = SMap.find tk tmap in flush stdout; Log.clear_log (); try @@ -236,7 +234,7 @@ let for_all_tests sk tmap tk = unexpected_throw sk tk e) else () let for_all_sections sk = - let tmap, tst = StringMap.find sk (!global_sections) in + let tmap, tst = SMap.find sk (!global_sections) in let tst = List.rev tst in if must_run_section sk then ( View it on GitLab: https://gitlab.com/monnier/typer/-/compare/fd990da11c5d209610726476dd0bb89f… -- View it on GitLab: https://gitlab.com/monnier/typer/-/compare/fd990da11c5d209610726476dd0bb89f… You're receiving this email because of your account on gitlab.com.

1 0

[Git][monnier/typer][master] 7 commits: Fix an issue in the unification of metavariables
by Jean-Alexandre Barszcz 14 Sep '20

14 Sep '20

Jean-Alexandre Barszcz pushed to branch master at Stefan / Typer Commits: c34d6d0c by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Fix an issue in the unification of metavariables The issue was that unification was not idempotent in certain cases. In particular, when unifying a metavar that has a non-identity substitution (let's say lxp1) with a term (let's say lxp2) that refers to some metavariables, the corresponding metavariable references in the associated term (thus in lxp1 after association) could have different substitutions from the same references in lxp2. See the added comment for a more detailed example. - - - - - 023ea461 by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Move the Eq builtin to debruijn.ml to make it available for elab. - - - - - b4d53239 by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Make Eq.refl available to the ocaml code * src/debruijn.ml : Add a definition of the lexp for Eq.refl * src/builtin.ml : Register the constant Eq.refl * btl/builtins.typer (Eq_refl) : Use the builtin variable ##Eq.refl instead of registering the builtin with the `Built-in` form. This ensures that we have the right variable and type, and might help to keep things in sync between the ocaml and typer code. - - - - - efe2032d by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Make the case elaboration code more consistent This commit doesn't substantially change the behavior of the case elaboration, but makes the code a bit more consistent and might save some unnecessary metavariables in some cases. - - - - - 4c632a1f by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Add dependent elimination This commit changes elaboration, conversion, typechecking, erasure, and the computation of free variables and WHNFs for case expressions, to account for the fact that the context of all the branches of case expressions is extended with a proof of equality between the branch's head and the case's target. Careful elimination of this equality proof with Eq_cast makes dependent elimination possible. - - - - - b082a329 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Conversion for metavariables - - - - - fd990da1 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Case conversion - - - - - 10 changed files: - btl/builtins.typer - src/builtin.ml - src/debruijn.ml - src/elab.ml - src/inverse_subst.ml - src/lexp.ml - src/opslexp.ml - src/unification.ml - tests/elab_test.ml - tests/eval_test.ml Changes: ===================================== btl/builtins.typer ===================================== @@ -48,7 +48,7 @@ Void = typecons Void; %% Eq : (l : TypeLevel) ≡> (t : Type_ l) ≡> t -> t -> Type_ l %% Eq' : (l : TypeLevel) ≡> Type_ l -> Type_ l -> Type_ l Eq_refl : ((x : ?t) ≡> Eq x x); -Eq_refl = Built-in "Eq.refl"; +Eq_refl = ##Eq\.refl; Eq_cast : (x : ?) ≡> (y : ?) ≡> (p : Eq x y) ===================================== src/builtin.ml ===================================== @@ -99,19 +99,6 @@ let dloc = DB.dloc let op_binary t = mkArrow (Anormal, (dloc, None), t, dloc, mkArrow (Anormal, (dloc, None), t, dloc, t)) -let type_eq = - let lv = (dloc, Some "l") in - let tv = (dloc, Some "t") in - mkArrow (Aerasable, lv, - DB.type_level, dloc, - mkArrow (Aerasable, tv, - mkSort (dloc, Stype (mkVar (lv, 0))), dloc, - mkArrow (Anormal, (dloc, None), - mkVar (tv, 0), dloc, - mkArrow (Anormal, (dloc, None), - mkVar (tv, 1), dloc, - mkSort (dloc, Stype (mkVar (lv, 3))))))) - let o2l_bool ctx b = get_predef (if b then "true" else "false") ctx (* Typer list as seen during runtime. *) @@ -161,7 +148,9 @@ let register_builtin_csts () = add_builtin_cst "Integer" DB.type_integer; add_builtin_cst "Float" DB.type_float; add_builtin_cst "String" DB.type_string; - add_builtin_cst "Elab_Context" DB.type_elabctx + add_builtin_cst "Elab_Context" DB.type_elabctx; + add_builtin_cst "Eq" DB.type_eq; + add_builtin_cst "Eq.refl" DB.eq_refl let register_builtin_types () = let _ = new_builtin_type "Sexp" DB.type0 in @@ -175,7 +164,6 @@ let register_builtin_types () = "Array" (mkArrow (Anormal, (dloc, None), DB.type0, dloc, DB.type0)) in let _ = new_builtin_type "FileHandle" DB.type0 in - let _ = new_builtin_type "Eq" type_eq in () let _ = register_builtin_csts (); ===================================== src/debruijn.ml ===================================== @@ -96,6 +96,37 @@ let type_integer = mkBuiltin ((dloc, "Integer"), type0, None) let type_float = mkBuiltin ((dloc, "Float"), type0, None) let type_string = mkBuiltin ((dloc, "String"), type0, None) let type_elabctx = mkBuiltin ((dloc, "Elab_Context"), type0, None) +let type_eq_type = + let lv = (dloc, Some "l") in + let tv = (dloc, Some "t") in + mkArrow (Aerasable, lv, + type_level, dloc, + mkArrow (Aerasable, tv, + mkSort (dloc, Stype (mkVar (lv, 0))), dloc, + mkArrow (Anormal, (dloc, None), + mkVar (tv, 0), dloc, + mkArrow (Anormal, (dloc, None), + mkVar (tv, 1), dloc, + mkSort (dloc, Stype (mkVar (lv, 3))))))) +let type_eq = mkBuiltin ((dloc, "Eq"), type_eq_type, None) +let eq_refl = + let lv = (dloc, Some "l") in + let tv = (dloc, Some "t") in + let xv = (dloc, Some "x") in + mkBuiltin ((dloc, "Eq.refl"), + mkArrow (Aerasable, lv, + type_level, dloc, + mkArrow (Aerasable, tv, + mkSort (dloc, Stype (mkVar (lv, 0))), dloc, + mkArrow (Aerasable, xv, + mkVar (tv, 0), dloc, + mkCall (type_eq, + [Aerasable, mkVar (lv, 2); + Aerasable, mkVar (tv, 1); + Anormal, mkVar (xv, 0); + Anormal, mkVar (xv, 0)])))), + None) + (* easier to debug with type annotations *) type env_elem = (vname * varbind * ltype) ===================================== src/elab.ml ===================================== @@ -467,11 +467,11 @@ let rec meta_to_var ids (e : lexp) = -> let ncases = SMap.map (fun (l, fields, e) - -> (l, fields, loop (o + List.length fields) e)) + -> (l, fields, loop (o + List.length fields + 1) e)) cases in mkCase (l, loop o e, loop o t, ncases, match default with None -> None - | Some (v, e) -> Some (v, loop (1 + o) e)) + | Some (v, e) -> Some (v, loop (2 + o) e)) | Metavar (id, s, name) -> if IMap.mem id ids then mkVar (name, o + count - IMap.find id ids) @@ -736,20 +736,24 @@ and check_case rtype (loc, target, ppatterns) ctx = (* get target and its type *) let tlxp, tltp = infer target ctx in + let tknd = OL.get_type (ectx_to_lctx ctx) tltp in + let tlvl = match OL.lexp'_whnf tknd (ectx_to_lctx ctx) with + | Sort (_, Stype l) -> l + | _ -> fatal "Target lexp's kind is not a sort" in let it_cs_as = ref None in let ltarget = ref tlxp in let get_cs_as it' lctor = + let unify_ind expected actual = + match Unif.unify actual expected (ectx_to_lctx ctx) with + | (_::_) + -> lexp_error loc lctor + ("Expected pattern of type `" ^ lexp_string expected + ^ "` but got `" ^ lexp_string actual ^ "`") + | [] -> () in match !it_cs_as with | Some (it, cs, args) - -> let _ = match Unif.unify it' it (ectx_to_lctx ctx) with - | (_::_) - -> lexp_error loc lctor - ("Expected pattern of type `" - ^ lexp_string it ^ "` but got `" - ^ lexp_string it' ^ "`") - | [] -> () in - (cs, args) + -> unify_ind it it'; (cs, args) | None -> match OL.lexp'_whnf it' (ectx_to_lctx ctx) with | Inductive (_, _, fargs, constructors) @@ -771,8 +775,9 @@ and check_case rtype (loc, target, ppatterns) ctx = | Call (f, args) -> (f, args) | _ -> (e,[]) in let (it, targs) = call_split tltp in + unify_ind it it'; let constructors = - match OL.lexp'_whnf it (ectx_to_lctx ctx) with + match OL.lexp'_whnf it (ectx_to_lctx ctx) with | Inductive (_, _, fargs, constructors) -> assert (List.length fargs = List.length targs); constructors @@ -780,16 +785,36 @@ and check_case rtype (loc, target, ppatterns) ctx = ("Can't `case` on objects of this type: " ^ lexp_string tltp); SMap.empty in + it_cs_as := Some (it, constructors, targs); (constructors, targs) in (* Read patterns one by one *) let fold_fun (lbranches, dflt) (pat, pexp) = + let shift_to_extended_ctx nctx lexp = + mkSusp lexp (S.shift (M.length (ectx_to_lctx nctx) + - M.length (ectx_to_lctx ctx))) in + + let ctx_extend_with_eq nctx head_lexp = + (* Add a proof of equality between the target and the branch + head to the context *) + let tlxp' = shift_to_extended_ctx nctx tlxp in + let tltp' = shift_to_extended_ctx nctx tltp in + let tlvl' = shift_to_extended_ctx nctx tlvl in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl'); (* Typelevel *) + (Aerasable, tltp'); (* Inductive type *) + (Anormal, head_lexp); (* Lexp of the branch head *) + (Anormal, tlxp')]) (* Target lexp *) + in ctx_extend nctx (loc, None) Variable eqty + in + let add_default v = (if dflt != None then uniqueness_warn pat); let nctx = ctx_extend ctx v Variable tltp in - let rtype' = mkSusp rtype (S.shift (M.length (ectx_to_lctx nctx) - - M.length (ectx_to_lctx ctx))) in + let head_lexp = mkVar (v, 0) in + let nctx = ctx_extend_with_eq nctx head_lexp in + let rtype' = shift_to_extended_ctx nctx rtype in let lexp = check pexp rtype' nctx in lbranches, Some (v, lexp) in @@ -870,9 +895,15 @@ and check_case rtype (loc, target, ppatterns) ctx = make_nctx nctx (ssink var s) pargs cargs pe ((ak, var)::acc) in let nctx, fargs = make_nctx ctx subst pargs cargs SMap.empty [] in - let rtype' = mkSusp rtype - (S.shift (M.length (ectx_to_lctx nctx) - - M.length (ectx_to_lctx ctx))) in + let head_lexp_ctor = + shift_to_extended_ctx nctx + (mkCall (lctor, List.map (fun (_, a) -> (Aerasable, a)) targs)) in + let head_lexp_args = + List.mapi (fun i (ak, vname) -> + (ak, mkVar (vname, List.length fargs - i - 1))) fargs in + let head_lexp = mkCall (head_lexp_ctor, head_lexp_args) in + let nctx = ctx_extend_with_eq nctx head_lexp in + let rtype' = shift_to_extended_ctx nctx rtype in let lexp = check pexp rtype' nctx in SMap.add cons_name (loc, fargs, lexp) lbranches, dflt ===================================== src/inverse_subst.ml ===================================== @@ -304,11 +304,12 @@ and apply_inv_subst (e : lexp) (s : subst) : lexp = -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, apply_inv_subst e s')) + let s'' = ssink (l, None) s' in + (l, cargs, apply_inv_subst e s'')) cases, match default with | None -> default - | Some (v,e) -> Some (v, apply_inv_subst e (ssink v s))) + | Some (v,e) -> Some (v, apply_inv_subst e (ssink (l, None) (ssink v s)))) | Metavar (id, s', name) -> match metavar_lookup id with | MVal e -> apply_inv_subst (push_susp e s') s ===================================== src/lexp.ml ===================================== @@ -574,11 +574,11 @@ let rec push_susp e s = (* Push a suspension one level down. *) -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, mkSusp e s')) + (l, cargs, mkSusp e (ssink (l, None) s'))) cases, match default with | None -> default - | Some (v,e) -> Some (v, mkSusp e (ssink v s))) + | Some (v,e) -> Some (v, mkSusp e (ssink (l, None) (ssink v s)))) (* Susp should never appear around Var/Susp/Metavar because mkSusp * pushes the subst into them eagerly. IOW if there's a Susp(Var..) * or Susp(Metavar..) it's because some chunk of code should use mkSusp @@ -641,11 +641,12 @@ let clean e = -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, clean s' e)) + let s'' = ssink (l, None) s' in + (l, cargs, clean s'' e)) cases, match default with | None -> default - | Some (v,e) -> Some (v, clean (ssink v s) e)) + | Some (v,e) -> Some (v, clean (ssink (l, None) (ssink v s)) e)) | Susp (e, s') -> clean (scompose s' s) e | Var _ -> if S.identity_p s then e else clean S.identity (mkSusp e s) ===================================== src/opslexp.ml ===================================== @@ -38,6 +38,22 @@ module S = Subst (* module L = List *) module DB = Debruijn +type set_plexp = (lexp * lexp) list +type sort_compose_result + = SortResult of ltype + | SortInvalid + | SortK1NotType + | SortK2NotType +type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t + (* Metavars that appear in non-erasable positions. *) + * unit IMap.t + +module LMap + (* Memoization table. FIXME: Ideally the keys should be "weak", but + * I haven't found any such functionality in OCaml's libs. *) + = Hashtbl.Make + (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end) + let error_tc = Log.log_error ~section:"TC" let warning_tc = Log.log_warning ~section:"TC" @@ -133,8 +149,13 @@ let lexp_close lctx e = * return value as little as possible since WHNF will inherently introduce * call-by-name behavior. *) -let lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = +(* FIXME This large letrec closes the loop between lexp_whnf_aux and + get_type so that we can use get_type in the WHNF of a case to get + the inductive type of the target (and it's typelevel). A better + solution would be to add these values as annotations in the lexp + datatype. *) let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = + let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = match lexp_lexp' e with | Var v -> (match lookup_value ctx v with | None -> e @@ -157,6 +178,12 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = | _ -> e) (* Keep `e`, assuming it's more readable! *) | Case (l, e, rt, branches, default) -> let e' = lexp_whnf_aux e ctx in + let get_refl e = + let etype = get_type ctx e in (* FIXME we should not need get_type here *) + let elevel = match lexp'_whnf (get_type ctx etype) ctx with + | Sort (_, Stype l) -> l + | _ -> Log.internal_error "" in + mkCall (DB.eq_refl, [Aerasable, elevel; Aerasable, etype; Aerasable, e]) in let reduce it name aargs = let targs = match lexp_lexp' (lexp_whnf_aux it ctx) with | Inductive (_,_,fargs,_) -> fargs @@ -173,11 +200,14 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = (s, targs)) (S.identity, targs) aargs in + (* Substitute case Eq variable by the proof (Eq.refl l t e') *) + let subst = S.cons (get_refl e') subst in lexp_whnf_aux (push_susp branch subst) ctx with Not_found -> match default with | Some (v,default) - -> lexp_whnf_aux (push_susp default (S.substitute e')) ctx + -> let subst = S.cons (get_refl e') (S.substitute e') in + lexp_whnf_aux (push_susp default subst) ctx | _ -> Log.log_error ~section:"WHNF" ~loc:l ("Unhandled constructor " ^ name ^ "in case expression"); @@ -203,29 +233,28 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = in lexp_whnf_aux e ctx -let lexp'_whnf e (ctx : DB.lexp_context) : lexp' = +and lexp'_whnf e (ctx : DB.lexp_context) : lexp' = lexp_lexp' (lexp_whnf_aux e ctx) -let lexp_whnf e (ctx : DB.lexp_context) : lexp = +and lexp_whnf e (ctx : DB.lexp_context) : lexp = lexp_whnf_aux e ctx (** A very naive implementation of sets of pairs of lexps. *) -type set_plexp = (lexp * lexp) list -let set_empty : set_plexp = [] -let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool +and set_empty : set_plexp = [] +and set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool = try let _ = List.find (fun (e1', e2') -> L.eq e1 e1' && L.eq e2 e2') s in true with Not_found -> false -let set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp +and set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp = (* assert (not (set_member_p s e1 e2)); *) ((e1, e2) :: s) -let set_shift_n (s : set_plexp) (n : U.db_offset) +and set_shift_n (s : set_plexp) (n : U.db_offset) = List.map (let s = S.shift n in fun (e1, e2) -> (Lexp.push_susp e1 s, Lexp.push_susp e2 s)) s -let set_shift s : set_plexp = set_shift_n s 1 +and set_shift s : set_plexp = set_shift_n s 1 (********* Testing if two types are "convertible" aka "equivalent" *********) @@ -235,7 +264,7 @@ let set_shift s : set_plexp = set_shift_n s 1 * `c` is the maximum "constant" level that occurs in `e` * and `m` maps variable indices to the maxmimum depth at which they were * found. *) -let level_canon e = +and level_canon e = let add_var_depth v d ((c,m) as acc) = let o = try IMap.find v m with Not_found -> -1 in if o < d then (c, IMap.add v d m) else acc in @@ -255,14 +284,14 @@ let level_canon e = | _ -> (max_int, m) in canon e 0 (0,IMap.empty) -let level_leq (c1, m1) (c2, m2) = +and level_leq (c1, m1) (c2, m2) = c1 <= c2 && c1 != max_int && IMap.for_all (fun i d -> try d <= IMap.find i m2 with Not_found -> false) m1 (* Returns true if e₁ and e₂ are equal (upto alpha/beta/...). *) -let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = +and conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = let e1' = lexp_whnf e1 ctx in let e2' = lexp_whnf e2 ctx in e1' == e2' || @@ -330,19 +359,109 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = | _,_ -> false in l1 == l2 && conv_args ctx vs' args1 args2 | (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> l1 = l2 && conv_p t1 t2 - (* I'm not sure to understand how to compare two Metavar * - * Should I do a `lookup`? Or is it that simple: *) - (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*) - (* FIXME: Various missing cases, such as Case. *) + | (Case (_, target1, r1, cases1, def1), Case (_, target2, r2, cases2, def2)) + -> (* FIXME The termination of this case conversion is very + fragile. Indeed, we recurse in all branches, bypassing any + termination condition. Checking syntactic equality as a + base case seems to be sufficient in simple cases, but it + is probably not enough in general. *) + eq e1' e2' || ( + conv_p target1 target2 && + conv_p r1 r2 && ( + (* Compare the branches *) + (* We can arbitrarily use target1 since target1 and target2 + are convertible *) + let target = target1 in + let etype = lexp_whnf (get_type ctx target) ctx in + let ekind = get_type ctx etype in + let elvl = match lexp'_whnf ekind ctx with + | Sort (_, Stype l) -> l + | _ -> Log.log_fatal ~loc:(lexp_location ekind) + "Target lexp's kind is not a sort"; in + (* 1. Get the inductive for the field types *) + let it, aargs = match lexp_lexp' etype with + | Call (f, args) -> (f, args) + | _ -> (etype, []) in + (* 2. Build the substitution for the inductive arguments *) + let fargs, ctors = + (match lexp'_whnf it ctx with + | Inductive (_, _, fargs, constructors) + -> fargs, constructors + | _ -> Log.log_fatal ("Case of non-inductive in conv_p")) in + let fargs_subst = List.fold_left2 (fun s _farg (_, aarg) -> S.cons aarg s) + S.identity fargs aargs in + (* 3. Compare the branches *) + let ctx_extend_with_eq ctx subst hlxp = + let tlxp = mkSusp target subst in + let tltp = mkSusp etype subst in + let tlvl = mkSusp elvl subst in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl); (* Typelevel *) + (Aerasable, tltp); (* Inductive type *) + (Anormal, hlxp); (* Lexp of the branch head *) + (Anormal, tlxp)]) in (* Target lexp *) + DB.lexp_ctx_cons ctx (DB.dloc, None) Variable eqty in + (* The map module doesn't have a function to compare two + maps with the key (which is needed to get the field types + from the inductive. Instead, we work with the lists of + associations. *) + (try + List.for_all2 (fun (l1, (_, fields1, e1)) (l2, (_, fields2, e2)) -> + l1 = l2 && + let fieldtypes = SMap.find l1 ctors in + let rec mkctx ctx args s i vdefs1 vdefs2 fieldtypes = + match vdefs1, vdefs2, fieldtypes with + | [], [], [] -> Some (ctx, List.rev args, s) + | (ak1, vdef1)::vdefs1, (ak2, vdef2)::vdefs2, + (ak', vdef', ftype)::fieldtypes + -> if ak1 = ak2 && ak2 = ak' then + mkctx + (DB.lexp_ctx_cons ctx vdef1 Variable (mkSusp ftype s)) + ((ak1, (mkVar (vdef1, i)))::args) + (ssink vdef1 s) + (i - 1) + vdefs1 vdefs2 fieldtypes + else None + | _,_,_ -> None in + match mkctx ctx [] fargs_subst (List.length fields1) + fields1 fields2 fieldtypes with + | None -> false + | Some (nctx, args, _subst) -> + let offset = (List.length fields1) in + let subst = S.shift offset in + let eaargs = + List.map (fun (_, a) -> (P.Aerasable, a)) aargs in + let ctor = mkSusp (mkCall (mkCons (it, (DB.dloc, l1)), + eaargs)) subst in + let hlxp = mkCall (ctor, args) in + let nctx = ctx_extend_with_eq nctx subst hlxp in + conv_p' nctx (set_shift_n vs' (offset + 1)) e1 e2 + ) (SMap.bindings cases1) (SMap.bindings cases2) + with + | Invalid_argument _ -> false (* If the lists have different length *) + ) + && (match (def1, def2) with + | (Some (v1, e1), Some (v2, e2)) -> + let nctx = DB.lctx_extend ctx v1 Variable etype in + let subst = S.shift 1 in + let hlxp = mkVar ((DB.dloc, None), 0) in + let nctx = ctx_extend_with_eq nctx subst hlxp in + conv_p' nctx (set_shift_n vs' 2) e1 e2 + | None, None -> true + | _, _ -> false))) + | (Metavar (id1,s1,_), Metavar (id2,s2,_)) when id1 == id2 -> + (* FIXME Should we use conversion on the terms of the + substitution instead of syntactic equality? *) + subst_eq s1 s2 | (_, _) -> false -let conv_p (ctx : DB.lexp_context) e1 e2 +and conv_p (ctx : DB.lexp_context) e1 e2 = if e1 == e2 then true else conv_p' ctx set_empty e1 e2 (********* Testing if a lexp is properly typed *********) -let rec mkSLlub ctx e1 e2 = +and mkSLlub ctx e1 e2 = let lwhnf1 = lexp_whnf e1 ctx in let lwhnf2 = lexp_whnf e2 ctx in match (lexp_lexp' lwhnf1, lexp_lexp' lwhnf2) with @@ -357,13 +476,7 @@ let rec mkSLlub ctx e1 e2 = else if level_leq ce2 ce1 then e1 else mkSortLevel (mkSLlub' (e1, e2)) (* FIXME: Could be more canonical *) -type sort_compose_result - = SortResult of ltype - | SortInvalid - | SortK1NotType - | SortK2NotType - -let sort_compose ctx1 ctx2 l ak k1 k2 = +and sort_compose ctx1 ctx2 l ak k1 k2 = (* BEWARE! Technically `k2` can refer to `v`, but this should only happen * if `v` is a TypeLevel. *) let lwhnf1 = lexp'_whnf k1 ctx1 in @@ -403,11 +516,11 @@ let sort_compose ctx1 ctx2 l ak k1 k2 = | (Sort (_, _), _) -> SortK2NotType | (_, _) -> SortK1NotType -let dbset_push ak erased = +and dbset_push ak erased = let nerased = DB.set_sink 1 erased in if ak = P.Aerasable then DB.set_set 0 nerased else nerased -let nerased_let defs erased = +and nerased_let defs erased = (* Let bindings are not erasable, with the important exception of * let-bindings of the form `x = y` where `y` is an erasable var. * This exception is designed so that macros like `case` which need to @@ -433,7 +546,7 @@ let nerased_let defs erased = erased es (* "check ctx e" should return τ when "Δ ⊢ e : τ" *) -let rec check'' erased ctx e = +and check'' erased ctx e = let check = check'' in let assert_type ctx e t t' = if conv_p ctx t t' then () @@ -608,7 +721,14 @@ let rec check'' erased ctx e = match lexp_lexp' e with | Call (f, args) -> (f, args) | _ -> (e,[]) in - let etype = lexp_whnf (check erased ctx e) ctx in + let etype = lexp_whnf (check erased ctx e) ctx in + (* FIXME save the type in the case lexp instead of recomputing + it over and over again *) + let ekind = get_type ctx etype in + let elvl = match lexp'_whnf ekind ctx with + | Sort (_, Stype l) -> l + | _ -> Log.log_error ~loc:(lexp_location ekind) + "Target lexp's kind is not a sort"; DB.level0 in let it, aargs = call_split etype in (match lexp'_whnf it ctx, aargs with | Inductive (_, _, fargs, constructors), aargs -> @@ -622,27 +742,46 @@ let rec check'' erased ctx e = | _,_ -> (error_tc ~loc:l "Wrong arg number to inductive type!"; s) in let s = mksubst S.identity fargs aargs in + let ctx_extend_with_eq ctx subst hlxp nerased = + let tlxp = mkSusp e subst in + let tltp = mkSusp etype subst in + let tlvl = mkSusp elvl subst in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl); (* Typelevel *) + (Aerasable, tltp); (* Inductive type *) + (Anormal, hlxp); (* Lexp of the branch head *) + (Anormal, tlxp)]) in (* Target lexp *) + (* The eq proof is erasable. *) + let nerased = dbset_push Aerasable nerased in + let nctx = DB.lexp_ctx_cons ctx (l, None) Variable eqty in + (nerased, nctx) in SMap.iter (fun name (l, vdefs, branch) -> let fieldtypes = SMap.find name constructors in - let rec mkctx erased ctx s vdefs fieldtypes = + let rec mkctx erased ctx s hlxp vdefs fieldtypes = match vdefs, fieldtypes with - | [], [] -> (erased, ctx) + | [], [] -> (erased, ctx, hlxp) (* FIXME: If ak is Aerasable, make sure the var only * appears in type annotations. *) | (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes -> mkctx (dbset_push ak erased) (DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s)) - (S.cons (mkVar (vdef, 0)) - (S.mkShift s 1)) + (ssink vdef s) + (mkCall (mkSusp hlxp (S.shift 1), [(ak, mkVar (vdef, 0))])) vdefs fieldtypes | _,_ -> (error_tc ~loc:l "Wrong number of args to constructor!"; - (erased, ctx)) in - let (nerased, nctx) = mkctx erased ctx s vdefs fieldtypes in + (erased, ctx, hlxp)) in + let hctor = + mkCall (mkCons (it, (l, name)), + List.map (fun (_, a) -> (P.Aerasable, a)) aargs) in + let (nerased, nctx, hlxp) = + mkctx erased ctx s hctor vdefs fieldtypes in + let subst = S.shift (List.length vdefs) in + let (nerased, nctx) = ctx_extend_with_eq nctx subst hlxp nerased in assert_type nctx branch (check nerased nctx branch) - (mkSusp ret (S.shift (List.length fieldtypes)))) + (mkSusp ret (S.shift ((List.length fieldtypes) + 1)))) branches; let diff = SMap.cardinal constructors - SMap.cardinal branches in (match default with @@ -650,8 +789,13 @@ let rec check'' erased ctx e = -> if diff <= 0 then warning_tc ~loc:l "Redundant default clause"; let nctx = (DB.lctx_extend ctx v (LetDef (0, e)) etype) in - assert_type nctx d (check (DB.set_sink 1 erased) nctx d) - (mkSusp ret (S.shift 1)) + let nerased = DB.set_sink 1 erased in + let subst = S.shift 1 in + let hlxp = mkVar ((l, None), 0) in + let (nerased, nctx) = + ctx_extend_with_eq nctx subst hlxp nerased in + assert_type nctx d (check nerased nctx d) + (mkSusp ret (S.shift 2)) | None -> if diff > 0 then error_tc ~loc:l ("Non-exhaustive match: " @@ -697,24 +841,21 @@ let rec check'' erased ctx e = check erased ctx e | MVar (_, t, _) -> push_susp t s) -let check' ctx e = +and check' ctx e = let res = check'' DB.set_empty ctx e in (Log.stop_on_error (); res) -let check = check' +and check ctx e = check' ctx e (** Compute the set of free (meta)variables. **) -let rec list_union l1 l2 = match l1 with +and list_union l1 l2 = match l1 with | [] -> l2 | (x::l1) -> list_union l1 (if List.mem x l2 then l2 else (x::l2)) -type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t - (* Metavars that appear in non-erasable positions. *) - * unit IMap.t -let mv_set_empty : mv_set = (IMap.empty, IMap.empty) -let mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes) -let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set +and mv_set_empty : mv_set = (IMap.empty, IMap.empty) +and mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes) +and mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set = (IMap.merge (fun _m oss1 oss2 -> match (oss1, oss2) with | (None, _) -> oss2 @@ -730,25 +871,19 @@ let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set Some ss1) ms1 ms2, IMap.merge (fun _m _o1 _o2 -> Some ()) nes1 nes2) -let mv_set_erase (ms, _nes) = (ms, IMap.empty) +and mv_set_erase (ms, _nes) = (ms, IMap.empty) -module LMap - (* Memoization table. FIXME: Ideally the keys should be "weak", but - * I haven't found any such functionality in OCaml's libs. *) - = Hashtbl.Make - (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end) -let fv_memo = LMap.create 1000 +and fv_memo = LMap.create 1000 -let fv_empty = (DB.set_empty, mv_set_empty) -let fv_union (fv1, mv1) (fv2, mv2) +and fv_empty = (DB.set_empty, mv_set_empty) +and fv_union (fv1, mv1) (fv2, mv2) = (DB.set_union fv1 fv2, mv_set_union mv1 mv2) -let fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs) -let fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs) -let fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs) +and fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs) +and fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs) +and fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs) -let rec fv (e : lexp) : (DB.set * mv_set) = - let fv' e = - match lexp_lexp' e with +and fv (e : lexp) : (DB.set * mv_set) = + let fv' e = match lexp_lexp' e with | Imm _ -> fv_empty | SortLevel SLz -> fv_empty | SortLevel (SLsucc e) -> fv e @@ -800,9 +935,9 @@ let rec fv (e : lexp) : (DB.set * mv_set) = -> let s = fv_union (fv e) (fv_erase (fv t)) in let s = match def with | None -> s - | Some (_, e) -> fv_union s (fv_hoist 1 (fv e)) in + | Some (_, e) -> fv_union s (fv_hoist 2 (fv e)) in SMap.fold (fun _ (_, fields, e) s - -> fv_union s (fv_hoist (List.length fields) (fv e))) + -> fv_union s (fv_hoist (List.length fields + 1) (fv e))) cases s | Metavar (id, s, name) -> (match metavar_lookup id with @@ -822,7 +957,7 @@ let rec fv (e : lexp) : (DB.set * mv_set) = (** Finding the type of a expression. **) (* This should never signal any warning/error. *) -let rec get_type ctx e = +and get_type ctx e = match lexp_lexp' e with | Imm (Float (_, _)) -> DB.type_float | Imm (Integer (_, _)) -> DB.type_int @@ -948,7 +1083,7 @@ let rec erase_type (lxp: lexp): E.elexp = | L.Case(l, target, _, cases, default) -> E.Case(l, (erase_type target), (clean_map cases), - (clean_maybe default)) + (clean_default default)) | L.Susp(l, s) -> erase_type (L.push_susp l s) @@ -977,10 +1112,12 @@ and filter_arg_list lst = and clean_decls decls = List.map (fun (v, lxp, _) -> (v, (erase_type lxp))) decls -and clean_maybe lxp = - match lxp with - | Some (v, lxp) -> Some (v, erase_type lxp) - | None -> None +and clean_default lxp = + match lxp with + | Some (v, lxp) -> + Some (v, + erase_type (L.push_susp lxp (S.substitute DB.type0))) + | None -> None and clean_map cases = let clean_arg_list lst = @@ -994,7 +1131,8 @@ and clean_map cases = clean_arg_list lst [] in SMap.map (fun (l, args, expr) - -> (l, (clean_arg_list args), (erase_type expr))) + -> (l, (clean_arg_list args), + erase_type (L.push_susp expr (S.substitute DB.type0)))) cases (** Turning a set of declarations into an object. **) ===================================== src/unification.ml ===================================== @@ -291,16 +291,35 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp) | lxp' when occurs_in idx lxp' -> [(CKimpossible, ctx, lxp1, lxp2)] | lxp' -> metavar_table := associate idx lxp' (!metavar_table); - match unify t (OL.get_type ctx lxp) ctx with - | [] as r -> r - (* FIXME: Let's ignore the error for now. *) - | _ - -> log_info ?loc:None - ("Unification of metavar type failed:\n " - ^ lexp_string t ^ " != " - ^ lexp_string (OL.get_type ctx lxp) - ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n"); - [(CKresidual, ctx, lxp1, lxp2)] in + let type_unif_residue = + match unify t (OL.get_type ctx lxp) ctx with + | [] as r -> r + (* FIXME: Let's ignore the error for now. *) + | _ + -> log_info ?loc:None + ("Unification of metavar type failed:\n " + ^ lexp_string t ^ " != " + ^ lexp_string (OL.get_type ctx lxp) + ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n"); + [(CKresidual, ctx, lxp1, lxp2)] in + (* FIXME Here, we unify lxp1 with lxp2 again, because that + the metavariables occuring in the associated term might + have different substitutions from the corresponding + metavariables on the other side (due to subst inversion + not being a perfect inverse of subtitution application). + + For example, when unifying `?τ↑1[114]` with `(List[56] + ?ℓ↑0[117] ?a↑0[118])`, we associate the metavar ?τ[114] + with the lexp `(List[55] ?ℓ() · ↑0[117] ?a() · ↑0[118])` + (after applying the inverse substitution of ↑1), and the + lexp (?τ↑1[114]) becomes `(List[56] ?ℓ(↑1 () · ↑0)[117] + ?a(↑1 () · ↑0)[118])`, which is not exactly the same as + the right-hand side. My solution/kludge to this problem is + to do a second unification to fix the metavar + substitutions on the right-hand side, but there is + probably a cleaner way to solve this. *) + let second_unif_residue = unify lxp1 lxp2 ctx in + List.append type_unif_residue second_unif_residue in match lexp_lexp' lxp2 with | Metavar (idx2, s2, name) -> if idx = idx2 then ===================================== tests/elab_test.ml ===================================== @@ -72,4 +72,72 @@ example2 : alwaysbool (box Int); example2 = true; |} +let _ = add_elab_test_decl + "depelim with Nats" + {| +type Nat + | Z + | S Nat; + +Nat_induction : + (P : Nat -> Type_ ?l) ≡> + P Z -> + ((n : Nat) -> P n -> P (S n)) -> + ((n : Nat) -> P n); +Nat_induction base step n = + ##case_ (n + | Z => Eq_cast (p := ##DeBruijn 0) (f := P) base + | S n' => Eq_cast (p := ##DeBruijn 0) (f := P) (step n' (Nat_induction (P := P) base step n'))); + +plus : Nat -> Nat -> Nat; +plus x y = + case x + | Z => y + | S x' => S (plus x' y); + ++0_identity : (n : Nat) -> Eq (plus n Z) n; ++0_identity = + Nat_induction + (P := (lambda n -> Eq (plus n Z) n)) + Eq_refl + (lambda n-1 n-1+0=n-1 -> + Eq_cast + (p := n-1+0=n-1) + (f := lambda n-1_n -> Eq (S (plus n-1 Z)) (S n-1_n)) + Eq_refl); + |} + +let _ = add_elab_test_decl + "case conversion" + {| +unify = + macro ( + lambda sxps -> + do {vname <- gensym (); + IO_return + (quote ((uquote vname) : (uquote (Sexp_node (Sexp_symbol "##Eq") sxps)); + (uquote vname) = Eq_refl; + )); + }); + +case_ = ##case_; + +type Nat + | S Nat + | Z; + +plus : ?; +plus x y = + case x + | Z => y + | S n => S (plus n y); + +f x y b = + case b + | true => plus x y + | false => Z; + +unify (f Z (S Z)) (f (S Z) Z); + |} + let _ = run_all () ===================================== tests/eval_test.ml ===================================== @@ -427,7 +427,7 @@ Not prop = (contra : prop) ≡> False; head : (ls : List ?τ) -> (p : Not (Eq nil ls)) -> ?τ; head ls p = ##case_ (ls - | nil => unvoid (##DeBruijn 0) + | nil => unvoid (p (contra := (##DeBruijn 0))) | cons x xs => x); l = (cons 0 nil); View it on GitLab: https://gitlab.com/monnier/typer/-/compare/a5a05e7b3285a8abe9bfb12788023aa9… -- View it on GitLab: https://gitlab.com/monnier/typer/-/compare/a5a05e7b3285a8abe9bfb12788023aa9… You're receiving this email because of your account on gitlab.com.

1 0

[Git][monnier/typer][depelim] 6 commits: Add dependent elimination
by Jean-Alexandre Barszcz 14 Sep '20

14 Sep '20

Jean-Alexandre Barszcz pushed to branch depelim at Stefan / Typer Commits: 4c632a1f by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Add dependent elimination This commit changes elaboration, conversion, typechecking, erasure, and the computation of free variables and WHNFs for case expressions, to account for the fact that the context of all the branches of case expressions is extended with a proof of equality between the branch's head and the case's target. Careful elimination of this equality proof with Eq_cast makes dependent elimination possible. - - - - - b082a329 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Conversion for metavariables - - - - - fd990da1 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Case conversion - - - - - fd0d1b71 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 [WIP] Big ints in sexps and for int literals Issues to resolve: - Should we refer to the big ints module as `Z` (as done here) or as `BI`, as is done elsewhere in the codebase? - Review every use of the partial Z.to_int, to make sure that it makes sense. In particular, I am not sure about the decision to change the `Elab_*` functions to take `Integer`s instead of `Int`s. I have done this to avoid having to deal with the partiality on the Typer side, but it means that these functions could technically fail. - Should type levels be big ints? - - - - - d50f4b33 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Improve quoting - - - - - c21079e7 by Jean-Alexandre Barszcz at 2020-09-14T15:56:01-04:00 Add a macro for dependent elimination - - - - - 19 changed files: - btl/builtins.typer - btl/case.typer - + btl/depelim.typer - btl/list.typer - btl/pervasive.typer - btl/polyfun.typer - btl/tuple.typer - src/debug.ml - src/elab.ml - src/eval.ml - src/inverse_subst.ml - src/lexer.ml - src/lexp.ml - src/opslexp.ml - src/sexp.ml - tests/elab_test.ml - tests/eval_test.ml - tests/macro_test.ml - tests/unify_test.ml Changes: ===================================== btl/builtins.typer ===================================== @@ -108,11 +108,6 @@ Int_- = Built-in "Int.-" : Int -> Int -> Int; Int_* = Built-in "Int.*" : Int -> Int -> Int; Int_/ = Built-in "Int./" : Int -> Int -> Int; -_+_ = Int_+; -_-_ = Int_-; -_*_ = Int_*; -_/_ = Int_/; - %% modulo Int_mod = Built-in "Int.mod" : Int -> Int -> Int; @@ -142,6 +137,11 @@ Integer_- = Built-in "Integer.-" : Integer -> Integer -> Integer; Integer_* = Built-in "Integer.*" : Integer -> Integer -> Integer; Integer_/ = Built-in "Integer./" : Integer -> Integer -> Integer; +_+_ = Integer_+; +_-_ = Integer_-; +_*_ = Integer_*; +_/_ = Integer_/; + Integer_< = Built-in "Integer.<" : Integer -> Integer -> Bool; Integer_> = Built-in "Integer.>" : Integer -> Integer -> Bool; Integer_eq = Built-in "Integer.=" : Integer -> Integer -> Bool; @@ -367,7 +367,7 @@ Elab_isconstructor = Built-in "Elab.isconstructor" %% Check if the n'th field of a constructor is erasable %% If the constructor isn't defined it will always return false %% -Elab_is-nth-erasable = Built-in "Elab.is-nth-erasable" : String -> Int -> Elab_Context -> Bool; +Elab_is-nth-erasable = Built-in "Elab.is-nth-erasable" : String -> Integer -> Elab_Context -> Bool; %% %% Check if a field of a constructor is erasable @@ -380,14 +380,14 @@ Elab_is-arg-erasable = Built-in "Elab.is-arg-erasable" : String -> String -> Ela %% It return "_" in case the field isn't defined %% see pervasive.typer for a more convenient function %% -Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Int -> Elab_Context -> String; +Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Integer -> Elab_Context -> String; %% %% Get the position of a field in a constructor %% It return -1 in case the field isn't defined %% see pervasive.typer for a more convenient function %% -Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Int; +Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Integer; %% %% Get the docstring associated with a symbol ===================================== btl/case.typer ===================================== @@ -156,7 +156,7 @@ get-branches vars sexps = let to-case sexp = let tup-exprs : Sexp -> List Sexp; - tup-exprs sexp = if (Int_eq (List_length vars) 1) then + tup-exprs sexp = if (Integer_eq (List_length vars) 1) then (cons (expand-tuple-ctor sexp) nil) else (List_map expand-tuple-ctor (get-tup-exprs sexp)); @@ -229,7 +229,7 @@ kinds pat = let %% What I do not expect to work is a combinaison of %% arguments with name, other without name and all this in a random order %% - mf : Elab_Context -> Sexp -> Int -> Bool; + mf : Elab_Context -> Sexp -> Integer -> Bool; mf env arg i = Sexp_dispatch arg (lambda s ss -> if (Sexp_eq s (Sexp_symbol "_:=_")) then ( if (Sexp_eq (List_nth 0 ss Sexp_error) dflt-var) then @@ -283,8 +283,8 @@ renamed-pat pat names = let %% %% Get the name of the n'th element of any tuple %% - tuple-nth : Int -> Sexp; - tuple-nth n = Sexp_symbol (String_concat "%" (Int->String n)); + tuple-nth : Integer -> Sexp; + tuple-nth n = Sexp_symbol (String_concat "%" (Integer->String n)); %% %% Get the constructor of the pattern as argument @@ -304,7 +304,7 @@ renamed-pat pat names = let %% Produce code according to argument kind %% and if it already use explicit field or not %% - mf : List Bool -> Sexp -> Int -> Sexp; + mf : List Bool -> Sexp -> Integer -> Sexp; mf kinds v i = Sexp_dispatch v (lambda sym ss -> if (Sexp_eq sym (Sexp_symbol "_:=_")) @@ -421,7 +421,7 @@ introduced-vars pat = let %% It is useful to know where is the variable in `ks` to get its kind %% (kind is actualy only erasable or not) %% - ff : IO (Pair Int (List Sexp)) -> Sexp -> IO (Pair Int (List Sexp)); + ff : IO (Pair Integer (List Sexp)) -> Sexp -> IO (Pair Integer (List Sexp)); ff p v = let o = do { @@ -808,25 +808,25 @@ in case parts adjust-len : List (Pair Pats Code) -> List (Pair Pats Code); adjust-len branches = let - max-len : Int; + max-len : Integer; max-len = let - ff : Int -> Pair Pats Code -> Int; + ff : Integer -> Pair Pats Code -> Integer; ff n branch = case branch | pair pats _ => - if (Int_< n (List_length pats)) then + if (Integer_< n (List_length pats)) then (List_length pats) else (n); in List_foldl ff 0 branches; - preppend-dflt : Int -> Pair Pats Code -> Pair Pats Code; + preppend-dflt : Integer -> Pair Pats Code -> Pair Pats Code; preppend-dflt n branch = let - sup : Int -> Pats; + sup : Integer -> Pats; sup n = - if (Int_eq n 0) then + if (Integer_eq n 0) then (nil) else (cons dflt-var (sup (n - 1))); ===================================== btl/depelim.typer ===================================== @@ -0,0 +1,69 @@ +%% This macro was written for the following operators (the precedence +%% level 42 is chosen to match that of the builtin case): +%% +%% define-operator "as" 42 42; +%% define-operator "return" 42 42; + +case_as_return_impl args = + let impl target_sexp var_sexp ret_and_branches_sexp = + case Sexp_wrap ret_and_branches_sexp + | node hd (cons ret_sexp branches) => + %% TODO Check that var_sexp is a variable. + %% TODO Check that hd is the symbol `_|_`. + let + on_branch branch_sexp = + case Sexp_wrap branch_sexp + | node arrow_sexp (cons head_sexp (cons body_sexp nil)) => + %% TODO Check the arrow_sexp? + Sexp_node + arrow_sexp + (cons head_sexp + (cons (quote (##Eq\.cast + (x := uquote head_sexp) + (y := uquote target_sexp) + (p := ##DeBruijn 0) + (f := lambda (uquote var_sexp) -> + uquote ret_sexp) + (uquote body_sexp))) + nil)) + | _ => Sexp_error; %% FIXME improve error reporting + new_branches = List_map on_branch branches; + in %% We extend the builtin case, so nested patterns don't work + quote (##case_ + (uquote (Sexp_node (Sexp_symbol "_|_") + (cons target_sexp new_branches)))) + | _ => Sexp_error; + in case args + | cons target_sexp + (cons var_sexp + (cons ret_and_branches_sexp nil)) + => impl target_sexp var_sexp ret_and_branches_sexp + | cons target_sexp + (cons ret_and_branches_sexp nil) + => %% If the `as` clause is omitted, and the target is a + %% symbol, use it for `var_sexp` as well. + (case Sexp_wrap target_sexp + | symbol _ => impl target_sexp target_sexp ret_and_branches_sexp + | _ => Sexp_error) + | _ => Sexp_error; + +case_as_return_ = macro (lambda args -> IO_return (case_as_return_impl args)); +case_return_ = macro (lambda args -> IO_return (case_as_return_impl args)); + +%% Example usage + +%% type Nat +%% | Z +%% | S Nat; +%% +%% Nat_induction : +%% (P : Nat -> Type_ ?l) ≡> +%% P Z -> +%% ((n : Nat) -> P n -> P (S n)) -> +%% ((n : Nat) -> P n); +%% Nat_induction = +%% lambda l (P : Nat -> Type_ l) ≡> +%% lambda base step n -> +%% case n return (P n) %% <--- The as clause is omitted: the target is a var. +%% | Z => base +%% | S n' => (step n' (Nat_induction (P := P) base step n')); ===================================== btl/list.typer ===================================== @@ -25,14 +25,14 @@ %% Alternative (tail recursive): %% %% length xs = let -%% helper : (a : Type) ≡> Int -> List a -> Int; +%% helper : (a : Type) ≡> Integer -> List a -> Integer; %% helper len xs = case xs %% | nil => len %% | cons hd tl => helper (len + 1) tl; %% in helper 0 xs; %% %% -length : (a : Type) ≡> List a -> Int; +length : (a : Type) ≡> List a -> Integer; length xs = case xs | nil => 0 | cons hd tl => @@ -83,9 +83,9 @@ map f = lambda xs -> case xs %% %% As `map` but user's function also takes element index as last argument %% -mapi : (a : Type) ≡> (b : Type) ≡> (a -> Int -> b) -> List a -> List b; +mapi : (a : Type) ≡> (b : Type) ≡> (a -> Integer -> b) -> List a -> List b; mapi = lambda f -> lambda xs -> let - helper : (a -> Int -> b) -> Int -> List a -> List b; + helper : (a -> Integer -> b) -> Integer -> List a -> List b; helper = lambda f -> lambda i -> lambda xs -> case xs | nil => nil | cons x xs => cons (f x i) (helper f (i + 1) xs); @@ -105,9 +105,9 @@ map2 = lambda f -> lambda xs -> lambda ys -> case xs %% %% As `foldl` but user's function also takes element index as last argument %% -foldli : (a : Type) ≡> (b : Type) ≡> (a -> b -> Int -> a) -> a -> List b -> a; +foldli : (a : Type) ≡> (b : Type) ≡> (a -> b -> Integer -> a) -> a -> List b -> a; foldli = lambda f -> lambda o -> lambda xs -> let - helper : (a -> b -> Int -> a) -> Int -> a -> List b -> a; + helper : (a -> b -> Integer -> a) -> Integer -> a -> List b -> a; helper = lambda f -> lambda i -> lambda o -> lambda xs -> case xs | nil => o | cons x xs => helper f (i + 1) (f o x i) xs; @@ -144,11 +144,11 @@ find = lambda f -> lambda xs -> case xs %% %% Get the n'th element of a list or a default if the list is smaller than n %% -nth : (a : Type) ≡> Int -> List a -> a -> a; +nth : (a : Type) ≡> Integer -> List a -> a -> a; nth = lambda n -> lambda xs -> lambda d -> case xs | nil => d | cons x xs - => case Int_<= n 0 + => case Integer_<= n 0 | true => x | false => nth (n - 1) xs d; @@ -223,7 +223,7 @@ in map mf xs; empty? : (a : Type) ≡> List a -> Bool; %% %% O(N): -%% empty? = lambda xs -> Int_eq (length xs) 0; +%% empty? = lambda xs -> Integer_eq (length xs) 0; %% %% O(1): empty? = lambda xs -> case xs ===================================== btl/pervasive.typer ===================================== @@ -38,7 +38,7 @@ none = datacons Option none; %%%% List functions -List_length : List ?a -> Int; % Recursive defs aren't generalized :-( +List_length : List ?a -> Integer; % Recursive defs aren't generalized :-( List_length xs = case xs | nil => 0 | cons hd tl => @@ -76,11 +76,11 @@ List_find f = lambda xs -> case xs | nil => none | cons x xs => case f x | true => some x | false => List_find f xs; -List_nth : Int -> List ?a -> ?a -> ?a; +List_nth : Integer -> List ?a -> ?a -> ?a; List_nth = lambda n -> lambda xs -> lambda d -> case xs | nil => d | cons x xs - => case Int_<= n 0 + => case Integer_<= n 0 | true => x | false => List_nth (n - 1) xs d; @@ -150,9 +150,9 @@ List_foldl f i xs = case xs | nil => i | cons x xs => List_foldl f (f i x) xs; -List_mapi : (a : Type) ≡> (b : Type) ≡> (a -> Int -> b) -> List a -> List b; +List_mapi : (a : Type) ≡> (b : Type) ≡> (a -> Integer -> b) -> List a -> List b; List_mapi f xs = let - helper : (a -> Int -> b) -> Int -> List a -> List b; + helper : (a -> Integer -> b) -> Integer -> List a -> List b; helper f i xs = case xs | nil => nil | cons x xs => cons (f x i) (helper f (i + 1) xs); @@ -175,7 +175,7 @@ List_fold2 f o xs ys = case xs %% Is argument List empty? List_empty : List ?a -> Bool; -List_empty xs = Int_eq (List_length xs) 0; +List_empty xs = Integer_eq (List_length xs) 0; %%% Good 'ol combinators @@ -203,21 +203,30 @@ K x y = x; %% which will construct an Sexp equivalent to `x` at run-time. %% This is basically *cross stage persistence* for Sexp. quote1 : Sexp -> Sexp; -quote1 x = let k = K x; +quote1 x = let qlist : List Sexp -> Sexp; qlist xs = case xs | nil => Sexp_symbol "nil" | cons x xs => Sexp_node (Sexp_symbol "cons") (cons (quote1 x) (cons (qlist xs) nil)); + make_app str sexp = + Sexp_node (Sexp_symbol str) (cons sexp nil); + node op y = case (Sexp_eq op (Sexp_symbol "uquote")) | true => List_head Sexp_error y | false => Sexp_node (Sexp_symbol "##Sexp.node") (cons (quote1 op) (cons (qlist y) nil)); - symbol s = Sexp_node (Sexp_symbol "##Sexp.symbol") - (cons (Sexp_string s) nil) - in Sexp_dispatch x node symbol k k k k; + symbol s = make_app "##Sexp.symbol" (Sexp_string s); + string s = make_app "##Sexp.string" (Sexp_string s); + integer i = make_app "##Sexp.integer" (Sexp_integer i); + float f = make_app "##Sexp.float" (Sexp_float f); + block sxp = + %% FIXME ##Sexp.block takes a string (and prelexes + %% it) but we have a sexp, what should we do? + Sexp_symbol "<error FIXME block quoting>"; + in Sexp_dispatch x node symbol string integer float block; %% quote definition quote = macro (lambda x -> IO_return (quote1 (List_head Sexp_error x))); @@ -462,10 +471,10 @@ Decidable = typecons (Decidable (prop : Type_ ?ℓ)) (true (p ::: prop)) (false (p ::: Not prop)); %% Testing generalization in inductive type constructors. -LList : Type -> Int -> Type; %FIXME: `LList : ?` should be sufficient! -type LList (a : Type) (n : Int) +LList : Type -> Integer -> Type; %FIXME: `LList : ?` should be sufficient! +type LList (a : Type) (n : Integer) | vnil (p ::: Eq n 0) - | vcons a (LList a ?n1) (p ::: Eq n (?n1 + 1)); %FIXME: Unsound wraparound! + | vcons a (LList a ?n1) (p ::: Eq n (?n1 + 1)); %%%% If @@ -543,7 +552,7 @@ in case (String_eq r "_") %% Elab_arg-pos a b c = let r = Elab_arg-pos' a b c; -in case (Int_eq r (-1)) +in case (Integer_eq r (-1)) | true => (none) | false => (some r); @@ -634,6 +643,17 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro; %% _|_ = let lib = load "btl/polyfun.typer" in lib._|_; +%% +%% case_as_return_, case_return_ +%% A `case` for dependent elimination +%% + +define-operator "as" 42 42; +define-operator "return" 42 42; +depelim = load "btl/depelim.typer"; +case_as_return_ = depelim.case_as_return_; +case_return_ = depelim.case_return_; + %%%% Unit tests function for doing file %% It's hard to do a primitive which execute test file ===================================== btl/polyfun.typer ===================================== @@ -84,7 +84,7 @@ cases-to-sexp vars cases = let (cons pat (cons body nil)); tup : Bool; - tup = Int_< 1 (List_length vars); + tup = Integer_< 1 (List_length vars); in Sexp_node (Sexp_symbol "case_") (cons (Sexp_node (Sexp_symbol "_|_") (cons ===================================== btl/tuple.typer ===================================== @@ -66,7 +66,7 @@ gen-vars vars = io-list (List_map %% gen-tuple-names : List Sexp -> List Sexp; gen-tuple-names vars = List_mapi - (lambda _ i -> Sexp_symbol (String_concat "%" (Int->String i))) + (lambda _ i -> Sexp_symbol (String_concat "%" (Integer->String i))) vars; %% @@ -90,7 +90,7 @@ gen-deduce vars = List_map %% tuple-nth = macro (lambda args -> let - nerr = lambda _ -> (Int->Integer (-1)); + nerr = lambda _ -> (-1); %% argument `n` of this macro n : Integer; @@ -138,10 +138,10 @@ assign-tuple = macro (lambda args -> let %% map every tuple's variable %% using `tuple-nth` to assign element to variable - mf : Sexp -> Sexp -> Int -> Sexp; + mf : Sexp -> Sexp -> Integer -> Sexp; mf t arg i = Sexp_node (Sexp_symbol "_=_") (cons arg (cons (Sexp_node (Sexp_symbol "tuple-nth") - (cons t (cons (Sexp_integer (Int->Integer i)) nil))) nil)); + (cons t (cons (Sexp_integer i) nil))) nil)); in do { IO_return (Sexp_node (Sexp_symbol "_;_") (List_mapi ===================================== src/debug.ml ===================================== @@ -90,7 +90,7 @@ let rec debug_sexp_print sexp = print_string "\""; print_string str; print_string "\"" | Integer(loc, n) - -> print_info "Integer: " loc; print_int n + -> print_info "Integer: " loc; Z.print n | Float(loc, x) -> print_info "Float: " loc; print_float x ===================================== src/elab.ml ===================================== @@ -278,7 +278,7 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context = | [String (_, name); l; r] -> let level s = match s with | Symbol (_, "") -> None - | Integer (_, n) -> Some n + | Integer (_, n) -> Some (Z.to_int n) | _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in let (grm, a, b, c) = ctx in (SMap.add name (level l, level r) grm, a, b, c) @@ -467,11 +467,11 @@ let rec meta_to_var ids (e : lexp) = -> let ncases = SMap.map (fun (l, fields, e) - -> (l, fields, loop (o + List.length fields) e)) + -> (l, fields, loop (o + List.length fields + 1) e)) cases in mkCase (l, loop o e, loop o t, ncases, match default with None -> None - | Some (v, e) -> Some (v, loop (1 + o) e)) + | Some (v, e) -> Some (v, loop (2 + o) e)) | Metavar (id, s, name) -> if IMap.mem id ids then mkVar (name, o + count - IMap.find id ids) @@ -736,6 +736,10 @@ and check_case rtype (loc, target, ppatterns) ctx = (* get target and its type *) let tlxp, tltp = infer target ctx in + let tknd = OL.get_type (ectx_to_lctx ctx) tltp in + let tlvl = match OL.lexp'_whnf tknd (ectx_to_lctx ctx) with + | Sort (_, Stype l) -> l + | _ -> fatal "Target lexp's kind is not a sort" in let it_cs_as = ref None in let ltarget = ref tlxp in @@ -787,11 +791,30 @@ and check_case rtype (loc, target, ppatterns) ctx = (* Read patterns one by one *) let fold_fun (lbranches, dflt) (pat, pexp) = + let shift_to_extended_ctx nctx lexp = + mkSusp lexp (S.shift (M.length (ectx_to_lctx nctx) + - M.length (ectx_to_lctx ctx))) in + + let ctx_extend_with_eq nctx head_lexp = + (* Add a proof of equality between the target and the branch + head to the context *) + let tlxp' = shift_to_extended_ctx nctx tlxp in + let tltp' = shift_to_extended_ctx nctx tltp in + let tlvl' = shift_to_extended_ctx nctx tlvl in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl'); (* Typelevel *) + (Aerasable, tltp'); (* Inductive type *) + (Anormal, head_lexp); (* Lexp of the branch head *) + (Anormal, tlxp')]) (* Target lexp *) + in ctx_extend nctx (loc, None) Variable eqty + in + let add_default v = (if dflt != None then uniqueness_warn pat); let nctx = ctx_extend ctx v Variable tltp in - let rtype' = mkSusp rtype (S.shift (M.length (ectx_to_lctx nctx) - - M.length (ectx_to_lctx ctx))) in + let head_lexp = mkVar (v, 0) in + let nctx = ctx_extend_with_eq nctx head_lexp in + let rtype' = shift_to_extended_ctx nctx rtype in let lexp = check pexp rtype' nctx in lbranches, Some (v, lexp) in @@ -872,9 +895,15 @@ and check_case rtype (loc, target, ppatterns) ctx = make_nctx nctx (ssink var s) pargs cargs pe ((ak, var)::acc) in let nctx, fargs = make_nctx ctx subst pargs cargs SMap.empty [] in - let rtype' = mkSusp rtype - (S.shift (M.length (ectx_to_lctx nctx) - - M.length (ectx_to_lctx ctx))) in + let head_lexp_ctor = + shift_to_extended_ctx nctx + (mkCall (lctor, List.map (fun (_, a) -> (Aerasable, a)) targs)) in + let head_lexp_args = + List.mapi (fun i (ak, vname) -> + (ak, mkVar (vname, List.length fargs - i - 1))) fargs in + let head_lexp = mkCall (head_lexp_ctor, head_lexp_args) in + let nctx = ctx_extend_with_eq nctx head_lexp in + let rtype' = shift_to_extended_ctx nctx rtype in let lexp = check pexp rtype' nctx in SMap.add cons_name (loc, fargs, lexp) lbranches, dflt @@ -1567,7 +1596,7 @@ let sform_arrow kind ctx loc sargs ot = let sform_immediate ctx loc sargs ot = match sargs with | [(String _) as se] -> mkImm (se), Inferred DB.type_string - | [(Integer _) as se] -> mkImm (se), Inferred DB.type_int + | [(Integer _) as se] -> mkImm (se), Inferred DB.type_integer | [(Float _) as se] -> mkImm (se), Inferred DB.type_float | [Block (sl, pts, el)] -> let grm = ectx_get_grammar ctx in @@ -1774,7 +1803,7 @@ let sform_type ctx loc sargs ot = let sform_debruijn ctx loc sargs ot = match sargs with | [Integer (l,i)] - -> if i < 0 || i > get_size ctx then + -> let i = Z.to_int i in if i < 0 || i > get_size ctx then (sexp_error l "##DeBruijn index out of bounds"; sform_dummy_ret ctx loc) else ===================================== src/eval.ml ===================================== @@ -283,7 +283,7 @@ let make_string loc depth args_val = match args_val with | _ -> error loc "Sexp.string expects one string as argument" let make_integer loc depth args_val = match args_val with - | [Vinteger n] -> Vsexp (Integer (loc, BI.to_int n)) + | [Vinteger n] -> Vsexp (Integer (loc, n)) | _ -> error loc "Sexp.integer expects one integer as argument" let make_float loc depth args_val = match args_val with @@ -373,7 +373,7 @@ let rec eval lxp (ctx : Env.runtime_env) (trace : eval_debug_info): (value_type) match lxp with (* Leafs *) (* ---------------- *) - | Imm(Integer (_, i)) -> Vint i + | Imm(Integer (_, i)) -> Vinteger i | Imm(String (_, s)) -> Vstring s | Imm(Float (_, n)) -> Vfloat n | Imm(sxp) -> Vsexp sxp @@ -567,7 +567,7 @@ and sexp_dispatch loc depth args = | Node (op, s) -> eval_call nd [Vsexp op; o2v_list s] | Symbol (_ , s) -> eval_call sym [Vstring s] | String (_ , s) -> eval_call str [Vstring s] - | Integer (_ , i) -> eval_call it [Vint i] + | Integer (_ , i) -> eval_call it [Vinteger i] | Float (_ , f) -> eval_call flt [Vfloat f] | Block (_ , _, _) as b -> (* I think this code breaks what Blocks are. *) @@ -826,7 +826,7 @@ let is_constructor loc depth args_val = match args_val with | _ -> error loc "Elab.isconstructor takes a String and an Elab_Context as arguments" let is_nth_erasable loc depth args_val = match args_val with - | [Vstring name; Vint nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name nth_arg ectx) + | [Vstring name; Vinteger nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name (Z.to_int nth_arg) ectx) | _ -> error loc "Elab.is-nth-erasable takes a String, an Int and an Elab_Context as arguments" let is_arg_erasable loc depth args_val = match args_val with @@ -834,11 +834,11 @@ let is_arg_erasable loc depth args_val = match args_val with | _ -> error loc "Elab.is-arg-erasable takes two String and an Elab_Context as arguments" let nth_arg loc depth args_val = match args_val with - | [Vstring t; Vint nth; Velabctx ectx] -> Vstring (nth_ctor_arg t nth ectx) + | [Vstring t; Vinteger nth; Velabctx ectx] -> Vstring (nth_ctor_arg t (Z.to_int nth) ectx) | _ -> error loc "Elab.nth-arg takes a String, an Int and an Elab_Context as arguments" let arg_pos loc depth args_val = match args_val with - | [Vstring t; Vstring a; Velabctx ectx] -> Vint (ctor_arg_pos t a ectx) + | [Vstring t; Vstring a; Velabctx ectx] -> Vinteger (Z.of_int (ctor_arg_pos t a ectx)) | _ -> error loc "Elab.arg-pos takes two String and an Elab_Context as arguments" let array_append loc depth args_val = match args_val with ===================================== src/inverse_subst.ml ===================================== @@ -304,11 +304,12 @@ and apply_inv_subst (e : lexp) (s : subst) : lexp = -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, apply_inv_subst e s')) + let s'' = ssink (l, None) s' in + (l, cargs, apply_inv_subst e s'')) cases, match default with | None -> default - | Some (v,e) -> Some (v, apply_inv_subst e (ssink v s))) + | Some (v,e) -> Some (v, apply_inv_subst e (ssink (l, None) (ssink v s)))) | Metavar (id, s', name) -> match metavar_lookup id with | MVal e -> apply_inv_subst (push_susp e s') s ===================================== src/lexer.ml ===================================== @@ -58,7 +58,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos if bp >= String.length name then ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), @@ -75,7 +75,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos | _ -> ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), ===================================== src/lexp.ml ===================================== @@ -574,11 +574,11 @@ let rec push_susp e s = (* Push a suspension one level down. *) -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, mkSusp e s')) + (l, cargs, mkSusp e (ssink (l, None) s'))) cases, match default with | None -> default - | Some (v,e) -> Some (v, mkSusp e (ssink v s))) + | Some (v,e) -> Some (v, mkSusp e (ssink (l, None) (ssink v s)))) (* Susp should never appear around Var/Susp/Metavar because mkSusp * pushes the subst into them eagerly. IOW if there's a Susp(Var..) * or Susp(Metavar..) it's because some chunk of code should use mkSusp @@ -641,11 +641,12 @@ let clean e = -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, clean s' e)) + let s'' = ssink (l, None) s' in + (l, cargs, clean s'' e)) cases, match default with | None -> default - | Some (v,e) -> Some (v, clean (ssink v s) e)) + | Some (v,e) -> Some (v, clean (ssink (l, None) (ssink v s)) e)) | Susp (e, s') -> clean (scompose s' s) e | Var _ -> if S.identity_p s then e else clean S.identity (mkSusp e s) @@ -961,7 +962,7 @@ and lexp_str ctx (exp : lexp) : string = match lexp_lexp' exp with | Imm(value) -> (match value with | String (_, s) -> tval ("\"" ^ s ^ "\"") - | Integer(_, s) -> tval (string_of_int s) + | Integer(_, s) -> tval (Z.to_string s) | Float (_, s) -> tval (string_of_float s) | e -> sexp_string e) ===================================== src/opslexp.ml ===================================== @@ -38,6 +38,22 @@ module S = Subst (* module L = List *) module DB = Debruijn +type set_plexp = (lexp * lexp) list +type sort_compose_result + = SortResult of ltype + | SortInvalid + | SortK1NotType + | SortK2NotType +type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t + (* Metavars that appear in non-erasable positions. *) + * unit IMap.t + +module LMap + (* Memoization table. FIXME: Ideally the keys should be "weak", but + * I haven't found any such functionality in OCaml's libs. *) + = Hashtbl.Make + (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end) + let error_tc = Log.log_error ~section:"TC" let warning_tc = Log.log_warning ~section:"TC" @@ -133,8 +149,13 @@ let lexp_close lctx e = * return value as little as possible since WHNF will inherently introduce * call-by-name behavior. *) -let lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = +(* FIXME This large letrec closes the loop between lexp_whnf_aux and + get_type so that we can use get_type in the WHNF of a case to get + the inductive type of the target (and it's typelevel). A better + solution would be to add these values as annotations in the lexp + datatype. *) let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = + let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = match lexp_lexp' e with | Var v -> (match lookup_value ctx v with | None -> e @@ -157,6 +178,12 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = | _ -> e) (* Keep `e`, assuming it's more readable! *) | Case (l, e, rt, branches, default) -> let e' = lexp_whnf_aux e ctx in + let get_refl e = + let etype = get_type ctx e in (* FIXME we should not need get_type here *) + let elevel = match lexp'_whnf (get_type ctx etype) ctx with + | Sort (_, Stype l) -> l + | _ -> Log.internal_error "" in + mkCall (DB.eq_refl, [Aerasable, elevel; Aerasable, etype; Aerasable, e]) in let reduce it name aargs = let targs = match lexp_lexp' (lexp_whnf_aux it ctx) with | Inductive (_,_,fargs,_) -> fargs @@ -173,11 +200,14 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = (s, targs)) (S.identity, targs) aargs in + (* Substitute case Eq variable by the proof (Eq.refl l t e') *) + let subst = S.cons (get_refl e') subst in lexp_whnf_aux (push_susp branch subst) ctx with Not_found -> match default with | Some (v,default) - -> lexp_whnf_aux (push_susp default (S.substitute e')) ctx + -> let subst = S.cons (get_refl e') (S.substitute e') in + lexp_whnf_aux (push_susp default subst) ctx | _ -> Log.log_error ~section:"WHNF" ~loc:l ("Unhandled constructor " ^ name ^ "in case expression"); @@ -203,29 +233,28 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = in lexp_whnf_aux e ctx -let lexp'_whnf e (ctx : DB.lexp_context) : lexp' = +and lexp'_whnf e (ctx : DB.lexp_context) : lexp' = lexp_lexp' (lexp_whnf_aux e ctx) -let lexp_whnf e (ctx : DB.lexp_context) : lexp = +and lexp_whnf e (ctx : DB.lexp_context) : lexp = lexp_whnf_aux e ctx (** A very naive implementation of sets of pairs of lexps. *) -type set_plexp = (lexp * lexp) list -let set_empty : set_plexp = [] -let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool +and set_empty : set_plexp = [] +and set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool = try let _ = List.find (fun (e1', e2') -> L.eq e1 e1' && L.eq e2 e2') s in true with Not_found -> false -let set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp +and set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp = (* assert (not (set_member_p s e1 e2)); *) ((e1, e2) :: s) -let set_shift_n (s : set_plexp) (n : U.db_offset) +and set_shift_n (s : set_plexp) (n : U.db_offset) = List.map (let s = S.shift n in fun (e1, e2) -> (Lexp.push_susp e1 s, Lexp.push_susp e2 s)) s -let set_shift s : set_plexp = set_shift_n s 1 +and set_shift s : set_plexp = set_shift_n s 1 (********* Testing if two types are "convertible" aka "equivalent" *********) @@ -235,7 +264,7 @@ let set_shift s : set_plexp = set_shift_n s 1 * `c` is the maximum "constant" level that occurs in `e` * and `m` maps variable indices to the maxmimum depth at which they were * found. *) -let level_canon e = +and level_canon e = let add_var_depth v d ((c,m) as acc) = let o = try IMap.find v m with Not_found -> -1 in if o < d then (c, IMap.add v d m) else acc in @@ -255,14 +284,14 @@ let level_canon e = | _ -> (max_int, m) in canon e 0 (0,IMap.empty) -let level_leq (c1, m1) (c2, m2) = +and level_leq (c1, m1) (c2, m2) = c1 <= c2 && c1 != max_int && IMap.for_all (fun i d -> try d <= IMap.find i m2 with Not_found -> false) m1 (* Returns true if e₁ and e₂ are equal (upto alpha/beta/...). *) -let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = +and conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = let e1' = lexp_whnf e1 ctx in let e2' = lexp_whnf e2 ctx in e1' == e2' || @@ -330,19 +359,109 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = | _,_ -> false in l1 == l2 && conv_args ctx vs' args1 args2 | (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> l1 = l2 && conv_p t1 t2 - (* I'm not sure to understand how to compare two Metavar * - * Should I do a `lookup`? Or is it that simple: *) - (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*) - (* FIXME: Various missing cases, such as Case. *) + | (Case (_, target1, r1, cases1, def1), Case (_, target2, r2, cases2, def2)) + -> (* FIXME The termination of this case conversion is very + fragile. Indeed, we recurse in all branches, bypassing any + termination condition. Checking syntactic equality as a + base case seems to be sufficient in simple cases, but it + is probably not enough in general. *) + eq e1' e2' || ( + conv_p target1 target2 && + conv_p r1 r2 && ( + (* Compare the branches *) + (* We can arbitrarily use target1 since target1 and target2 + are convertible *) + let target = target1 in + let etype = lexp_whnf (get_type ctx target) ctx in + let ekind = get_type ctx etype in + let elvl = match lexp'_whnf ekind ctx with + | Sort (_, Stype l) -> l + | _ -> Log.log_fatal ~loc:(lexp_location ekind) + "Target lexp's kind is not a sort"; in + (* 1. Get the inductive for the field types *) + let it, aargs = match lexp_lexp' etype with + | Call (f, args) -> (f, args) + | _ -> (etype, []) in + (* 2. Build the substitution for the inductive arguments *) + let fargs, ctors = + (match lexp'_whnf it ctx with + | Inductive (_, _, fargs, constructors) + -> fargs, constructors + | _ -> Log.log_fatal ("Case of non-inductive in conv_p")) in + let fargs_subst = List.fold_left2 (fun s _farg (_, aarg) -> S.cons aarg s) + S.identity fargs aargs in + (* 3. Compare the branches *) + let ctx_extend_with_eq ctx subst hlxp = + let tlxp = mkSusp target subst in + let tltp = mkSusp etype subst in + let tlvl = mkSusp elvl subst in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl); (* Typelevel *) + (Aerasable, tltp); (* Inductive type *) + (Anormal, hlxp); (* Lexp of the branch head *) + (Anormal, tlxp)]) in (* Target lexp *) + DB.lexp_ctx_cons ctx (DB.dloc, None) Variable eqty in + (* The map module doesn't have a function to compare two + maps with the key (which is needed to get the field types + from the inductive. Instead, we work with the lists of + associations. *) + (try + List.for_all2 (fun (l1, (_, fields1, e1)) (l2, (_, fields2, e2)) -> + l1 = l2 && + let fieldtypes = SMap.find l1 ctors in + let rec mkctx ctx args s i vdefs1 vdefs2 fieldtypes = + match vdefs1, vdefs2, fieldtypes with + | [], [], [] -> Some (ctx, List.rev args, s) + | (ak1, vdef1)::vdefs1, (ak2, vdef2)::vdefs2, + (ak', vdef', ftype)::fieldtypes + -> if ak1 = ak2 && ak2 = ak' then + mkctx + (DB.lexp_ctx_cons ctx vdef1 Variable (mkSusp ftype s)) + ((ak1, (mkVar (vdef1, i)))::args) + (ssink vdef1 s) + (i - 1) + vdefs1 vdefs2 fieldtypes + else None + | _,_,_ -> None in + match mkctx ctx [] fargs_subst (List.length fields1) + fields1 fields2 fieldtypes with + | None -> false + | Some (nctx, args, _subst) -> + let offset = (List.length fields1) in + let subst = S.shift offset in + let eaargs = + List.map (fun (_, a) -> (P.Aerasable, a)) aargs in + let ctor = mkSusp (mkCall (mkCons (it, (DB.dloc, l1)), + eaargs)) subst in + let hlxp = mkCall (ctor, args) in + let nctx = ctx_extend_with_eq nctx subst hlxp in + conv_p' nctx (set_shift_n vs' (offset + 1)) e1 e2 + ) (SMap.bindings cases1) (SMap.bindings cases2) + with + | Invalid_argument _ -> false (* If the lists have different length *) + ) + && (match (def1, def2) with + | (Some (v1, e1), Some (v2, e2)) -> + let nctx = DB.lctx_extend ctx v1 Variable etype in + let subst = S.shift 1 in + let hlxp = mkVar ((DB.dloc, None), 0) in + let nctx = ctx_extend_with_eq nctx subst hlxp in + conv_p' nctx (set_shift_n vs' 2) e1 e2 + | None, None -> true + | _, _ -> false))) + | (Metavar (id1,s1,_), Metavar (id2,s2,_)) when id1 == id2 -> + (* FIXME Should we use conversion on the terms of the + substitution instead of syntactic equality? *) + subst_eq s1 s2 | (_, _) -> false -let conv_p (ctx : DB.lexp_context) e1 e2 +and conv_p (ctx : DB.lexp_context) e1 e2 = if e1 == e2 then true else conv_p' ctx set_empty e1 e2 (********* Testing if a lexp is properly typed *********) -let rec mkSLlub ctx e1 e2 = +and mkSLlub ctx e1 e2 = let lwhnf1 = lexp_whnf e1 ctx in let lwhnf2 = lexp_whnf e2 ctx in match (lexp_lexp' lwhnf1, lexp_lexp' lwhnf2) with @@ -357,13 +476,7 @@ let rec mkSLlub ctx e1 e2 = else if level_leq ce2 ce1 then e1 else mkSortLevel (mkSLlub' (e1, e2)) (* FIXME: Could be more canonical *) -type sort_compose_result - = SortResult of ltype - | SortInvalid - | SortK1NotType - | SortK2NotType - -let sort_compose ctx1 ctx2 l ak k1 k2 = +and sort_compose ctx1 ctx2 l ak k1 k2 = (* BEWARE! Technically `k2` can refer to `v`, but this should only happen * if `v` is a TypeLevel. *) let lwhnf1 = lexp'_whnf k1 ctx1 in @@ -403,11 +516,11 @@ let sort_compose ctx1 ctx2 l ak k1 k2 = | (Sort (_, _), _) -> SortK2NotType | (_, _) -> SortK1NotType -let dbset_push ak erased = +and dbset_push ak erased = let nerased = DB.set_sink 1 erased in if ak = P.Aerasable then DB.set_set 0 nerased else nerased -let nerased_let defs erased = +and nerased_let defs erased = (* Let bindings are not erasable, with the important exception of * let-bindings of the form `x = y` where `y` is an erasable var. * This exception is designed so that macros like `case` which need to @@ -433,7 +546,7 @@ let nerased_let defs erased = erased es (* "check ctx e" should return τ when "Δ ⊢ e : τ" *) -let rec check'' erased ctx e = +and check'' erased ctx e = let check = check'' in let assert_type ctx e t t' = if conv_p ctx t t' then () @@ -453,7 +566,7 @@ let rec check'' erased ctx e = s in match lexp_lexp' e with | Imm (Float (_, _)) -> DB.type_float - | Imm (Integer (_, _)) -> DB.type_int + | Imm (Integer (_, _)) -> DB.type_integer | Imm (String (_, _)) -> DB.type_string | Imm (Block (_, _, _) | Symbol _ | Node (_, _)) -> (error_tc ~loc:(lexp_location e) "Unsupported immediate value!"; @@ -608,7 +721,14 @@ let rec check'' erased ctx e = match lexp_lexp' e with | Call (f, args) -> (f, args) | _ -> (e,[]) in - let etype = lexp_whnf (check erased ctx e) ctx in + let etype = lexp_whnf (check erased ctx e) ctx in + (* FIXME save the type in the case lexp instead of recomputing + it over and over again *) + let ekind = get_type ctx etype in + let elvl = match lexp'_whnf ekind ctx with + | Sort (_, Stype l) -> l + | _ -> Log.log_error ~loc:(lexp_location ekind) + "Target lexp's kind is not a sort"; DB.level0 in let it, aargs = call_split etype in (match lexp'_whnf it ctx, aargs with | Inductive (_, _, fargs, constructors), aargs -> @@ -622,27 +742,46 @@ let rec check'' erased ctx e = | _,_ -> (error_tc ~loc:l "Wrong arg number to inductive type!"; s) in let s = mksubst S.identity fargs aargs in + let ctx_extend_with_eq ctx subst hlxp nerased = + let tlxp = mkSusp e subst in + let tltp = mkSusp etype subst in + let tlvl = mkSusp elvl subst in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl); (* Typelevel *) + (Aerasable, tltp); (* Inductive type *) + (Anormal, hlxp); (* Lexp of the branch head *) + (Anormal, tlxp)]) in (* Target lexp *) + (* The eq proof is erasable. *) + let nerased = dbset_push Aerasable nerased in + let nctx = DB.lexp_ctx_cons ctx (l, None) Variable eqty in + (nerased, nctx) in SMap.iter (fun name (l, vdefs, branch) -> let fieldtypes = SMap.find name constructors in - let rec mkctx erased ctx s vdefs fieldtypes = + let rec mkctx erased ctx s hlxp vdefs fieldtypes = match vdefs, fieldtypes with - | [], [] -> (erased, ctx) + | [], [] -> (erased, ctx, hlxp) (* FIXME: If ak is Aerasable, make sure the var only * appears in type annotations. *) | (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes -> mkctx (dbset_push ak erased) (DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s)) - (S.cons (mkVar (vdef, 0)) - (S.mkShift s 1)) + (ssink vdef s) + (mkCall (mkSusp hlxp (S.shift 1), [(ak, mkVar (vdef, 0))])) vdefs fieldtypes | _,_ -> (error_tc ~loc:l "Wrong number of args to constructor!"; - (erased, ctx)) in - let (nerased, nctx) = mkctx erased ctx s vdefs fieldtypes in + (erased, ctx, hlxp)) in + let hctor = + mkCall (mkCons (it, (l, name)), + List.map (fun (_, a) -> (P.Aerasable, a)) aargs) in + let (nerased, nctx, hlxp) = + mkctx erased ctx s hctor vdefs fieldtypes in + let subst = S.shift (List.length vdefs) in + let (nerased, nctx) = ctx_extend_with_eq nctx subst hlxp nerased in assert_type nctx branch (check nerased nctx branch) - (mkSusp ret (S.shift (List.length fieldtypes)))) + (mkSusp ret (S.shift ((List.length fieldtypes) + 1)))) branches; let diff = SMap.cardinal constructors - SMap.cardinal branches in (match default with @@ -650,8 +789,13 @@ let rec check'' erased ctx e = -> if diff <= 0 then warning_tc ~loc:l "Redundant default clause"; let nctx = (DB.lctx_extend ctx v (LetDef (0, e)) etype) in - assert_type nctx d (check (DB.set_sink 1 erased) nctx d) - (mkSusp ret (S.shift 1)) + let nerased = DB.set_sink 1 erased in + let subst = S.shift 1 in + let hlxp = mkVar ((l, None), 0) in + let (nerased, nctx) = + ctx_extend_with_eq nctx subst hlxp nerased in + assert_type nctx d (check nerased nctx d) + (mkSusp ret (S.shift 2)) | None -> if diff > 0 then error_tc ~loc:l ("Non-exhaustive match: " @@ -697,24 +841,21 @@ let rec check'' erased ctx e = check erased ctx e | MVar (_, t, _) -> push_susp t s) -let check' ctx e = +and check' ctx e = let res = check'' DB.set_empty ctx e in (Log.stop_on_error (); res) -let check = check' +and check ctx e = check' ctx e (** Compute the set of free (meta)variables. **) -let rec list_union l1 l2 = match l1 with +and list_union l1 l2 = match l1 with | [] -> l2 | (x::l1) -> list_union l1 (if List.mem x l2 then l2 else (x::l2)) -type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t - (* Metavars that appear in non-erasable positions. *) - * unit IMap.t -let mv_set_empty : mv_set = (IMap.empty, IMap.empty) -let mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes) -let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set +and mv_set_empty : mv_set = (IMap.empty, IMap.empty) +and mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes) +and mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set = (IMap.merge (fun _m oss1 oss2 -> match (oss1, oss2) with | (None, _) -> oss2 @@ -730,25 +871,19 @@ let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set Some ss1) ms1 ms2, IMap.merge (fun _m _o1 _o2 -> Some ()) nes1 nes2) -let mv_set_erase (ms, _nes) = (ms, IMap.empty) +and mv_set_erase (ms, _nes) = (ms, IMap.empty) -module LMap - (* Memoization table. FIXME: Ideally the keys should be "weak", but - * I haven't found any such functionality in OCaml's libs. *) - = Hashtbl.Make - (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end) -let fv_memo = LMap.create 1000 +and fv_memo = LMap.create 1000 -let fv_empty = (DB.set_empty, mv_set_empty) -let fv_union (fv1, mv1) (fv2, mv2) +and fv_empty = (DB.set_empty, mv_set_empty) +and fv_union (fv1, mv1) (fv2, mv2) = (DB.set_union fv1 fv2, mv_set_union mv1 mv2) -let fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs) -let fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs) -let fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs) +and fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs) +and fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs) +and fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs) -let rec fv (e : lexp) : (DB.set * mv_set) = - let fv' e = - match lexp_lexp' e with +and fv (e : lexp) : (DB.set * mv_set) = + let fv' e = match lexp_lexp' e with | Imm _ -> fv_empty | SortLevel SLz -> fv_empty | SortLevel (SLsucc e) -> fv e @@ -800,9 +935,9 @@ let rec fv (e : lexp) : (DB.set * mv_set) = -> let s = fv_union (fv e) (fv_erase (fv t)) in let s = match def with | None -> s - | Some (_, e) -> fv_union s (fv_hoist 1 (fv e)) in + | Some (_, e) -> fv_union s (fv_hoist 2 (fv e)) in SMap.fold (fun _ (_, fields, e) s - -> fv_union s (fv_hoist (List.length fields) (fv e))) + -> fv_union s (fv_hoist (List.length fields + 1) (fv e))) cases s | Metavar (id, s, name) -> (match metavar_lookup id with @@ -822,10 +957,10 @@ let rec fv (e : lexp) : (DB.set * mv_set) = (** Finding the type of a expression. **) (* This should never signal any warning/error. *) -let rec get_type ctx e = +and get_type ctx e = match lexp_lexp' e with | Imm (Float (_, _)) -> DB.type_float - | Imm (Integer (_, _)) -> DB.type_int + | Imm (Integer (_, _)) -> DB.type_integer | Imm (String (_, _)) -> DB.type_string | Imm (Block (_, _, _) | Symbol _ | Node (_, _)) -> DB.type_int | Builtin (_, t, _) -> t @@ -948,7 +1083,7 @@ let rec erase_type (lxp: lexp): E.elexp = | L.Case(l, target, _, cases, default) -> E.Case(l, (erase_type target), (clean_map cases), - (clean_maybe default)) + (clean_default default)) | L.Susp(l, s) -> erase_type (L.push_susp l s) @@ -977,10 +1112,12 @@ and filter_arg_list lst = and clean_decls decls = List.map (fun (v, lxp, _) -> (v, (erase_type lxp))) decls -and clean_maybe lxp = - match lxp with - | Some (v, lxp) -> Some (v, erase_type lxp) - | None -> None +and clean_default lxp = + match lxp with + | Some (v, lxp) -> + Some (v, + erase_type (L.push_susp lxp (S.substitute DB.type0))) + | None -> None and clean_map cases = let clean_arg_list lst = @@ -994,7 +1131,8 @@ and clean_map cases = clean_arg_list lst [] in SMap.map (fun (l, args, expr) - -> (l, (clean_arg_list args), (erase_type expr))) + -> (l, (clean_arg_list args), + erase_type (L.push_susp expr (S.substitute DB.type0)))) cases (** Turning a set of declarations into an object. **) ===================================== src/sexp.ml ===================================== @@ -27,16 +27,13 @@ open Grammar let sexp_error ?print_action loc msg = Log.log_error ~section:"SEXP" ?print_action ~loc msg -type integer = (* Num.num *) int +type integer = Z.t type symbol = location * string type sexp = (* Syntactic expression, kind of like Lisp. *) | Block of location * pretoken list * location | Symbol of symbol | String of location * string - (* FIXME: It would make a lof of sense to use a bigint here, but `compare` - * burps on Big_int objects, and `compare` is used for hash-consing of lexp - * objects which contain sexp objects as well. *) | Integer of location * integer | Float of location * float | Node of sexp * sexp list @@ -76,7 +73,7 @@ let rec sexp_string sexp = | Symbol(_, "") -> "()" (* Epsilon *) | Symbol(_, name) -> name | String(_, str) -> "\"" ^ str ^ "\"" - | Integer(_, n) -> string_of_int n + | Integer(_, n) -> Z.to_string n | Float(_, x) -> string_of_float x | Node(f, args) -> let str = "(" ^ (sexp_string f) in ===================================== tests/elab_test.ml ===================================== @@ -51,7 +51,7 @@ let add_elab_test_decl = let _ = add_elab_test_expr "Instanciate implicit arguments" ~setup:{| -f : (i : Int) -> Eq i i -> Int; +f : (i : Integer) -> Eq i i -> Integer; f = lambda i -> lambda eq -> i; |} ~expected:"f 4 (Eq_refl (x := 4));" @@ -72,4 +72,90 @@ example2 : alwaysbool (box Int); example2 = true; |} +let _ = add_elab_test_decl + "depelim with Nats" + {| +type Nat + | Z + | S Nat; + +Nat_induction : + (P : Nat -> Type_ ?l) ≡> + P Z -> + ((n : Nat) -> P n -> P (S n)) -> + ((n : Nat) -> P n); +Nat_induction base step n = + ##case_ (n + | Z => Eq_cast (p := ##DeBruijn 0) (f := P) base + | S n' => Eq_cast (p := ##DeBruijn 0) (f := P) (step n' (Nat_induction (P := P) base step n'))); + +plus : Nat -> Nat -> Nat; +plus x y = + case x + | Z => y + | S x' => S (plus x' y); + ++0_identity : (n : Nat) -> Eq (plus n Z) n; ++0_identity = + Nat_induction + (P := (lambda n -> Eq (plus n Z) n)) + Eq_refl + (lambda n-1 n-1+0=n-1 -> + Eq_cast + (p := n-1+0=n-1) + (f := lambda n-1_n -> Eq (S (plus n-1 Z)) (S n-1_n)) + Eq_refl); + |} + +let _ = add_elab_test_decl + "depelim macro" + {| +type Nat + | Z + | S Nat; + +Nat_induction : + (P : Nat -> Type_ ?l) ≡> + P Z -> + ((n : Nat) -> P n -> P (S n)) -> + ((n : Nat) -> P n); +Nat_induction base step n = + case n return (P n) + | Z => base + | S n' => (step n' (Nat_induction (P := P) base step n')); + |} + +let _ = add_elab_test_decl + "case conversion" + {| +unify = + macro ( + lambda sxps -> + do {vname <- gensym (); + IO_return + (quote ((uquote vname) : (uquote (Sexp_node (Sexp_symbol "##Eq") sxps)); + (uquote vname) = Eq_refl; + )); + }); + +case_ = ##case_; + +type Nat + | S Nat + | Z; + +plus : ?; +plus x y = + case x + | Z => y + | S n => S (plus n y); + +f x y b = + case b + | true => plus x y + | false => Z; + +unify (f Z (S Z)) (f (S Z) Z); + |} + let _ = run_all () ===================================== tests/eval_test.ml ===================================== @@ -112,7 +112,7 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Lambda" - "sqr : Int -> Int; + "sqr : Integer -> Integer; sqr = lambda x -> x * x;" "sqr 4;" (* == *) "16" @@ -120,10 +120,10 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Nested Lambda" - "sqr : Int -> Int; + "sqr : Integer -> Integer; sqr = lambda x -> x * x; - cube : Int -> Int; + cube : Integer -> Integer; cube = lambda x -> x * (sqr x);" "cube 4" (* == *) "64" @@ -148,7 +148,7 @@ let _ = test_eval_eqv_named b = (ctr2 (ctr2 ctr0)); z = 3; c = (ctr3 (ctr2 ctr0)); w = 4; - test_fun : idt -> Int; + test_fun : idt -> Integer; test_fun = lambda k -> case k | ctr1 l => 1 | ctr2 l => 2 @@ -166,7 +166,7 @@ let nat_decl = " zero = datacons Nat zero; succ = datacons Nat succ; - to-num : Nat -> Int; + to-num : Nat -> Integer; to-num = lambda (x : Nat) -> case x | (succ y) => (1 + (to-num y)) | zero => 0;" @@ -210,8 +210,8 @@ let _ = test_eval_eqv_named two = succ one; three = succ two; - even : Nat -> Int; - odd : Nat -> Int; + even : Nat -> Integer; + odd : Nat -> Integer; odd = lambda (n : Nat) -> case n | zero => 0 @@ -229,7 +229,7 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Partial Application" - "add : Int -> Int -> Int; + "add : Integer -> Integer -> Integer; add = lambda x y -> (x + y); inc1 = add 1; @@ -265,7 +265,7 @@ let _ = test_eval_eqv_named (* * Special forms *) -let _ = test_eval_eqv "w = 2" "decltype w" "Int" +let _ = test_eval_eqv "w = 2" "decltype w" "Integer" let _ = test_eval_eqv "w = 2" "declexpr w" "2" let _ = (add_test "EVAL" "Monads" (fun () -> @@ -288,9 +288,9 @@ let _ = (add_test "EVAL" "Monads" (fun () -> let _ = test_eval_eqv_named "Argument Reordering" - "fun = lambda (x : Int) => - lambda (y : Int) -> - lambda (z : Int) -> x * y + z;" + "fun = lambda (x : Integer) => + lambda (y : Integer) -> + lambda (z : Integer) -> x * y + z;" "fun (x := 3) 2 1; fun (x := 3) (z := 1) 4; @@ -312,7 +312,7 @@ let _ = test_eval_eqv_named "Metavars" let _ = test_eval_eqv_named "Explicit field patterns" "Triplet = typecons Triplet - (triplet (a ::: Int) (b :: Float) (c : String) (d :: Int)); + (triplet (a ::: Integer) (b :: Float) (c : String) (d :: Integer)); triplet = datacons Triplet triplet; t = triplet (b := 5.0) (a := 3) (d := 7) (c := \"hello\");" @@ -330,7 +330,7 @@ let _ = test_eval_eqv_named "Implicit Arguments" {| - fun = lambda (x : Int) => + fun = lambda (x : Integer) => lambda (p : Eq x x) -> x; |} @@ -344,7 +344,7 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Equalities" - "f : (α : Type) ≡> (p : Eq Int α) -> Int -> α; + "f : (α : Type) ≡> (p : Eq Integer α) -> Integer -> α; f = lambda α ≡> lambda p x -> Eq_cast (f := lambda v -> v) (p := p) x" @@ -364,7 +364,7 @@ let _ = test_eval_eqv_named Pair = typecons (Pair (a : Type) (b : Type)) (cons (x :: a) (y :: b)); - ptest : Pair Int String; + ptest : Pair Integer String; ptest = (##datacons Pair cons) (x := 4) (y := \"hello\"); px = case ptest | (##datacons ? cons) (x := v) => v; @@ -427,7 +427,7 @@ Not prop = (contra : prop) ≡> False; head : (ls : List ?τ) -> (p : Not (Eq nil ls)) -> ?τ; head ls p = ##case_ (ls - | nil => unvoid (##DeBruijn 0) + | nil => unvoid (p (contra := (##DeBruijn 0))) | cons x xs => x); l = (cons 0 nil); ===================================== tests/macro_test.ml ===================================== @@ -57,10 +57,10 @@ let _ = (add_test "MACROS" "macros base" (fun () -> let rctx, ectx = Elab.eval_decl_str dcode ectx rctx in - let ecode = "(lambda (x : Int) -> sqr 3) 5;" in + let ecode = "(lambda (x : Integer) -> sqr 3) 5;" in let ret = Elab.eval_expr_str ecode ectx rctx in - expect_equal_values ret [Vint(3 * 3)])) + expect_equal_values ret [Vinteger (Z.of_int (3 * 3))])) let _ = (add_test "MACROS" "macros decls" (fun () -> let dcode = " @@ -68,9 +68,9 @@ let _ = (add_test "MACROS" "macros decls" (fun () -> let chain-decl : Sexp -> Sexp -> Sexp; chain-decl a b = Sexp_node (Sexp_symbol \"_;_\") (cons a (cons b nil)) in - let make-decl : String -> Int -> Sexp; + let make-decl : String -> Integer -> Sexp; make-decl name val = - (Sexp_node (Sexp_symbol \"_=_\") (cons (Sexp_symbol name) (cons (Sexp_integer (Int->Integer val)) nil))) in + (Sexp_node (Sexp_symbol \"_=_\") (cons (Sexp_symbol name) (cons (Sexp_integer val) nil))) in let d1 = make-decl \"a\" 1 in let d2 = make-decl \"b\" 2 in @@ -85,7 +85,7 @@ let _ = (add_test "MACROS" "macros decls" (fun () -> let ecode = "a; b;" in let ret = Elab.eval_expr_str ecode ectx rctx in - expect_equal_values ret [Vint(1); Vint(2)])) + expect_equal_values ret [Vinteger(Z.of_int 1); Vinteger(Z.of_int 2)])) (* run all tests *) let _ = run_all () ===================================== tests/unify_test.ml ===================================== @@ -82,14 +82,14 @@ let str_int_4 = "i = 4" let str_case = "i = case true | true => 2 | false => 42" -let str_case2 = "i = case nil(a := Int) +let str_case2 = "i = case nil(a := Integer) | nil => 12 | _ => 24" let str_let = "i = let a = 5 in a + 1" let str_let2 = "j = let b = 5 in b" -let str_lambda = "sqr = lambda (x : Int) -> x * x;" -let str_lambda2 = "sqr = lambda (x : Int) -> x * x;" -let str_lambda3 = "sqr = lambda (x : Int) -> lambda (y : Int) -> x * y;" +let str_lambda = "sqr = lambda (x : Integer) -> x * x;" +let str_lambda2 = "sqr = lambda (x : Integer) -> x * x;" +let str_lambda3 = "sqr = lambda (x : Integer) -> lambda (y : Integer) -> x * y;" let str_type = "i = let j = decltype(Type) in decltype(j);" let str_type2 = "j = let i = Int -> Int in decltype(i);" @@ -128,11 +128,11 @@ let generate_testable (_: lexp list) : ((lexp * lexp * result) list) = ( mkLambda ((Anormal), (Util.dummy_location, Some "L1"), mkVar((Util.dummy_location, Some "z"), 3), - mkImm (Integer (Util.dummy_location, 3))), + mkImm (Integer (Util.dummy_location, Z.of_int 3))), mkLambda ((Anormal), (Util.dummy_location, Some "L2"), mkVar((Util.dummy_location, Some "z"), 4), - mkImm (Integer (Util.dummy_location, 3))), Nothing ) + mkImm (Integer (Util.dummy_location, Z.of_int 3))), Nothing ) ::(input_induct , input_induct , Equivalent) (* 2 *) ::(input_int_4 , input_int_4 , Equivalent) (* 3 *) View it on GitLab: https://gitlab.com/monnier/typer/-/compare/6da5889fa2f69d9ebe1dd80524178453… -- View it on GitLab: https://gitlab.com/monnier/typer/-/compare/6da5889fa2f69d9ebe1dd80524178453… You're receiving this email because of your account on gitlab.com.

1 0

[Git][monnier/typer][depelim] 28 commits: Make eval tests throw on a compilation failure.
by Jean-Alexandre Barszcz 13 Sep '20

13 Sep '20

Jean-Alexandre Barszcz pushed to branch depelim at Stefan / Typer Commits: 115d8b01 by Simon Génier at 2020-09-09T12:06:50-04:00 Make eval tests throw on a compilation failure. - - - - - e8257259 by Simon Génier at 2020-09-09T12:06:59-04:00 Remove commented eval test. - - - - - 940ade63 by Simon Génier at 2020-09-09T12:06:59-04:00 Do not print callstack of test handler. This line always print the same callstack, that of the handler, which gives no information about why the test failed. - - - - - 53c514f5 by Simon Génier at 2020-09-09T12:06:59-04:00 Actually record the backtrace of exceptions while testing. - - - - - e0d4964e by Simon Génier at 2020-09-09T12:06:59-04:00 Print compiler log on a compilation error in tests. - - - - - e290b701 by Simon Génier at 2020-09-09T12:06:59-04:00 Fix implicit arguments test. - - - - - 5f740bf1 by Simon Génier at 2020-09-09T12:06:59-04:00 Fix case test with generic types. - - - - - b6466a2b by Simon Génier at 2020-09-09T12:07:23-04:00 Fix the rest of the eval tests. - - - - - 2041b4dd by Simon Génier at 2020-09-09T12:07:34-04:00 Remove = at the end of the flags to the test driver. I think the intention was to have GNU style flags like --verbose=3, but that does not even work. - - - - - 56e4fbed by Simon Génier at 2020-09-09T13:24:41-04:00 Easier elaboration tests. I extracted these changes from another branch since I will need them for yet another. Ther should make elaboration tests easier to write. * New assertions reduce the amount of code to check the results. * Correctly restore state to be able to compare metavariables in two different code fragments. - - - - - 9d41029c by Simon Génier at 2020-09-09T13:24:48-04:00 Rework add_test to avoid warnings. - - - - - 10c27014 by Simon Génier at 2020-09-09T13:24:48-04:00 Make success and failure values. - - - - - 18f49df0 by Simon Génier at 2020-09-09T13:31:55-04:00 Make expected an optional argument in elaboration tests. - - - - - b7eb8f08 by Simon Génier at 2020-09-09T14:08:48-04:00 Fix safe head test. - - - - - a8e2af1a by Simon Génier at 2020-09-10T09:38:07-04:00 Oops: add back running tests in the order they were inserted. - - - - - a4540d14 by Simon Génier at 2020-09-10T15:47:53-04:00 Merge changes to elaboration and evaluation tests. - - - - - 4eac6264 by Simon Génier at 2020-09-10T16:05:31-04:00 Get rid of warning by using String.uppercase_ascii. This function is available since 4.03, and 4.05 is now on Debian stable so it is safe to use. - - - - - a5a05e7b by Simon Génier at 2020-09-11T17:22:08-04:00 Merge branch 'string-uppercase' into master. - - - - - c34d6d0c by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Fix an issue in the unification of metavariables The issue was that unification was not idempotent in certain cases. In particular, when unifying a metavar that has a non-identity substitution (let's say lxp1) with a term (let's say lxp2) that refers to some metavariables, the corresponding metavariable references in the associated term (thus in lxp1 after association) could have different substitutions from the same references in lxp2. See the added comment for a more detailed example. - - - - - 023ea461 by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Move the Eq builtin to debruijn.ml to make it available for elab. - - - - - b4d53239 by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Make Eq.refl available to the ocaml code * src/debruijn.ml : Add a definition of the lexp for Eq.refl * src/builtin.ml : Register the constant Eq.refl * btl/builtins.typer (Eq_refl) : Use the builtin variable ##Eq.refl instead of registering the builtin with the `Built-in` form. This ensures that we have the right variable and type, and might help to keep things in sync between the ocaml and typer code. - - - - - efe2032d by Jean-Alexandre Barszcz at 2020-09-13T17:06:35-04:00 Make the case elaboration code more consistent This commit doesn't substantially change the behavior of the case elaboration, but makes the code a bit more consistent and might save some unnecessary metavariables in some cases. - - - - - 2f295e56 by Jean-Alexandre Barszcz at 2020-09-13T17:59:43-04:00 Add dependent elimination This commit changes elaboration, conversion, typechecking, erasure, and the computation of free variables and WHNFs for case expressions, to account for the fact that the context of all the branches of case expressions is extended with a proof of equality between the branch's head and the case's target. Careful elimination of this equality proof with Eq_cast makes dependent elimination possible. - - - - - caa7bf07 by Jean-Alexandre Barszcz at 2020-09-13T22:12:25-04:00 Conversion for metavariables - - - - - 709128db by Jean-Alexandre Barszcz at 2020-09-13T22:36:27-04:00 Case conversion - - - - - 7d4c6a80 by Jean-Alexandre Barszcz at 2020-09-13T22:36:27-04:00 [WIP] Big ints in sexps and for int literals Issues to resolve: - Should we refer to the big ints module as `Z` (as done here) or as `BI`, as is done elsewhere in the codebase? - Review every use of the partial Z.to_int, to make sure that it makes sense. In particular, I am not sure about the decision to change the `Elab_*` functions to take `Integer`s instead of `Int`s. I have done this to avoid having to deal with the partiality on the Typer side, but it means that these functions could technically fail. - Should type levels be big ints? - - - - - 9e758d24 by Jean-Alexandre Barszcz at 2020-09-13T22:36:27-04:00 Improve quoting - - - - - 6da5889f by Jean-Alexandre Barszcz at 2020-09-13T22:36:28-04:00 Add a macro for dependent elimination - - - - - 30 changed files: - GNUmakefile - btl/builtins.typer - btl/case.typer - + btl/depelim.typer - btl/list.typer - btl/pervasive.typer - btl/polyfun.typer - btl/tuple.typer - src/builtin.ml - src/debruijn.ml - src/debug.ml - src/elab.ml - src/eval.ml - src/inverse_subst.ml - src/lexer.ml - src/lexp.ml - src/log.ml - src/opslexp.ml - src/sexp.ml - src/unification.ml - src/util.ml - tests/elab_test.ml - tests/env_test.ml - tests/eval_test.ml - tests/inverse_test.ml - tests/macro_test.ml - tests/sexp_test.ml - tests/unify_test.ml - tests/utest_lib.ml - tests/utest_main.ml Changes: ===================================== GNUmakefile ===================================== @@ -69,7 +69,7 @@ tests-build: $(BUILDDIR)/tests/utests tests-run: - @./$(BUILDDIR)/tests/utests --verbose= 3 + @./$(BUILDDIR)/tests/utests --verbose 3 test-file: $(OCAMLBUILD) src/test.$(COMPILE_MODE) -I src $(OBFLAGS) @@ -105,7 +105,7 @@ run/typer: @./$(BUILDDIR)/typer run/tests: - @./$(BUILDDIR)/tests/utests --verbose= 1 + @./$(BUILDDIR)/tests/utests --verbose 1 run/typer-file: @./$(BUILDDIR)/typer ./samples/test__.typer ===================================== btl/builtins.typer ===================================== @@ -48,7 +48,7 @@ Void = typecons Void; %% Eq : (l : TypeLevel) ≡> (t : Type_ l) ≡> t -> t -> Type_ l %% Eq' : (l : TypeLevel) ≡> Type_ l -> Type_ l -> Type_ l Eq_refl : ((x : ?t) ≡> Eq x x); -Eq_refl = Built-in "Eq.refl"; +Eq_refl = ##Eq\.refl; Eq_cast : (x : ?) ≡> (y : ?) ≡> (p : Eq x y) @@ -108,11 +108,6 @@ Int_- = Built-in "Int.-" : Int -> Int -> Int; Int_* = Built-in "Int.*" : Int -> Int -> Int; Int_/ = Built-in "Int./" : Int -> Int -> Int; -_+_ = Int_+; -_-_ = Int_-; -_*_ = Int_*; -_/_ = Int_/; - %% modulo Int_mod = Built-in "Int.mod" : Int -> Int -> Int; @@ -142,6 +137,11 @@ Integer_- = Built-in "Integer.-" : Integer -> Integer -> Integer; Integer_* = Built-in "Integer.*" : Integer -> Integer -> Integer; Integer_/ = Built-in "Integer./" : Integer -> Integer -> Integer; +_+_ = Integer_+; +_-_ = Integer_-; +_*_ = Integer_*; +_/_ = Integer_/; + Integer_< = Built-in "Integer.<" : Integer -> Integer -> Bool; Integer_> = Built-in "Integer.>" : Integer -> Integer -> Bool; Integer_eq = Built-in "Integer.=" : Integer -> Integer -> Bool; @@ -367,7 +367,7 @@ Elab_isconstructor = Built-in "Elab.isconstructor" %% Check if the n'th field of a constructor is erasable %% If the constructor isn't defined it will always return false %% -Elab_is-nth-erasable = Built-in "Elab.is-nth-erasable" : String -> Int -> Elab_Context -> Bool; +Elab_is-nth-erasable = Built-in "Elab.is-nth-erasable" : String -> Integer -> Elab_Context -> Bool; %% %% Check if a field of a constructor is erasable @@ -380,14 +380,14 @@ Elab_is-arg-erasable = Built-in "Elab.is-arg-erasable" : String -> String -> Ela %% It return "_" in case the field isn't defined %% see pervasive.typer for a more convenient function %% -Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Int -> Elab_Context -> String; +Elab_nth-arg' = Built-in "Elab.nth-arg" : String -> Integer -> Elab_Context -> String; %% %% Get the position of a field in a constructor %% It return -1 in case the field isn't defined %% see pervasive.typer for a more convenient function %% -Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Int; +Elab_arg-pos' = Built-in "Elab.arg-pos" : String -> String -> Elab_Context -> Integer; %% %% Get the docstring associated with a symbol ===================================== btl/case.typer ===================================== @@ -156,7 +156,7 @@ get-branches vars sexps = let to-case sexp = let tup-exprs : Sexp -> List Sexp; - tup-exprs sexp = if (Int_eq (List_length vars) 1) then + tup-exprs sexp = if (Integer_eq (List_length vars) 1) then (cons (expand-tuple-ctor sexp) nil) else (List_map expand-tuple-ctor (get-tup-exprs sexp)); @@ -229,7 +229,7 @@ kinds pat = let %% What I do not expect to work is a combinaison of %% arguments with name, other without name and all this in a random order %% - mf : Elab_Context -> Sexp -> Int -> Bool; + mf : Elab_Context -> Sexp -> Integer -> Bool; mf env arg i = Sexp_dispatch arg (lambda s ss -> if (Sexp_eq s (Sexp_symbol "_:=_")) then ( if (Sexp_eq (List_nth 0 ss Sexp_error) dflt-var) then @@ -283,8 +283,8 @@ renamed-pat pat names = let %% %% Get the name of the n'th element of any tuple %% - tuple-nth : Int -> Sexp; - tuple-nth n = Sexp_symbol (String_concat "%" (Int->String n)); + tuple-nth : Integer -> Sexp; + tuple-nth n = Sexp_symbol (String_concat "%" (Integer->String n)); %% %% Get the constructor of the pattern as argument @@ -304,7 +304,7 @@ renamed-pat pat names = let %% Produce code according to argument kind %% and if it already use explicit field or not %% - mf : List Bool -> Sexp -> Int -> Sexp; + mf : List Bool -> Sexp -> Integer -> Sexp; mf kinds v i = Sexp_dispatch v (lambda sym ss -> if (Sexp_eq sym (Sexp_symbol "_:=_")) @@ -421,7 +421,7 @@ introduced-vars pat = let %% It is useful to know where is the variable in `ks` to get its kind %% (kind is actualy only erasable or not) %% - ff : IO (Pair Int (List Sexp)) -> Sexp -> IO (Pair Int (List Sexp)); + ff : IO (Pair Integer (List Sexp)) -> Sexp -> IO (Pair Integer (List Sexp)); ff p v = let o = do { @@ -808,25 +808,25 @@ in case parts adjust-len : List (Pair Pats Code) -> List (Pair Pats Code); adjust-len branches = let - max-len : Int; + max-len : Integer; max-len = let - ff : Int -> Pair Pats Code -> Int; + ff : Integer -> Pair Pats Code -> Integer; ff n branch = case branch | pair pats _ => - if (Int_< n (List_length pats)) then + if (Integer_< n (List_length pats)) then (List_length pats) else (n); in List_foldl ff 0 branches; - preppend-dflt : Int -> Pair Pats Code -> Pair Pats Code; + preppend-dflt : Integer -> Pair Pats Code -> Pair Pats Code; preppend-dflt n branch = let - sup : Int -> Pats; + sup : Integer -> Pats; sup n = - if (Int_eq n 0) then + if (Integer_eq n 0) then (nil) else (cons dflt-var (sup (n - 1))); ===================================== btl/depelim.typer ===================================== @@ -0,0 +1,69 @@ +%% This macro was written for the following operators (the precedence +%% level 42 is chosen to match that of the builtin case): +%% +%% define-operator "as" 42 42; +%% define-operator "return" 42 42; + +case_as_return_impl args = + let impl target_sexp var_sexp ret_and_branches_sexp = + case Sexp_wrap ret_and_branches_sexp + | node hd (cons ret_sexp branches) => + %% TODO Check that var_sexp is a variable. + %% TODO Check that hd is the symbol `_|_`. + let + on_branch branch_sexp = + case Sexp_wrap branch_sexp + | node arrow_sexp (cons head_sexp (cons body_sexp nil)) => + %% TODO Check the arrow_sexp? + Sexp_node + arrow_sexp + (cons head_sexp + (cons (quote (##Eq\.cast + (x := uquote head_sexp) + (y := uquote target_sexp) + (p := ##DeBruijn 0) + (f := lambda (uquote var_sexp) -> + uquote ret_sexp) + (uquote body_sexp))) + nil)) + | _ => Sexp_error; %% FIXME improve error reporting + new_branches = List_map on_branch branches; + in %% We extend the builtin case, so nested patterns don't work + quote (##case_ + (uquote (Sexp_node (Sexp_symbol "_|_") + (cons target_sexp new_branches)))) + | _ => Sexp_error; + in case args + | cons target_sexp + (cons var_sexp + (cons ret_and_branches_sexp nil)) + => impl target_sexp var_sexp ret_and_branches_sexp + | cons target_sexp + (cons ret_and_branches_sexp nil) + => %% If the `as` clause is omitted, and the target is a + %% symbol, use it for `var_sexp` as well. + (case Sexp_wrap target_sexp + | symbol _ => impl target_sexp target_sexp ret_and_branches_sexp + | _ => Sexp_error) + | _ => Sexp_error; + +case_as_return_ = macro (lambda args -> IO_return (case_as_return_impl args)); +case_return_ = macro (lambda args -> IO_return (case_as_return_impl args)); + +%% Example usage + +%% type Nat +%% | Z +%% | S Nat; +%% +%% Nat_induction : +%% (P : Nat -> Type_ ?l) ≡> +%% P Z -> +%% ((n : Nat) -> P n -> P (S n)) -> +%% ((n : Nat) -> P n); +%% Nat_induction = +%% lambda l (P : Nat -> Type_ l) ≡> +%% lambda base step n -> +%% case n return (P n) %% <--- The as clause is omitted: the target is a var. +%% | Z => base +%% | S n' => (step n' (Nat_induction (P := P) base step n')); ===================================== btl/list.typer ===================================== @@ -25,14 +25,14 @@ %% Alternative (tail recursive): %% %% length xs = let -%% helper : (a : Type) ≡> Int -> List a -> Int; +%% helper : (a : Type) ≡> Integer -> List a -> Integer; %% helper len xs = case xs %% | nil => len %% | cons hd tl => helper (len + 1) tl; %% in helper 0 xs; %% %% -length : (a : Type) ≡> List a -> Int; +length : (a : Type) ≡> List a -> Integer; length xs = case xs | nil => 0 | cons hd tl => @@ -83,9 +83,9 @@ map f = lambda xs -> case xs %% %% As `map` but user's function also takes element index as last argument %% -mapi : (a : Type) ≡> (b : Type) ≡> (a -> Int -> b) -> List a -> List b; +mapi : (a : Type) ≡> (b : Type) ≡> (a -> Integer -> b) -> List a -> List b; mapi = lambda f -> lambda xs -> let - helper : (a -> Int -> b) -> Int -> List a -> List b; + helper : (a -> Integer -> b) -> Integer -> List a -> List b; helper = lambda f -> lambda i -> lambda xs -> case xs | nil => nil | cons x xs => cons (f x i) (helper f (i + 1) xs); @@ -105,9 +105,9 @@ map2 = lambda f -> lambda xs -> lambda ys -> case xs %% %% As `foldl` but user's function also takes element index as last argument %% -foldli : (a : Type) ≡> (b : Type) ≡> (a -> b -> Int -> a) -> a -> List b -> a; +foldli : (a : Type) ≡> (b : Type) ≡> (a -> b -> Integer -> a) -> a -> List b -> a; foldli = lambda f -> lambda o -> lambda xs -> let - helper : (a -> b -> Int -> a) -> Int -> a -> List b -> a; + helper : (a -> b -> Integer -> a) -> Integer -> a -> List b -> a; helper = lambda f -> lambda i -> lambda o -> lambda xs -> case xs | nil => o | cons x xs => helper f (i + 1) (f o x i) xs; @@ -144,11 +144,11 @@ find = lambda f -> lambda xs -> case xs %% %% Get the n'th element of a list or a default if the list is smaller than n %% -nth : (a : Type) ≡> Int -> List a -> a -> a; +nth : (a : Type) ≡> Integer -> List a -> a -> a; nth = lambda n -> lambda xs -> lambda d -> case xs | nil => d | cons x xs - => case Int_<= n 0 + => case Integer_<= n 0 | true => x | false => nth (n - 1) xs d; @@ -223,7 +223,7 @@ in map mf xs; empty? : (a : Type) ≡> List a -> Bool; %% %% O(N): -%% empty? = lambda xs -> Int_eq (length xs) 0; +%% empty? = lambda xs -> Integer_eq (length xs) 0; %% %% O(1): empty? = lambda xs -> case xs ===================================== btl/pervasive.typer ===================================== @@ -38,7 +38,7 @@ none = datacons Option none; %%%% List functions -List_length : List ?a -> Int; % Recursive defs aren't generalized :-( +List_length : List ?a -> Integer; % Recursive defs aren't generalized :-( List_length xs = case xs | nil => 0 | cons hd tl => @@ -76,11 +76,11 @@ List_find f = lambda xs -> case xs | nil => none | cons x xs => case f x | true => some x | false => List_find f xs; -List_nth : Int -> List ?a -> ?a -> ?a; +List_nth : Integer -> List ?a -> ?a -> ?a; List_nth = lambda n -> lambda xs -> lambda d -> case xs | nil => d | cons x xs - => case Int_<= n 0 + => case Integer_<= n 0 | true => x | false => List_nth (n - 1) xs d; @@ -150,9 +150,9 @@ List_foldl f i xs = case xs | nil => i | cons x xs => List_foldl f (f i x) xs; -List_mapi : (a : Type) ≡> (b : Type) ≡> (a -> Int -> b) -> List a -> List b; +List_mapi : (a : Type) ≡> (b : Type) ≡> (a -> Integer -> b) -> List a -> List b; List_mapi f xs = let - helper : (a -> Int -> b) -> Int -> List a -> List b; + helper : (a -> Integer -> b) -> Integer -> List a -> List b; helper f i xs = case xs | nil => nil | cons x xs => cons (f x i) (helper f (i + 1) xs); @@ -175,7 +175,7 @@ List_fold2 f o xs ys = case xs %% Is argument List empty? List_empty : List ?a -> Bool; -List_empty xs = Int_eq (List_length xs) 0; +List_empty xs = Integer_eq (List_length xs) 0; %%% Good 'ol combinators @@ -203,21 +203,30 @@ K x y = x; %% which will construct an Sexp equivalent to `x` at run-time. %% This is basically *cross stage persistence* for Sexp. quote1 : Sexp -> Sexp; -quote1 x = let k = K x; +quote1 x = let qlist : List Sexp -> Sexp; qlist xs = case xs | nil => Sexp_symbol "nil" | cons x xs => Sexp_node (Sexp_symbol "cons") (cons (quote1 x) (cons (qlist xs) nil)); + make_app str sexp = + Sexp_node (Sexp_symbol str) (cons sexp nil); + node op y = case (Sexp_eq op (Sexp_symbol "uquote")) | true => List_head Sexp_error y | false => Sexp_node (Sexp_symbol "##Sexp.node") (cons (quote1 op) (cons (qlist y) nil)); - symbol s = Sexp_node (Sexp_symbol "##Sexp.symbol") - (cons (Sexp_string s) nil) - in Sexp_dispatch x node symbol k k k k; + symbol s = make_app "##Sexp.symbol" (Sexp_string s); + string s = make_app "##Sexp.string" (Sexp_string s); + integer i = make_app "##Sexp.integer" (Sexp_integer i); + float f = make_app "##Sexp.float" (Sexp_float f); + block sxp = + %% FIXME ##Sexp.block takes a string (and prelexes + %% it) but we have a sexp, what should we do? + Sexp_symbol "<error FIXME block quoting>"; + in Sexp_dispatch x node symbol string integer float block; %% quote definition quote = macro (lambda x -> IO_return (quote1 (List_head Sexp_error x))); @@ -462,10 +471,10 @@ Decidable = typecons (Decidable (prop : Type_ ?ℓ)) (true (p ::: prop)) (false (p ::: Not prop)); %% Testing generalization in inductive type constructors. -LList : Type -> Int -> Type; %FIXME: `LList : ?` should be sufficient! -type LList (a : Type) (n : Int) +LList : Type -> Integer -> Type; %FIXME: `LList : ?` should be sufficient! +type LList (a : Type) (n : Integer) | vnil (p ::: Eq n 0) - | vcons a (LList a ?n1) (p ::: Eq n (?n1 + 1)); %FIXME: Unsound wraparound! + | vcons a (LList a ?n1) (p ::: Eq n (?n1 + 1)); %%%% If @@ -543,7 +552,7 @@ in case (String_eq r "_") %% Elab_arg-pos a b c = let r = Elab_arg-pos' a b c; -in case (Int_eq r (-1)) +in case (Integer_eq r (-1)) | true => (none) | false => (some r); @@ -634,6 +643,17 @@ plain-let_in_ = let lib = load "btl/plain-let.typer" in lib.plain-let-macro; %% _|_ = let lib = load "btl/polyfun.typer" in lib._|_; +%% +%% case_as_return_, case_return_ +%% A `case` for dependent elimination +%% + +define-operator "as" 42 42; +define-operator "return" 42 42; +depelim = load "btl/depelim.typer"; +case_as_return_ = depelim.case_as_return_; +case_return_ = depelim.case_return_; + %%%% Unit tests function for doing file %% It's hard to do a primitive which execute test file ===================================== btl/polyfun.typer ===================================== @@ -84,7 +84,7 @@ cases-to-sexp vars cases = let (cons pat (cons body nil)); tup : Bool; - tup = Int_< 1 (List_length vars); + tup = Integer_< 1 (List_length vars); in Sexp_node (Sexp_symbol "case_") (cons (Sexp_node (Sexp_symbol "_|_") (cons ===================================== btl/tuple.typer ===================================== @@ -66,7 +66,7 @@ gen-vars vars = io-list (List_map %% gen-tuple-names : List Sexp -> List Sexp; gen-tuple-names vars = List_mapi - (lambda _ i -> Sexp_symbol (String_concat "%" (Int->String i))) + (lambda _ i -> Sexp_symbol (String_concat "%" (Integer->String i))) vars; %% @@ -90,7 +90,7 @@ gen-deduce vars = List_map %% tuple-nth = macro (lambda args -> let - nerr = lambda _ -> (Int->Integer (-1)); + nerr = lambda _ -> (-1); %% argument `n` of this macro n : Integer; @@ -138,10 +138,10 @@ assign-tuple = macro (lambda args -> let %% map every tuple's variable %% using `tuple-nth` to assign element to variable - mf : Sexp -> Sexp -> Int -> Sexp; + mf : Sexp -> Sexp -> Integer -> Sexp; mf t arg i = Sexp_node (Sexp_symbol "_=_") (cons arg (cons (Sexp_node (Sexp_symbol "tuple-nth") - (cons t (cons (Sexp_integer (Int->Integer i)) nil))) nil)); + (cons t (cons (Sexp_integer i) nil))) nil)); in do { IO_return (Sexp_node (Sexp_symbol "_;_") (List_mapi ===================================== src/builtin.ml ===================================== @@ -99,19 +99,6 @@ let dloc = DB.dloc let op_binary t = mkArrow (Anormal, (dloc, None), t, dloc, mkArrow (Anormal, (dloc, None), t, dloc, t)) -let type_eq = - let lv = (dloc, Some "l") in - let tv = (dloc, Some "t") in - mkArrow (Aerasable, lv, - DB.type_level, dloc, - mkArrow (Aerasable, tv, - mkSort (dloc, Stype (mkVar (lv, 0))), dloc, - mkArrow (Anormal, (dloc, None), - mkVar (tv, 0), dloc, - mkArrow (Anormal, (dloc, None), - mkVar (tv, 1), dloc, - mkSort (dloc, Stype (mkVar (lv, 3))))))) - let o2l_bool ctx b = get_predef (if b then "true" else "false") ctx (* Typer list as seen during runtime. *) @@ -161,7 +148,9 @@ let register_builtin_csts () = add_builtin_cst "Integer" DB.type_integer; add_builtin_cst "Float" DB.type_float; add_builtin_cst "String" DB.type_string; - add_builtin_cst "Elab_Context" DB.type_elabctx + add_builtin_cst "Elab_Context" DB.type_elabctx; + add_builtin_cst "Eq" DB.type_eq; + add_builtin_cst "Eq.refl" DB.eq_refl let register_builtin_types () = let _ = new_builtin_type "Sexp" DB.type0 in @@ -175,7 +164,6 @@ let register_builtin_types () = "Array" (mkArrow (Anormal, (dloc, None), DB.type0, dloc, DB.type0)) in let _ = new_builtin_type "FileHandle" DB.type0 in - let _ = new_builtin_type "Eq" type_eq in () let _ = register_builtin_csts (); ===================================== src/debruijn.ml ===================================== @@ -96,6 +96,37 @@ let type_integer = mkBuiltin ((dloc, "Integer"), type0, None) let type_float = mkBuiltin ((dloc, "Float"), type0, None) let type_string = mkBuiltin ((dloc, "String"), type0, None) let type_elabctx = mkBuiltin ((dloc, "Elab_Context"), type0, None) +let type_eq_type = + let lv = (dloc, Some "l") in + let tv = (dloc, Some "t") in + mkArrow (Aerasable, lv, + type_level, dloc, + mkArrow (Aerasable, tv, + mkSort (dloc, Stype (mkVar (lv, 0))), dloc, + mkArrow (Anormal, (dloc, None), + mkVar (tv, 0), dloc, + mkArrow (Anormal, (dloc, None), + mkVar (tv, 1), dloc, + mkSort (dloc, Stype (mkVar (lv, 3))))))) +let type_eq = mkBuiltin ((dloc, "Eq"), type_eq_type, None) +let eq_refl = + let lv = (dloc, Some "l") in + let tv = (dloc, Some "t") in + let xv = (dloc, Some "x") in + mkBuiltin ((dloc, "Eq.refl"), + mkArrow (Aerasable, lv, + type_level, dloc, + mkArrow (Aerasable, tv, + mkSort (dloc, Stype (mkVar (lv, 0))), dloc, + mkArrow (Aerasable, xv, + mkVar (tv, 0), dloc, + mkCall (type_eq, + [Aerasable, mkVar (lv, 2); + Aerasable, mkVar (tv, 1); + Anormal, mkVar (xv, 0); + Anormal, mkVar (xv, 0)])))), + None) + (* easier to debug with type annotations *) type env_elem = (vname * varbind * ltype) ===================================== src/debug.ml ===================================== @@ -90,7 +90,7 @@ let rec debug_sexp_print sexp = print_string "\""; print_string str; print_string "\"" | Integer(loc, n) - -> print_info "Integer: " loc; print_int n + -> print_info "Integer: " loc; Z.print n | Float(loc, x) -> print_info "Float: " loc; print_float x ===================================== src/elab.ml ===================================== @@ -278,7 +278,7 @@ let sdform_define_operator (ctx : elab_context) loc sargs _ot : elab_context = | [String (_, name); l; r] -> let level s = match s with | Symbol (_, "") -> None - | Integer (_, n) -> Some n + | Integer (_, n) -> Some (Z.to_int n) | _ -> sexp_error (sexp_location s) "Expecting an integer or ()"; None in let (grm, a, b, c) = ctx in (SMap.add name (level l, level r) grm, a, b, c) @@ -467,11 +467,11 @@ let rec meta_to_var ids (e : lexp) = -> let ncases = SMap.map (fun (l, fields, e) - -> (l, fields, loop (o + List.length fields) e)) + -> (l, fields, loop (o + List.length fields + 1) e)) cases in mkCase (l, loop o e, loop o t, ncases, match default with None -> None - | Some (v, e) -> Some (v, loop (1 + o) e)) + | Some (v, e) -> Some (v, loop (2 + o) e)) | Metavar (id, s, name) -> if IMap.mem id ids then mkVar (name, o + count - IMap.find id ids) @@ -736,20 +736,24 @@ and check_case rtype (loc, target, ppatterns) ctx = (* get target and its type *) let tlxp, tltp = infer target ctx in + let tknd = OL.get_type (ectx_to_lctx ctx) tltp in + let tlvl = match OL.lexp'_whnf tknd (ectx_to_lctx ctx) with + | Sort (_, Stype l) -> l + | _ -> fatal "Target lexp's kind is not a sort" in let it_cs_as = ref None in let ltarget = ref tlxp in let get_cs_as it' lctor = + let unify_ind expected actual = + match Unif.unify actual expected (ectx_to_lctx ctx) with + | (_::_) + -> lexp_error loc lctor + ("Expected pattern of type `" ^ lexp_string expected + ^ "` but got `" ^ lexp_string actual ^ "`") + | [] -> () in match !it_cs_as with | Some (it, cs, args) - -> let _ = match Unif.unify it' it (ectx_to_lctx ctx) with - | (_::_) - -> lexp_error loc lctor - ("Expected pattern of type `" - ^ lexp_string it ^ "` but got `" - ^ lexp_string it' ^ "`") - | [] -> () in - (cs, args) + -> unify_ind it it'; (cs, args) | None -> match OL.lexp'_whnf it' (ectx_to_lctx ctx) with | Inductive (_, _, fargs, constructors) @@ -771,8 +775,9 @@ and check_case rtype (loc, target, ppatterns) ctx = | Call (f, args) -> (f, args) | _ -> (e,[]) in let (it, targs) = call_split tltp in + unify_ind it it'; let constructors = - match OL.lexp'_whnf it (ectx_to_lctx ctx) with + match OL.lexp'_whnf it (ectx_to_lctx ctx) with | Inductive (_, _, fargs, constructors) -> assert (List.length fargs = List.length targs); constructors @@ -780,16 +785,36 @@ and check_case rtype (loc, target, ppatterns) ctx = ("Can't `case` on objects of this type: " ^ lexp_string tltp); SMap.empty in + it_cs_as := Some (it, constructors, targs); (constructors, targs) in (* Read patterns one by one *) let fold_fun (lbranches, dflt) (pat, pexp) = + let shift_to_extended_ctx nctx lexp = + mkSusp lexp (S.shift (M.length (ectx_to_lctx nctx) + - M.length (ectx_to_lctx ctx))) in + + let ctx_extend_with_eq nctx head_lexp = + (* Add a proof of equality between the target and the branch + head to the context *) + let tlxp' = shift_to_extended_ctx nctx tlxp in + let tltp' = shift_to_extended_ctx nctx tltp in + let tlvl' = shift_to_extended_ctx nctx tlvl in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl'); (* Typelevel *) + (Aerasable, tltp'); (* Inductive type *) + (Anormal, head_lexp); (* Lexp of the branch head *) + (Anormal, tlxp')]) (* Target lexp *) + in ctx_extend nctx (loc, None) Variable eqty + in + let add_default v = (if dflt != None then uniqueness_warn pat); let nctx = ctx_extend ctx v Variable tltp in - let rtype' = mkSusp rtype (S.shift (M.length (ectx_to_lctx nctx) - - M.length (ectx_to_lctx ctx))) in + let head_lexp = mkVar (v, 0) in + let nctx = ctx_extend_with_eq nctx head_lexp in + let rtype' = shift_to_extended_ctx nctx rtype in let lexp = check pexp rtype' nctx in lbranches, Some (v, lexp) in @@ -870,9 +895,15 @@ and check_case rtype (loc, target, ppatterns) ctx = make_nctx nctx (ssink var s) pargs cargs pe ((ak, var)::acc) in let nctx, fargs = make_nctx ctx subst pargs cargs SMap.empty [] in - let rtype' = mkSusp rtype - (S.shift (M.length (ectx_to_lctx nctx) - - M.length (ectx_to_lctx ctx))) in + let head_lexp_ctor = + shift_to_extended_ctx nctx + (mkCall (lctor, List.map (fun (_, a) -> (Aerasable, a)) targs)) in + let head_lexp_args = + List.mapi (fun i (ak, vname) -> + (ak, mkVar (vname, List.length fargs - i - 1))) fargs in + let head_lexp = mkCall (head_lexp_ctor, head_lexp_args) in + let nctx = ctx_extend_with_eq nctx head_lexp in + let rtype' = shift_to_extended_ctx nctx rtype in let lexp = check pexp rtype' nctx in SMap.add cons_name (loc, fargs, lexp) lbranches, dflt @@ -1565,7 +1596,7 @@ let sform_arrow kind ctx loc sargs ot = let sform_immediate ctx loc sargs ot = match sargs with | [(String _) as se] -> mkImm (se), Inferred DB.type_string - | [(Integer _) as se] -> mkImm (se), Inferred DB.type_int + | [(Integer _) as se] -> mkImm (se), Inferred DB.type_integer | [(Float _) as se] -> mkImm (se), Inferred DB.type_float | [Block (sl, pts, el)] -> let grm = ectx_get_grammar ctx in @@ -1772,7 +1803,7 @@ let sform_type ctx loc sargs ot = let sform_debruijn ctx loc sargs ot = match sargs with | [Integer (l,i)] - -> if i < 0 || i > get_size ctx then + -> let i = Z.to_int i in if i < 0 || i > get_size ctx then (sexp_error l "##DeBruijn index out of bounds"; sform_dummy_ret ctx loc) else @@ -1945,21 +1976,19 @@ let default_rctx = EV.from_ectx default_ectx * --------------------------------------------------------- *) let lexp_expr_str str ctx = - try let tenv = default_stt in - let grm = ectx_get_grammar ctx in - let limit = Some ";" in - let pxps = sexp_parse_str str tenv grm limit in - let lexps = lexp_parse_all pxps ctx in - List.iter (fun lxp -> ignore (OL.check (ectx_to_lctx ctx) lxp)) - lexps; - lexps - with Log.Stop_Compilation s -> [] + let tenv = default_stt in + let grm = ectx_get_grammar ctx in + let limit = Some ";" in + let pxps = sexp_parse_str str tenv grm limit in + let lexps = lexp_parse_all pxps ctx in + List.iter (fun lxp -> ignore (OL.check (ectx_to_lctx ctx) lxp)) + lexps; + lexps let lexp_decl_str str ctx = - try let tenv = default_stt in - let tokens = lex_str str tenv in - lexp_p_decls [] tokens ctx - with Log.Stop_Compilation s -> ([],ctx) + let tenv = default_stt in + let tokens = lex_str str tenv in + lexp_p_decls [] tokens ctx (* Eval String @@ -1967,15 +1996,11 @@ let lexp_decl_str str ctx = (* Because we cant include Elab in eval.ml *) let eval_expr_str str lctx rctx = - try let lxps = lexp_expr_str str lctx in - let elxps = List.map OL.erase_type lxps in - EV.eval_all elxps rctx false - with Log.Stop_Compilation s -> [] + let lxps = lexp_expr_str str lctx in + let elxps = List.map OL.erase_type lxps in + EV.eval_all elxps rctx false let eval_decl_str str lctx rctx = - let prev_lctx, prev_rctx = lctx, rctx in - try - let lxps, lctx = lexp_decl_str str lctx in - let elxps = (List.map OL.clean_decls lxps) in - (EV.eval_decls_toplevel elxps rctx), lctx - with Log.Stop_Compilation s -> (prev_rctx, prev_lctx) + let lxps, lctx = lexp_decl_str str lctx in + let elxps = List.map OL.clean_decls lxps in + (EV.eval_decls_toplevel elxps rctx), lctx ===================================== src/eval.ml ===================================== @@ -283,7 +283,7 @@ let make_string loc depth args_val = match args_val with | _ -> error loc "Sexp.string expects one string as argument" let make_integer loc depth args_val = match args_val with - | [Vinteger n] -> Vsexp (Integer (loc, BI.to_int n)) + | [Vinteger n] -> Vsexp (Integer (loc, n)) | _ -> error loc "Sexp.integer expects one integer as argument" let make_float loc depth args_val = match args_val with @@ -373,7 +373,7 @@ let rec eval lxp (ctx : Env.runtime_env) (trace : eval_debug_info): (value_type) match lxp with (* Leafs *) (* ---------------- *) - | Imm(Integer (_, i)) -> Vint i + | Imm(Integer (_, i)) -> Vinteger i | Imm(String (_, s)) -> Vstring s | Imm(Float (_, n)) -> Vfloat n | Imm(sxp) -> Vsexp sxp @@ -567,7 +567,7 @@ and sexp_dispatch loc depth args = | Node (op, s) -> eval_call nd [Vsexp op; o2v_list s] | Symbol (_ , s) -> eval_call sym [Vstring s] | String (_ , s) -> eval_call str [Vstring s] - | Integer (_ , i) -> eval_call it [Vint i] + | Integer (_ , i) -> eval_call it [Vinteger i] | Float (_ , f) -> eval_call flt [Vfloat f] | Block (_ , _, _) as b -> (* I think this code breaks what Blocks are. *) @@ -826,7 +826,7 @@ let is_constructor loc depth args_val = match args_val with | _ -> error loc "Elab.isconstructor takes a String and an Elab_Context as arguments" let is_nth_erasable loc depth args_val = match args_val with - | [Vstring name; Vint nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name nth_arg ectx) + | [Vstring name; Vinteger nth_arg; Velabctx ectx] -> o2v_bool (erasable_p name (Z.to_int nth_arg) ectx) | _ -> error loc "Elab.is-nth-erasable takes a String, an Int and an Elab_Context as arguments" let is_arg_erasable loc depth args_val = match args_val with @@ -834,11 +834,11 @@ let is_arg_erasable loc depth args_val = match args_val with | _ -> error loc "Elab.is-arg-erasable takes two String and an Elab_Context as arguments" let nth_arg loc depth args_val = match args_val with - | [Vstring t; Vint nth; Velabctx ectx] -> Vstring (nth_ctor_arg t nth ectx) + | [Vstring t; Vinteger nth; Velabctx ectx] -> Vstring (nth_ctor_arg t (Z.to_int nth) ectx) | _ -> error loc "Elab.nth-arg takes a String, an Int and an Elab_Context as arguments" let arg_pos loc depth args_val = match args_val with - | [Vstring t; Vstring a; Velabctx ectx] -> Vint (ctor_arg_pos t a ectx) + | [Vstring t; Vstring a; Velabctx ectx] -> Vinteger (Z.of_int (ctor_arg_pos t a ectx)) | _ -> error loc "Elab.arg-pos takes two String and an Elab_Context as arguments" let array_append loc depth args_val = match args_val with ===================================== src/inverse_subst.ml ===================================== @@ -304,11 +304,12 @@ and apply_inv_subst (e : lexp) (s : subst) : lexp = -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, apply_inv_subst e s')) + let s'' = ssink (l, None) s' in + (l, cargs, apply_inv_subst e s'')) cases, match default with | None -> default - | Some (v,e) -> Some (v, apply_inv_subst e (ssink v s))) + | Some (v,e) -> Some (v, apply_inv_subst e (ssink (l, None) (ssink v s)))) | Metavar (id, s', name) -> match metavar_lookup id with | MVal e -> apply_inv_subst (push_susp e s') s ===================================== src/lexer.ml ===================================== @@ -58,7 +58,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos if bp >= String.length name then ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), @@ -75,7 +75,7 @@ let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos | _ -> ((if np == NPint then Integer ({file;line;column=column+cpos;docstr=docstr}, - int_of_string (string_sub name bpos bp)) + Z.of_string (string_sub name bpos bp)) else Float ({file;line;column=column+cpos;docstr=docstr}, float_of_string (string_sub name bpos bp))), ===================================== src/lexp.ml ===================================== @@ -574,11 +574,11 @@ let rec push_susp e s = (* Push a suspension one level down. *) -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, mkSusp e s')) + (l, cargs, mkSusp e (ssink (l, None) s'))) cases, match default with | None -> default - | Some (v,e) -> Some (v, mkSusp e (ssink v s))) + | Some (v,e) -> Some (v, mkSusp e (ssink (l, None) (ssink v s)))) (* Susp should never appear around Var/Susp/Metavar because mkSusp * pushes the subst into them eagerly. IOW if there's a Susp(Var..) * or Susp(Metavar..) it's because some chunk of code should use mkSusp @@ -641,11 +641,12 @@ let clean e = -> let s' = L.fold_left (fun s (_,ov) -> ssink ov s) s cargs in - (l, cargs, clean s' e)) + let s'' = ssink (l, None) s' in + (l, cargs, clean s'' e)) cases, match default with | None -> default - | Some (v,e) -> Some (v, clean (ssink v s) e)) + | Some (v,e) -> Some (v, clean (ssink (l, None) (ssink v s)) e)) | Susp (e, s') -> clean (scompose s' s) e | Var _ -> if S.identity_p s then e else clean S.identity (mkSusp e s) @@ -961,7 +962,7 @@ and lexp_str ctx (exp : lexp) : string = match lexp_lexp' exp with | Imm(value) -> (match value with | String (_, s) -> tval ("\"" ^ s ^ "\"") - | Integer(_, s) -> tval (string_of_int s) + | Integer(_, s) -> tval (Z.to_string s) | Float (_, s) -> tval (string_of_float s) | e -> sexp_string e) ===================================== src/log.ml ===================================== @@ -47,7 +47,7 @@ let string_of_level lvl = | Debug -> "Debug" let level_of_string str = - match Util.string_uppercase str with + match String.uppercase_ascii str with | "NOTHING" -> Nothing | "FATAL" -> Fatal | "ERROR" -> Error ===================================== src/opslexp.ml ===================================== @@ -38,6 +38,22 @@ module S = Subst (* module L = List *) module DB = Debruijn +type set_plexp = (lexp * lexp) list +type sort_compose_result + = SortResult of ltype + | SortInvalid + | SortK1NotType + | SortK2NotType +type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t + (* Metavars that appear in non-erasable positions. *) + * unit IMap.t + +module LMap + (* Memoization table. FIXME: Ideally the keys should be "weak", but + * I haven't found any such functionality in OCaml's libs. *) + = Hashtbl.Make + (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end) + let error_tc = Log.log_error ~section:"TC" let warning_tc = Log.log_warning ~section:"TC" @@ -133,8 +149,13 @@ let lexp_close lctx e = * return value as little as possible since WHNF will inherently introduce * call-by-name behavior. *) -let lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = +(* FIXME This large letrec closes the loop between lexp_whnf_aux and + get_type so that we can use get_type in the WHNF of a case to get + the inductive type of the target (and it's typelevel). A better + solution would be to add these values as annotations in the lexp + datatype. *) let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = + let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = match lexp_lexp' e with | Var v -> (match lookup_value ctx v with | None -> e @@ -157,6 +178,12 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = | _ -> e) (* Keep `e`, assuming it's more readable! *) | Case (l, e, rt, branches, default) -> let e' = lexp_whnf_aux e ctx in + let get_refl e = + let etype = get_type ctx e in (* FIXME we should not need get_type here *) + let elevel = match lexp'_whnf (get_type ctx etype) ctx with + | Sort (_, Stype l) -> l + | _ -> Log.internal_error "" in + mkCall (DB.eq_refl, [Aerasable, elevel; Aerasable, etype; Aerasable, e]) in let reduce it name aargs = let targs = match lexp_lexp' (lexp_whnf_aux it ctx) with | Inductive (_,_,fargs,_) -> fargs @@ -173,11 +200,14 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = (s, targs)) (S.identity, targs) aargs in + (* Substitute case Eq variable by the proof (Eq.refl l t e') *) + let subst = S.cons (get_refl e') subst in lexp_whnf_aux (push_susp branch subst) ctx with Not_found -> match default with | Some (v,default) - -> lexp_whnf_aux (push_susp default (S.substitute e')) ctx + -> let subst = S.cons (get_refl e') (S.substitute e') in + lexp_whnf_aux (push_susp default subst) ctx | _ -> Log.log_error ~section:"WHNF" ~loc:l ("Unhandled constructor " ^ name ^ "in case expression"); @@ -203,29 +233,28 @@ let rec lexp_whnf_aux e (ctx : DB.lexp_context) : lexp = in lexp_whnf_aux e ctx -let lexp'_whnf e (ctx : DB.lexp_context) : lexp' = +and lexp'_whnf e (ctx : DB.lexp_context) : lexp' = lexp_lexp' (lexp_whnf_aux e ctx) -let lexp_whnf e (ctx : DB.lexp_context) : lexp = +and lexp_whnf e (ctx : DB.lexp_context) : lexp = lexp_whnf_aux e ctx (** A very naive implementation of sets of pairs of lexps. *) -type set_plexp = (lexp * lexp) list -let set_empty : set_plexp = [] -let set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool +and set_empty : set_plexp = [] +and set_member_p (s : set_plexp) (e1 : lexp) (e2 : lexp) : bool = try let _ = List.find (fun (e1', e2') -> L.eq e1 e1' && L.eq e2 e2') s in true with Not_found -> false -let set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp +and set_add (s : set_plexp) (e1 : lexp) (e2 : lexp) : set_plexp = (* assert (not (set_member_p s e1 e2)); *) ((e1, e2) :: s) -let set_shift_n (s : set_plexp) (n : U.db_offset) +and set_shift_n (s : set_plexp) (n : U.db_offset) = List.map (let s = S.shift n in fun (e1, e2) -> (Lexp.push_susp e1 s, Lexp.push_susp e2 s)) s -let set_shift s : set_plexp = set_shift_n s 1 +and set_shift s : set_plexp = set_shift_n s 1 (********* Testing if two types are "convertible" aka "equivalent" *********) @@ -235,7 +264,7 @@ let set_shift s : set_plexp = set_shift_n s 1 * `c` is the maximum "constant" level that occurs in `e` * and `m` maps variable indices to the maxmimum depth at which they were * found. *) -let level_canon e = +and level_canon e = let add_var_depth v d ((c,m) as acc) = let o = try IMap.find v m with Not_found -> -1 in if o < d then (c, IMap.add v d m) else acc in @@ -255,14 +284,14 @@ let level_canon e = | _ -> (max_int, m) in canon e 0 (0,IMap.empty) -let level_leq (c1, m1) (c2, m2) = +and level_leq (c1, m1) (c2, m2) = c1 <= c2 && c1 != max_int && IMap.for_all (fun i d -> try d <= IMap.find i m2 with Not_found -> false) m1 (* Returns true if e₁ and e₂ are equal (upto alpha/beta/...). *) -let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = +and conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = let e1' = lexp_whnf e1 ctx in let e2' = lexp_whnf e2 ctx in e1' == e2' || @@ -330,19 +359,109 @@ let rec conv_p' (ctx : DB.lexp_context) (vs : set_plexp) e1 e2 : bool = | _,_ -> false in l1 == l2 && conv_args ctx vs' args1 args2 | (Cons (t1, (_, l1)), Cons (t2, (_, l2))) -> l1 = l2 && conv_p t1 t2 - (* I'm not sure to understand how to compare two Metavar * - * Should I do a `lookup`? Or is it that simple: *) - (*| (Metavar (id1,_,_), Metavar (id2,_,_)) -> id1 = id2*) - (* FIXME: Various missing cases, such as Case. *) + | (Case (_, target1, r1, cases1, def1), Case (_, target2, r2, cases2, def2)) + -> (* FIXME The termination of this case conversion is very + fragile. Indeed, we recurse in all branches, bypassing any + termination condition. Checking syntactic equality as a + base case seems to be sufficient in simple cases, but it + is probably not enough in general. *) + eq e1' e2' || ( + conv_p target1 target2 && + conv_p r1 r2 && ( + (* Compare the branches *) + (* We can arbitrarily use target1 since target1 and target2 + are convertible *) + let target = target1 in + let etype = lexp_whnf (get_type ctx target) ctx in + let ekind = get_type ctx etype in + let elvl = match lexp'_whnf ekind ctx with + | Sort (_, Stype l) -> l + | _ -> Log.log_fatal ~loc:(lexp_location ekind) + "Target lexp's kind is not a sort"; in + (* 1. Get the inductive for the field types *) + let it, aargs = match lexp_lexp' etype with + | Call (f, args) -> (f, args) + | _ -> (etype, []) in + (* 2. Build the substitution for the inductive arguments *) + let fargs, ctors = + (match lexp'_whnf it ctx with + | Inductive (_, _, fargs, constructors) + -> fargs, constructors + | _ -> Log.log_fatal ("Case of non-inductive in conv_p")) in + let fargs_subst = List.fold_left2 (fun s _farg (_, aarg) -> S.cons aarg s) + S.identity fargs aargs in + (* 3. Compare the branches *) + let ctx_extend_with_eq ctx subst hlxp = + let tlxp = mkSusp target subst in + let tltp = mkSusp etype subst in + let tlvl = mkSusp elvl subst in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl); (* Typelevel *) + (Aerasable, tltp); (* Inductive type *) + (Anormal, hlxp); (* Lexp of the branch head *) + (Anormal, tlxp)]) in (* Target lexp *) + DB.lexp_ctx_cons ctx (DB.dloc, None) Variable eqty in + (* The map module doesn't have a function to compare two + maps with the key (which is needed to get the field types + from the inductive. Instead, we work with the lists of + associations. *) + (try + List.for_all2 (fun (l1, (_, fields1, e1)) (l2, (_, fields2, e2)) -> + l1 = l2 && + let fieldtypes = SMap.find l1 ctors in + let rec mkctx ctx args s i vdefs1 vdefs2 fieldtypes = + match vdefs1, vdefs2, fieldtypes with + | [], [], [] -> Some (ctx, List.rev args, s) + | (ak1, vdef1)::vdefs1, (ak2, vdef2)::vdefs2, + (ak', vdef', ftype)::fieldtypes + -> if ak1 = ak2 && ak2 = ak' then + mkctx + (DB.lexp_ctx_cons ctx vdef1 Variable (mkSusp ftype s)) + ((ak1, (mkVar (vdef1, i)))::args) + (ssink vdef1 s) + (i - 1) + vdefs1 vdefs2 fieldtypes + else None + | _,_,_ -> None in + match mkctx ctx [] fargs_subst (List.length fields1) + fields1 fields2 fieldtypes with + | None -> false + | Some (nctx, args, _subst) -> + let offset = (List.length fields1) in + let subst = S.shift offset in + let eaargs = + List.map (fun (_, a) -> (P.Aerasable, a)) aargs in + let ctor = mkSusp (mkCall (mkCons (it, (DB.dloc, l1)), + eaargs)) subst in + let hlxp = mkCall (ctor, args) in + let nctx = ctx_extend_with_eq nctx subst hlxp in + conv_p' nctx (set_shift_n vs' (offset + 1)) e1 e2 + ) (SMap.bindings cases1) (SMap.bindings cases2) + with + | Invalid_argument _ -> false (* If the lists have different length *) + ) + && (match (def1, def2) with + | (Some (v1, e1), Some (v2, e2)) -> + let nctx = DB.lctx_extend ctx v1 Variable etype in + let subst = S.shift 1 in + let hlxp = mkVar ((DB.dloc, None), 0) in + let nctx = ctx_extend_with_eq nctx subst hlxp in + conv_p' nctx (set_shift_n vs' 2) e1 e2 + | None, None -> true + | _, _ -> false))) + | (Metavar (id1,s1,_), Metavar (id2,s2,_)) when id1 == id2 -> + (* FIXME Should we use conversion on the terms of the + substitution instead of syntactic equality? *) + subst_eq s1 s2 | (_, _) -> false -let conv_p (ctx : DB.lexp_context) e1 e2 +and conv_p (ctx : DB.lexp_context) e1 e2 = if e1 == e2 then true else conv_p' ctx set_empty e1 e2 (********* Testing if a lexp is properly typed *********) -let rec mkSLlub ctx e1 e2 = +and mkSLlub ctx e1 e2 = let lwhnf1 = lexp_whnf e1 ctx in let lwhnf2 = lexp_whnf e2 ctx in match (lexp_lexp' lwhnf1, lexp_lexp' lwhnf2) with @@ -357,13 +476,7 @@ let rec mkSLlub ctx e1 e2 = else if level_leq ce2 ce1 then e1 else mkSortLevel (mkSLlub' (e1, e2)) (* FIXME: Could be more canonical *) -type sort_compose_result - = SortResult of ltype - | SortInvalid - | SortK1NotType - | SortK2NotType - -let sort_compose ctx1 ctx2 l ak k1 k2 = +and sort_compose ctx1 ctx2 l ak k1 k2 = (* BEWARE! Technically `k2` can refer to `v`, but this should only happen * if `v` is a TypeLevel. *) let lwhnf1 = lexp'_whnf k1 ctx1 in @@ -403,11 +516,11 @@ let sort_compose ctx1 ctx2 l ak k1 k2 = | (Sort (_, _), _) -> SortK2NotType | (_, _) -> SortK1NotType -let dbset_push ak erased = +and dbset_push ak erased = let nerased = DB.set_sink 1 erased in if ak = P.Aerasable then DB.set_set 0 nerased else nerased -let nerased_let defs erased = +and nerased_let defs erased = (* Let bindings are not erasable, with the important exception of * let-bindings of the form `x = y` where `y` is an erasable var. * This exception is designed so that macros like `case` which need to @@ -433,7 +546,7 @@ let nerased_let defs erased = erased es (* "check ctx e" should return τ when "Δ ⊢ e : τ" *) -let rec check'' erased ctx e = +and check'' erased ctx e = let check = check'' in let assert_type ctx e t t' = if conv_p ctx t t' then () @@ -453,7 +566,7 @@ let rec check'' erased ctx e = s in match lexp_lexp' e with | Imm (Float (_, _)) -> DB.type_float - | Imm (Integer (_, _)) -> DB.type_int + | Imm (Integer (_, _)) -> DB.type_integer | Imm (String (_, _)) -> DB.type_string | Imm (Block (_, _, _) | Symbol _ | Node (_, _)) -> (error_tc ~loc:(lexp_location e) "Unsupported immediate value!"; @@ -608,7 +721,14 @@ let rec check'' erased ctx e = match lexp_lexp' e with | Call (f, args) -> (f, args) | _ -> (e,[]) in - let etype = lexp_whnf (check erased ctx e) ctx in + let etype = lexp_whnf (check erased ctx e) ctx in + (* FIXME save the type in the case lexp instead of recomputing + it over and over again *) + let ekind = get_type ctx etype in + let elvl = match lexp'_whnf ekind ctx with + | Sort (_, Stype l) -> l + | _ -> Log.log_error ~loc:(lexp_location ekind) + "Target lexp's kind is not a sort"; DB.level0 in let it, aargs = call_split etype in (match lexp'_whnf it ctx, aargs with | Inductive (_, _, fargs, constructors), aargs -> @@ -622,27 +742,46 @@ let rec check'' erased ctx e = | _,_ -> (error_tc ~loc:l "Wrong arg number to inductive type!"; s) in let s = mksubst S.identity fargs aargs in + let ctx_extend_with_eq ctx subst hlxp nerased = + let tlxp = mkSusp e subst in + let tltp = mkSusp etype subst in + let tlvl = mkSusp elvl subst in + let eqty = mkCall (DB.type_eq, + [(Aerasable, tlvl); (* Typelevel *) + (Aerasable, tltp); (* Inductive type *) + (Anormal, hlxp); (* Lexp of the branch head *) + (Anormal, tlxp)]) in (* Target lexp *) + (* The eq proof is erasable. *) + let nerased = dbset_push Aerasable nerased in + let nctx = DB.lexp_ctx_cons ctx (l, None) Variable eqty in + (nerased, nctx) in SMap.iter (fun name (l, vdefs, branch) -> let fieldtypes = SMap.find name constructors in - let rec mkctx erased ctx s vdefs fieldtypes = + let rec mkctx erased ctx s hlxp vdefs fieldtypes = match vdefs, fieldtypes with - | [], [] -> (erased, ctx) + | [], [] -> (erased, ctx, hlxp) (* FIXME: If ak is Aerasable, make sure the var only * appears in type annotations. *) | (ak, vdef)::vdefs, (ak', vdef', ftype)::fieldtypes -> mkctx (dbset_push ak erased) (DB.lexp_ctx_cons ctx vdef Variable (mkSusp ftype s)) - (S.cons (mkVar (vdef, 0)) - (S.mkShift s 1)) + (ssink vdef s) + (mkCall (mkSusp hlxp (S.shift 1), [(ak, mkVar (vdef, 0))])) vdefs fieldtypes | _,_ -> (error_tc ~loc:l "Wrong number of args to constructor!"; - (erased, ctx)) in - let (nerased, nctx) = mkctx erased ctx s vdefs fieldtypes in + (erased, ctx, hlxp)) in + let hctor = + mkCall (mkCons (it, (l, name)), + List.map (fun (_, a) -> (P.Aerasable, a)) aargs) in + let (nerased, nctx, hlxp) = + mkctx erased ctx s hctor vdefs fieldtypes in + let subst = S.shift (List.length vdefs) in + let (nerased, nctx) = ctx_extend_with_eq nctx subst hlxp nerased in assert_type nctx branch (check nerased nctx branch) - (mkSusp ret (S.shift (List.length fieldtypes)))) + (mkSusp ret (S.shift ((List.length fieldtypes) + 1)))) branches; let diff = SMap.cardinal constructors - SMap.cardinal branches in (match default with @@ -650,8 +789,13 @@ let rec check'' erased ctx e = -> if diff <= 0 then warning_tc ~loc:l "Redundant default clause"; let nctx = (DB.lctx_extend ctx v (LetDef (0, e)) etype) in - assert_type nctx d (check (DB.set_sink 1 erased) nctx d) - (mkSusp ret (S.shift 1)) + let nerased = DB.set_sink 1 erased in + let subst = S.shift 1 in + let hlxp = mkVar ((l, None), 0) in + let (nerased, nctx) = + ctx_extend_with_eq nctx subst hlxp nerased in + assert_type nctx d (check nerased nctx d) + (mkSusp ret (S.shift 2)) | None -> if diff > 0 then error_tc ~loc:l ("Non-exhaustive match: " @@ -697,24 +841,21 @@ let rec check'' erased ctx e = check erased ctx e | MVar (_, t, _) -> push_susp t s) -let check' ctx e = +and check' ctx e = let res = check'' DB.set_empty ctx e in (Log.stop_on_error (); res) -let check = check' +and check ctx e = check' ctx e (** Compute the set of free (meta)variables. **) -let rec list_union l1 l2 = match l1 with +and list_union l1 l2 = match l1 with | [] -> l2 | (x::l1) -> list_union l1 (if List.mem x l2 then l2 else (x::l2)) -type mv_set = (scope_level * ltype * ctx_length * vname) IMap.t - (* Metavars that appear in non-erasable positions. *) - * unit IMap.t -let mv_set_empty : mv_set = (IMap.empty, IMap.empty) -let mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes) -let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set +and mv_set_empty : mv_set = (IMap.empty, IMap.empty) +and mv_set_add (ms, nes) id x : mv_set = (IMap.add id x ms, IMap.add id () nes) +and mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set = (IMap.merge (fun _m oss1 oss2 -> match (oss1, oss2) with | (None, _) -> oss2 @@ -730,25 +871,19 @@ let mv_set_union ((ms1, nes1) : mv_set) ((ms2, nes2) : mv_set) : mv_set Some ss1) ms1 ms2, IMap.merge (fun _m _o1 _o2 -> Some ()) nes1 nes2) -let mv_set_erase (ms, _nes) = (ms, IMap.empty) +and mv_set_erase (ms, _nes) = (ms, IMap.empty) -module LMap - (* Memoization table. FIXME: Ideally the keys should be "weak", but - * I haven't found any such functionality in OCaml's libs. *) - = Hashtbl.Make - (struct type t = lexp let hash = Hashtbl.hash let equal = (==) end) -let fv_memo = LMap.create 1000 +and fv_memo = LMap.create 1000 -let fv_empty = (DB.set_empty, mv_set_empty) -let fv_union (fv1, mv1) (fv2, mv2) +and fv_empty = (DB.set_empty, mv_set_empty) +and fv_union (fv1, mv1) (fv2, mv2) = (DB.set_union fv1 fv2, mv_set_union mv1 mv2) -let fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs) -let fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs) -let fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs) +and fv_sink n (fvs, mvs) = (DB.set_sink n fvs, mvs) +and fv_hoist n (fvs, mvs) = (DB.set_hoist n fvs, mvs) +and fv_erase (fvs, mvs) = (fvs, mv_set_erase mvs) -let rec fv (e : lexp) : (DB.set * mv_set) = - let fv' e = - match lexp_lexp' e with +and fv (e : lexp) : (DB.set * mv_set) = + let fv' e = match lexp_lexp' e with | Imm _ -> fv_empty | SortLevel SLz -> fv_empty | SortLevel (SLsucc e) -> fv e @@ -800,9 +935,9 @@ let rec fv (e : lexp) : (DB.set * mv_set) = -> let s = fv_union (fv e) (fv_erase (fv t)) in let s = match def with | None -> s - | Some (_, e) -> fv_union s (fv_hoist 1 (fv e)) in + | Some (_, e) -> fv_union s (fv_hoist 2 (fv e)) in SMap.fold (fun _ (_, fields, e) s - -> fv_union s (fv_hoist (List.length fields) (fv e))) + -> fv_union s (fv_hoist (List.length fields + 1) (fv e))) cases s | Metavar (id, s, name) -> (match metavar_lookup id with @@ -822,10 +957,10 @@ let rec fv (e : lexp) : (DB.set * mv_set) = (** Finding the type of a expression. **) (* This should never signal any warning/error. *) -let rec get_type ctx e = +and get_type ctx e = match lexp_lexp' e with | Imm (Float (_, _)) -> DB.type_float - | Imm (Integer (_, _)) -> DB.type_int + | Imm (Integer (_, _)) -> DB.type_integer | Imm (String (_, _)) -> DB.type_string | Imm (Block (_, _, _) | Symbol _ | Node (_, _)) -> DB.type_int | Builtin (_, t, _) -> t @@ -948,7 +1083,7 @@ let rec erase_type (lxp: lexp): E.elexp = | L.Case(l, target, _, cases, default) -> E.Case(l, (erase_type target), (clean_map cases), - (clean_maybe default)) + (clean_default default)) | L.Susp(l, s) -> erase_type (L.push_susp l s) @@ -977,10 +1112,12 @@ and filter_arg_list lst = and clean_decls decls = List.map (fun (v, lxp, _) -> (v, (erase_type lxp))) decls -and clean_maybe lxp = - match lxp with - | Some (v, lxp) -> Some (v, erase_type lxp) - | None -> None +and clean_default lxp = + match lxp with + | Some (v, lxp) -> + Some (v, + erase_type (L.push_susp lxp (S.substitute DB.type0))) + | None -> None and clean_map cases = let clean_arg_list lst = @@ -994,7 +1131,8 @@ and clean_map cases = clean_arg_list lst [] in SMap.map (fun (l, args, expr) - -> (l, (clean_arg_list args), (erase_type expr))) + -> (l, (clean_arg_list args), + erase_type (L.push_susp expr (S.substitute DB.type0)))) cases (** Turning a set of declarations into an object. **) ===================================== src/sexp.ml ===================================== @@ -27,16 +27,13 @@ open Grammar let sexp_error ?print_action loc msg = Log.log_error ~section:"SEXP" ?print_action ~loc msg -type integer = (* Num.num *) int +type integer = Z.t type symbol = location * string type sexp = (* Syntactic expression, kind of like Lisp. *) | Block of location * pretoken list * location | Symbol of symbol | String of location * string - (* FIXME: It would make a lof of sense to use a bigint here, but `compare` - * burps on Big_int objects, and `compare` is used for hash-consing of lexp - * objects which contain sexp objects as well. *) | Integer of location * integer | Float of location * float | Node of sexp * sexp list @@ -76,7 +73,7 @@ let rec sexp_string sexp = | Symbol(_, "") -> "()" (* Epsilon *) | Symbol(_, name) -> name | String(_, str) -> "\"" ^ str ^ "\"" - | Integer(_, n) -> string_of_int n + | Integer(_, n) -> Z.to_string n | Float(_, x) -> string_of_float x | Node(f, args) -> let str = "(" ^ (sexp_string f) in ===================================== src/unification.ml ===================================== @@ -291,16 +291,35 @@ and unify_metavar ctx idx s1 (lxp1: lexp) (lxp2: lexp) | lxp' when occurs_in idx lxp' -> [(CKimpossible, ctx, lxp1, lxp2)] | lxp' -> metavar_table := associate idx lxp' (!metavar_table); - match unify t (OL.get_type ctx lxp) ctx with - | [] as r -> r - (* FIXME: Let's ignore the error for now. *) - | _ - -> log_info ?loc:None - ("Unification of metavar type failed:\n " - ^ lexp_string t ^ " != " - ^ lexp_string (OL.get_type ctx lxp) - ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n"); - [(CKresidual, ctx, lxp1, lxp2)] in + let type_unif_residue = + match unify t (OL.get_type ctx lxp) ctx with + | [] as r -> r + (* FIXME: Let's ignore the error for now. *) + | _ + -> log_info ?loc:None + ("Unification of metavar type failed:\n " + ^ lexp_string t ^ " != " + ^ lexp_string (OL.get_type ctx lxp) + ^ "\n" ^ "for " ^ lexp_string lxp ^ "\n"); + [(CKresidual, ctx, lxp1, lxp2)] in + (* FIXME Here, we unify lxp1 with lxp2 again, because that + the metavariables occuring in the associated term might + have different substitutions from the corresponding + metavariables on the other side (due to subst inversion + not being a perfect inverse of subtitution application). + + For example, when unifying `?τ↑1[114]` with `(List[56] + ?ℓ↑0[117] ?a↑0[118])`, we associate the metavar ?τ[114] + with the lexp `(List[55] ?ℓ() · ↑0[117] ?a() · ↑0[118])` + (after applying the inverse substitution of ↑1), and the + lexp (?τ↑1[114]) becomes `(List[56] ?ℓ(↑1 () · ↑0)[117] + ?a(↑1 () · ↑0)[118])`, which is not exactly the same as + the right-hand side. My solution/kludge to this problem is + to do a second unification to fix the metavar + substitutions on the right-hand side, but there is + probably a cleaner way to solve this. *) + let second_unif_residue = unify lxp1 lxp2 ctx in + List.append type_unif_residue second_unif_residue in match lexp_lexp' lxp2 with | Metavar (idx2, s2, name) -> if idx = idx2 then ===================================== src/util.ml ===================================== @@ -63,10 +63,6 @@ let loc_print loc = print_string (loc_string loc) let string_implode chars = String.concat "" (List.map (String.make 1) chars) let string_sub str b e = String.sub str b (e - b) -(* `String.uppercase` is deprecated since OCaml-4.03, but the replacement - * `String.uppercase_ascii` is not yet available in Debian stable's `ocaml`. *) -let string_uppercase s = String.uppercase s - let opt_map f x = match x with None -> None | Some x -> Some (f x) let str_split str sep = ===================================== tests/elab_test.ml ===================================== @@ -1,4 +1,4 @@ -(* elab_test.ml --- +(* elab_test.ml --- * * Copyright (C) 2016-2017 Free Software Foundation, Inc. * @@ -21,42 +21,45 @@ * * -------------------------------------------------------------------------- *) - open Utest_lib -open Pexp -open Lexp - -open Builtin - -let test - (input_gen: (unit -> 'a list)) - (fmt: 'b list -> string list) - (tester: 'a -> ('b * bool)): (string * bool) list = - let input = List.map tester (input_gen ()) - in let str = List.map (fun (s, _) -> s ) input - in let b = List.map (fun (_, b) -> b) input - in List.combine (fmt str) b - -let generate_tests (name: string) - (input_gen: (unit -> 'a list)) - (fmt: 'b list -> string list) - (tester: 'a -> ('b * bool)) = - let idx = (ref 0) - in List.map (fun (sub, res) -> - idx := !idx + 1; - add_test name - ((U.padding_left (string_of_int (!idx)) 2 '0') ^ " - " ^ sub) - (fun () -> if res then success () else failure ())) - (test input_gen fmt tester) - -(* let input = "y = lambda x -> x + 1;" *) -let inputs = - [("identity", {| -id = lambda (α : Type) ≡> lambda (x : α) -> x; -res = id 3; - |}); - ("whnf of case", {| +let add_elab_test elab test name ?(setup="") ?(expected="") input = + let run_elab_test () = + let ectx = Elab.default_ectx in + let _, ectx = Elab.lexp_decl_str setup ectx in + let last_metavar = !Unification.global_last_metavar in + let actual, _ = elab input ectx in + if String.equal expected "" + then success + else + (Unification.global_last_metavar := last_metavar; + let expected, _ = elab expected ectx in + test actual expected) + in + add_test "ELAB" name run_elab_test + +(** Run setup, then elaborate [input]. Succeeds if there are no compilation + errors and [expected] elaborates to the same lexp, if provided. *) +let add_elab_test_expr = + add_elab_test (fun s ctx -> Elab.lexp_expr_str s ctx, ctx) expect_equal_lexps + +(** Like {!add_elab_test_expr}, but elaborates [input] and [expected] as top + level declarations instead of expressions. *) +let add_elab_test_decl = + add_elab_test Elab.lexp_decl_str expect_equal_decls + +let _ = add_elab_test_expr + "Instanciate implicit arguments" + ~setup:{| +f : (i : Integer) -> Eq i i -> Integer; +f = lambda i -> lambda eq -> i; + |} + ~expected:"f 4 (Eq_refl (x := 4));" + "f 4 Eq_refl;" + +let _ = add_elab_test_decl + "Whnf of case" + {| Box = (typecons (Box (l : TypeLevel) (t : Type_ l)) (box t)); box = (datacons Box box); unbox b = ##case_ (b | box inside => inside); @@ -67,103 +70,96 @@ example1 = true; example2 : alwaysbool (box Int); example2 = true; - |}); - ] - -let generate_lexp_from_str str = - List.hd ((fun (lst, _) -> - (List.map - (fun (_, lxp, _) -> lxp)) - (List.flatten lst)) - (Elab.lexp_decl_str str Elab.default_ectx)) - -let _ = generate_tests - "TYPECHECK" - (fun () -> inputs) - (fun x -> x) - (fun (name, input) -> - let result = - try - let ectx = Elab.default_ectx in - let pres = Prelexer.prelex_string input in - let sxps = Lexer.lex Grammar.default_stt pres in - let _lxps, _ectx = Elab.lexp_p_decls [] sxps ectx in - Log.stop_on_error(); - true - with - | Log.Stop_Compilation _ -> (Log.print_and_clear_log (); false) - | Log.Internal_error _ -> (Log.print_and_clear_log (); false) in - (name, result) - ) - -let lctx = Elab.default_ectx -(* let _ = (add_test "TYPECHEK_LEXP" "lexp_print" (fun () -> - * - * let dcode = " - * sqr = lambda (x) -> x * x; - * cube = lambda (x) -> x * (sqr x); - * - * mult = lambda (x) -> lambda (y) -> x * y; - * - * twice = (mult 2); - * - * let_fun = lambda (x) -> - * let a = (twice x); b = (mult 2 x); in - * a + b;" in - * - * let ret1, _ = lexp_decl_str dcode lctx in - * - * let to_str decls = - * let str = _lexp_str_decls (!compact_ppctx) (List.flatten ret1) in - * List.fold_left (fun str lxp -> str ^ lxp) "" str in - * - * (\* Cast to string *\) - * let str1 = to_str ret1 in - * - * print_string str1; - * - * (\* read code again *\) - * let ret2, _ = lexp_decl_str str1 lctx in - * - * (\* Cast to string *\) - * let str2 = to_str ret2 in - * - * if str1 = str2 then success () else failure () - * )) *) - -(* -let set_to_list s = - StringSet.fold (fun g a -> g::a) s [] - -let _ = (add_test "LEXP" "Free Variable" (fun () -> - - let dcode = " - a = 2; - b = 3; - f = lambda n -> (a + n); % a is a fv - g = lambda x -> ((f b) + a + x); % f,a,b are fv - " in - - let ret = pexp_decl_str dcode in - let g = match List.rev ret with - | (_, g, _)::_ -> g - | _ -> raise (Unexpected_result "Unexpected empty list") in - - let (bound, free) = free_variable g in - - let bound = set_to_list bound in - let (free, _) = free in - - match bound with - | ["x"] ->( - match free with - | ["_+_"; "f"; "b"; "a"] -> success () - | _ -> failure ()) - | _ -> failure () - -)) *) - -(* run all tests *) -let _ = run_all () + |} + +let _ = add_elab_test_decl + "depelim with Nats" + {| +type Nat + | Z + | S Nat; + +Nat_induction : + (P : Nat -> Type_ ?l) ≡> + P Z -> + ((n : Nat) -> P n -> P (S n)) -> + ((n : Nat) -> P n); +Nat_induction = + lambda l (P : Nat -> Type_ l) ≡> + lambda base step n -> + ##case_ (n + | Z => Eq_cast (p := ##DeBruijn 0) (f := P) base + | S n' => Eq_cast (p := ##DeBruijn 0) (f := P) (step n' (Nat_induction (P := P) base step n'))); + +plus : Nat -> Nat -> Nat; +plus x y = + case x + | Z => y + | S x' => S (plus x' y); + ++0_identity : (n : Nat) -> Eq (plus n Z) n; ++0_identity = + Nat_induction + (P := (lambda n -> Eq (plus n Z) n)) + Eq_refl + (lambda n-1 n-1+0=n-1 -> + Eq_cast + (p := n-1+0=n-1) + (f := lambda n-1_n -> Eq (S (plus n-1 Z)) (S n-1_n)) + Eq_refl); + |} + +let _ = add_elab_test_decl + "depelim macro" + {| +type Nat + | Z + | S Nat; + +Nat_induction : + (P : Nat -> Type_ ?l) ≡> + P Z -> + ((n : Nat) -> P n -> P (S n)) -> + ((n : Nat) -> P n); +Nat_induction = + lambda l (P : Nat -> Type_ l) ≡> + lambda base step n -> + case n return (P n) + | Z => base + | S n' => (step n' (Nat_induction (P := P) base step n')); + |} + +let _ = add_elab_test_decl + "case conversion" + {| +unify = + macro ( + lambda sxps -> + do {vname <- gensym (); + IO_return + (quote ((uquote vname) : (uquote (Sexp_node (Sexp_symbol "##Eq") sxps)); + (uquote vname) = Eq_refl; + )); + }); + +case_ = ##case_; + +type Nat + | S Nat + | Z; + +plus : ?; +plus x y = + case x + | Z => y + | S n => S (plus n y); + +f x y b = + case b + | true => plus x y + | false => Z; + +unify (f Z (S Z)) (f (S Z) Z); + |} let _ = run_all () ===================================== tests/env_test.ml ===================================== @@ -67,14 +67,8 @@ let _ = (add_test "ENV" "Set Variables" (fun () -> (ctx, idx - 1)) (rctx, n) var in - print_rte_ctx rctx; - - success () - ) - else - success () - -)) + print_rte_ctx rctx); + success)) (* run all tests *) ===================================== tests/eval_test.ml ===================================== @@ -52,15 +52,7 @@ let test_eval_eqv_named name decl run res = let erun = Elab.eval_expr_str run ectx rctx in (* evaluated run expr *) let eres = Elab.eval_expr_str res ectx rctx in (* evaluated res expr *) - if value_eq_list erun eres - then success () - else ( - (* List.hd was throwing when run or res failed to compile *) - (match erun with x::_ -> value_print x - | _ -> print_string ("no run expression\n")); - (match eres with x::_ -> value_print x - | _ -> print_string ("no result expression\n")); - failure ())) + expect_equal_values erun eres) let test_eval_eqv decl run res = test_eval_eqv_named run decl run res @@ -120,7 +112,7 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Lambda" - "sqr : Int -> Int; + "sqr : Integer -> Integer; sqr = lambda x -> x * x;" "sqr 4;" (* == *) "16" @@ -128,10 +120,10 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Nested Lambda" - "sqr : Int -> Int; + "sqr : Integer -> Integer; sqr = lambda x -> x * x; - cube : Int -> Int; + cube : Integer -> Integer; cube = lambda x -> x * (sqr x);" "cube 4" (* == *) "64" @@ -156,7 +148,7 @@ let _ = test_eval_eqv_named b = (ctr2 (ctr2 ctr0)); z = 3; c = (ctr3 (ctr2 ctr0)); w = 4; - test_fun : idt -> Int; + test_fun : idt -> Integer; test_fun = lambda k -> case k | ctr1 l => 1 | ctr2 l => 2 @@ -174,7 +166,7 @@ let nat_decl = " zero = datacons Nat zero; succ = datacons Nat succ; - to-num : Nat -> Int; + to-num : Nat -> Integer; to-num = lambda (x : Nat) -> case x | (succ y) => (1 + (to-num y)) | zero => 0;" @@ -218,8 +210,8 @@ let _ = test_eval_eqv_named two = succ one; three = succ two; - even : Nat -> Int; - odd : Nat -> Int; + even : Nat -> Integer; + odd : Nat -> Integer; odd = lambda (n : Nat) -> case n | zero => 0 @@ -237,7 +229,7 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Partial Application" - "add : Int -> Int -> Int; + "add : Integer -> Integer -> Integer; add = lambda x y -> (x + y); inc1 = add 1; @@ -273,24 +265,9 @@ let _ = test_eval_eqv_named (* * Special forms *) -let _ = test_eval_eqv "w = 2" "decltype w" "Int" +let _ = test_eval_eqv "w = 2" "decltype w" "Integer" let _ = test_eval_eqv "w = 2" "declexpr w" "2" -(* let attr_decl = " - * w = 2; - * greater-than = new-attribute (Int -> Int); - * greater-than = add-attribute greater-than w (lambda (x : Int) -> x);" - * - * let _ = test_eval_eqv_named - * "has-attribute" - * - * attr_decl - * - * "has-attribute greater-than w; - * (get-attribute greater-than w) 3;" - * - * "true; 3" *) - let _ = (add_test "EVAL" "Monads" (fun () -> let dcode = " @@ -304,17 +281,16 @@ let _ = (add_test "EVAL" "Monads" (fun () -> (* Eval defined lambda *) let ret = Elab.eval_expr_str rcode ectx rctx in - match ret with - | [v] -> success () - | _ -> failure () -)) + match ret with + | [v] -> success + | _ -> failure)) let _ = test_eval_eqv_named "Argument Reordering" - "fun = lambda (x : Int) => - lambda (y : Int) -> - lambda (z : Int) -> x * y + z;" + "fun = lambda (x : Integer) => + lambda (y : Integer) -> + lambda (z : Integer) -> x * y + z;" "fun (x := 3) 2 1; fun (x := 3) (z := 1) 4; @@ -336,7 +312,7 @@ let _ = test_eval_eqv_named "Metavars" let _ = test_eval_eqv_named "Explicit field patterns" "Triplet = typecons Triplet - (triplet (a ::: Int) (b :: Float) (c : String) (d :: Int)); + (triplet (a ::: Integer) (b :: Float) (c : String) (d :: Integer)); triplet = datacons Triplet triplet; t = triplet (b := 5.0) (a := 3) (d := 7) (c := \"hello\");" @@ -350,26 +326,25 @@ let _ = test_eval_eqv_named "\"hello\"; 5.0; \"hello\"; 5.0; \"hello\"; 7" -(* let _ = test_eval_eqv_named - * "Implicit Arguments" - * - * "default = new-attribute Macro; - * default = add-attribute default Int (macro (lambda (lst : List Sexp) -> - * (IO_return (Sexp_integer (Int->Integer 1))))); - * - * fun = lambda (x : Int) => - * lambda (y : Int) -> - * lambda (z : Int) -> x * y + z;" - * - * "fun 2 1; - * fun 2 1" - * - * "3; 3" *) +let _ = test_eval_eqv_named + "Implicit Arguments" + + {| + fun = lambda (x : Integer) => + lambda (p : Eq x x) -> + x; + |} + + {| + fun (Eq_refl (x := 2)) + |} + + "2" let _ = test_eval_eqv_named "Equalities" - "f : (α : Type) ≡> (p : Eq Int α) -> Int -> α; + "f : (α : Type) ≡> (p : Eq Integer α) -> Integer -> α; f = lambda α ≡> lambda p x -> Eq_cast (f := lambda v -> v) (p := p) x" @@ -382,14 +357,14 @@ let _ = test_eval_eqv_named "P = (a : Type) ≡> a -> Not (Not a); p : P; p = lambda a ≡> lambda x notx -> notx x; - tP : Decidable P; - tP = (datacons Decidable true) (prop := P) (p := p); + tP : Decidable (ℓ := ?ℓ₀) P; + tP = (datacons (Decidable (ℓ := ?ℓ₀)) true) (prop := P) (p := p); PairTest = typecons (Pair (a : Type) (b : Type)) (cons (x :: a) (y :: b)); Pair = typecons (Pair (a : Type) (b : Type)) (cons (x :: a) (y :: b)); - ptest : Pair Int String; + ptest : Pair Integer String; ptest = (##datacons Pair cons) (x := 4) (y := \"hello\"); px = case ptest | (##datacons ? cons) (x := v) => v; @@ -404,40 +379,70 @@ let _ = test_eval_eqv_named let _ = test_eval_eqv_named "Y" - "length_y = lambda t ≡> - %% FIXME: The `a` argument should be inferred! - Y (a := List t) (witness := (lambda l -> 0)) - (lambda length l - -> case l - | nil => 0 - | cons _ l => 1 + length l);" + {| + length_y = + Y (witness := (lambda l -> 0)) + (lambda length l + -> case l + | nil => 0 + | cons _ l => 1 + length l); + |} "length_y (cons 1 (cons 5 nil));" "2;" let _ = test_eval_eqv_named - "Block" + "Block" - "a = 2" + "a = 2" - "a + 1;" - "{a + 1};" + "a + 1;" + "{a + 1};" let _ = test_eval_eqv_named - "define-operator" + "define-operator" - "define-operator \"IF\" () 2; - define-operator \"THEN\" 2 1; - define-operator \"ELSE\" 1 66; - IF_THEN_ELSE_ = if_then_else_;" + {| + define-operator "IF" () 2; + define-operator "THEN" 2 1; + define-operator "ELSE" 1 66; + IF_THEN_ELSE_ = if_then_else_; + |} - "IF true THEN 2 ELSE 3;" - "if true then 2 else 3;" + "IF true THEN 2 ELSE 3;" + "if true then 2 else 3;" let _ = test_eval_eqv_named - "Type Alias" "ListInt = List Int;" "" (* == *) "" + "Type Alias" "ListInt = List Int;" "" "" -(* run all tests *) -let _ = run_all () +let _ = test_eval_eqv_named + "Equality in case : safe head" + + {| +unvoid (void : Void) = ##case_ void; + +Not prop = (contra : prop) ≡> False; + +head : (ls : List ?τ) -> (p : Not (Eq nil ls)) -> ?τ; +head ls p = + ##case_ (ls + | nil => unvoid (p (contra := (##DeBruijn 0))) + | cons x xs => x); + +l = (cons 0 nil); + +nil≠l : Not (Eq nil l); +nil≠l = + lambda (if_it_were : Eq nil l) ≡> + Eq_cast (x := nil) (y := l) + (p := if_it_were) + (f := lambda nill -> + case nill + | nil => True + | cons _ _ => False) + (); + |} + "head l nil≠l" "0" +let _ = run_all () ===================================== tests/inverse_test.ml ===================================== @@ -94,7 +94,7 @@ let inv_add_test name inputs = then b else not b) | None -> (not b)) true inputs - then success () else failure ()) + then success else failure) let _ = inv_add_test "Manual" input ===================================== tests/macro_test.ml ===================================== @@ -57,14 +57,10 @@ let _ = (add_test "MACROS" "macros base" (fun () -> let rctx, ectx = Elab.eval_decl_str dcode ectx rctx in - let ecode = "(lambda (x : Int) -> sqr 3) 5;" in + let ecode = "(lambda (x : Integer) -> sqr 3) 5;" in let ret = Elab.eval_expr_str ecode ectx rctx in - - match ret with - | [Vint(r)] -> expect_equal_int r (3 * 3) - | _ -> failure ()) -) + expect_equal_values ret [Vinteger (Z.of_int (3 * 3))])) let _ = (add_test "MACROS" "macros decls" (fun () -> let dcode = " @@ -72,9 +68,9 @@ let _ = (add_test "MACROS" "macros decls" (fun () -> let chain-decl : Sexp -> Sexp -> Sexp; chain-decl a b = Sexp_node (Sexp_symbol \"_;_\") (cons a (cons b nil)) in - let make-decl : String -> Int -> Sexp; + let make-decl : String -> Integer -> Sexp; make-decl name val = - (Sexp_node (Sexp_symbol \"_=_\") (cons (Sexp_symbol name) (cons (Sexp_integer (Int->Integer val)) nil))) in + (Sexp_node (Sexp_symbol \"_=_\") (cons (Sexp_symbol name) (cons (Sexp_integer val) nil))) in let d1 = make-decl \"a\" 1 in let d2 = make-decl \"b\" 2 in @@ -89,14 +85,7 @@ let _ = (add_test "MACROS" "macros decls" (fun () -> let ecode = "a; b;" in let ret = Elab.eval_expr_str ecode ectx rctx in - - match ret with - | [Vint(a); Vint(b)] -> - if (a = 1 && b = 2) then success () else failure () - - | _ -> failure ()) -) - + expect_equal_values ret [Vinteger(Z.of_int 1); Vinteger(Z.of_int 2)])) (* run all tests *) let _ = run_all () ===================================== tests/sexp_test.ml ===================================== @@ -4,7 +4,7 @@ open Utest_lib let sexp_parse_str dcode = sexp_parse_str dcode Grammar.default_stt Grammar.default_grammar (Some ";") - + let test_sexp_add dcode testfun = add_test "SEXP" dcode (fun () -> testfun (sexp_parse_str dcode)) @@ -14,8 +14,8 @@ let _ = test_sexp_add "lambda x -> x + x" (fun ret -> | [Node(Symbol(_, "lambda_->_"), [Symbol(_, "x"); Node(Symbol(_, "_+_"), [Symbol(_, "x"); Symbol(_, "x")])])] - -> success () - | _ -> failure () + -> success + | _ -> failure ) let _ = test_sexp_add "x * x * x" (fun ret -> @@ -23,8 +23,8 @@ let _ = test_sexp_add "x * x * x" (fun ret -> | [Node(Symbol(_, "_*_"), [Node(Symbol(_, "_*_"), [Symbol(_, "x"); Symbol(_, "x")]); Symbol(_, "x")])] - -> success () - | _ -> failure () + -> success + | _ -> failure ) let test_sexp_eqv dcode1 dcode2 = @@ -33,10 +33,10 @@ let test_sexp_eqv dcode1 dcode2 = let s1 = sexp_parse_str dcode1 in let s2 = sexp_parse_str dcode2 in if sexp_eq_list s1 s2 - then success () + then success else (sexp_print (List.hd s1); sexp_print (List.hd s2); - failure ())) + failure)) let _ = test_sexp_eqv "((a) ((1.00)))" "a 1.0" let _ = test_sexp_eqv "(x + y)" "_+_ x y" ===================================== tests/unify_test.ml ===================================== @@ -82,14 +82,14 @@ let str_int_4 = "i = 4" let str_case = "i = case true | true => 2 | false => 42" -let str_case2 = "i = case nil(a := Int) +let str_case2 = "i = case nil(a := Integer) | nil => 12 | _ => 24" let str_let = "i = let a = 5 in a + 1" let str_let2 = "j = let b = 5 in b" -let str_lambda = "sqr = lambda (x : Int) -> x * x;" -let str_lambda2 = "sqr = lambda (x : Int) -> x * x;" -let str_lambda3 = "sqr = lambda (x : Int) -> lambda (y : Int) -> x * y;" +let str_lambda = "sqr = lambda (x : Integer) -> x * x;" +let str_lambda2 = "sqr = lambda (x : Integer) -> x * x;" +let str_lambda3 = "sqr = lambda (x : Integer) -> lambda (y : Integer) -> x * y;" let str_type = "i = let j = decltype(Type) in decltype(j);" let str_type2 = "j = let i = Int -> Int in decltype(i);" @@ -128,11 +128,11 @@ let generate_testable (_: lexp list) : ((lexp * lexp * result) list) = ( mkLambda ((Anormal), (Util.dummy_location, Some "L1"), mkVar((Util.dummy_location, Some "z"), 3), - mkImm (Integer (Util.dummy_location, 3))), + mkImm (Integer (Util.dummy_location, Z.of_int 3))), mkLambda ((Anormal), (Util.dummy_location, Some "L2"), mkVar((Util.dummy_location, Some "z"), 4), - mkImm (Integer (Util.dummy_location, 3))), Nothing ) + mkImm (Integer (Util.dummy_location, Z.of_int 3))), Nothing ) ::(input_induct , input_induct , Equivalent) (* 2 *) ::(input_int_4 , input_int_4 , Equivalent) (* 3 *) @@ -224,7 +224,7 @@ let _ = List.map idx := !idx + 1; add_test "UNIFICATION" ((if !idx < 10 then "0" else "") ^ (string_of_int !idx) ^ " " ^ str ) - (fun () -> if expected = res then success () else failure ())) + (fun () -> if expected = res then success else failure)) (List.combine (fmt unifications) unifications ) let _ = run_all () ===================================== tests/utest_lib.ml ===================================== @@ -30,20 +30,16 @@ * * --------------------------------------------------------------------------- *) - -module U = Util open Fmt module StringMap = Map.Make (struct type t = string let compare = String.compare end) +type test_fun = unit -> int +type section = test_fun StringMap.t * string list -type test_fun = (unit -> int) -type tests = (test_fun) StringMap.t -type sections = ((tests) StringMap.t) * string list - -let success () = 0 -let failure () = (-1) +let success = 0 +let failure = -1 (* * SECTION NAME - TEST NAME - FUNCTION (() -> int) @@ -79,26 +75,26 @@ let set_verbose lvl = Log.set_typer_log_level (if lvl >= 3 then Log.Debug else Log.Nothing) let arg_defs = [ - ("--verbose=", + ("--verbose", Arg.Int set_verbose, " Set verbose level"); - ("--samples=", + ("--samples", Arg.String (fun g -> global_sample_dir := g), " Set sample directory"); (* Allow users to select which test to run *) - ("--fsection=", - Arg.String (fun g -> global_fsection := U.string_uppercase g), + ("--fsection", + Arg.String (fun g -> global_fsection := String.uppercase_ascii g), " Set test filter"); - ("--ftitle=", - Arg.String (fun g -> global_ftitle := U.string_uppercase g), + ("--ftitle", + Arg.String (fun g -> global_ftitle := String.uppercase_ascii g), " Set test filter"); ] let must_run_section str = !global_fsection = "" - || U.string_uppercase str = !global_fsection + || String.uppercase_ascii str = !global_fsection let must_run_title str = !global_ftitle = "" - || U.string_uppercase str = !global_ftitle + || String.uppercase_ascii str = !global_ftitle let parse_args () = Arg.parse arg_defs (fun s -> ()) "" @@ -115,63 +111,104 @@ let ut_string2 = ut_string 2 let unexpected_throw sk tk e = ut_string2 (red ^ "[ FAIL] " ^ sk ^ " - " ^ tk ^ "\n"); ut_string2 "[ ] UNEXPECTED THROW:\n"; - ut_string2 "[ ] ----------------------------- Callstack (20): -----------------------------------------\n"; - ut_string2 ("[ ] " ^ (Printexc.raw_backtrace_to_string (Printexc.get_callstack 20))); - ut_string2 "[ ] ---------------------------------------------------------------------------------------\n"; ut_string2 "[ ] ----------------------------- Backtrace: ----------------------------------------------\n"; ut_string2 ("[ ] " ^ (Printexc.get_backtrace ()) ^ "\n"); ut_string2 "[ ] ---------------------------------------------------------------------------------------\n"; ut_string2 "[ ] "; ut_string2 ((Printexc.to_string e) ^ "\n" ^ reset) -let _expect_equal_t to_string value expect = - if value = expect then - success () - else( - ut_string2 (red ^ "[ ] EXPECTED: " ^ (to_string expect)^ "\n"); - ut_string2 ( "[ ] GOT: " ^ (to_string value) ^ "\n" ^ reset); - failure ()) - -let expect_equal_int = _expect_equal_t string_of_int -let expect_equal_float = _expect_equal_t string_of_float -let expect_equal_str = _expect_equal_t (fun g -> g) - - -let add_section sname = - try - StringMap.find sname (!global_sections) - with - Not_found -> - insertion_order := sname::(!insertion_order); - (StringMap.empty, ref []) - -(* USAGE *) -(* +let _expect_equal_t equality_test to_string value expect = + if equality_test value expect then + success + else ( + ut_string2 (red ^ "EXPECTED: " ^ reset ^ "\n" ^ (to_string expect) ^ "\n"); + ut_string2 (red ^ "GOT: " ^ reset ^ "\n" ^ (to_string value) ^ "\n"); + failure) + +let print_value_list values = + List.fold_left (fun s v -> s ^ "\n" ^ Env.value_string v) "" values + +let expect_equal_int = _expect_equal_t Int.equal string_of_int +let expect_equal_float = _expect_equal_t Float.equal string_of_float +let expect_equal_str = _expect_equal_t String.equal (fun g -> g) +let expect_equal_values = _expect_equal_t Env.value_eq_list print_value_list + +let expect_equal_lexps = + let rec lexp_list_eq l r = + match l, r with + | [], [] -> true + | l_head :: l_tail, r_head :: r_tail when Lexp.eq l_head r_head + -> lexp_list_eq l_tail r_tail + | _ -> false + in + let string_of_lexp_list lexps = + List.fold_left (fun s lexp -> s ^ "\n" ^ Lexp.lexp_string lexp) "" lexps + in + _expect_equal_t lexp_list_eq string_of_lexp_list + +let expect_equal_decls = + let rec decl_eq l r = + let (_, l_vname), l_lexp, l_ltype = l in + let (_, r_vname), r_lexp, r_ltype = r in + Option.equal String.equal l_vname r_vname + && Lexp.eq l_lexp r_lexp + && Lexp.eq l_ltype r_ltype + in + let rec mutual_decl_list_eq l r = + match l, r with + | [], [] -> true + | l_head :: l_tail, r_head :: r_tail when decl_eq l_head r_head + -> mutual_decl_list_eq l_tail r_tail + | _ -> false + in + let rec decl_list_eq l r = + match l, r with + | [], [] -> true + | l_head :: l_tail, r_head :: r_tail when mutual_decl_list_eq l_head r_head + -> decl_list_eq l_tail r_tail + | _ -> false + in + let string_of_decl_list ds = + let buffer = Buffer.create 1024 in + let string_of_mutual_decl_list ds = + let source = Lexp.lexp_str_decls Lexp.pretty_ppctx ds in + let add_decl d = + Buffer.add_string buffer d; + Buffer.add_char buffer '\n' + in + List.iter add_decl source + in + List.iter string_of_mutual_decl_list ds; + Buffer.contents buffer + in + _expect_equal_t decl_list_eq string_of_decl_list + +(* USAGE + * * (add_test "LET" "Base Case" (fun () -> * let r = eval_string "let a = 2; b = 3; in a + b;" in * let v = (get_int r) in * if v = 5 then success () else failure ())) - * - * sname: Section Name - * tname: Test Name - * tfun : test function (unit -> int) *) -let add_test sname tname tfun = - - (* Does Section Exist ? *) - let (tmap, lst) = add_section sname in - - try let _ = StringMap.find tname tmap in - ut_string2 "TEST ALREADY EXISTS" - with - Not_found -> - - lst := tname::(!lst); - - (* add test *) - let ntmap = StringMap.add tname tfun tmap in - global_sections := StringMap.add sname (ntmap, lst) (!global_sections); - - number_test := (!number_test + 1) +let add_test section_name test_name test_fun = + let update_tests = function + | Some _ as entry + -> (ut_string2 (red ^ {|Test "|} ^ test_name ^ {|" alread exists.|} ^ reset); + entry) + | None + -> (number_test := !number_test + 1; + Some test_fun) + in + let update_sections section = + let updated_entry = match section with + | Some (tests, order) + -> StringMap.update test_name update_tests tests, test_name :: order + | None + -> (insertion_order := section_name :: !insertion_order; + StringMap.singleton test_name test_fun, [test_name]) + in + Some updated_entry + in + global_sections := StringMap.update section_name update_sections !global_sections (* sk : Section Key * tmap: test_name -> tmap @@ -180,29 +217,36 @@ let for_all_tests sk tmap tk = if (must_run_title tk) then ( let tv = StringMap.find tk tmap in flush stdout; + Log.clear_log (); try let r = tv () in if r = 0 then( ut_string2 (green ^ "[ OK] " ^ sk ^ " - " ^ tk ^ "\n" ^ reset)) else( ut_string2 (red ^ "[ FAIL] " ^ sk ^ " - " ^ tk ^ "\n" ^ reset); - ret_code := failure ()) - with e -> - ret_code := failure (); - unexpected_throw sk tk e) else () + ret_code := failure) + with + | Log.Stop_Compilation message -> + ret_code := failure; + ut_string2 (red ^ "[ FAIL] " ^ sk ^ " - " ^ tk ^ "\n"); + ut_string2 ("[ ] " ^ message ^ "\n" ^ reset); + Log.print_log (); + | e -> + ret_code := failure; + unexpected_throw sk tk e) else () let for_all_sections sk = - let tmap, tst = StringMap.find sk (!global_sections) in - - if (must_run_section sk) then( - ut_string2 ("[RUN ] " ^ sk ^ " \n"); - tst := List.rev (!tst); - List.iter (for_all_tests sk tmap) (!tst)) - - else () + let tmap, tst = StringMap.find sk (!global_sections) in + let tst = List.rev tst in + if must_run_section sk + then ( + ut_string2 ("[RUN ] " ^ sk ^ " \n"); + List.iter (for_all_tests sk tmap) tst) (* Run all *) let run_all () = + Printexc.record_backtrace true; + parse_args (); insertion_order := List.rev (!insertion_order); ===================================== tests/utest_main.ml ===================================== @@ -29,8 +29,8 @@ * Basic utest program run all tests * * --------------------------------------------------------------------------- *) + open Fmt -module U = Util let cut_name str = String.sub str 0 (String.length str - 12) @@ -43,18 +43,18 @@ let global_ftitle = ref "" let global_filter = ref false let arg_defs = [ - ("--verbose=", + ("--verbose", Arg.Int (fun g -> global_verbose_lvl := g), " Set verbose level"); - ("--samples=", + ("--samples", Arg.String (fun g -> global_sample_dir := g), " Set sample directory"); - ("--tests=", + ("--tests", Arg.String (fun g -> global_tests_dir := g), " Set tests directory"); (* Allow users to select which test to run *) - ("--fsection=", - Arg.String (fun g -> global_fsection := U.string_uppercase g; + ("--fsection", + Arg.String (fun g -> global_fsection := String.uppercase_ascii g; global_filter := true), " Set test filter"); - ("--ftitle=", - Arg.String (fun g -> global_ftitle := U.string_uppercase g; + ("--ftitle", + Arg.String (fun g -> global_ftitle := String.uppercase_ascii g; global_filter := true), " Set test filter"); ] @@ -88,7 +88,7 @@ let print_file_name i n name pass = let must_run str = not (!global_filter) - || U.string_uppercase (cut_name str) = !global_fsection + || String.uppercase_ascii (cut_name str) = !global_fsection (* search *_test.byte executable en run them Usage: @@ -130,10 +130,10 @@ let main () = let exit_code = ref 0 in let failed_test = ref 0 in let tests_n = ref 0 in - let test_args = " --samples= " ^ root_folder ^ - " --verbose= " ^ (string_of_int !global_verbose_lvl) ^ + let test_args = " --samples " ^ root_folder ^ + " --verbose " ^ (string_of_int !global_verbose_lvl) ^ (if not (!global_ftitle = "") then - (" --ftitle= " ^ !global_ftitle) else "") in + (" --ftitle " ^ !global_ftitle) else "") in List.iter (fun file -> flush stdout; View it on GitLab: https://gitlab.com/monnier/typer/-/compare/a41f221e5ac716f2dcac8b49e1a01e45… -- View it on GitLab: https://gitlab.com/monnier/typer/-/compare/a41f221e5ac716f2dcac8b49e1a01e45… You're receiving this email because of your account on gitlab.com.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

Typer Septembre 2020