From a8975fc4ca6f8457c19dee40ebd3fa5d5d736649 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 6 Jul 2021 16:16:22 +0200 Subject: [PATCH 001/113] TC: examples for subtypes --- examples/typeclass.ec | 94 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 94 insertions(+) create mode 100644 examples/typeclass.ec diff --git a/examples/typeclass.ec b/examples/typeclass.ec new file mode 100644 index 0000000000..6795a10cf4 --- /dev/null +++ b/examples/typeclass.ec @@ -0,0 +1,94 @@ +(* ==================================================================== *) +subtype 'a word (n : int) = { + w : 'a list | size w = n +} + witness. + +op cat ['a] [n m : int] (x : {'a word n}) (y : {'a word m}) : {'a word (n+m)} = + x ++ y. + +==> (traduction) + +op cat ['a] (x : 'a word) (y : 'a word) : 'a word = + x ++ y. + +lemma cat_spec ['a] : + forall (n m : int) (x y : 'a word), + size x = n => size y = m => size (cat x y) = (n + m). + +op xor [n m : int] (w1 : {word n}) (w2 : {word m}) : {word (min (n, m))} = + ... + +lemma foo ['a] [n : int] (w1 w2 : {'a word n}) : + xor w1 w2 = xor w2 w1. + +op vectorize ['a] [n m : int] (w : {'a word (n * m)}) : {{'a word n} word m}. + +-> Keeping information in application? Yes + -> should provide a syntax for giving the arguments + + {w : word 256} + + vectorize<:int, n = 4> w ==> infer: m = 64 + +-> What to do when the inference fails + 1. we reject (most likely) + 2. we open a goal + +-> In a proof script (apply: foo) or (rewrite foo) + 1. inference des dépendances (n, m, ...) + 2. décharger les conditions de bord (size w1 = n, size w2 = n) + +-> Goal + n : int + m : int + w1 : {word n} + w2 : {word m} + ==================================================================== + E[xor (cat w1 w2) (cat w2 w1)] + + rewrite foo + + n : int + m : int + w1 : {word n} + w2 : {word m} + ==================================================================== + E[xor (cat w2 w1) (cat w1 w2)] + + under condition: + exists p . size (cat w1 w2) = p /\ size (cat w2 w1) = p. + + ?p = size (cat w1 w2) + ?p = size (cat w2 w1) + +-> can be solved using a extended prolog-like engine + 1. declarations of variables (w1 : {word n}) (w2 : {word m}) + 2. prolog-like facts from operators types (-> ELPI) + 3. theories (ring / int) + +-> subtypes in procedures + + We can only depend on operators / constants. I.e. the following + program should be rejected: + + module M = { + var n : int + + proc f(x : {bool word M.n}) = { + } + } + + Question: + - What about dependent types in the type for results: + we reject programs if we cannot statically check the condition + - What about the logics? we have to patch them. + +(* ==================================================================== *) +nth ['a] 'a -> 'a list -> int -> 'a + +ws : {word n} list + +nth<:word> witness ws 2 : word +nth<:{word n}> + +coercion : 'a word n -> 'a list From 37892ab34a83a7dd35c92054da13857bd893b966 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 7 Sep 2021 15:49:14 +0200 Subject: [PATCH 002/113] parsing entry for tc parameters --- examples/subtype.ec | 94 +++++++++++++++++++ examples/typeclass.ec | 211 +++++++++++++++++++++++++++++------------- src/ecParser.mly | 16 ++-- src/ecParsetree.ml | 9 +- 4 files changed, 252 insertions(+), 78 deletions(-) create mode 100644 examples/subtype.ec diff --git a/examples/subtype.ec b/examples/subtype.ec new file mode 100644 index 0000000000..6795a10cf4 --- /dev/null +++ b/examples/subtype.ec @@ -0,0 +1,94 @@ +(* ==================================================================== *) +subtype 'a word (n : int) = { + w : 'a list | size w = n +} + witness. + +op cat ['a] [n m : int] (x : {'a word n}) (y : {'a word m}) : {'a word (n+m)} = + x ++ y. + +==> (traduction) + +op cat ['a] (x : 'a word) (y : 'a word) : 'a word = + x ++ y. + +lemma cat_spec ['a] : + forall (n m : int) (x y : 'a word), + size x = n => size y = m => size (cat x y) = (n + m). + +op xor [n m : int] (w1 : {word n}) (w2 : {word m}) : {word (min (n, m))} = + ... + +lemma foo ['a] [n : int] (w1 w2 : {'a word n}) : + xor w1 w2 = xor w2 w1. + +op vectorize ['a] [n m : int] (w : {'a word (n * m)}) : {{'a word n} word m}. + +-> Keeping information in application? Yes + -> should provide a syntax for giving the arguments + + {w : word 256} + + vectorize<:int, n = 4> w ==> infer: m = 64 + +-> What to do when the inference fails + 1. we reject (most likely) + 2. we open a goal + +-> In a proof script (apply: foo) or (rewrite foo) + 1. inference des dépendances (n, m, ...) + 2. décharger les conditions de bord (size w1 = n, size w2 = n) + +-> Goal + n : int + m : int + w1 : {word n} + w2 : {word m} + ==================================================================== + E[xor (cat w1 w2) (cat w2 w1)] + + rewrite foo + + n : int + m : int + w1 : {word n} + w2 : {word m} + ==================================================================== + E[xor (cat w2 w1) (cat w1 w2)] + + under condition: + exists p . size (cat w1 w2) = p /\ size (cat w2 w1) = p. + + ?p = size (cat w1 w2) + ?p = size (cat w2 w1) + +-> can be solved using a extended prolog-like engine + 1. declarations of variables (w1 : {word n}) (w2 : {word m}) + 2. prolog-like facts from operators types (-> ELPI) + 3. theories (ring / int) + +-> subtypes in procedures + + We can only depend on operators / constants. I.e. the following + program should be rejected: + + module M = { + var n : int + + proc f(x : {bool word M.n}) = { + } + } + + Question: + - What about dependent types in the type for results: + we reject programs if we cannot statically check the condition + - What about the logics? we have to patch them. + +(* ==================================================================== *) +nth ['a] 'a -> 'a list -> int -> 'a + +ws : {word n} list + +nth<:word> witness ws 2 : word +nth<:{word n}> + +coercion : 'a word n -> 'a list diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 6795a10cf4..433080d46a 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -1,94 +1,173 @@ -(* ==================================================================== *) -subtype 'a word (n : int) = { - w : 'a list | size w = n -} + witness. +(* -------------------------------------------------------------------- *) +require import AllCore List. -op cat ['a] [n m : int] (x : {'a word n}) (y : {'a word m}) : {'a word (n+m)} = - x ++ y. +type class finite = { + op enum : finite list + axiom enumP : forall (x : finite), x \in enum +}. -==> (traduction) +type class monoid = { + op mzero : monoid + op madd : monoid -> monoid -> monoid +}. -op cat ['a] (x : 'a word) (y : 'a word) : 'a word = - x ++ y. +(* instance monoid with int ... *) -lemma cat_spec ['a] : - forall (n m : int) (x y : 'a word), - size x = n => size y = m => size (cat x y) = (n + m). +type class group = { + op zero : group + op ([-]) : group -> group + op ( + ) : group -> group -> group -op xor [n m : int] (w1 : {word n}) (w2 : {word m}) : {word (min (n, m))} = - ... + axiom addr0 : left_id zero (+) + axiom addrN : left_inverse zero ([-]) (+) + axiom addrC : commutative (+) + axiom addrA : associative (+) +}. -lemma foo ['a] [n : int] (w1 w2 : {'a word n}) : - xor w1 w2 = xor w2 w1. +(* instance ['a <: group] monoid with 'a ... *) -op vectorize ['a] [n m : int] (w : {'a word (n * m)}) : {{'a word n} word m}. +type class ring <: group = { + op one : ring + op ( * ) : ring -> ring -> ring --> Keeping information in application? Yes - -> should provide a syntax for giving the arguments + axiom mulr1 : left_id one ( * ) + axiom mulrC : commutative ( * ) + axiom mulrA : associative ( * ) + axiom mulrDl : left_distributive ( * ) ( + ) +}. - {w : word 256} +(* instance group with int ... *) - vectorize<:int, n = 4> w ==> infer: m = 64 +(* +type class ['a <: ring] module_ <: group = { + op ( ** ) : 'a -> module_ -> module_ --> What to do when the inference fails - 1. we reject (most likely) - 2. we open a goal + axiom scalerDl : forall (a b : 'a) (x : module_), + (a + b) ** x = a ** x + b ** x --> In a proof script (apply: foo) or (rewrite foo) - 1. inference des dépendances (n, m, ...) - 2. décharger les conditions de bord (size w1 = n, size w2 = n) + axiom scalerDr : forall (a : 'a) (x y : module_), + a ** (x + y) = a ** x + a ** y +}. +*) --> Goal - n : int - m : int - w1 : {word n} - w2 : {word m} - ==================================================================== - E[xor (cat w1 w2) (cat w2 w1)] - rewrite foo +type class A = ... +type class B1 <: A +type class B2 <: A +type class C <: B1 & B2 - n : int - m : int - w1 : {word n} - w2 : {word m} - ==================================================================== - E[xor (cat w2 w1) (cat w1 w2)] +op ['a <: B1 & B2] - under condition: - exists p . size (cat w1 w2) = p /\ size (cat w2 w1) = p. +int -> group -> monoid +int -> monoid - ?p = size (cat w1 w2) - ?p = size (cat w2 w1) --> can be solved using a extended prolog-like engine - 1. declarations of variables (w1 : {word n}) (w2 : {word m}) - 2. prolog-like facts from operators types (-> ELPI) - 3. theories (ring / int) +type ('a <: ring) poly = 'a list. --> subtypes in procedures +op foo ['a <: group] (x y : 'a) = x + y. - We can only depend on operators / constants. I.e. the following - program should be rejected: +lemma add0r ['a <: group] : right_id<:'a, 'a> zero (+). +proof. + (* Works for bad reasons *) + by move=> x /=; rewrite addrC addr0. +qed. - module M = { - var n : int +(* type fingroup <: group & finite. *) - proc f(x : {bool word M.n}) = { +(* type class fingroup = group & finite *) + +(* -------------------------------------------------------------------- *) +op izero = 0. + +instance group with int + op zero = izero + op (+) = RealInt.add. + +instance ['a <: ring] ('a poly) <: ring = { +}. + +instance ['a <: group & ...] 'a <: ... = { +}. + +instance ['a <: group] 'a <: monoid = { +}. + +typeclass witness = { + op witness : witness; +}. + +instance ['a] 'a <: witness = { +}. + +(* -------------------------------------------------------------------- *) + + 1. typage -> selection des operateurs / inference des instances de tc + 2. reduction + 3. unification (tactiques) + 4. clonage + 5. envoi au SMT + + 1. + Fop : + -(old) path * ty list -> form + -(new) path * (ty * (map tcname -> tcinstance)) list -> form + + op ['a <: monoid] (+) : 'a -> 'a -> 'a. + + (+)<:int + monoid -> intadd_monoid> + (+)<:int + monoid -> intmul_monoid> + + 1.1 module de construction des formules avec typage + 1.2 utiliser le module ci-dessous + + let module M = MkForm(struct let env = env' end) in + + 1.3 UnionFind avec contraintes de TC + + 1.4 Overloading: + 3 + 4 + a. 3 Int.(+) 4 + b. 3 Monoid<:int>.(+) 4 (-> instance du dessus -> ignore) + + 1.5 foo<: int[monoid -> intadd_monoid] > + foo<: int[monoid -> intmul_monoid] > + + 2. -> Monoid.(+)<:int> -> Int.(+) + + 3. -> Pb d'unification des op + (+)<: ?[monoid -> ?] > ~ Int.(+) + + Mecanisme de resolution des TC + + 4. -> il faut cloner les TC + + 5. + + a. encodage + + record 'a premonoid = { + op zero : 'a + op add : 'a -> 'a -> 'a; + } + + pred ['a] ismonoid (m : 'a premonoid) = { + left_id m.zero m.add } - } - Question: - - What about dependent types in the type for results: - we reject programs if we cannot statically check the condition - - What about the logics? we have to patch them. + op ['a <: monoid] foo (x y : 'a) = x + y + + ->> foo ['a] (m : 'a premonoid) (x y : 'a) = m.add x y + + lemma foo ['a <: monoid] P + + ->> foo ['a] (m : 'a premonoid) : ismonoid m => P -(* ==================================================================== *) -nth ['a] 'a -> 'a list -> int -> 'a + let intmonoid = { zero = 0; add = intadd } -ws : {word n} list + lemma intmonoid_is_monoid : ismonoid int_monoid -nth<:word> witness ws 2 : word -nth<:{word n}> + b. reduction avant envoi + (+)<: int[monoid -> intadd_monoid > -> Int.(+) -coercion : 'a word n -> 'a list + c. ne pas envoyer certaines instances (e.g. int est un groupe) + -> instance [nosmt] e.g. diff --git a/src/ecParser.mly b/src/ecParser.mly index 692926103c..d28094e738 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1633,16 +1633,16 @@ typedecl: (* -------------------------------------------------------------------- *) (* Type classes *) typeclass: -| TYPE CLASS x=lident inth=tc_inth? EQ LBRACE body=tc_body RBRACE { - { ptc_name = x; - ptc_inth = inth; - ptc_ops = fst body; - ptc_axs = snd body; } +| TYPE CLASS + tya=tyvars_decl? x=lident inth=prefix(LTCOLON, lqident)? + EQ LBRACE body=tc_body RBRACE { + { ptc_name = x; + ptc_params = tya; + ptc_inth = inth; + ptc_ops = fst body; + ptc_axs = snd body; } } -tc_inth: -| LTCOLON x=lqident { x } - tc_body: | ops=tc_op* axs=tc_ax* { (ops, axs) } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 676c8f3122..3a408c94c1 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -909,10 +909,11 @@ type prealize = { (* -------------------------------------------------------------------- *) type ptypeclass = { - ptc_name : psymbol; - ptc_inth : pqsymbol option; - ptc_ops : (psymbol * pty) list; - ptc_axs : (psymbol * pformula) list; + ptc_name : psymbol; + ptc_params : ptyvardecls option; + ptc_inth : pqsymbol option; + ptc_ops : (psymbol * pty) list; + ptc_axs : (psymbol * pformula) list; } type ptycinstance = { From 37ed00f24666ac7ed18a1c459b79874956d90f09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Mon, 13 Sep 2021 18:35:38 +0200 Subject: [PATCH 003/113] It compiles --- examples/typeclass.ec | 10 +- src/#ecMatching.ml# | 1226 ++++++++++++++++++++++++++++++++++++++++ src/ecDecl.ml | 20 +- src/ecDecl.mli | 16 +- src/ecEnv.ml | 8 +- src/ecEnv.mli | 2 +- src/ecPrinting.ml | 4 +- src/ecScope.ml | 14 +- src/ecSubst.ml | 8 +- src/ecSubst.mli | 2 +- src/ecTheory.ml | 4 +- src/ecTheory.mli | 4 +- src/ecTheoryReplay.ml | 2 +- src/ecTheoryReplay.mli | 2 +- src/ecTyping.ml | 3 +- src/ecUnify.ml | 63 ++- src/ecUnify.mli | 8 +- 17 files changed, 1325 insertions(+), 71 deletions(-) create mode 100644 src/#ecMatching.ml# diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 433080d46a..b1f17a562e 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -38,7 +38,6 @@ type class ring <: group = { (* instance group with int ... *) -(* type class ['a <: ring] module_ <: group = { op ( ** ) : 'a -> module_ -> module_ @@ -48,9 +47,8 @@ type class ['a <: ring] module_ <: group = { axiom scalerDr : forall (a : 'a) (x y : module_), a ** (x + y) = a ** x + a ** y }. -*) - +(* type class A = ... type class B1 <: A type class B2 <: A @@ -60,7 +58,7 @@ op ['a <: B1 & B2] int -> group -> monoid int -> monoid - +*) type ('a <: ring) poly = 'a list. @@ -79,6 +77,7 @@ qed. (* -------------------------------------------------------------------- *) op izero = 0. +(* instance group with int op zero = izero op (+) = RealInt.add. @@ -98,6 +97,7 @@ typeclass witness = { instance ['a] 'a <: witness = { }. +*) (* -------------------------------------------------------------------- *) @@ -107,6 +107,8 @@ instance ['a] 'a <: witness = { 4. clonage 5. envoi au SMT + 0. Define or find tcname + 1. Fop : -(old) path * ty list -> form diff --git a/src/#ecMatching.ml# b/src/#ecMatching.ml# new file mode 100644 index 0000000000..6b33564d8a --- /dev/null +++ b/src/#ecMatching.ml# @@ -0,0 +1,1226 @@ +(* -------------------------------------------------------------------- + * Copyright (c) - 2012--2016 - IMDEA Software Institute + * Copyright (c) - 2012--2018 - Inria + * Copyright (c) - 2012--2018 - Ecole Polytechnique + * + * Distributed under the terms of the CeCILL-C-V1 license + * -------------------------------------------------------------------- *) + +(* -------------------------------------------------------------------- *) +(* Expressions / formulas matching for tactics *) +(* -------------------------------------------------------------------- *) + +(* -------------------------------------------------------------------- *) +open EcUtils +open EcMaps +open EcIdent +open EcParsetree +open EcEnv +open EcTypes +open EcModules +open EcFol +open EcGenRegexp + +(* -------------------------------------------------------------------- *) +module Zipper = struct + exception InvalidCPos + + module P = EcPath + + type ('a, 'state) folder = + 'a -> 'state -> instr -> 'state * instr list + + type ipath = + | ZTop + | ZWhile of expr * spath + | ZIfThen of expr * spath * stmt + | ZIfElse of expr * stmt * spath + + and spath = (instr list * instr list) * ipath + + type zipper = { + z_head : instr list; (* instructions on my left (rev) *) + z_tail : instr list; (* instructions on my right (me incl.) *) + z_path : ipath; (* path (zipper) leading to me *) + } + + let cpos (i : int) : codepos1 = (0, `ByPos i) + + let zipper hd tl zpr = { z_head = hd; z_tail = tl; z_path = zpr; } + + let find_by_cp_match ((i, cm) : int option * cp_match) (s : stmt) = + let rec progress (acc : instr list) (s : instr list) (i : int) = + if i <= 0 then + let shd = oget (List.Exceptionless.hd acc) in + let stl = oget (List.Exceptionless.tl acc) in + (stl, shd, s) + else + + let ir, s = + match s with [] -> raise InvalidCPos | ir :: s -> (ir, s) + in + + let i = + match ir.i_node, cm with + | Swhile _, `While -> i-1 + | Sif _, `If -> i-1 + | Sasgn _, `Assign -> i-1 + | Srnd _, `Sample -> i-1 + | Scall _, `Call -> i-1 + | _ , _ -> i + + in progress (ir :: acc) s i + + in + + let i = odfl 1 i in if i = 0 then raise InvalidCPos; + let rev, i = (i < 0), abs i in + + let s1, ir, s2 = + progress [] (if rev then List.rev s.s_node else s.s_node) i in + + match rev with + | false -> (s1, ir, s2) + | true -> (s2, ir, s1) + + let split_at_cp_base ~after (cb : cp_base) (s : stmt) = + match cb with + | `ByPos i -> begin + let i = if i < 0 then List.length s.s_node + i else i in + try List.takedrop (i - if after then 0 else 1) s.s_node + with (Invalid_argument _ | Not_found) -> raise InvalidCPos + end + + | `ByMatch (i, cm) -> + let (s1, i, s2) = find_by_cp_match (i, cm) s in + + match after with + | false -> (List.rev s1, i :: s2) + | true -> (List.rev_append s1 [i], s2) + + let split_at_cpos1 ~after ((ipos, cb) : codepos1) s = + let (s1, s2) = split_at_cp_base ~after cb s in + + let (s1, s2) = + match ipos with + | off when off > 0 -> + let (ss1, ss2) = + try List.takedrop off s2 + with (Invalid_argument _ | Not_found) -> raise InvalidCPos in + (s1 @ ss1, ss2) + + | off when off < 0 -> + let (ss1, ss2) = + try List.takedrop (List.length s1 + off) s1 + with (Invalid_argument _ | Not_found) -> raise InvalidCPos in + (ss1, ss2 @ s2) + + | _ -> (s1, s2) + + in (s1, s2) + + let find_by_cpos1 ?(rev = true) (cpos1 : codepos1) s = + match split_at_cpos1 ~after:false cpos1 s with + | (s1, i :: s2) -> ((if rev then List.rev s1 else s1), i, s2) + | _ -> raise InvalidCPos + + let zipper_at_nm_cpos1 ((cp1, sub) : codepos1 * int) s zpr = + let (s1, i, s2) = find_by_cpos1 cp1 s in + + match i.i_node, sub with + | Swhile (e, sw), 0 -> + (ZWhile (e, ((s1, s2), zpr)), sw) + + | Sif (e, ifs1, ifs2), 0 -> + (ZIfThen (e, ((s1, s2), zpr), ifs2), ifs1) + + | Sif (e, ifs1, ifs2), 1 -> + (ZIfElse (e, ifs1, ((s1, s2), zpr)), ifs2) + + | _ -> raise InvalidCPos + + let zipper_of_cpos ((nm, cp1) : codepos) s = + let zpr, s = + List.fold_left + (fun (zpr, s) nm1 -> zipper_at_nm_cpos1 nm1 s zpr) + (ZTop, s) nm in + + let s1, i, s2 = find_by_cpos1 cp1 s in + + zipper s1 (i :: s2) zpr + + let split_at_cpos1 cpos1 s = + split_at_cpos1 ~after:true cpos1 s + + let may_split_at_cpos1 ?(rev = false) cpos1 s = + ofdfl + (fun () -> if rev then (s.s_node, []) else ([], s.s_node)) + (omap (split_at_cpos1^~ s) cpos1) + + let rec zip i ((hd, tl), ip) = + let s = stmt (List.rev_append hd (List.ocons i tl)) in + + match ip with + | ZTop -> s + | ZWhile (e, sp) -> zip (Some (i_while (e, s))) sp + | ZIfThen (e, sp, se) -> zip (Some (i_if (e, s, se))) sp + | ZIfElse (e, se, sp) -> zip (Some (i_if (e, se, s))) sp + + let zip zpr = zip None ((zpr.z_head, zpr.z_tail), zpr.z_path) + + let after ~strict zpr = + let rec doit acc ip = + match ip with + | ZTop -> acc + | ZWhile (_, ((_, is), ip)) -> doit (is :: acc) ip + | ZIfThen (_, ((_, is), ip), _) -> doit (is :: acc) ip + | ZIfElse (_, _, ((_, is), ip)) -> doit (is :: acc) ip + in + + let after = + match zpr.z_tail, strict with + | [] , _ -> doit [[]] zpr.z_path + | is , false -> doit [is] zpr.z_path + | _ :: is, true -> doit [is] zpr.z_path + in + List.rev after + + let rec fold env cpos f state s = + let zpr = zipper_of_cpos cpos s in + + match zpr.z_tail with + | [] -> raise InvalidCPos + | i :: tl -> begin + match f env state i with + | (state', [i']) when i == i' && state == state' -> (state, s) + | (state', si ) -> (state', zip { zpr with z_tail = si @ tl }) + end +end + +(* -------------------------------------------------------------------- *) +type 'a evmap = { + ev_map : ('a option) Mid.t; + ev_unset : int; +} + +module EV = struct + let empty : 'a evmap = { + ev_map = Mid.empty; + ev_unset = 0; + } + + let add (x : ident) (m : 'a evmap) = + let chg = function Some _ -> assert false | None -> Some None in + let map = Mid.change chg x m.ev_map in + { ev_map = map; ev_unset = m.ev_unset + 1; } + + let mem (x : ident) (m : 'a evmap) = + EcUtils.is_some (Mid.find_opt x m.ev_map) + + let set (x : ident) (v : 'a) (m : 'a evmap) = + let chg = function + | None | Some (Some _) -> assert false + | Some None -> Some (Some v) + in + { ev_map = Mid.change chg x m.ev_map; ev_unset = m.ev_unset - 1; } + + let get (x : ident) (m : 'a evmap) = + match Mid.find_opt x m.ev_map with + | None -> None + | Some None -> Some `Unset + | Some (Some a) -> Some (`Set a) + + let isset (x : ident) (m : 'a evmap) = + match get x m with + | Some (`Set _) -> true + | _ -> false + + let doget (x : ident) (m : 'a evmap) = + match get x m with + | Some (`Set a) -> a + | _ -> assert false + + let of_idents (ids : ident list) : 'a evmap = + List.fold_left ((^~) add) empty ids + + let fold (f : ident -> 'a -> 'b -> 'b) ev state = + Mid.fold + (fun x t s -> match t with Some t -> f x t s | None -> s) + ev.ev_map state + + let filled (m : 'a evmap) = (m.ev_unset = 0) +end + +(* -------------------------------------------------------------------- *) +type mevmap = { + evm_form : form evmap; + evm_mem : EcMemory.memory evmap; + evm_mod : EcPath.mpath evmap; +} + +(* -------------------------------------------------------------------- *) +module MEV = struct + type item = [ + | `Form of form + | `Mem of EcMemory.memory + | `Mod of EcPath.mpath + ] + + type kind = [ `Form | `Mem | `Mod ] + + let empty : mevmap = { + evm_form = EV.empty; + evm_mem = EV.empty; + evm_mod = EV.empty; + } + + let of_idents ids k = + match k with + | `Form -> { empty with evm_form = EV.of_idents ids } + | `Mem -> { empty with evm_mem = EV.of_idents ids } + | `Mod -> { empty with evm_mod = EV.of_idents ids } + + let add x k m = + match k with + | `Form -> { m with evm_form = EV.add x m.evm_form } + | `Mem -> { m with evm_mem = EV.add x m.evm_mem } + | `Mod -> { m with evm_mod = EV.add x m.evm_mod } + + let mem x k m = + match k with + | `Form -> EV.mem x m.evm_form + | `Mem -> EV.mem x m.evm_mem + | `Mod -> EV.mem x m.evm_mod + + let set x v m = + match v with + | `Form v -> { m with evm_form = EV.set x v m.evm_form } + | `Mem v -> { m with evm_mem = EV.set x v m.evm_mem } + | `Mod v -> { m with evm_mod = EV.set x v m.evm_mod } + + let get x k m = + let tx f = function `Unset -> `Unset | `Set x -> `Set (f x) in + + match k with + | `Form -> omap (tx (fun x -> `Form x)) (EV.get x m.evm_form) + | `Mem -> omap (tx (fun x -> `Mem x)) (EV.get x m.evm_mem ) + | `Mod -> omap (tx (fun x -> `Mod x)) (EV.get x m.evm_mod ) + + let isset x k m = + match k with + | `Form -> EV.isset x m.evm_form + | `Mem -> EV.isset x m.evm_mem + | `Mod -> EV.isset x m.evm_mod + + let filled m = + EV.filled m.evm_form + && EV.filled m.evm_mem + && EV.filled m.evm_mod + + let fold (f : _ -> item -> _ -> _) m v = + let v = EV.fold (fun x k v -> f x (`Form k) v) m.evm_form v in + let v = EV.fold (fun x k v -> f x (`Mem k) v) m.evm_mem v in + let v = EV.fold (fun x k v -> f x (`Mod k) v) m.evm_mod v in + v + + let assubst ue ev = + let tysubst = { ty_subst_id with ts_u = EcUnify.UniEnv.assubst ue } in + let subst = Fsubst.f_subst_init ~sty:tysubst () in + let subst = EV.fold (fun x m s -> Fsubst.f_bind_mem s x m) ev.evm_mem subst in + let subst = EV.fold (fun x m s -> Fsubst.f_bind_mod s x m) ev.evm_mod subst in + let seen = ref Sid.empty in + + let rec for_ident x binding subst = + if Sid.mem x !seen then subst else begin + seen := Sid.add x !seen; + match binding with None -> subst | Some f -> + let subst = + Mid.fold2_inter (fun x bdx _ -> for_ident x bdx) + ev.evm_form.ev_map f.f_fv subst in + Fsubst.f_bind_local subst x (Fsubst.f_subst subst f) + end + in + + Mid.fold_left + (fun acc x bd -> for_ident x bd acc) + subst ev.evm_form.ev_map +end + +(* -------------------------------------------------------------------- *) +exception MatchFailure + +type fmoptions = { + fm_delta : bool; + fm_conv : bool; + fm_horder : bool; +} + +let fmsearch = + { fm_delta = false; + fm_conv = false; + fm_horder = true ; } + +let fmrigid = { + fm_delta = false; + fm_conv = true ; + fm_horder = true ; } + +let fmdelta = { + fm_delta = true ; + fm_conv = true ; + fm_horder = true ; } + +let fmnotation = { + fm_delta = false; + fm_conv = false; + fm_horder = false; } + +(* -------------------------------------------------------------------- *) +(* Rigid unification *) +let f_match_core opts hyps (ue, ev) ~ptn subject = + let ue = EcUnify.UniEnv.copy ue in + let ev = ref ev in + + let iscvar = function + | { f_node = Flocal x } -> is_none (EV.get x !ev.evm_form) + | _ -> false + in + + let conv = + match opts.fm_conv with + | true -> EcReduction.is_conv ~ri:EcReduction.full_compat hyps + | false -> EcReduction.is_alpha_eq hyps + in + + let rec doit env ((subst, mxs) as ilc) ptn subject = + let failure = + let oue, oev = (EcUnify.UniEnv.copy ue, !ev) in + fun () -> + EcUnify.UniEnv.restore ~dst:ue ~src:oue; ev := oev; + raise MatchFailure + in + + let default () = + if opts.fm_conv then begin + let subject = Fsubst.f_subst subst subject in + let ptn = Fsubst.f_subst (MEV.assubst ue !ev) ptn in + if not (conv ptn subject) then + failure () + end else failure () + in + + try + match ptn.f_node, subject.f_node with + | Flocal x1, Flocal x2 when Mid.mem x1 mxs -> begin + if not (id_equal (oget (Mid.find_opt x1 mxs)) x2) then + failure (); + try EcUnify.unify env ue ptn.f_ty subject.f_ty + with EcUnify.UnificationFailure _ -> failure () + end + + | Flocal x1, Flocal x2 when id_equal x1 x2 -> begin + try EcUnify.unify env ue ptn.f_ty subject.f_ty + with EcUnify.UnificationFailure _ -> failure () + end + + | Flocal x, _ -> begin + match EV.get x !ev.evm_form with + | None -> + raise MatchFailure + + | Some `Unset -> + let ssbj = Fsubst.f_subst subst subject in + let ssbj = Fsubst.f_subst (MEV.assubst ue !ev) ssbj in + if not (Mid.set_disjoint mxs ssbj.f_fv) then + raise MatchFailure; + begin + try EcUnify.unify env ue ptn.f_ty subject.f_ty + with EcUnify.UnificationFailure _ -> failure (); + end; + ev := { !ev with evm_form = EV.set x ssbj !ev.evm_form } + + | Some (`Set a) -> begin + let ssbj = Fsubst.f_subst subst subject in + + if not (conv ssbj a) then + let ssbj = Fsubst.f_subst (MEV.assubst ue !ev) subject in + if not (conv ssbj a) then + doit env ilc a ssbj + else + try EcUnify.unify env ue ptn.f_ty subject.f_ty + with EcUnify.UnificationFailure _ -> failure () + else + try EcUnify.unify env ue ptn.f_ty subject.f_ty + with EcUnify.UnificationFailure _ -> failure () + end + end + + | Fapp (f1, fs1), _ -> begin + try + match subject.f_node with + | Fapp (f2, fs2) -> begin + try doit_args env ilc (f1::fs1) (f2::fs2) + with MatchFailure when opts.fm_conv -> + let rptn = f_betared ptn in + if (ptn.f_tag <> rptn.f_tag) + then doit env ilc rptn subject + else failure () + end + | _ -> failure () + + with MatchFailure when opts.fm_horder -> + match f1.f_node with + | Flocal f when + not (Mid.mem f mxs) + && (EV.get f !ev.evm_form = Some `Unset) + && List.for_all iscvar fs1 + -> + + let oargs = List.map destr_local fs1 in + + if not (List.is_unique ~eq:id_equal oargs) then + failure (); + + let xsubst, bindings = + List.map_fold + (fun xsubst x -> + let x, xty = (destr_local x, x.f_ty) in + let nx = EcIdent.fresh x in + let xsubst = + Mid.find_opt x mxs + |> omap (fun y -> Fsubst.f_bind_rename xsubst y nx xty) + |> odfl xsubst + in (xsubst, (nx, GTty xty))) + Fsubst.f_subst_id fs1 in + + let ssbj = Fsubst.f_subst xsubst subject in + let ssbj = Fsubst.f_subst subst ssbj in + + if not (Mid.set_disjoint mxs ssbj.f_fv) then + failure (); + + begin + let fty = toarrow (List.map f_ty fs1) ssbj.f_ty in + + try EcUnify.unify env ue f1.f_ty fty + with EcUnify.UnificationFailure _ -> failure (); + end; + + let ssbj = f_lambda bindings ssbj in + + ev := { !ev with evm_form = EV.set f ssbj !ev.evm_form } + + | _ -> default () + end + + | Fquant (b1, q1, f1), Fquant (b2, q2, f2) when b1 = b2 -> + let n1, n2 = List.length q1, List.length q2 in + let q1, r1 = List.split_at (min n1 n2) q1 in + let q2, r2 = List.split_at (min n1 n2) q2 in + let (env, subst, mxs) = doit_bindings env (subst, mxs) q1 q2 in + doit env (subst, mxs) (f_quant b1 r1 f1) (f_quant b2 r2 f2) + + | Fquant _, Fquant _ -> + failure (); + + | Fpvar (pv1, m1), Fpvar (pv2, m2) -> + let pv1 = EcEnv.NormMp.norm_pvar env pv1 in + let pv2 = EcEnv.NormMp.norm_pvar env pv2 in + if not (EcTypes.pv_equal pv1 pv2) then + failure (); + doit_mem env mxs m1 m2 + + | Fif (c1, t1, e1), Fif (c2, t2, e2) -> + List.iter2 (doit env ilc) [c1; t1; e1] [c2; t2; e2] + + | Fmatch (b1, fs1, ty1), Fmatch (b2, fs2, ty2) -> begin + (try EcUnify.unify env ue ty1 ty2 + with EcUnify.UnificationFailure _ -> failure ()); + if List.length fs1 <> List.length fs2 then + failure (); + List.iter2 (doit env ilc) (b1 :: fs1) (b2 :: fs2) + end + + | Fint i1, Fint i2 -> + if not (EcBigInt.equal i1 i2) then failure (); + + | Fglob (mp1, me1), Fglob (mp2, me2) -> + let mp1 = EcEnv.NormMp.norm_mpath env mp1 in + let mp2 = EcEnv.NormMp.norm_mpath env mp2 in + if not (EcPath.m_equal mp1 mp2) then + failure (); + doit_mem env mxs me1 me2 + + | Ftuple fs1, Ftuple fs2 -> + if List.length fs1 <> List.length fs2 then + failure (); + List.iter2 (doit env ilc) fs1 fs2 + + | Fproj (f1, i), Fproj (f2, j) -> + if i <> j then failure () else doit env ilc f1 f2 + + | Fop (op1, tys1), Fop (op2, tys2) -> begin + if not (EcPath.p_equal op1 op2) then + failure (); + try List.iter2 (EcUnify.unify env ue) tys1 tys2 + with EcUnify.UnificationFailure _ -> failure () + end + + | FhoareF hf1, FhoareF hf2 -> begin + if not (EcReduction.EqTest.for_xp env hf1.hf_f hf2.hf_f) then + failure (); + let mxs = Mid.add EcFol.mhr EcFol.mhr mxs in + List.iter2 (doit env (subst, mxs)) + [hf1.hf_pr; hf1.hf_po] [hf2.hf_pr; hf2.hf_po] + end + + | FbdHoareF hf1, FbdHoareF hf2 -> begin + if not (EcReduction.EqTest.for_xp env hf1.bhf_f hf2.bhf_f) then + failure (); + if hf1.bhf_cmp <> hf2.bhf_cmp then + failure (); + let mxs = Mid.add EcFol.mhr EcFol.mhr mxs in + List.iter2 (doit env (subst, mxs)) + [hf1.bhf_pr; hf1.bhf_po; hf1.bhf_bd] + [hf2.bhf_pr; hf2.bhf_po; hf2.bhf_bd] + end + + | FequivF hf1, FequivF hf2 -> begin + if not (EcReduction.EqTest.for_xp env hf1.ef_fl hf2.ef_fl) then + failure (); + if not (EcReduction.EqTest.for_xp env hf1.ef_fr hf2.ef_fr) then + failure(); + let mxs = Mid.add EcFol.mleft EcFol.mleft mxs in + let mxs = Mid.add EcFol.mright EcFol.mright mxs in + List.iter2 + (doit env (subst, mxs)) + [hf1.ef_pr; hf1.ef_po] [hf2.ef_pr; hf2.ef_po] + end + + | Fpr pr1, Fpr pr2 -> begin + if not (EcReduction.EqTest.for_xp env pr1.pr_fun pr2.pr_fun) then + failure (); + doit_mem env mxs pr1.pr_mem pr2.pr_mem; + let mxs = Mid.add EcFol.mhr EcFol.mhr mxs in + List.iter2 + (doit env (subst, mxs)) + [pr1.pr_args; pr1.pr_event] [pr2.pr_args; pr2.pr_event] + end + + | _, _ -> default () + + with MatchFailure when opts.fm_delta -> + match fst_map f_node (destr_app ptn), + fst_map f_node (destr_app subject) + with + | (Fop (op1, tys1), args1), (Fop (op2, tys2), args2) -> begin +(* try + if not (EcPath.p_equal op1 op2) then + failure (); + try + List.iter2 (EcUnify.unify env ue) tys1 tys2; + doit_args env ilc args1 args2 + with EcUnify.UnificationFailure _ -> failure () + with MatchFailure -> *) +(* Benj: Fixme user reduction ... *) + if EcEnv.Op.reducible env op1 then + doit_reduce env ((doit env ilc)^~ subject) ptn.f_ty op1 tys1 args1 + else if EcEnv.Op.reducible env op2 then + doit_reduce env (doit env ilc ptn) subject.f_ty op2 tys2 args2 + else + failure () + end + + | (Flocal x1, args1), _ when LDecl.can_unfold x1 hyps -> + doit_lreduce env ((doit env ilc)^~ subject) ptn.f_ty x1 args1 + + | _, (Flocal x2, args2) when LDecl.can_unfold x2 hyps -> + doit_lreduce env (doit env ilc ptn) subject.f_ty x2 args2 + + | (Fop (op1, tys1), args1), _ when EcEnv.Op.reducible env op1 -> + doit_reduce env ((doit env ilc)^~ subject) ptn.f_ty op1 tys1 args1 + + | _, (Fop (op2, tys2), args2) when EcEnv.Op.reducible env op2 -> + doit_reduce env (doit env ilc ptn) subject.f_ty op2 tys2 args2 + + | _, _ -> failure () + + and doit_args env ilc fs1 fs2 = + if List.length fs1 <> List.length fs2 then + raise MatchFailure; + List.iter2 (doit env ilc) fs1 fs2 + + and doit_reduce env cb ty op tys args = + let reduced = + try f_app (EcEnv.Op.reduce env op tys) args ty + with NotReducible -> raise MatchFailure in + cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) + + and doit_lreduce _env cb ty x args = + let reduced = + try f_app (LDecl.unfold x hyps) args ty + with LookupFailure _ -> raise MatchFailure in + cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) + + and doit_mem _env mxs m1 m2 = + match EV.get m1 !ev.evm_mem with + | None -> + if not (EcMemory.mem_equal m1 m2) then + raise MatchFailure + + | Some `Unset -> + if Mid.mem m2 mxs then + raise MatchFailure; + ev := { !ev with evm_mem = EV.set m1 m2 !ev.evm_mem } + + | Some (`Set m1) -> + if not (EcMemory.mem_equal m1 m2) then + raise MatchFailure + + and doit_bindings env (subst, mxs) q1 q2 = + let doit_binding (env, subst, mxs) (x1, gty1) (x2, gty2) = + let gty2 = Fsubst.gty_subst subst gty2 in + + assert (not (Mid.mem x1 mxs) && not (Mid.mem x2 mxs)); + + let env, subst = + match gty1, gty2 with + | GTty ty1, GTty ty2 -> + begin + try EcUnify.unify env ue ty1 ty2 + with EcUnify.UnificationFailure _ -> raise MatchFailure + end; + + let subst = + if id_equal x1 x2 + then subst + else Fsubst.f_bind_rename subst x2 x1 ty2 + + and env = EcEnv.Var.bind_local x1 ty1 env in + + (env, subst) + + | GTmem None, GTmem None -> + (env, subst) + + | GTmem (Some m1), GTmem (Some m2) -> + let xp1 = EcMemory.lmt_xpath m1 in + let xp2 = EcMemory.lmt_xpath m2 in + let m1 = EcMemory.lmt_bindings m1 in + let m2 = EcMemory.lmt_bindings m2 in + + if not (EcPath.x_equal xp1 xp2) then + raise MatchFailure; + if not ( + try + EcSymbols.Msym.equal + (fun (p1,ty1) (p2,ty2) -> + if p1 <> p2 then raise MatchFailure; + EcUnify.unify env ue ty1 ty2; true) + m1 m2 + with EcUnify.UnificationFailure _ -> raise MatchFailure) + then + raise MatchFailure; + + let subst = + if id_equal x1 x2 + then subst + else Fsubst.f_bind_mem subst x2 x1 + in (env, subst) + + | GTmodty (p1, r1), GTmodty (p2, r2) -> + if not (ModTy.mod_type_equiv env p1 p2) then + raise MatchFailure; + if not (NormMp.equal_restr env r1 r2) then + raise MatchFailure; + + let subst = + if id_equal x1 x2 + then subst + else Fsubst.f_bind_mod subst x2 (EcPath.mident x1) + + and env = EcEnv.Mod.bind_local x1 p1 r1 env in + + (env, subst) + + | _, _ -> raise MatchFailure + in + (env, subst, Mid.add x1 x2 mxs) + in + List.fold_left2 doit_binding (env, subst, mxs) q1 q2 + + in + doit (EcEnv.LDecl.toenv hyps) (Fsubst.f_subst_id, Mid.empty) ptn subject; + (ue, !ev) + +let f_match opts hyps (ue, ev) ~ptn subject = + let (ue, ev) = f_match_core opts hyps (ue, ev) ~ptn subject in + if not (MEV.filled ev) then + raise MatchFailure; + let clue = + try EcUnify.UniEnv.close ue + with EcUnify.UninstanciateUni -> raise MatchFailure + in + (ue, clue, ev) + +(* -------------------------------------------------------------------- *) +type ptnpos = [`Select of int | `Sub of ptnpos] Mint.t +type occ = [`Inclusive | `Exclusive] * Sint.t + +exception InvalidPosition +exception InvalidOccurence + +module FPosition = struct + type select = [`Accept of int | `Continue] + + (* ------------------------------------------------------------------ *) + let empty : ptnpos = Mint.empty + + (* ------------------------------------------------------------------ *) + let is_empty (p : ptnpos) = Mint.is_empty p + + (* ------------------------------------------------------------------ *) + let rec tostring (p : ptnpos) = + let items = Mint.bindings p in + let items = + List.map + (fun (i, p) -> Printf.sprintf "%d[%s]" i (tostring1 p)) + items + in + String.concat ", " items + + (* ------------------------------------------------------------------ *) + and tostring1 = function + | `Select i when i < 0 -> "-" + | `Select i -> Printf.sprintf "-(%d)" i + | `Sub p -> tostring p + + (* ------------------------------------------------------------------ *) + let occurences = + let rec doit1 n p = + match p with + | `Select _ -> n+1 + | `Sub p -> doit n p + + and doit n (ps : ptnpos) = + Mint.fold (fun _ p n -> doit1 n p) ps n + + in + fun p -> doit 0 p + + (* ------------------------------------------------------------------ *) + let filter ((mode, s) : occ) = + let rec doit1 n p = + match p with + | `Select _ -> begin + match mode with + | `Inclusive -> (n+1, if Sint.mem n s then Some p else None ) + | `Exclusive -> (n+1, if Sint.mem n s then None else Some p) + end + + | `Sub p -> begin + match doit n p with + | (n, sub) when Mint.is_empty sub -> (n, None) + | (n, sub) -> (n, Some (`Sub sub)) + end + + and doit n (ps : ptnpos) = + Mint.mapi_filter_fold (fun _ p n -> doit1 n p) ps n + + in + fun p -> snd (doit 1 p) + + (* ------------------------------------------------------------------ *) + let is_occurences_valid o cpos = + let (min, max) = (Sint.min_elt o, Sint.max_elt o) in + not (min < 1 || max > occurences cpos) + + (* ------------------------------------------------------------------ *) + let select ?o test = + let rec doit1 ctxt pos fp = + match test ctxt fp with + | `Accept i -> Some (`Select i) + | `Continue -> begin + let subp = + match fp.f_node with + | Fif (c, f1, f2) -> doit pos (`WithCtxt (ctxt, [c; f1; f2])) + | Fapp (f, fs) -> doit pos (`WithCtxt (ctxt, f :: fs)) + | Ftuple fs -> doit pos (`WithCtxt (ctxt, fs)) + + | Fmatch (b, fs, _) -> + doit pos (`WithCtxt (ctxt, b :: fs)) + + | Fquant (_, b, f) -> + let xs = List.pmap (function (x, GTty _) -> Some x | _ -> None) b in + let ctxt = List.fold_left ((^~) Sid.add) ctxt xs in + doit pos (`WithCtxt (ctxt, [f])) + + | Flet (lp, f1, f2) -> + let subctxt = List.fold_left ((^~) Sid.add) ctxt (lp_ids lp) in + doit pos (`WithSubCtxt [(ctxt, f1); (subctxt, f2)]) + + | Fproj (f, _) -> + doit pos (`WithCtxt (ctxt, [f])) + + | Fpr pr -> + let subctxt = Sid.add pr.pr_mem ctxt in + doit pos (`WithSubCtxt [(ctxt, pr.pr_args); (subctxt, pr.pr_event)]) + + | FhoareF hs -> + doit pos (`WithCtxt (Sid.add EcFol.mhr ctxt, [hs.hf_pr; hs.hf_po])) + + | FbdHoareF hs -> + let subctxt = Sid.add EcFol.mhr ctxt in + doit pos (`WithSubCtxt ([(subctxt, hs.bhf_pr); + (subctxt, hs.bhf_po); + ( ctxt, hs.bhf_bd)])) + + | FequivF es -> + let ctxt = Sid.add EcFol.mleft ctxt in + let ctxt = Sid.add EcFol.mright ctxt in + doit pos (`WithCtxt (ctxt, [es.ef_pr; es.ef_po])) + + | _ -> None + in + omap (fun p -> `Sub p) subp + end + + and doit pos fps = + let fps = + match fps with + | `WithCtxt (ctxt, fps) -> + List.mapi + (fun i fp -> + doit1 ctxt (i::pos) fp |> omap (fun p -> (i, p))) + fps + + | `WithSubCtxt fps -> + List.mapi + (fun i (ctxt, fp) -> + doit1 ctxt (i::pos) fp |> omap (fun p -> (i, p))) + fps + in + + let fps = List.pmap identity fps in + match fps with + | [] -> None + | _ -> Some (Mint.of_list fps) + + in + fun fp -> + let cpos = + match doit [] (`WithCtxt (Sid.empty, [fp])) with + | None -> Mint.empty + | Some p -> p + in + match o with + | None -> cpos + | Some o -> + if not (is_occurences_valid (snd o) cpos) then + raise InvalidOccurence; + filter o cpos + + (* ------------------------------------------------------------------ *) + let select_form ?(xconv = `Conv) ?(keyed = false) hyps o p target = + let na = List.length (snd (EcFol.destr_app p)) in + + let kmatch key tp = + match key, (fst (destr_app tp)).f_node with + | `NoKey , _ -> true + | `Path p, Fop (p', _) -> EcPath.p_equal p p' + | `Path _, _ -> false + | `Var x, Flocal x' -> id_equal x x' + | `Var _, _ -> false + in + + let keycheck tp key = not keyed || kmatch key tp in + + let key = + match (fst (destr_app p)).f_node with + | Fop (p, _) -> `Path p + | Flocal x -> `Var x + | _ -> `NoKey + in + + let test xconv _ tp = + if not (keycheck tp key) then `Continue else begin + let (tp, ti) = + match tp.f_node with + | Fapp (h, hargs) when List.length hargs > na -> + let (a1, a2) = List.takedrop na hargs in + (f_app h a1 (toarrow (List.map f_ty a2) tp.f_ty), na) + | _ -> (tp, -1) + in + if EcReduction.xconv xconv hyps p tp then `Accept ti else `Continue + end + + in select ?o (test xconv) target + + (* ------------------------------------------------------------------ *) + let map (p : ptnpos) (tx : form -> form) (f : form) = + let rec doit1 p fp = + match p with + | `Select i when i < 0 -> tx fp + + | `Select i -> begin + let (f, fs) = EcFol.destr_app fp in + if List.length fs < i then raise InvalidPosition; + let (fs1, fs2) = List.takedrop i fs in + let f' = f_app f fs1 (toarrow (List.map f_ty fs2) fp.f_ty) in + f_app (tx f') fs2 fp.f_ty + end + + | `Sub p -> begin + match fp.f_node with + | Flocal _ -> raise InvalidPosition + | Fpvar _ -> raise InvalidPosition + | Fglob _ -> raise InvalidPosition + | Fop _ -> raise InvalidPosition + | Fint _ -> raise InvalidPosition + + | Fquant (q, b, f) -> + let f' = as_seq1 (doit p [f]) in + FSmart.f_quant (fp, (q, b, f)) (q, b, f') + + | Fif (c, f1, f2) -> + let (c', f1', f2') = as_seq3 (doit p [c; f1; f2]) in + FSmart.f_if (fp, (c, f1, f2)) (c', f1', f2') + + | Fmatch (b, fs, ty) -> + let bfs = doit p (b :: fs) in + FSmart.f_match (fp, (b, fs, ty)) (List.hd bfs, List.tl bfs, ty) + + | Fapp (f, fs) -> begin + match doit p (f :: fs) with + | [] -> assert false + | f' :: fs' -> + FSmart.f_app (fp, (f, fs, fp.f_ty)) (f', fs', fp.f_ty) + end + + | Ftuple fs -> + let fs' = doit p fs in + FSmart.f_tuple (fp, fs) fs' + + | Fproj (f, i) -> + FSmart.f_proj (fp, (f, fp.f_ty)) (as_seq1 (doit p [f]), fp.f_ty) i + + | Flet (lv, f1, f2) -> + let (f1', f2') = as_seq2 (doit p [f1; f2]) in + FSmart.f_let (fp, (lv, f1, f2)) (lv, f1', f2') + + | Fpr pr -> + let (args', event') = as_seq2 (doit p [pr.pr_args; pr.pr_event]) in + f_pr pr.pr_mem pr.pr_fun args' event' + + | FhoareF hf -> + let (hf_pr, hf_po) = as_seq2 (doit p [hf.hf_pr; hf.hf_po]) in + f_hoareF_r { hf with hf_pr; hf_po; } + + | FbdHoareF hf -> + let sub = doit p [hf.bhf_pr; hf.bhf_po; hf.bhf_bd] in + let (bhf_pr, bhf_po, bhf_bd) = as_seq3 sub in + f_bdHoareF_r { hf with bhf_pr; bhf_po; bhf_bd; } + + | FequivF ef -> + let (ef_pr, ef_po) = as_seq2 (doit p [ef.ef_pr; ef.ef_po]) in + f_equivF_r { ef with ef_pr; ef_po; } + + | FhoareS _ -> raise InvalidPosition + | FbdHoareS _ -> raise InvalidPosition + | FequivS _ -> raise InvalidPosition + | FeagerF _ -> raise InvalidPosition + end + + and doit ps fps = + match Mint.is_empty ps with + | true -> fps + | false -> + let imin = fst (Mint.min_binding ps) + and imax = fst (Mint.max_binding ps) in + if imin < 0 || imax >= List.length fps then + raise InvalidPosition; + let fps = List.mapi (fun i x -> (x, Mint.find_opt i ps)) fps in + let fps = List.map (function (f, None) -> f | (f, Some p) -> doit1 p f) fps in + fps + + in + as_seq1 (doit p [f]) + + (* ------------------------------------------------------------------ *) + let topattern ?x (p : ptnpos) (f : form) = + let x = match x with None -> EcIdent.create "_p" | Some x -> x in + let tx fp = f_local x fp.f_ty in (x, map p tx f) +end + +(* -------------------------------------------------------------------- *) +type cptenv = CPTEnv of f_subst + +let can_concretize ev ue = + EcUnify.UniEnv.closed ue && MEV.filled ev + +(* -------------------------------------------------------------------------- *) +type regexp_instr = regexp1_instr gen_regexp + +and regexp1_instr = + | RAssign (*of lvalue * expr*) + | RSample (*of lvalue * expr*) + | RCall (*of lvalue option * EcPath.xpath * expr list*) + | RIf of (*expr *) regexp_instr * regexp_instr + | RWhile of (*expr *) regexp_instr + + +module RegexpBaseInstr = struct + open Zipper + + type regexp = regexp_instr + type regexp1 = regexp1_instr + + type pos = int + type path = int list + + type subject = instr list + + type engine = { + e_zipper : zipper; + e_pos : pos; + e_path : pos list; + } + + let mkengine (s : subject) = { + e_zipper = zipper [] s ZTop; + e_pos = 0; + e_path = []; + } + + let position (e : engine) = + e.e_pos + + let at_start (e : engine) = + List.is_empty e.e_zipper.z_head + + let at_end (e : engine) = + List.is_empty e.e_zipper.z_tail + + let path (e : engine) = + e.e_pos :: e.e_path + + let eat_option (f : 'a -> 'a -> unit) (x : 'a option) (xn : 'a option) = + match x, xn with + | None , Some _ -> raise NoMatch + | Some _, None -> raise NoMatch + | None , None -> () + | Some x, Some y -> f x y + + let eat_list (f : 'a -> 'a -> unit) (x : 'a list) (xn : 'a list) = + try List.iter2 f x xn + with Invalid_argument _ -> raise NoMatch (* FIXME *) + + let eat_lvalue (lv : lvalue) (lvn : lvalue) = + if not (lv_equal lv lvn) then raise NoMatch + + let eat_expr (e : expr) (en : expr) = + if not (e_equal e en) then raise NoMatch + + let eat_xpath (f : EcPath.xpath) (fn : EcPath.xpath) = + if not (EcPath.x_equal f fn) then raise NoMatch + + let rec eat_base (eng : engine) (r : regexp1) = + let z = eng.e_zipper in + + match z.z_tail with + | [] -> raise NoMatch + + | i :: tail -> begin + match (i.i_node,r) with + | Sasgn _, RAssign + | Srnd _, RSample + | Scall _, RCall -> (eat eng, []) + + | Sif (e, st, sf), RIf (stn, sfn) -> begin + let e_t = mkengine st.s_node in + let e_t = + let zp = ZIfThen (e, ((z.z_head, tail), z.z_path), sf) in + let zp = { e_t.e_zipper with z_path = zp; } in + { e_t with e_path = 0 :: eng.e_pos :: eng.e_path; e_zipper = zp; } in + + let e_f = mkengine sf.s_node in + let e_f = + let zp = ZIfElse (e, st, ((z.z_head, tail), z.z_path)) in + let zp = { e_f.e_zipper with z_path = zp; } in + { e_f with e_path = 1 :: eng.e_pos :: eng.e_path; e_zipper = zp; } in + + (eat eng, [(e_t, stn); (e_f, sfn)]) + end + + | Swhile (e, s), RWhile sn -> begin + let es = mkengine s.s_node in + let es = + let zp = ZWhile (e, ((z.z_head, tail), z.z_path)) in + let zp = { es.e_zipper with z_path = zp; } in + { es with e_path = 0 :: eng.e_pos :: eng.e_path; e_zipper = zp; } in + + (eat eng, [(es, sn)]) + end + + | _, _ -> raise NoMatch + end + + and eat (e : engine) = { + e with e_zipper = zip_eat e.e_zipper; + e_pos = e.e_pos + 1; + } + + and zip_eat (z : zipper) = + match z.z_tail with + | [] -> raise NoMatch + | i :: tail -> zipper (i :: z.z_head) tail z.z_path + + let extract (e : engine) ((lo, hi) : pos * pos) = + if hi <= lo then [] else + + let s = List.rev_append e.e_zipper.z_head e.e_zipper.z_tail in + List.of_enum (List.enum s |> Enum.skip lo |> Enum.take (hi-lo)) + + let rec next_zipper (z : zipper) = + match z.z_tail with + | i :: tail -> + begin match i.i_node with + | Sif (e, stmttrue, stmtfalse) -> + let z = (i::z.z_head, tail), z.z_path in + let path = ZIfThen (e, z, stmtfalse) in + let z' = zipper [] stmttrue.s_node path in + Some z' + + | Swhile (e, block) -> + let z = (i::z.z_head, tail), z.z_path in + let path = ZWhile (e, z) in + let z' = zipper [] block.s_node path in + Some z' + + | Sasgn _ | Srnd _ | Scall _ | _ -> + Some { z with z_head = i :: z.z_head ; z_tail = tail } + end + + | [] -> + match z.z_path with + | ZTop -> None + + | ZWhile (_e, ((head, tail), path)) -> + let z' = zipper head tail path in + next_zipper z' + + | ZIfThen (e, father, stmtfalse) -> + let stmttrue = stmt (List.rev z.z_head) in + let z' = zipper [] stmtfalse.s_node (ZIfElse (e, stmttrue, father)) in + next_zipper z' + + | ZIfElse (_e, _stmttrue, ((head, tail), path)) -> + let z' = zipper head tail path in + next_zipper z' + + let next (e : engine) = + next_zipper e.e_zipper |> omap (fun z -> + { e with e_zipper = z; e_pos = List.length z.z_head }) +end + +module RegexpStmt = EcGenRegexp.Regexp(RegexpBaseInstr) diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 02d9352779..762486b618 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -17,7 +17,12 @@ module BI = EcBigInt module Ssym = EcSymbols.Ssym (* -------------------------------------------------------------------- *) -type ty_param = EcIdent.t * EcPath.Sp.t +type typeclass = { + tc_name : EcPath.path; + tc_args : ty list; +} + +type ty_param = EcIdent.t * typeclass list type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] @@ -53,7 +58,7 @@ let tydecl_as_record (td : tydecl) = match td.tyd_type with `Record x -> x | _ -> assert false (* -------------------------------------------------------------------- *) -let abs_tydecl ?(resolve = true) ?(tc = Sp.empty) ?(params = `Int 0) () = +let abs_tydecl ?(resolve = true) ?(tc = Sp.empty) ?(params = `Int 0) () : tydecl = let params = match params with | `Named params -> @@ -61,7 +66,7 @@ let abs_tydecl ?(resolve = true) ?(tc = Sp.empty) ?(params = `Int 0) () = | `Int n -> let fmt = fun x -> Printf.sprintf "'%s" x in List.map - (fun x -> (EcIdent.create x, Sp.empty)) + (fun x -> (EcIdent.create x, [])) (*TODO: typeclass list to define*) (EcUid.NameGen.bulk ~fmt n) in @@ -277,10 +282,11 @@ let axiomatized_op ?(nargs = 0) ?(nosmt = false) path (tparams, bd) = ax_visibility = if nosmt then `NoSmt else `Visible; } (* -------------------------------------------------------------------- *) -type typeclass = { - tc_prt : EcPath.path option; - tc_ops : (EcIdent.t * EcTypes.ty) list; - tc_axs : (EcSymbols.symbol * EcCoreFol.form) list; +type tc_decl = { + tc_prt : EcPath.path option; + tc_tparams : ty_params; + tc_ops : (EcIdent.t * EcTypes.ty) list; + tc_axs : (EcSymbols.symbol * EcCoreFol.form) list; } (* -------------------------------------------------------------------- *) diff --git a/src/ecDecl.mli b/src/ecDecl.mli index 280428e6be..f9a526549b 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -15,7 +15,12 @@ open EcTypes open EcCoreFol (* -------------------------------------------------------------------- *) -type ty_param = EcIdent.t * EcPath.Sp.t +type typeclass = { + tc_name : EcPath.path; + tc_args : ty list; +} + +type ty_param = EcIdent.t * typeclass list type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] @@ -158,10 +163,11 @@ val axiomatized_op : -> axiom (* -------------------------------------------------------------------- *) -type typeclass = { - tc_prt : EcPath.path option; - tc_ops : (EcIdent.t * EcTypes.ty) list; - tc_axs : (EcSymbols.symbol * form) list; +type tc_decl = { + tc_prt : EcPath.path option; + tc_tparams : ty_params; + tc_ops : (EcIdent.t * EcTypes.ty) list; + tc_axs : (EcSymbols.symbol * EcCoreFol.form) list; } (* -------------------------------------------------------------------- *) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 11452983a9..3611d1fbc0 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -109,7 +109,7 @@ type mc = { mc_operators : (ipath * EcDecl.operator) MMsym.t; mc_axioms : (ipath * EcDecl.axiom) MMsym.t; mc_theories : (ipath * (ctheory * thmode)) MMsym.t; - mc_typeclasses: (ipath * typeclass) MMsym.t; + mc_typeclasses: (ipath * tc_decl) MMsym.t; mc_rwbase : (ipath * path) MMsym.t; mc_components : ipath MMsym.t; } @@ -856,7 +856,7 @@ module MC = struct let on1 (opid, optype) = let opname = EcIdent.name opid in let optype = ty_subst tsubst optype in - let opdecl = mk_op ~opaque:false [(self, Sp.singleton mypath)] optype (Some OP_TC) in + let opdecl = mk_op ~opaque:false [(*(self, Sp.singleton mypath)*)] optype (Some OP_TC) in (*TODO: typeclass list to define*) (opid, xpath opname, optype, opdecl) in List.map on1 tc.tc_ops @@ -875,7 +875,7 @@ module MC = struct List.map (fun (x, ax) -> let ax = Fsubst.f_subst fsubst ax in - (x, { ax_tparams = [(self, Sp.singleton mypath)]; + (x, { ax_tparams = [(*(self, Sp.singleton mypath)*)]; (*TODO: typeclass list to define*) ax_spec = ax; ax_kind = `Axiom (Ssym.empty, false); ax_visibility = `NoSmt; })) @@ -1274,7 +1274,7 @@ let try_lf f = (* ------------------------------------------------------------------ *) module TypeClass = struct - type t = typeclass + type t = tc_decl let by_path_opt (p : EcPath.path) (env : env) = omap diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 3f7ba120f3..80a70edfdb 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -341,7 +341,7 @@ end (* -------------------------------------------------------------------- *) module TypeClass : sig - type t = typeclass + type t = tc_decl val add : path -> env -> env val bind : ?import:import -> symbol -> t -> env -> env diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 0bbe6bd168..1b91286a2b 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -1804,12 +1804,12 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = (* -------------------------------------------------------------------- *) let pp_tyvar_ctt (ppe : PPEnv.t) fmt (tvar, ctt) = - match EcPath.Sp.elements ctt with + match ctt with | [] -> pp_tyvar ppe fmt tvar | ctt -> Format.fprintf fmt "%a <: %a" (pp_tyvar ppe) tvar - (pp_list " &@ " (pp_tcname ppe)) ctt + (pp_list " &@ " (fun fmt tc -> pp_tcname ppe fmt tc.tc_name)) ctt (* -------------------------------------------------------------------- *) let pp_tyvarannot (ppe : PPEnv.t) fmt ids = diff --git a/src/ecScope.ml b/src/ecScope.ml index 4f68367f3e..ff7b60237d 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1308,7 +1308,7 @@ module Op = struct let ax = EcFol.f_forall (List.map (snd_map gtty) bds) ax in let ax = - { ax_tparams = List.map (fun ty -> (ty, Sp.empty)) nparams; + { ax_tparams = List.map (fun ty -> (ty, [])) nparams; ax_spec = ax; ax_kind = `Axiom (Ssym.empty, false); ax_visibility = `Visible; } in @@ -1559,7 +1559,7 @@ module Ty = struct scope (* ------------------------------------------------------------------ *) - let add_class (scope : scope) { pl_desc = tcd } = + let add_class (scope : scope) { pl_desc = tcd; pl_loc = loc } = assert (scope.sc_pr_uc = None); let name = unloc tcd.ptc_name in @@ -1590,10 +1590,13 @@ module Ty = struct |> oiter (fun (x, y) -> hierror ~loc:y.pl_loc "duplicated axiom name: `%s'" x.pl_desc); + (* Check typeclasses arguments *) + let ue = TT.transtyvars scenv (loc, tcd.ptc_params) in + (* Check operators types *) let operators = let check1 (x, ty) = - let ue = EcUnify.UniEnv.create (Some []) in + let ue = EcUnify.UniEnv.copy ue in let ty = transty tp_tydecl scenv ue ty in let ty = Tuni.offun (EcUnify.UniEnv.close ue) ty in (EcIdent.create (unloc x), ty) @@ -1604,7 +1607,7 @@ module Ty = struct let axioms = let scenv = EcEnv.Var.bind_locals operators scenv in let check1 (x, ax) = - let ue = EcUnify.UniEnv.create (Some []) in + let ue = EcUnify.UniEnv.copy ue in let ax = trans_prop scenv ue ax in let ax = EcFol.Fsubst.uni (EcUnify.UniEnv.close ue) ax in (unloc x, ax) @@ -1612,7 +1615,8 @@ module Ty = struct tcd.ptc_axs |> List.map check1 in (* Construct actual type-class *) - { tc_prt = uptc; tc_ops = operators; tc_axs = axioms; } + { tc_prt = uptc; tc_tparams = EcUnify.UniEnv.tparams ue; + tc_ops = operators; tc_axs = axioms; } in bindclass scope (name, tclass) diff --git a/src/ecSubst.ml b/src/ecSubst.ml index b5cf7fd36a..a1eab1a229 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -292,8 +292,8 @@ let init_tparams (s : _subst) (params : ty_params) (params' : ty_params) = add_tparams s params (List.map (fun (p',_) -> tvar p') params') (* -------------------------------------------------------------------- *) -let subst_typaram (s : _subst) ((id, tc) : ty_param) = - (EcIdent.fresh id, Sp.fold (fun p tc -> Sp.add (s.s_p p) tc) tc Sp.empty) +let subst_typaram (s : _subst) ((id, tc) : ty_param) : ty_param = + (EcIdent.fresh id, [] (*Sp.fold (fun p tc -> Sp.add (s.s_p p) tc) tc Sp.empty*)) (*TODO: typeclass list to define*) let subst_typarams (s : _subst) (typ : ty_params) = List.map (subst_typaram s) typ @@ -472,10 +472,10 @@ let subst_instance (s : _subst) tci = (* -------------------------------------------------------------------- *) let subst_tc (s : _subst) tc = let tc_prt = tc.tc_prt |> omap s.s_p in + let tc_tparams = List.map (subst_typaram s) tc.tc_tparams in let tc_ops = List.map (snd_map s.s_ty) tc.tc_ops in let tc_axs = List.map (snd_map (subst_form s)) tc.tc_axs in - { tc_prt; tc_ops; tc_axs; } - + { tc_prt; tc_tparams; tc_ops; tc_axs; } (* -------------------------------------------------------------------- *) (* SUBSTITUTION OVER THEORIES *) let rec subst_theory_item_r (s : _subst) (item : theory_item_r) = diff --git a/src/ecSubst.mli b/src/ecSubst.mli index 70ba5379cc..a390096829 100644 --- a/src/ecSubst.mli +++ b/src/ecSubst.mli @@ -44,7 +44,7 @@ val subst_theory : subst -> theory -> theory val subst_ax : subst -> axiom -> axiom val subst_op : subst -> operator -> operator val subst_tydecl : subst -> tydecl -> tydecl -val subst_tc : subst -> typeclass -> typeclass +val subst_tc : subst -> tc_decl -> tc_decl val subst_ctheory : subst -> ctheory -> ctheory (* -------------------------------------------------------------------- *) diff --git a/src/ecTheory.ml b/src/ecTheory.ml index 574c757614..c701ac842d 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -39,7 +39,7 @@ and theory_item_r = | Th_theory of (symbol * (theory * thmode)) | Th_export of EcPath.path | Th_instance of (ty_params * EcTypes.ty) * tcinstance - | Th_typeclass of (symbol * typeclass) + | Th_typeclass of (symbol * tc_decl) | Th_baserw of symbol | Th_addrw of EcPath.path * EcPath.path list | Th_reduction of (EcPath.path * rule_option * rule option) list @@ -96,7 +96,7 @@ and ctheory_item_r = | CTh_theory of (symbol * (ctheory * thmode)) | CTh_export of EcPath.path | CTh_instance of (ty_params * EcTypes.ty) * tcinstance - | CTh_typeclass of (symbol * typeclass) + | CTh_typeclass of (symbol * tc_decl) | CTh_baserw of symbol | CTh_addrw of EcPath.path * EcPath.path list | CTh_reduction of (EcPath.path * rule_option * rule option) list diff --git a/src/ecTheory.mli b/src/ecTheory.mli index 9baaa7d950..68908c59a5 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -35,7 +35,7 @@ and theory_item_r = | Th_theory of (symbol * (theory * thmode)) | Th_export of EcPath.path | Th_instance of (ty_params * EcTypes.ty) * tcinstance - | Th_typeclass of (symbol * typeclass) + | Th_typeclass of (symbol * tc_decl) | Th_baserw of symbol | Th_addrw of EcPath.path * EcPath.path list | Th_reduction of (EcPath.path * rule_option * rule option) list @@ -92,7 +92,7 @@ and ctheory_item_r = | CTh_theory of (symbol * (ctheory * thmode)) | CTh_export of EcPath.path | CTh_instance of (ty_params * EcTypes.ty) * tcinstance - | CTh_typeclass of (symbol * typeclass) + | CTh_typeclass of (symbol * tc_decl) | CTh_baserw of symbol | CTh_addrw of EcPath.path * EcPath.path list | CTh_reduction of (EcPath.path * rule_option * rule option) list diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 96596b5e0f..de2ea081a3 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -49,7 +49,7 @@ and 'a ovrhooks = { hbaserw : 'a -> symbol -> 'a; haddrw : 'a -> EcPath.path * EcPath.path list -> 'a; hauto : 'a -> bool * int * string option * EcPath.path list -> 'a; - htycl : 'a -> symbol * typeclass -> 'a; + htycl : 'a -> symbol * tc_decl -> 'a; hinst : 'a -> (ty_params * ty) * tcinstance -> 'a; husered : 'a -> (EcPath.path * EcTheory.rule_option * EcTheory.rule option) list -> 'a; hthenter : 'a -> thmode -> symbol -> 'a; diff --git a/src/ecTheoryReplay.mli b/src/ecTheoryReplay.mli index a542dea8a9..db7c366ad4 100644 --- a/src/ecTheoryReplay.mli +++ b/src/ecTheoryReplay.mli @@ -45,7 +45,7 @@ and 'a ovrhooks = { hbaserw : 'a -> symbol -> 'a; haddrw : 'a -> EcPath.path * EcPath.path list -> 'a; hauto : 'a -> bool * int * string option * EcPath.path list -> 'a; - htycl : 'a -> symbol * typeclass -> 'a; + htycl : 'a -> symbol * tc_decl -> 'a; hinst : 'a -> (ty_params * ty) * tcinstance -> 'a; husered : 'a -> (EcPath.path * EcTheory.rule_option * EcTheory.rule option) list -> 'a; hthenter : 'a -> thmode -> symbol -> 'a; diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 14addb6775..3cc9fe3ce3 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -420,9 +420,10 @@ let transtcs (env : EcEnv.env) tcs = (* -------------------------------------------------------------------- *) let transtyvars (env : EcEnv.env) (loc, tparams) = + let tparams = tparams |> omap (fun tparams -> - let for1 ({ pl_desc = x }, tc) = (EcIdent.create x, transtcs env tc) in + let for1 ({ pl_desc = x }, tc) = (EcIdent.create x, [] (*transtcs env tc*)) in (*TODO*) if not (List.is_unique (List.map (unloc |- fst) tparams)) then tyerror loc env DuplicatedTyVar; List.map for1 tparams) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index a0b7ffeac6..d5dbf9c47d 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -19,11 +19,11 @@ module Sp = EcPath.Sp module TC = EcTypeClass (* -------------------------------------------------------------------- *) -exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * Sp.t] +exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * typeclass] exception UninstanciateUni (* -------------------------------------------------------------------- *) -type pb = [ `TyUni of ty * ty | `TcCtt of ty * Sp.t ] +type pb = [ `TyUni of ty * ty | `TcCtt of ty * typeclass ] module UFArgs = struct module I = struct @@ -34,11 +34,11 @@ module UFArgs = struct end module D = struct - type data = Sp.t * ty option + type data = typeclass list * ty option type effects = pb list let default : data = - (Sp.empty, None) + ([], None) let isvoid ((_, x) : data) = (x = None) @@ -48,17 +48,14 @@ module UFArgs = struct let union d1 d2 = match d1, d2 with | (tc1, None), (tc2, None) -> - ((Sp.union tc1 tc2, None), []) + ((tc1 @ tc2, None), []) | (tc1, Some ty1), (tc2, Some ty2) -> - ((Sp.union tc1 tc2, Some ty1), [`TyUni (ty1, ty2)]) + ((tc1 @ tc2, Some ty1), [`TyUni (ty1, ty2)]) | (tc1, None ), (tc2, Some ty) | (tc2, Some ty), (tc1, None ) -> - let tc = Sp.diff tc1 tc2 in - if Sp.is_empty tc - then ((Sp.union tc1 tc2, Some ty), []) - else ((Sp.union tc1 tc2, Some ty), [`TcCtt (ty, tc)]) + ((tc1 @ tc2, Some ty), List.map (fun tc -> `TcCtt (ty, tc)) tc1) end end @@ -66,7 +63,7 @@ module UF = EcUFind.Make(UFArgs.I)(UFArgs.D) (* -------------------------------------------------------------------- *) module UnifyCore = struct - let fresh ?(tc = Sp.empty) ?ty uf = + let fresh ?(tc = []) ?ty uf = let uid = EcUid.unique () in let uf = match ty with @@ -79,7 +76,7 @@ module UnifyCore = struct end (* -------------------------------------------------------------------- *) -let rec unify_core (env : EcEnv.env) (tvtc : Sp.t Mid.t) (uf : UF.t) pb = +let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) pb = let failure () = raise (UnificationFailure pb) in let gr = EcEnv.TypeClass.graph env in @@ -101,12 +98,15 @@ let rec unify_core (env : EcEnv.env) (tvtc : Sp.t Mid.t) (uf : UF.t) pb = in let has_tcs ~src ~dst = + true (*TODO*) + (* Sp.for_all (fun dst1 -> Sp.exists (fun src1 -> TC.Graph.has_path ~src:src1 ~dst:dst1 gr) src) dst + *) in let ocheck i t = @@ -135,7 +135,7 @@ let rec unify_core (env : EcEnv.env) (tvtc : Sp.t Mid.t) (uf : UF.t) pb = in let setvar i t = - let (ti, effects) = UFArgs.D.union (UF.data i !uf) (Sp.empty, Some t) in + let (ti, effects) = UFArgs.D.union (UF.data i !uf) ([], Some t) in if odfl false (snd ti |> omap (ocheck i)) then failure (); List.iter (Queue.push^~ pb) effects; uf := UF.set i ti !uf @@ -143,7 +143,7 @@ let rec unify_core (env : EcEnv.env) (tvtc : Sp.t Mid.t) (uf : UF.t) pb = and getvar t = match t.ty_node with | Tunivar i -> snd_map (odfl t) (UF.data i !uf) - | _ -> (Sp.empty, t) + | _ -> ([], t) in @@ -199,10 +199,10 @@ let rec unify_core (env : EcEnv.env) (tvtc : Sp.t Mid.t) (uf : UF.t) pb = match ty.ty_node with | Tunivar i -> - uf := UF.set i (Sp.union tc tytc, None) !uf + uf := UF.set i (tc :: tytc, None) !uf | Tvar x -> - let xtcs = odfl Sp.empty (Mid.find_opt x tvtc) in + let xtcs = odfl [] (Mid.find_opt x tvtc) in if not (has_tcs ~src:xtcs ~dst:tc) then failure () @@ -210,9 +210,11 @@ let rec unify_core (env : EcEnv.env) (tvtc : Sp.t Mid.t) (uf : UF.t) pb = if not (has_tcs ~src:tytc ~dst:tc) then let module E = struct exception Failure end in - let inst = instances_for_tcs tc in + let inst = [] (*instances_for_tcs tc*) in (*TODO*) let for1 uf p = + uf + (* let for_inst ((typ, gty), p') = try if not (TC.Graph.has_path ~src:p' ~dst:p gr) then @@ -220,8 +222,8 @@ let rec unify_core (env : EcEnv.env) (tvtc : Sp.t Mid.t) (uf : UF.t) pb = let (uf, gty) = let (uf, subst) = List.fold_left - (fun (uf, s) (v, tc) -> - let (uf, uid) = UnifyCore.fresh ~tc uf in + (fun (uf, s) (v, tc) -> (*TODO: typeclass list to use*) + let (uf, uid) = UnifyCore.fresh uf in (uf, Mid.add v uid s)) (uf, Mid.empty) typ in @@ -233,8 +235,9 @@ let rec unify_core (env : EcEnv.env) (tvtc : Sp.t Mid.t) (uf : UF.t) pb = in try List.find_map for_inst inst with Not_found -> failure () + *) in - uf := List.fold_left for1 !uf (Sp.elements tc) + uf := for1 !uf tc end done in @@ -275,7 +278,7 @@ let subst_of_uf (uf : UF.t) = type unienv_r = { ue_uf : UF.t; ue_named : EcIdent.t Mstr.t; - ue_tvtc : Sp.t Mid.t; + ue_tvtc : typeclass list Mid.t; ue_decl : EcIdent.t list; ue_closed : bool; } @@ -308,7 +311,7 @@ module UniEnv = struct }; id end - let create (vd : (EcIdent.t * Sp.t) list option) = + let create (vd : (EcIdent.t * typeclass list) list option) = let ue = { ue_uf = UF.initial; ue_named = Mstr.empty; @@ -338,19 +341,19 @@ module UniEnv = struct match tvi with | None -> List.fold_left - (fun s (v, tc) -> Mid.add v (fresh ~tc ue) s) + (fun s (v, tc) -> Mid.add v (fresh ue) s) (*TODO: typeclass list to use*) Mid.empty params | Some (TVIunamed lt) -> List.fold_left2 - (fun s (v, tc) ty -> Mid.add v (fresh ~tc ~ty ue) s) + (fun s (v, tc) ty -> Mid.add v (fresh ~ty ue) s) (*TODO: typeclass list to define*) Mid.empty params lt | Some (TVInamed lt) -> let for1 s (v, tc) = let t = - try fresh ~tc ~ty:(List.assoc (EcIdent.name v) lt) ue - with Not_found -> fresh ~tc ue + try fresh ~ty:(List.assoc (EcIdent.name v) lt) ue (*TODO: typeclass list to define*) + with Not_found -> fresh ue (*TODO: typeclass list to define*) in Mid.add v t s in @@ -386,7 +389,7 @@ module UniEnv = struct let assubst ue = subst_of_uf (!ue).ue_uf let tparams ue = - let fortv x = odfl Sp.empty (Mid.find_opt x (!ue).ue_tvtc) in + let fortv x = [](*odfl Sp.empty (Mid.find_opt x (!ue).ue_tvtc)*) in List.map (fun x -> (x, fortv x)) (List.rev (!ue).ue_decl) end @@ -446,16 +449,22 @@ let select_op ?(hidden = false) ?(filter = fun _ -> true) tvi env name ue psig = () | Some (TVIunamed lt) -> + (* List.iter2 (fun ty (_, tc) -> hastc env subue ty tc) lt op.D.op_tparams + *) + () | Some (TVInamed ls) -> let tparams = List.map (fst_map EcIdent.name) op.D.op_tparams in let tparams = Msym.of_list tparams in + (* List.iter (fun (x, ty) -> hastc env subue ty (oget (Msym.find_opt x tparams))) ls + *) + () with UnificationFailure _ -> raise E.Failure end; diff --git a/src/ecUnify.mli b/src/ecUnify.mli index ab13ed3f3c..0996b401ca 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -14,7 +14,7 @@ open EcTypes open EcDecl (* -------------------------------------------------------------------- *) -exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * Sp.t] +exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * typeclass] exception UninstanciateUni type unienv @@ -27,10 +27,10 @@ type tvi = tvar_inst option type uidmap = uid -> ty option module UniEnv : sig - val create : (EcIdent.t * Sp.t) list option -> unienv + val create : (EcIdent.t * typeclass list) list option -> unienv val copy : unienv -> unienv (* constant time *) val restore : dst:unienv -> src:unienv -> unit (* constant time *) - val fresh : ?tc:EcPath.Sp.t -> ?ty:ty -> unienv -> ty + val fresh : ?tc:typeclass list -> ?ty:ty -> unienv -> ty val getnamed : unienv -> symbol -> EcIdent.t val repr : unienv -> ty -> ty val opentvi : unienv -> ty_params -> tvi -> ty EcIdent.Mid.t @@ -43,7 +43,7 @@ module UniEnv : sig end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val hastc : EcEnv.env -> unienv -> ty -> Sp.t -> unit +val hastc : EcEnv.env -> unienv -> ty -> typeclass -> unit val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty From 51e9f8d8d542ec9991d5960f454812e87af9bb91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Thu, 16 Sep 2021 14:58:20 +0200 Subject: [PATCH 004/113] Parser error --- examples/typeclass.ec | 17 ++++++++------ src/ecEnv.ml | 10 +++++++-- src/ecParser.mly | 26 +++++++++++----------- src/ecParsetree.ml | 23 +++++++++---------- src/ecPrinting.ml | 18 +++++++++++++-- src/ecScope.ml | 12 +++++----- src/ecSubst.ml | 6 ++++- src/ecTyping.ml | 52 ++++++++++++++++++++++++++----------------- src/ecUnify.ml | 23 ++++++++++--------- 9 files changed, 110 insertions(+), 77 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index b1f17a562e..8e8ca951b9 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -48,6 +48,8 @@ type class ['a <: ring] module_ <: group = { a ** (x + y) = a ** x + a ** y }. +print ( ** ). + (* type class A = ... type class B1 <: A @@ -60,7 +62,7 @@ int -> group -> monoid int -> monoid *) -type ('a <: ring) poly = 'a list. +type 'a poly = 'a list. op foo ['a <: group] (x y : 'a) = x + y. @@ -77,13 +79,15 @@ qed. (* -------------------------------------------------------------------- *) op izero = 0. -(* instance group with int - op zero = izero - op (+) = RealInt.add. + op zero = izero + op (+) = CoreInt.add + op ([-]) = CoreInt.opp. + +instance 'a module_ with ['a <: ring] 'a poly +. + -instance ['a <: ring] ('a poly) <: ring = { -}. instance ['a <: group & ...] 'a <: ... = { }. @@ -97,7 +101,6 @@ typeclass witness = { instance ['a] 'a <: witness = { }. -*) (* -------------------------------------------------------------------- *) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 3611d1fbc0..a9a5036eaa 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -856,7 +856,10 @@ module MC = struct let on1 (opid, optype) = let opname = EcIdent.name opid in let optype = ty_subst tsubst optype in - let opdecl = mk_op ~opaque:false [(*(self, Sp.singleton mypath)*)] optype (Some OP_TC) in (*TODO: typeclass list to define*) + let tcargs = List.map (fun (a, _) -> tvar a) tc.tc_tparams in + let opargs = (self, [{tc_name = mypath; tc_args = tcargs}]) in + let opargs = tc.tc_tparams @ [opargs] in + let opdecl = mk_op ~opaque:false opargs optype (Some OP_TC) in (opid, xpath opname, optype, opdecl) in List.map on1 tc.tc_ops @@ -874,8 +877,11 @@ module MC = struct let axioms = List.map (fun (x, ax) -> + let tcargs = List.map (fun (a, _) -> tvar a) tc.tc_tparams in + let axargs = (self, [{tc_name = mypath; tc_args = tcargs}]) in + let axargs = tc.tc_tparams @ [axargs] in let ax = Fsubst.f_subst fsubst ax in - (x, { ax_tparams = [(*(self, Sp.singleton mypath)*)]; (*TODO: typeclass list to define*) + (x, { ax_tparams = axargs; ax_spec = ax; ax_kind = `Axiom (Ssym.empty, false); ax_visibility = `NoSmt; })) diff --git a/src/ecParser.mly b/src/ecParser.mly index d28094e738..88e50352c9 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1586,11 +1586,16 @@ signature_item: pfd_uses = (not i, qs); } } (* -------------------------------------------------------------------- *) -(* EcTypes declarations / definitions *) +(* EcTypes declarations / definitions *) + +tcparam: +| x=lqident { (x, []) } +| ty=loc(simpl_type_exp) x=lqident { (x, [ty]) } +| tys=paren(plist1(loc(type_exp), COMMA)) x=lqident { (x, tys) } typaram: | x=tident { (x, []) } -| x=tident LTCOLON tc=plist1(lqident, AMP) { (x, tc) } +| x=tident LTCOLON tc=plist1(tcparam, AMP) { (x, tc) } typarams: | empty { [] } @@ -1655,25 +1660,20 @@ tc_ax: (* -------------------------------------------------------------------- *) (* Type classes (instances) *) tycinstance: -| INSTANCE x=qident +| INSTANCE x=qident args=tyci_args? WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* { + let args = args |> omap (fun (c, p) -> `Ring (c, p)) in { pti_name = x; pti_type = (odfl [] typ, ty); pti_ops = ops; pti_axs = axs; - pti_args = None; } + pti_args = args; } } -| INSTANCE x=qident c=uoption(UINT) p=uoption(UINT) - WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* - { - { pti_name = x; - pti_type = (odfl [] typ, ty); - pti_ops = ops; - pti_axs = axs; - pti_args = Some (`Ring (c, p)); } - } +tyci_args: +| c=uoption(UINT) p=uoption(UINT) + { (c, p) } tyci_op: | OP x=oident EQ tg=qoident diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 3a408c94c1..a14a4f4979 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -206,7 +206,8 @@ type pmodule_decl = { } (* -------------------------------------------------------------------- *) -type ptyparams = (psymbol * pqsymbol list) list +type ptyparam = psymbol * (pqsymbol * pty list) list +type ptyparams = ptyparam list type ptydname = (ptyparams * psymbol) located type ptydecl = { @@ -304,9 +305,6 @@ let rec pf_ident ?(raw = false) f = type ppattern = | PPApp of (pqsymbol * ptyannot option) * osymbol list -type ptyvardecls = - (psymbol * pqsymbol list) list - type pop_def = | PO_abstr of pty | PO_concr of pty * pexpr @@ -328,7 +326,7 @@ type poperator = { po_name : psymbol; po_aliases: psymbol list; po_tags : psymbol list; - po_tyvars : ptyvardecls option; + po_tyvars : ptyparams option; po_args : ptybindings; po_def : pop_def; po_ax : osymbol_r; @@ -350,14 +348,14 @@ and ppind = ptybindings * (ppind_ctor list) type ppredicate = { pp_name : psymbol; - pp_tyvars : (psymbol * pqsymbol list) list option; + pp_tyvars : ptyparams option; pp_def : ppred_def; } (* -------------------------------------------------------------------- *) type pnotation = { nt_name : psymbol; - nt_tv : ptyvardecls option; + nt_tv : ptyparams option; nt_bd : (psymbol * pty) list; nt_args : (psymbol * (psymbol list * pty option)) list; nt_codom : pty; @@ -370,7 +368,7 @@ type abrvopts = (bool * abrvopt) list type pabbrev = { ab_name : psymbol; - ab_tv : ptyvardecls option; + ab_tv : ptyparams option; ab_args : ptybindings; ab_def : pty * pexpr; ab_opts : abrvopts; @@ -893,7 +891,7 @@ type paxiom_kind = type paxiom = { pa_name : psymbol; - pa_tyvars : (psymbol * pqsymbol list) list option; + pa_tyvars : ptyparams option; pa_vars : pgtybindings option; pa_formula : pformula; pa_kind : paxiom_kind; @@ -910,15 +908,15 @@ type prealize = { (* -------------------------------------------------------------------- *) type ptypeclass = { ptc_name : psymbol; - ptc_params : ptyvardecls option; + ptc_params : ptyparams option; ptc_inth : pqsymbol option; ptc_ops : (psymbol * pty) list; ptc_axs : (psymbol * pformula) list; } type ptycinstance = { - pti_name : pqsymbol; - pti_type : (psymbol * pqsymbol list) list * pty; + pti_name : psymbol; + pti_type : ptyparams * pty; pti_ops : (psymbol * (pty list * pqsymbol)) list; pti_axs : (psymbol * ptactic_core) list; pti_args : [`Ring of (zint option * zint option)] option; @@ -927,7 +925,6 @@ type ptycinstance = { (* -------------------------------------------------------------------- *) type ident_spec = psymbol list - (* -------------------------------------------------------------------- *) type ('inv, 's) gphelper = | Helper_inv of 'inv diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 1b91286a2b..590e1c1e45 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -1802,6 +1802,19 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = in Format.fprintf fmt "@[%t%t.@]" pp_prelude pp_body + + +(* -------------------------------------------------------------------- *) +let pp_tc (ppe : PPEnv.t) fmt tc = + match tc.tc_args with + | [] -> pp_tcname ppe fmt tc.tc_name + | [ty] -> Format.fprintf fmt "%a %a" + (pp_type ppe) ty + (pp_tcname ppe) tc.tc_name + | tys -> Format.fprintf fmt "(%a) %a" + (pp_list ",@ " (pp_type ppe)) tys + (pp_tcname ppe) tc.tc_name + (* -------------------------------------------------------------------- *) let pp_tyvar_ctt (ppe : PPEnv.t) fmt (tvar, ctt) = match ctt with @@ -1809,7 +1822,7 @@ let pp_tyvar_ctt (ppe : PPEnv.t) fmt (tvar, ctt) = | ctt -> Format.fprintf fmt "%a <: %a" (pp_tyvar ppe) tvar - (pp_list " &@ " (fun fmt tc -> pp_tcname ppe fmt tc.tc_name)) ctt + (pp_list " &@ " (fun fmt tc -> pp_tc ppe fmt tc)) ctt (* -------------------------------------------------------------------- *) let pp_tyvarannot (ppe : PPEnv.t) fmt ids = @@ -1958,7 +1971,8 @@ let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = (pp_list "@\n" pp_branch) cfix | Some (OP_TC) -> - Format.fprintf fmt "= < type-class-operator >" + Format.fprintf fmt ": %a = < type-class-operator >" + (pp_type ppe) ty in match ts with diff --git a/src/ecScope.ml b/src/ecScope.ml index ff7b60237d..345f216903 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1577,6 +1577,9 @@ module Ty = struct | Some (tcp, _) -> tcp) in + (* Check typeclasses arguments *) + let ue = TT.transtyvars scenv (loc, tcd.ptc_params) in + let asty = let body = ofold (fun p tc -> Sp.add p tc) Sp.empty uptc in { tyd_params = []; tyd_type = `Abstract body; tyd_resolve = true; } in @@ -1590,9 +1593,6 @@ module Ty = struct |> oiter (fun (x, y) -> hierror ~loc:y.pl_loc "duplicated axiom name: `%s'" x.pl_desc); - (* Check typeclasses arguments *) - let ue = TT.transtyvars scenv (loc, tcd.ptc_params) in - (* Check operators types *) let operators = let check1 (x, ty) = @@ -1808,9 +1808,8 @@ module Ty = struct (EcIdent.name x, (true, ty_subst subst opty))) tc.tc_ops -(* (* ------------------------------------------------------------------ *) - let add_generic_tc (scope : scope) _mode { pl_desc = tci; pl_loc = loc; } = + let add_generic_instance (scope : scope) _mode { pl_desc = tci; pl_loc = loc; } = let ty = let ue = TT.transtyvars scope.sc_env (loc, Some (fst tci.pti_type)) in let ty = transty tp_tydecl scope.sc_env ue (snd tci.pti_type) in @@ -1838,7 +1837,6 @@ module Ty = struct try EcUnify.hastc scope.sc_env ue ty (Sp.singleton (fst tc)); tc with EcUnify.UnificationFailure _ -> hierror "type must be an instance of `%s'" (EcPath.tostring (fst tc)) -*) *) (* ------------------------------------------------------------------ *) @@ -1871,7 +1869,7 @@ module Ty = struct | _ -> if EcUtils.is_some tci.pti_args then hierror "unsupported-option"; - failwith "unsupported" (* FIXME *) + add_generic_instance scope mode toptci (* FIXME *) (* ------------------------------------------------------------------ *) let add_datatype (scope : scope) (tydname : ptydname) dt = diff --git a/src/ecSubst.ml b/src/ecSubst.ml index a1eab1a229..2ac3cdca2d 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -291,9 +291,13 @@ let add_tparams (s : _subst) (params : ty_params) tys = let init_tparams (s : _subst) (params : ty_params) (params' : ty_params) = add_tparams s params (List.map (fun (p',_) -> tvar p') params') +(* -------------------------------------------------------------------- *) +let subst_typeclass s tc = + {tc_name = s.s_p tc.tc_name; tc_args = List.map s.s_ty tc.tc_args; } + (* -------------------------------------------------------------------- *) let subst_typaram (s : _subst) ((id, tc) : ty_param) : ty_param = - (EcIdent.fresh id, [] (*Sp.fold (fun p tc -> Sp.add (s.s_p p) tc) tc Sp.empty*)) (*TODO: typeclass list to define*) + (EcIdent.fresh id, List.map (subst_typeclass s) tc) let subst_typarams (s : _subst) (typ : ty_params) = List.map (subst_typaram s) typ diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 3cc9fe3ce3..581b36daec 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -409,27 +409,6 @@ let tp_uni = { tp_uni = true ; tp_tvar = false; } (* params/local vars. *) (* -------------------------------------------------------------------- *) type ismap = (instr list) Mstr.t -(* -------------------------------------------------------------------- *) -let transtcs (env : EcEnv.env) tcs = - let for1 tc = - match EcEnv.TypeClass.lookup_opt (unloc tc) env with - | None -> tyerror tc.pl_loc env (UnknownTypeClass (unloc tc)) - | Some (p, _) -> p (* FIXME: TC HOOK *) - in - Sp.of_list (List.map for1 tcs) - -(* -------------------------------------------------------------------- *) -let transtyvars (env : EcEnv.env) (loc, tparams) = - - let tparams = tparams |> omap - (fun tparams -> - let for1 ({ pl_desc = x }, tc) = (EcIdent.create x, [] (*transtcs env tc*)) in (*TODO*) - if not (List.is_unique (List.map (unloc |- fst) tparams)) then - tyerror loc env DuplicatedTyVar; - List.map for1 tparams) - in - EcUnify.UniEnv.create tparams - (* -------------------------------------------------------------------- *) exception TymodCnvFailure of tymod_cnv_failure @@ -803,6 +782,37 @@ let transty_for_decl env ty = let ue = UE.create (Some []) in transty tp_nothing env ue ty +(* -------------------------------------------------------------------- *) +let transtcs (env : EcEnv.env) (tyvars : ty_params) (tcs : (pqsymbol * pty list) list) : typeclass list = + let for1 (tc : pqsymbol * pty list) = + let (tc_name, args) = tc in + match EcEnv.TypeClass.lookup_opt (unloc tc_name) env with + | None -> tyerror (loc tc_name) env (UnknownTypeClass (unloc tc_name)) + | Some (p, decl) -> + (*TODOTCD: TC HOOK.*) + let ue = UE.create (Some (List.rev tyvars)) in + let args = List.map (transty tp_nothing env ue) args in + (*Raise an exception like in None*) + assert (List.length decl.tc_tparams = List.length args); + { tc_name = p; tc_args = args; } + in + List.map for1 tcs + +(* -------------------------------------------------------------------- *) +let transtyvars (env : EcEnv.env) (loc, (tparams : ptyparams option)) = + let tparams = tparams |> omap + (fun tparams -> + let for1 tyvars ({ pl_desc = x }, tc) = + let x = EcIdent.create x in + let t = transtcs env tyvars tc in + (x, t) :: tyvars + in + if not (List.is_unique (List.map (unloc |- fst) tparams)) then + tyerror loc env DuplicatedTyVar; + List.rev (List.fold_left for1 [] tparams)) + in + EcUnify.UniEnv.create tparams + (* -------------------------------------------------------------------- *) let transpattern1 env ue (p : EcParsetree.plpattern) = match p.pl_desc with diff --git a/src/ecUnify.ml b/src/ecUnify.ml index d5dbf9c47d..73e0952201 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -85,20 +85,21 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p let uf = ref uf in let pb = let x = Queue.create () in Queue.push pb x; x in - let instances_for_tcs tcs = + (*TODOTCC*) + let instances_for_tcs (tcs : typeclass list) = let tcfilter (i, tc) = match tc with `General p -> Some (i, p) | _ -> None in List.filter (fun (_, tc1) -> - Sp.for_all - (fun tc2 -> TC.Graph.has_path ~src:tc1 ~dst:tc2 gr) + List.for_all + (fun tc2 -> TC.Graph.has_path ~src:tc1 ~dst:tc2.tc_name gr) tcs) (List.pmap tcfilter inst) in let has_tcs ~src ~dst = - true (*TODO*) + true (*TODOTCD*) (* Sp.for_all (fun dst1 -> @@ -210,7 +211,7 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p if not (has_tcs ~src:tytc ~dst:tc) then let module E = struct exception Failure end in - let inst = [] (*instances_for_tcs tc*) in (*TODO*) + (*let inst = instances_for_tcs tc in*) (*TODOTCD*) let for1 uf p = uf @@ -222,7 +223,7 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p let (uf, gty) = let (uf, subst) = List.fold_left - (fun (uf, s) (v, tc) -> (*TODO: typeclass list to use*) + (fun (uf, s) (v, tc) -> (*TODOTCD: typeclass list to use*) let (uf, uid) = UnifyCore.fresh uf in (uf, Mid.add v uid s)) (uf, Mid.empty) typ @@ -341,19 +342,19 @@ module UniEnv = struct match tvi with | None -> List.fold_left - (fun s (v, tc) -> Mid.add v (fresh ue) s) (*TODO: typeclass list to use*) + (fun s (v, tc) -> Mid.add v (fresh ue) s) (*TODOTCD: typeclass list to use*) Mid.empty params | Some (TVIunamed lt) -> List.fold_left2 - (fun s (v, tc) ty -> Mid.add v (fresh ~ty ue) s) (*TODO: typeclass list to define*) + (fun s (v, tc) ty -> Mid.add v (fresh ~ty ue) s) (*TODOTCD: typeclass list to define*) Mid.empty params lt | Some (TVInamed lt) -> let for1 s (v, tc) = let t = - try fresh ~ty:(List.assoc (EcIdent.name v) lt) ue (*TODO: typeclass list to define*) - with Not_found -> fresh ue (*TODO: typeclass list to define*) + try fresh ~ty:(List.assoc (EcIdent.name v) lt) ue (*TODOTCD: typeclass list to define*) + with Not_found -> fresh ue (*TODOTCD: typeclass list to define*) in Mid.add v t s in @@ -389,7 +390,7 @@ module UniEnv = struct let assubst ue = subst_of_uf (!ue).ue_uf let tparams ue = - let fortv x = [](*odfl Sp.empty (Mid.find_opt x (!ue).ue_tvtc)*) in + let fortv x = odfl [] (Mid.find_opt x (!ue).ue_tvtc) in List.map (fun x -> (x, fortv x)) (List.rev (!ue).ue_decl) end From ad321e5d6c162b47e2060ea630dcb1e8b256ab63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Thu, 16 Sep 2021 15:45:30 +0200 Subject: [PATCH 005/113] It compiles, need to modify parser --- src/ecParser.mly | 2 +- src/ecParsetree.ml | 5 ++--- src/ecScope.ml | 29 ++++++++++++++++------------- 3 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index 88e50352c9..a0c22cd64e 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1660,7 +1660,7 @@ tc_ax: (* -------------------------------------------------------------------- *) (* Type classes (instances) *) tycinstance: -| INSTANCE x=qident args=tyci_args? +| INSTANCE x=tcparam args=tyci_args? WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* { let args = args |> omap (fun (c, p) -> `Ring (c, p)) in diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index a14a4f4979..9f9285b920 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -206,8 +206,7 @@ type pmodule_decl = { } (* -------------------------------------------------------------------- *) -type ptyparam = psymbol * (pqsymbol * pty list) list -type ptyparams = ptyparam list +type ptyparams = (psymbol * (pqsymbol * pty list) list) list type ptydname = (ptyparams * psymbol) located type ptydecl = { @@ -915,7 +914,7 @@ type ptypeclass = { } type ptycinstance = { - pti_name : psymbol; + pti_name : (pqsymbol * pty list); pti_type : ptyparams * pty; pti_ops : (psymbol * (pty list * pqsymbol)) list; pti_axs : (psymbol * ptactic_core) list; diff --git a/src/ecScope.ml b/src/ecScope.ml index 345f216903..5197e3e689 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1818,30 +1818,33 @@ module Ty = struct in let (tcp, tc) = - match EcEnv.TypeClass.lookup_opt (unloc tci.pti_name) (env scope) with + match EcEnv.TypeClass.lookup_opt (unloc (fst tci.pti_name)) (env scope) with | None -> - hierror ~loc:tci.pti_name.pl_loc - "unknown type-class: %s" (string_of_qsymbol (unloc tci.pti_name)) + hierror ~loc:(fst tci.pti_name).pl_loc + "unknown type-class: %s" (string_of_qsymbol (unloc (fst tci.pti_name))) | Some tc -> tc in let symbols = symbols_of_tc scope.sc_env (snd ty) (tcp, tc) in let _symbols = check_tci_operators scope.sc_env ty tci.pti_ops symbols in - + let scope = { scope with sc_env = EcEnv.TypeClass.add_instance ty (`General tcp) scope.sc_env } - -(* - let ue = EcUnify.UniEnv.create (Some []) in - let ty = fst (EcUnify.UniEnv.openty ue (fst ty) None (snd ty)) in - try EcUnify.hastc scope.sc_env ue ty (Sp.singleton (fst tc)); tc - with EcUnify.UnificationFailure _ -> - hierror "type must be an instance of `%s'" (EcPath.tostring (fst tc)) -*) + in + (*TODOTCD*) + (* + let _ = snd tci.pti_name in + let ue = EcUnify.UniEnv.create (Some []) in + let ty = fst (EcUnify.UniEnv.openty ue (fst ty) None (snd ty)) in + try EcUnify.hastc scope.sc_env ue ty tc; tc + with EcUnify.UnificationFailure _ -> + hierror "type must be an instance of `%s'" (EcPath.tostring tc.tc_name) + *) + assert false (* ------------------------------------------------------------------ *) let add_instance (scope : scope) mode ({ pl_desc = tci } as toptci) = - match unloc tci.pti_name with + match unloc (fst tci.pti_name) with | ([], "bring") -> begin if EcUtils.is_some tci.pti_args then hierror "unsupported-option"; From d5beecfb81afd411ac419bba0faec28213a42d4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Thu, 16 Sep 2021 17:13:01 +0200 Subject: [PATCH 006/113] Pierre-Yves fixed parser and other stuff --- examples/typeclass.ec | 8 +++--- src/ecDecl.ml | 6 ++-- src/ecDecl.mli | 9 +++--- src/ecEnv.ml | 32 +++++++++++----------- src/ecHiInductive.ml | 2 +- src/ecParser.mly | 4 +-- src/ecParsetree.ml | 11 +++++--- src/ecPrinting.ml | 4 +-- src/ecScope.ml | 64 ++++++++++++++++++++----------------------- src/ecScope.mli | 2 +- src/ecSubst.ml | 10 ++++--- src/ecTheory.ml | 2 +- src/ecTheory.mli | 2 +- src/ecTheoryReplay.ml | 7 ++++- src/ecTyping.ml | 28 ++++++++----------- src/ecTyping.mli | 3 ++ src/ecUnify.ml | 4 +-- src/ecUnify.mli | 1 - 18 files changed, 100 insertions(+), 99 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 8e8ca951b9..5dee66c048 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -84,13 +84,13 @@ instance group with int op (+) = CoreInt.add op ([-]) = CoreInt.opp. -instance 'a module_ with ['a <: ring] 'a poly -. - +op polyZ ['a <: ring] (c : 'a) (p : 'a poly) : 'a poly. +instance 'b module_ with ['b <: ring] 'b poly + op ( ** ) = polyZ<:'b>. instance ['a <: group & ...] 'a <: ... = { -}. +} instance ['a <: group] 'a <: monoid = { }. diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 762486b618..a4fd75a148 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -34,7 +34,7 @@ type tydecl = { and ty_body = [ | `Concrete of EcTypes.ty - | `Abstract of Sp.t + | `Abstract of typeclass list | `Datatype of ty_dtype | `Record of EcCoreFol.form * (EcSymbols.symbol * EcTypes.ty) list ] @@ -58,7 +58,7 @@ let tydecl_as_record (td : tydecl) = match td.tyd_type with `Record x -> x | _ -> assert false (* -------------------------------------------------------------------- *) -let abs_tydecl ?(resolve = true) ?(tc = Sp.empty) ?(params = `Int 0) () : tydecl = +let abs_tydecl ?(resolve = true) ?(tc = []) ?(params = `Int 0) () : tydecl = let params = match params with | `Named params -> @@ -283,8 +283,8 @@ let axiomatized_op ?(nargs = 0) ?(nosmt = false) path (tparams, bd) = (* -------------------------------------------------------------------- *) type tc_decl = { - tc_prt : EcPath.path option; tc_tparams : ty_params; + tc_prt : typeclass option; tc_ops : (EcIdent.t * EcTypes.ty) list; tc_axs : (EcSymbols.symbol * EcCoreFol.form) list; } diff --git a/src/ecDecl.mli b/src/ecDecl.mli index f9a526549b..ffc278b485 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -10,7 +10,6 @@ open EcUtils open EcSymbols open EcBigInt -open EcPath open EcTypes open EcCoreFol @@ -32,7 +31,7 @@ type tydecl = { and ty_body = [ | `Concrete of EcTypes.ty - | `Abstract of Sp.t + | `Abstract of typeclass list | `Datatype of ty_dtype | `Record of form * (EcSymbols.symbol * EcTypes.ty) list ] @@ -44,11 +43,11 @@ and ty_dtype = { } val tydecl_as_concrete : tydecl -> EcTypes.ty -val tydecl_as_abstract : tydecl -> Sp.t +val tydecl_as_abstract : tydecl -> typeclass list val tydecl_as_datatype : tydecl -> ty_dtype val tydecl_as_record : tydecl -> form * (EcSymbols.symbol * EcTypes.ty) list -val abs_tydecl : ?resolve:bool -> ?tc:Sp.t -> ?params:ty_pctor -> unit -> tydecl +val abs_tydecl : ?resolve:bool -> ?tc:typeclass list -> ?params:ty_pctor -> unit -> tydecl val ty_instanciate : ty_params -> ty list -> ty -> ty @@ -164,8 +163,8 @@ val axiomatized_op : (* -------------------------------------------------------------------- *) type tc_decl = { - tc_prt : EcPath.path option; tc_tparams : ty_params; + tc_prt : typeclass option; tc_ops : (EcIdent.t * EcTypes.ty) list; tc_axs : (EcSymbols.symbol * EcCoreFol.form) list; } diff --git a/src/ecEnv.ml b/src/ecEnv.ml index a9a5036eaa..eb05edd227 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -173,7 +173,7 @@ and escope = { and tcinstance = [ | `Ring of EcDecl.ring | `Field of EcDecl.field - | `General of EcPath.path + | `General of typeclass ] and redinfo = @@ -1302,7 +1302,7 @@ module TypeClass = struct | None -> env | Some prt -> let myself = EcPath.pqname (root env) name in - { env with env_tc = TC.Graph.add ~src:myself ~dst:prt env.env_tc } + { env with env_tc = TC.Graph.add ~src:myself ~dst:prt.tc_name env.env_tc } let bind ?(import = import0) name tc env = let env = if import.im_immediate then rebind name tc env else env in @@ -1321,7 +1321,7 @@ module TypeClass = struct let graph (env : env) = env.env_tc - let bind_instance ty cr tci = + let bind_instance (ty : ty_params * ty) (cr : tcinstance) tci = (ty, cr) :: tci let add_instance ?(import = import0) ty cr env = @@ -1565,17 +1565,17 @@ module Ty = struct let env = MC.bind_tydecl name ty env in match ty.tyd_type with - | `Abstract tc -> + | `Abstract tcs -> let myty = let myp = EcPath.pqname (root env) name in let typ = List.map (fst_map EcIdent.fresh) ty.tyd_params in - (typ, EcTypes.tconstr myp (List.map (tvar |- fst) typ)) in - let instr = - Sp.fold - (fun p inst -> TypeClass.bind_instance myty (`General p) inst) - tc env.env_tci + (typ, EcTypes.tconstr myp (List.map (tvar |- fst) typ)) in + let env_tci = + List.fold + (fun inst (tc : typeclass) -> TypeClass.bind_instance myty (`General tc) inst) + env.env_tci tcs in - { env with env_tci = instr } + { env with env_tci } | _ -> env @@ -2875,14 +2875,14 @@ module Theory = struct | CTh_type (x, tyd) -> begin match tyd.tyd_type with - | `Abstract tc -> + | `Abstract tcs -> (* FIXME: this code is a duplicate *) let myty = let typ = List.map (fst_map EcIdent.fresh) tyd.tyd_params in - (typ, EcTypes.tconstr (xpath x) (List.map (tvar |- fst) typ)) + (typ, EcTypes.tconstr (xpath x) (List.map (tvar |- fst) typ)) in - Sp.fold - (fun p inst -> TypeClass.bind_instance myty (`General p) inst) - tc inst + List.fold + (fun inst tc -> TypeClass.bind_instance myty (`General tc) inst) + inst tcs | _ -> inst end @@ -2911,7 +2911,7 @@ module Theory = struct | CTh_typeclass (x, tc) -> tc.tc_prt |> omap (fun prt -> let src = EcPath.pqname path x in - TC.Graph.add ~src ~dst:prt base) + TC.Graph.add ~src ~dst:prt.tc_name base) | _ -> None in bind_base_cth for1 diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index f9918263e6..3e6315b3a7 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -98,7 +98,7 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let env0 = let myself = { tyd_params = EcUnify.UniEnv.tparams ue; - tyd_type = `Abstract EcPath.Sp.empty; + tyd_type = `Abstract []; tyd_resolve = true; } in EcEnv.Ty.bind (unloc name) myself env diff --git a/src/ecParser.mly b/src/ecParser.mly index a0c22cd64e..7977f1f9f6 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1623,7 +1623,7 @@ typedecl: | TYPE td=rlist1(tyd_name, COMMA) { List.map (mk_tydecl^~ (PTYD_Abstract [])) td } -| TYPE td=tyd_name LTCOLON tcs=rlist1(qident, COMMA) +| TYPE td=tyd_name LTCOLON tcs=rlist1(tcparam, COMMA) { [mk_tydecl td (PTYD_Abstract tcs)] } | TYPE td=tyd_name EQ te=loc(type_exp) @@ -1639,7 +1639,7 @@ typedecl: (* Type classes *) typeclass: | TYPE CLASS - tya=tyvars_decl? x=lident inth=prefix(LTCOLON, lqident)? + tya=tyvars_decl? x=lident inth=prefix(LTCOLON, tcparam)? EQ LBRACE body=tc_body RBRACE { { ptc_name = x; ptc_params = tya; diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 9f9285b920..55568974f1 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -206,7 +206,10 @@ type pmodule_decl = { } (* -------------------------------------------------------------------- *) -type ptyparams = (psymbol * (pqsymbol * pty list) list) list +(*TODOTCC*) +type ptcparam = pqsymbol * pty list +type ptyparam = psymbol * ptcparam list +type ptyparams = ptyparam list type ptydname = (ptyparams * psymbol) located type ptydecl = { @@ -216,7 +219,7 @@ type ptydecl = { } and ptydbody = - | PTYD_Abstract of pqsymbol list + | PTYD_Abstract of ptcparam list | PTYD_Alias of pty | PTYD_Record of precord | PTYD_Datatype of pdatatype @@ -908,13 +911,13 @@ type prealize = { type ptypeclass = { ptc_name : psymbol; ptc_params : ptyparams option; - ptc_inth : pqsymbol option; + ptc_inth : ptcparam option; ptc_ops : (psymbol * pty) list; ptc_axs : (psymbol * pformula) list; } type ptycinstance = { - pti_name : (pqsymbol * pty list); + pti_name : ptcparam; pti_type : ptyparams * pty; pti_ops : (psymbol * (pty list * pqsymbol)) list; pti_axs : (psymbol * ptactic_core) list; diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 590e1c1e45..04417af722 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -2957,9 +2957,9 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, (cth, mode)) = ops end - | `General p -> + | `General tc -> Format.fprintf fmt "instance %a with %a." - (pp_type ppe) ty pp_path p + (pp_type ppe) ty (pp_tc ppe) tc end | EcTheory.CTh_baserw name -> diff --git a/src/ecScope.ml b/src/ecScope.ml index 5197e3e689..bdc5e1e215 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1525,15 +1525,11 @@ module Ty = struct assert (scope.sc_pr_uc = None); let (args, name) = info.pl_desc and loc = info.pl_loc in - let tcs = - List.map - (fun tc -> fst (EcEnv.TypeClass.lookup (unloc tc) scope.sc_env)) - tcs - in let ue = TT.transtyvars scope.sc_env (loc, Some args) in + let tcs = List.map (TT.transtc scope.sc_env ue) tcs in let tydecl = { tyd_params = EcUnify.UniEnv.tparams ue; - tyd_type = `Abstract (Sp.of_list tcs); + tyd_type = `Abstract tcs; tyd_resolve = true; } in bind scope (unloc name, tydecl) @@ -1568,21 +1564,14 @@ module Ty = struct check_name_available scope tcd.ptc_name; let tclass = - let uptc = - tcd.ptc_inth |> omap - (fun { pl_loc = uploc; pl_desc = uptc } -> - match EcEnv.TypeClass.lookup_opt uptc scenv with - | None -> hierror ~loc:uploc "unknown type-class: `%s'" - (string_of_qsymbol uptc) - | Some (tcp, _) -> tcp) - in - (* Check typeclasses arguments *) let ue = TT.transtyvars scenv (loc, tcd.ptc_params) in + let uptc = tcd.ptc_inth |> omap (TT.transtc scenv ue) in + let asty = - let body = ofold (fun p tc -> Sp.add p tc) Sp.empty uptc in - { tyd_params = []; tyd_type = `Abstract body; tyd_resolve = true; } in + let body = otolist uptc in + { tyd_params = []; tyd_type = `Abstract body; tyd_resolve = true; } in let scenv = EcEnv.Ty.bind name asty scenv in (* Check for duplicated field names *) @@ -1672,9 +1661,11 @@ module Ty = struct match Mstr.find_opt x ops with | None -> m | Some (loc, (p, opty)) -> - if not (EcReduction.EqTest.for_type env ty opty) then - hierror ~loc "invalid type for operator `%s'" x; - Mstr.add x p m) + if not (EcReduction.EqTest.for_type env ty opty) then begin + let ppe = EcPrinting.PPEnv.ofenv env in + hierror ~loc "invalid type for operator `%s': %a / %a" + x (EcPrinting.pp_type ppe) ty (EcPrinting.pp_type ppe) opty + end; Mstr.add x p m) Mstr.empty reqs (* ------------------------------------------------------------------ *) @@ -1765,7 +1756,9 @@ module Ty = struct let scope = { scope with sc_env = List.fold_left - (fun env p -> EcEnv.TypeClass.add_instance ty (`General p) env) + (fun env p -> + let tc = { tc_name = p; tc_args = [] } in + EcEnv.TypeClass.add_instance ty (`General tc) env) (EcEnv.Algebra.add_ring (snd ty) cr scope.sc_env) [p_zmod; p_ring; p_idomain] } @@ -1795,7 +1788,9 @@ module Ty = struct let scope = { scope with sc_env = List.fold_left - (fun env p -> EcEnv.TypeClass.add_instance ty (`General p) env) + (fun env p -> + let tc = { tc_name = p; tc_args = [] } in + EcEnv.TypeClass.add_instance ty (`General tc) env) (EcEnv.Algebra.add_field (snd ty) cr scope.sc_env) [p_zmod; p_ring; p_idomain; p_field] } @@ -1803,34 +1798,34 @@ module Ty = struct (* ------------------------------------------------------------------ *) let symbols_of_tc (_env : EcEnv.env) ty (tcp, tc) = - let subst = { ty_subst_id with ts_def = Mp.of_list [tcp, ([], ty)] } in + (* FIXME: TC: substitute tc.tc_tparams with tcp.tc_args *) + (* FIXME: TC: check that tcp.tc_args meets the reqs. of tc.tc_params *) + let subst = { ty_subst_id with ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)] } in List.map (fun (x, opty) -> (EcIdent.name x, (true, ty_subst subst opty))) tc.tc_ops (* ------------------------------------------------------------------ *) let add_generic_instance (scope : scope) _mode { pl_desc = tci; pl_loc = loc; } = - let ty = + let (typarams, _) as ty = let ue = TT.transtyvars scope.sc_env (loc, Some (fst tci.pti_type)) in let ty = transty tp_tydecl scope.sc_env ue (snd tci.pti_type) in assert (EcUnify.UniEnv.closed ue); (EcUnify.UniEnv.tparams ue, Tuni.offun (EcUnify.UniEnv.close ue) ty) in - let (tcp, tc) = - match EcEnv.TypeClass.lookup_opt (unloc (fst tci.pti_name)) (env scope) with - | None -> - hierror ~loc:(fst tci.pti_name).pl_loc - "unknown type-class: %s" (string_of_qsymbol (unloc (fst tci.pti_name))) - | Some tc -> tc - in + let tcp = + let ue = EcUnify.UniEnv.create (Some typarams) in + TT.transtc scope.sc_env ue tci.pti_name in + + let tc = EcEnv.TypeClass.by_path tcp.tc_name scope.sc_env in - let symbols = symbols_of_tc scope.sc_env (snd ty) (tcp, tc) in + let symbols = symbols_of_tc scope.sc_env ty (tcp, tc) in let _symbols = check_tci_operators scope.sc_env ty tci.pti_ops symbols in - let scope = + { scope with sc_env = EcEnv.TypeClass.add_instance ty (`General tcp) scope.sc_env } - in + (*TODOTCD*) (* let _ = snd tci.pti_name in @@ -1840,7 +1835,6 @@ module Ty = struct with EcUnify.UnificationFailure _ -> hierror "type must be an instance of `%s'" (EcPath.tostring tc.tc_name) *) - assert false (* ------------------------------------------------------------------ *) let add_instance (scope : scope) mode ({ pl_desc = tci } as toptci) = diff --git a/src/ecScope.mli b/src/ecScope.mli index 0790eee528..9766ccfb75 100644 --- a/src/ecScope.mli +++ b/src/ecScope.mli @@ -116,7 +116,7 @@ end (* -------------------------------------------------------------------- *) module Ty : sig - val add : scope -> ptydname -> pqsymbol list -> scope + val add : scope -> ptydname -> ptcparam list -> scope val add_class : scope -> ptypeclass located -> scope val add_instance : scope -> Ax.mode -> ptycinstance located -> scope diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 2ac3cdca2d..58b799b913 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -293,7 +293,8 @@ let init_tparams (s : _subst) (params : ty_params) (params' : ty_params) = (* -------------------------------------------------------------------- *) let subst_typeclass s tc = - {tc_name = s.s_p tc.tc_name; tc_args = List.map s.s_ty tc.tc_args; } + { tc_name = s.s_p tc.tc_name; + tc_args = List.map s.s_ty tc.tc_args; } (* -------------------------------------------------------------------- *) let subst_typaram (s : _subst) ((id, tc) : ty_param) : ty_param = @@ -313,7 +314,7 @@ let open_tydecl (s:_subst) (tyd:tydecl) tys = let sty = add_tparams s tyd.tyd_params tys in match tyd.tyd_type with | `Abstract tc -> - `Abstract (Sp.fold (fun p tc -> Sp.add (s.s_p p) tc) tc Sp.empty) + `Abstract (List.map (subst_typeclass s) tc) | `Concrete ty -> `Concrete (sty.s_ty ty) | `Datatype dtype -> @@ -471,15 +472,16 @@ let subst_instance (s : _subst) tci = match tci with | `Ring cr -> `Ring (subst_ring s cr) | `Field cr -> `Field (subst_field s cr) - | `General p -> `General (s.s_p p) + | `General tc -> `General (subst_typeclass s tc) (* -------------------------------------------------------------------- *) let subst_tc (s : _subst) tc = - let tc_prt = tc.tc_prt |> omap s.s_p in + let tc_prt = omap (subst_typeclass s) tc.tc_prt in let tc_tparams = List.map (subst_typaram s) tc.tc_tparams in let tc_ops = List.map (snd_map s.s_ty) tc.tc_ops in let tc_axs = List.map (snd_map (subst_form s)) tc.tc_axs in { tc_prt; tc_tparams; tc_ops; tc_axs; } + (* -------------------------------------------------------------------- *) (* SUBSTITUTION OVER THEORIES *) let rec subst_theory_item_r (s : _subst) (item : theory_item_r) = diff --git a/src/ecTheory.ml b/src/ecTheory.ml index c701ac842d..40ada56db2 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -45,7 +45,7 @@ and theory_item_r = | Th_reduction of (EcPath.path * rule_option * rule option) list | Th_auto of (bool * int * symbol option * path list) -and tcinstance = [ `Ring of ring | `Field of field | `General of path ] +and tcinstance = [ `Ring of ring | `Field of field | `General of typeclass ] and thmode = [ `Abstract | `Concrete ] and rule_pattern = diff --git a/src/ecTheory.mli b/src/ecTheory.mli index 68908c59a5..e9e3347539 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -41,7 +41,7 @@ and theory_item_r = | Th_reduction of (EcPath.path * rule_option * rule option) list | Th_auto of (bool * int * symbol option * path list) -and tcinstance = [ `Ring of ring | `Field of field | `General of EcPath.path ] +and tcinstance = [ `Ring of ring | `Field of field | `General of typeclass ] and thmode = [ `Abstract | `Concrete ] and rule_pattern = diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index de2ea081a3..9caa8efc80 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -911,6 +911,11 @@ and replay_instance let forpath p = odfl p (forpath p) in + let fortypeclass (tc : typeclass) = + (* FIXME: TC *) + { tc_name = forpath tc.tc_name; + tc_args = List.map (EcSubst.subst_ty subst) tc.tc_args; } in + try let (typ, ty) = EcSubst.subst_genty subst (typ, ty) in let tc = @@ -939,7 +944,7 @@ and replay_instance match tc with | `Ring cr -> `Ring (doring cr) | `Field cr -> `Field (dofield cr) - | `General p -> `General (forpath p) + | `General p -> `General (fortypeclass p) in let scope = ove.ovre_hooks.hinst scope ((typ, ty), tc) in diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 581b36daec..e54dcc8389 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -783,28 +783,24 @@ let transty_for_decl env ty = transty tp_nothing env ue ty (* -------------------------------------------------------------------- *) -let transtcs (env : EcEnv.env) (tyvars : ty_params) (tcs : (pqsymbol * pty list) list) : typeclass list = - let for1 (tc : pqsymbol * pty list) = - let (tc_name, args) = tc in - match EcEnv.TypeClass.lookup_opt (unloc tc_name) env with - | None -> tyerror (loc tc_name) env (UnknownTypeClass (unloc tc_name)) - | Some (p, decl) -> - (*TODOTCD: TC HOOK.*) - let ue = UE.create (Some (List.rev tyvars)) in - let args = List.map (transty tp_nothing env ue) args in - (*Raise an exception like in None*) - assert (List.length decl.tc_tparams = List.length args); - { tc_name = p; tc_args = args; } - in - List.map for1 tcs +let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = + match EcEnv.TypeClass.lookup_opt (unloc tc_name) env with + | None -> + tyerror (loc tc_name) env (UnknownTypeClass (unloc tc_name)) + | Some (p, decl) -> + let args = List.map (transty tp_tydecl env ue) args in + (*FIXME: TC: Raise an exception like in None*) + assert (List.length decl.tc_tparams = List.length args); + { tc_name = p; tc_args = args; } (* -------------------------------------------------------------------- *) let transtyvars (env : EcEnv.env) (loc, (tparams : ptyparams option)) = let tparams = tparams |> omap (fun tparams -> let for1 tyvars ({ pl_desc = x }, tc) = - let x = EcIdent.create x in - let t = transtcs env tyvars tc in + let x = EcIdent.create x in + let ue = UE.create (Some tyvars) in + let t = List.map (transtc env ue) tc in (x, t) :: tyvars in if not (List.is_unique (List.map (unloc |- fst) tparams)) then diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 03331089b9..ad8fda005f 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -128,6 +128,9 @@ val tp_tydecl : typolicy val tp_relax : typolicy (* -------------------------------------------------------------------- *) +val transtc: + env -> EcUnify.unienv -> ptcparam -> EcDecl.typeclass + val transtyvars: env -> (EcLocation.t * ptyparams option) -> EcUnify.unienv diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 73e0952201..5738d1e372 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -93,7 +93,7 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p List.filter (fun (_, tc1) -> List.for_all - (fun tc2 -> TC.Graph.has_path ~src:tc1 ~dst:tc2.tc_name gr) + (fun tc2 -> TC.Graph.has_path ~src:tc1.tc_name ~dst:tc2.tc_name gr) tcs) (List.pmap tcfilter inst) in @@ -427,7 +427,7 @@ let select_op ?(hidden = false) ?(filter = fun _ -> true) tvi env name ue psig = let len = List.length lt in fun op -> let tparams = op.D.op_tparams in - List.length tparams = len + List.length tparams = len | Some (TVInamed ls) -> fun op -> let tparams = List.map (fst_map EcIdent.name) op.D.op_tparams in diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 0996b401ca..c96ea23bba 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -9,7 +9,6 @@ (* -------------------------------------------------------------------- *) open EcUid open EcSymbols -open EcPath open EcTypes open EcDecl From 64d401f136f4f9416a563b5028434a370e888db0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Mon, 20 Sep 2021 12:19:27 +0200 Subject: [PATCH 007/113] Added error message when different number of type arguments in typeclass --- src/ecTyping.ml | 6 ++++-- src/ecTyping.mli | 1 + src/ecUserMessages.ml | 7 +++++++ 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/ecTyping.ml b/src/ecTyping.ml index e54dcc8389..a5abaf3a1b 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -122,6 +122,7 @@ type tyerror = | UnknownScope of qsymbol | FilterMatchFailure | LvMapOnNonAssign +| NumberOfTypeclassArgumentsMismatch of qsymbol * ty_params * ty list exception TyError of EcLocation.t * EcEnv.env * tyerror @@ -789,8 +790,9 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = tyerror (loc tc_name) env (UnknownTypeClass (unloc tc_name)) | Some (p, decl) -> let args = List.map (transty tp_tydecl env ue) args in - (*FIXME: TC: Raise an exception like in None*) - assert (List.length decl.tc_tparams = List.length args); + (*TODOTCC: name of error and arguments*) + if (List.length decl.tc_tparams = List.length args) then + tyerror (loc tc_name) env (NumberOfTypeclassArgumentsMismatch ((unloc tc_name), decl.tc_tparams, args)); { tc_name = p; tc_args = args; } (* -------------------------------------------------------------------- *) diff --git a/src/ecTyping.mli b/src/ecTyping.mli index ad8fda005f..778a534563 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -112,6 +112,7 @@ type tyerror = | UnknownScope of qsymbol | FilterMatchFailure | LvMapOnNonAssign +| NumberOfTypeclassArgumentsMismatch of qsymbol * ty_params * ty list exception TymodCnvFailure of tymod_cnv_failure exception TyError of EcLocation.t * env * tyerror diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 6909dcdd7c..553ec11fc7 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -365,6 +365,13 @@ end = struct | LvMapOnNonAssign -> msg "map-style left-value cannot be used with assignments" + (*TODOTCC: printing correctly, lineskip*) + | NumberOfTypeclassArgumentsMismatch (sc, typarams, tys) -> + msg "different number of typeclass type parameters and arguments provided in %a: %a %a" + pp_qsymbol sc + (EcPrinting.pp_list "@, " (fun fmt (id, _) -> pp_symbol fmt (EcIdent.name id))) typarams + (EcPrinting.pp_list "@, " pp_type) tys + let pp_restr_error env fmt (w, e) = let ppe = EcPrinting.PPEnv.ofenv env in let pp_v fmt xp = EcPrinting.pp_pv ppe fmt (pv_glob xp) in From d229960f427b3cd5873f26e160d120eb25539564 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Tue, 5 Oct 2021 18:07:58 +0200 Subject: [PATCH 008/113] Pre checkout --- .merlin | 1 + _tags | 6 +++--- opam | 1 + src/ecElpi.ml | 40 ++++++++++++++++++++++++++++++++++++++++ src/ecElpi.mli | 1 + src/ecParsetree.ml | 1 - src/ecUserMessages.ml | 3 +-- 7 files changed, 47 insertions(+), 6 deletions(-) create mode 100644 src/ecElpi.ml create mode 100644 src/ecElpi.mli diff --git a/.merlin b/.merlin index 04458b4314..83a121262e 100644 --- a/.merlin +++ b/.merlin @@ -15,6 +15,7 @@ PKG zarith PKG pcre PKG inifiles PKG yojson +PKG elpi FLG -rectypes FLG -w Y -w Z -w -23 -w +28 -w +33 diff --git a/_tags b/_tags index 8e65a34595..fabe9eba94 100644 --- a/_tags +++ b/_tags @@ -15,6 +15,6 @@ true : bin_annot : include # -------------------------------------------------------------------- - : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson) - : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson) - : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson) + : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson,elpi) + : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson,elpi) + : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson,elpi) diff --git a/opam b/opam index f7367317a9..fb7b63abaf 100644 --- a/opam +++ b/opam @@ -26,6 +26,7 @@ depends: [ "ocamlbuild" "ocamlfind" "yojson" + "elpi" ] post-messages: [ "EasyCrypt needs external provers to be installed. From opam, you diff --git a/src/ecElpi.ml b/src/ecElpi.ml new file mode 100644 index 0000000000..de1fb79317 --- /dev/null +++ b/src/ecElpi.ml @@ -0,0 +1,40 @@ +open Elpi.API + +let setup = + Setup.init [Elpi__Builtin.std_builtins] "." [] + +let program el lts = + let fl = Compile.default_flags in + let ps = List.map (fun (loc, t) -> Utils.clause_of_term 0 loc t) lts in + Compile.program fl el ps + +let query p loc q = + let cq = Query.compile p loc q in + Compile.optimize cq + +let query_once p loc q = + let exec = query p loc q in + Execute.once exec + +let _ = + let (el, strs) = setup in + let lf : Ast.Loc.t = { + source_name = "foo"; + source_start = 0; + source_stop = 0; + line = 0; + line_starts_at = 0; + } in + (*TODO: we should use the smart constructors in RawData to build the term or terms.*) + let t = RawOpaqueData.of_loc lf in + let lts = [(lf, t)] in + let p = program el lts in + let lq : Ast.Loc.t = { + source_name = "bar"; + source_start = 0; + source_stop = 0; + line = 0; + line_starts_at = 0; + } in + let q = Query.Query { predicate="bar"; arguments=N} in + query_once p lq q diff --git a/src/ecElpi.mli b/src/ecElpi.mli new file mode 100644 index 0000000000..cd5ab457d0 --- /dev/null +++ b/src/ecElpi.mli @@ -0,0 +1 @@ +open Elpi diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 55568974f1..9428a6aa6d 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -206,7 +206,6 @@ type pmodule_decl = { } (* -------------------------------------------------------------------- *) -(*TODOTCC*) type ptcparam = pqsymbol * pty list type ptyparam = psymbol * ptcparam list type ptyparams = ptyparam list diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 553ec11fc7..24175886c5 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -365,9 +365,8 @@ end = struct | LvMapOnNonAssign -> msg "map-style left-value cannot be used with assignments" - (*TODOTCC: printing correctly, lineskip*) | NumberOfTypeclassArgumentsMismatch (sc, typarams, tys) -> - msg "different number of typeclass type parameters and arguments provided in %a: %a %a" + msg "different number of typeclass type parameters and arguments provided in %a:@\n - %a @\n - %a" pp_qsymbol sc (EcPrinting.pp_list "@, " (fun fmt (id, _) -> pp_symbol fmt (EcIdent.name id))) typarams (EcPrinting.pp_list "@, " pp_type) tys From 6b79bbb512afb218e1a2ca730d6241a79c57af6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Fri, 5 Nov 2021 10:43:35 +0100 Subject: [PATCH 009/113] Added everything --- src/ecUnify.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 5738d1e372..3e3708d533 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -98,6 +98,7 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p (List.pmap tcfilter inst) in + (*Checks if *) let has_tcs ~src ~dst = true (*TODOTCD*) (* @@ -211,7 +212,9 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p if not (has_tcs ~src:tytc ~dst:tc) then let module E = struct exception Failure end in - (*let inst = instances_for_tcs tc in*) (*TODOTCD*) + + + (*let inst = instances_for_tcs tc in*) (*TODOTCD: ELPI here*) let for1 uf p = uf From 0bae431d9424590072dea721d5f9ac3cd3108d5b Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 11 Oct 2021 17:23:24 +0200 Subject: [PATCH 010/113] --- examples/subtype.ec | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/examples/subtype.ec b/examples/subtype.ec index 6795a10cf4..819f800f28 100644 --- a/examples/subtype.ec +++ b/examples/subtype.ec @@ -23,6 +23,10 @@ lemma foo ['a] [n : int] (w1 w2 : {'a word n}) : op vectorize ['a] [n m : int] (w : {'a word (n * m)}) : {{'a word n} word m}. +lemma vectorize_spec ['a] (w : 'a list) : size w = (n * m) => + size (vectorize w) = m + /\ (all (fun w' => size w' = n) (vectorize w)). + -> Keeping information in application? Yes -> should provide a syntax for giving the arguments @@ -84,8 +88,17 @@ op vectorize ['a] [n m : int] (w : {'a word (n * m)}) : {{'a word n} word m}. - What about the logics? we have to patch them. (* ==================================================================== *) +all : 'a t * 'a -> bool + +axiom all_spec : forall (f : 'a t -> 'a) (s : 'a t), all (s, f s). + nth ['a] 'a -> 'a list -> int -> 'a +lemma nth_spec ['a] (x : 'a) (s : 'a list) (i : int) : + forall P, + (forall y, all<: 'a> (y, x) -> P y) -> + P x -> (forall y, all<: 'a list> (s, y) -> P y) -> P (nth x s i). + ws : {word n} list nth<:word> witness ws 2 : word From 6432c4c08a32f58ecad040c60c8e8f8529140e84 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 18 Oct 2021 08:02:16 +0200 Subject: [PATCH 011/113] --- examples/subtype.ec | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/subtype.ec b/examples/subtype.ec index 819f800f28..1f4c2f2535 100644 --- a/examples/subtype.ec +++ b/examples/subtype.ec @@ -90,7 +90,7 @@ lemma vectorize_spec ['a] (w : 'a list) : size w = (n * m) => (* ==================================================================== *) all : 'a t * 'a -> bool -axiom all_spec : forall (f : 'a t -> 'a) (s : 'a t), all (s, f s). +axiom all_spec ['a] : forall (f : 'a t -> 'a) (s : 'a t), all (s, f s). nth ['a] 'a -> 'a list -> int -> 'a From c2ed9ae8e6034762329f1a77b27a1dd069f1ea12 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 5 Nov 2021 11:43:22 +0100 Subject: [PATCH 012/113] ask for tc axioms realization when declaring an instance --- examples/typeclass.ec | 12 +++++++++++ src/ecScope.ml | 50 ++++++++++++++++++++++++++++++++----------- src/ecTyping.ml | 7 +++--- src/ecTyping.mli | 2 +- src/ecUserMessages.ml | 2 +- 5 files changed, 54 insertions(+), 19 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 5dee66c048..dfc94e6eb1 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -76,6 +76,18 @@ qed. (* type class fingroup = group & finite *) +(* -------------------------------------------------------------------- *) +op bool_enum = [true; false]. + +instance finite with bool + op enum = bool_enum. + +realize enumP. +proof. by case. qed. + +op all ['a <: finite] (p : 'a -> bool) = + all p enum<:'a>. + (* -------------------------------------------------------------------- *) op izero = 0. diff --git a/src/ecScope.ml b/src/ecScope.ml index bdc5e1e215..0416d1e2cf 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1611,12 +1611,11 @@ module Ty = struct (* ------------------------------------------------------------------ *) let check_tci_operators env tcty ops reqs = - let ue = EcUnify.UniEnv.create (Some (fst tcty)) in - let rmap = Mstr.of_list reqs in + let ue = EcUnify.UniEnv.create (Some (fst tcty)) in let ops = let tt1 m (x, (tvi, op)) = - if not (Mstr.mem (unloc x) rmap) then + if not (Mstr.mem (unloc x) reqs) then hierror ~loc:x.pl_loc "invalid operator name: `%s'" (unloc x); let tvi = List.map (TT.transty tp_tydecl env ue) tvi in @@ -1651,13 +1650,13 @@ module Ty = struct in List.fold_left tt1 Mstr.empty ops in - List.iter - (fun (x, (req, _)) -> + Mstr.iter + (fun x (req, _) -> if req && not (Mstr.mem x ops) then hierror "no definition for operator `%s'" x) reqs; - List.fold_left - (fun m (x, (_, ty)) -> + Mstr.fold + (fun x (_, ty) m -> match Mstr.find_opt x ops with | None -> m | Some (loc, (p, opty)) -> @@ -1666,7 +1665,7 @@ module Ty = struct hierror ~loc "invalid type for operator `%s': %a / %a" x (EcPrinting.pp_type ppe) ty (EcPrinting.pp_type ppe) opty end; Mstr.add x p m) - Mstr.empty reqs + reqs Mstr.empty (* ------------------------------------------------------------------ *) let check_tci_axioms scope mode axs reqs = @@ -1749,6 +1748,7 @@ module Ty = struct (EcUnify.UniEnv.tparams ue, Tuni.offun (EcUnify.UniEnv.close ue) ty) in let symbols = EcAlgTactic.ring_symbols scope.sc_env kind (snd ty) in + let symbols = Mstr.of_list symbols in let symbols = check_tci_operators scope.sc_env ty tci.pti_ops symbols in let cr = ring_of_symmap scope.sc_env (snd ty) kind symbols in let axioms = EcAlgTactic.ring_axioms scope.sc_env cr in @@ -1781,6 +1781,7 @@ module Ty = struct (EcUnify.UniEnv.tparams ue, Tuni.offun (EcUnify.UniEnv.close ue) ty) in let symbols = EcAlgTactic.field_symbols scope.sc_env (snd ty) in + let symbols = Mstr.of_list symbols in let symbols = check_tci_operators scope.sc_env ty tci.pti_ops symbols in let cr = field_of_symmap scope.sc_env (snd ty) symbols in let axioms = EcAlgTactic.field_axioms scope.sc_env cr in @@ -1806,7 +1807,7 @@ module Ty = struct tc.tc_ops (* ------------------------------------------------------------------ *) - let add_generic_instance (scope : scope) _mode { pl_desc = tci; pl_loc = loc; } = + let add_generic_instance (scope : scope) mode { pl_desc = tci; pl_loc = loc; } = let (typarams, _) as ty = let ue = TT.transtyvars scope.sc_env (loc, Some (fst tci.pti_type)) in let ty = transty tp_tydecl scope.sc_env ue (snd tci.pti_type) in @@ -1820,11 +1821,34 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name scope.sc_env in - let symbols = symbols_of_tc scope.sc_env ty (tcp, tc) in - let _symbols = check_tci_operators scope.sc_env ty tci.pti_ops symbols in + let tcsyms = symbols_of_tc scope.sc_env ty (tcp, tc) in + let tcsyms = Mstr.of_list tcsyms in + let symbols = check_tci_operators scope.sc_env ty tci.pti_ops tcsyms in - { scope with - sc_env = EcEnv.TypeClass.add_instance ty (`General tcp) scope.sc_env } + let tysubst = EcSubst.add_tydef EcSubst.empty tcp.tc_name ([], snd ty) in + + let subst = + List.fold_left + (fun subst (opname, ty) -> + let oppath = Mstr.find (EcIdent.name opname) symbols in + let op = EcFol.f_op oppath [] ty in + EcFol.Fsubst.f_bind_local subst opname op) + EcFol.Fsubst.f_subst_id tc.tc_ops in + + let axioms = + List.map + (fun (name, ax) -> + let ax = EcFol.Fsubst.f_subst subst ax in + let ax = EcSubst.subst_form tysubst ax in + (name, ax)) + tc.tc_axs in + + let inter = check_tci_axioms scope mode tci.pti_axs axioms in + let scope = + { scope with + sc_env = EcEnv.TypeClass.add_instance ty (`General tcp) scope.sc_env } in + + Ax.add_defer scope inter (*TODOTCD*) (* diff --git a/src/ecTyping.ml b/src/ecTyping.ml index a5abaf3a1b..5c416b4aa6 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -122,7 +122,7 @@ type tyerror = | UnknownScope of qsymbol | FilterMatchFailure | LvMapOnNonAssign -| NumberOfTypeclassArgumentsMismatch of qsymbol * ty_params * ty list +| TCArgsCountMismatch of qsymbol * ty_params * ty list exception TyError of EcLocation.t * EcEnv.env * tyerror @@ -790,9 +790,8 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = tyerror (loc tc_name) env (UnknownTypeClass (unloc tc_name)) | Some (p, decl) -> let args = List.map (transty tp_tydecl env ue) args in - (*TODOTCC: name of error and arguments*) - if (List.length decl.tc_tparams = List.length args) then - tyerror (loc tc_name) env (NumberOfTypeclassArgumentsMismatch ((unloc tc_name), decl.tc_tparams, args)); + if List.length decl.tc_tparams <> List.length args then + tyerror (loc tc_name) env (TCArgsCountMismatch (unloc tc_name, decl.tc_tparams, args)); { tc_name = p; tc_args = args; } (* -------------------------------------------------------------------- *) diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 778a534563..dfde5a128f 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -112,7 +112,7 @@ type tyerror = | UnknownScope of qsymbol | FilterMatchFailure | LvMapOnNonAssign -| NumberOfTypeclassArgumentsMismatch of qsymbol * ty_params * ty list +| TCArgsCountMismatch of qsymbol * ty_params * ty list exception TymodCnvFailure of tymod_cnv_failure exception TyError of EcLocation.t * env * tyerror diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 24175886c5..a5a928a002 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -365,7 +365,7 @@ end = struct | LvMapOnNonAssign -> msg "map-style left-value cannot be used with assignments" - | NumberOfTypeclassArgumentsMismatch (sc, typarams, tys) -> + | TCArgsCountMismatch (sc, typarams, tys) -> msg "different number of typeclass type parameters and arguments provided in %a:@\n - %a @\n - %a" pp_qsymbol sc (EcPrinting.pp_list "@, " (fun fmt (id, _) -> pp_symbol fmt (EcIdent.name id))) typarams From a420ad540158b3a198155161614f99531bf0ac86 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 5 Nov 2021 11:55:18 +0100 Subject: [PATCH 013/113] check parent constraint when adding a new tc instance --- examples/typeclass.ec | 6 ++++++ src/ecScope.ml | 24 ++++++++++++++---------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index dfc94e6eb1..ef162d4eff 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -6,6 +6,9 @@ type class finite = { axiom enumP : forall (x : finite), x \in enum }. +type class foo <: finite = { +}. + type class monoid = { op mzero : monoid op madd : monoid -> monoid -> monoid @@ -79,12 +82,15 @@ qed. (* -------------------------------------------------------------------- *) op bool_enum = [true; false]. +instance foo with bool. + instance finite with bool op enum = bool_enum. realize enumP. proof. by case. qed. + op all ['a <: finite] (p : 'a -> bool) = all p enum<:'a>. diff --git a/src/ecScope.ml b/src/ecScope.ml index 0416d1e2cf..4b2b8b9253 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1821,6 +1821,20 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name scope.sc_env in + tc.tc_prt |> oiter (fun prt -> + let ue = EcUnify.UniEnv.create (Some typarams) in + + let ppe = EcPrinting.PPEnv.ofenv scope.sc_env in + Format.eprintf "[W]%a@." (EcPrinting.pp_type ppe) (snd ty); + Format.eprintf "[W]%s %a@." + (EcPath.tostring prt.tc_name) + (EcPrinting.pp_list " " (EcPrinting.pp_type ppe)) prt.tc_args; + try EcUnify.hastc scope.sc_env ue (snd ty) prt + with EcUnify.UnificationFailure _ -> + hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) + ); + + let tcsyms = symbols_of_tc scope.sc_env ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in let symbols = check_tci_operators scope.sc_env ty tci.pti_ops tcsyms in @@ -1850,16 +1864,6 @@ module Ty = struct Ax.add_defer scope inter - (*TODOTCD*) - (* - let _ = snd tci.pti_name in - let ue = EcUnify.UniEnv.create (Some []) in - let ty = fst (EcUnify.UniEnv.openty ue (fst ty) None (snd ty)) in - try EcUnify.hastc scope.sc_env ue ty tc; tc - with EcUnify.UnificationFailure _ -> - hierror "type must be an instance of `%s'" (EcPath.tostring tc.tc_name) - *) - (* ------------------------------------------------------------------ *) let add_instance (scope : scope) mode ({ pl_desc = tci } as toptci) = match unloc (fst tci.pti_name) with From 1fab9bad5a05c19cc6133f91f21d1b037cda471a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Mon, 8 Nov 2021 15:18:53 +0100 Subject: [PATCH 014/113] Added everything again --- src/ecUnify.ml | 38 +++----------------------------------- 1 file changed, 3 insertions(+), 35 deletions(-) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 3e3708d533..048f2ff3b4 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -76,41 +76,13 @@ module UnifyCore = struct end (* -------------------------------------------------------------------- *) +(*TODOTCC: what is this big function supposed to do?*) let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) pb = let failure () = raise (UnificationFailure pb) in - let gr = EcEnv.TypeClass.graph env in - let inst = EcEnv.TypeClass.get_instances env in - let uf = ref uf in let pb = let x = Queue.create () in Queue.push pb x; x in - (*TODOTCC*) - let instances_for_tcs (tcs : typeclass list) = - let tcfilter (i, tc) = - match tc with `General p -> Some (i, p) | _ -> None - in - List.filter - (fun (_, tc1) -> - List.for_all - (fun tc2 -> TC.Graph.has_path ~src:tc1.tc_name ~dst:tc2.tc_name gr) - tcs) - (List.pmap tcfilter inst) - in - - (*Checks if *) - let has_tcs ~src ~dst = - true (*TODOTCD*) - (* - Sp.for_all - (fun dst1 -> - Sp.exists - (fun src1 -> TC.Graph.has_path ~src:src1 ~dst:dst1 gr) - src) - dst - *) - in - let ocheck i t = let i = UF.find i !uf in let map = Hint.create 0 in @@ -205,8 +177,7 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p | Tvar x -> let xtcs = odfl [] (Mid.find_opt x tvtc) in - if not (has_tcs ~src:xtcs ~dst:tc) then - failure () + () | _ -> if not (has_tcs ~src:tytc ~dst:tc) then @@ -214,11 +185,9 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p - (*let inst = instances_for_tcs tc in*) (*TODOTCD: ELPI here*) + let inst = instances_for_tcs tc in (*TODOTCD: ELPI here*) let for1 uf p = - uf - (* let for_inst ((typ, gty), p') = try if not (TC.Graph.has_path ~src:p' ~dst:p gr) then @@ -239,7 +208,6 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p in try List.find_map for_inst inst with Not_found -> failure () - *) in uf := for1 !uf tc end From 89fea98ba8126997814d7fec3bb0170fe7a8246d Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 8 Nov 2021 16:40:18 +0100 Subject: [PATCH 015/113] api for tc resolution + inclusion in EcUnify --- src/ecDecl.ml | 1 - src/ecEnv.ml | 28 +++++----- src/ecEnv.mli | 9 ++-- src/ecScope.ml | 2 +- src/ecTypeClass.ml | 95 -------------------------------- src/ecTypeClass.mli | 31 ----------- src/ecTyping.ml | 16 ++++-- src/ecUnify.ml | 129 ++++++++++++++++++++------------------------ src/ecUnify.mli | 6 ++- 9 files changed, 94 insertions(+), 223 deletions(-) delete mode 100644 src/ecTypeClass.ml delete mode 100644 src/ecTypeClass.mli diff --git a/src/ecDecl.ml b/src/ecDecl.ml index a4fd75a148..514f4b931e 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -12,7 +12,6 @@ open EcTypes open EcCoreFol module Sp = EcPath.Sp -module TC = EcTypeClass module BI = EcBigInt module Ssym = EcSymbols.Ssym diff --git a/src/ecEnv.ml b/src/ecEnv.ml index eb05edd227..b05e2a4ffc 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -24,7 +24,6 @@ module Msym = EcSymbols.Msym module Mp = EcPath.Mp module Sid = EcIdent.Sid module Mid = EcIdent.Mid -module TC = EcTypeClass module Mint = EcMaps.Mint (* -------------------------------------------------------------------- *) @@ -153,7 +152,7 @@ type preenv = { env_actmem : EcMemory.memory option; env_abs_st : EcModules.abs_uses Mid.t; env_tci : ((ty_params * ty) * tcinstance) list; - env_tc : TC.graph; + env_tc : tc_decl list; env_rwbase : Sp.t Mip.t; env_atbase : (path list Mint.t) Msym.t; env_redbase : mredinfo; @@ -263,7 +262,7 @@ let empty gstate = env_actmem = None; env_abs_st = Mid.empty; env_tci = []; - env_tc = TC.Graph.empty; + env_tc = []; env_rwbase = Mip.empty; env_atbase = Msym.empty; env_redbase = Mrd.empty; @@ -1298,11 +1297,7 @@ module TypeClass = struct let rebind name tc env = let env = MC.bind_typeclass name tc env in - match tc.tc_prt with - | None -> env - | Some prt -> - let myself = EcPath.pqname (root env) name in - { env with env_tc = TC.Graph.add ~src:myself ~dst:prt.tc_name env.env_tc } + { env with env_tc = tc :: env.env_tc } let bind ?(import = import0) name tc env = let env = if import.im_immediate then rebind name tc env else env in @@ -1333,6 +1328,14 @@ module TypeClass = struct env_item = mk_citem import (CTh_instance (ty, cr)) :: env.env_item; } let get_instances env = env.env_tci + + let hastc + (env : env) (tvtc : (typeclass list) Mid.t) + (ty : ty) (tc : typeclass) + = (* env.env_tc -> all tc declaration *) + (* env.env_tci -> all tc instances *) + + true end (* -------------------------------------------------------------------- *) @@ -2907,11 +2910,10 @@ module Theory = struct (* ------------------------------------------------------------------ *) let bind_tc_cth = - let for1 path base = function - | CTh_typeclass (x, tc) -> - tc.tc_prt |> omap (fun prt -> - let src = EcPath.pqname path x in - TC.Graph.add ~src ~dst:prt.tc_name base) + let for1 _path base = function + | CTh_typeclass (_, tc) -> + Some (tc :: base) + | _ -> None in bind_base_cth for1 diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 80a70edfdb..7a34bd8f12 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -7,6 +7,7 @@ * -------------------------------------------------------------------- *) (* -------------------------------------------------------------------- *) +open EcIdent open EcPath open EcSymbols open EcTypes @@ -343,9 +344,8 @@ end module TypeClass : sig type t = tc_decl - val add : path -> env -> env - val bind : ?import:import -> symbol -> t -> env -> env - val graph : env -> EcTypeClass.graph + val add : path -> env -> env + val bind : ?import:import -> symbol -> t -> env -> env val by_path : path -> env -> t val by_path_opt : path -> env -> t option @@ -355,7 +355,10 @@ module TypeClass : sig val add_instance : ?import:import -> (ty_params * ty) -> tcinstance -> env -> env val get_instances : env -> ((ty_params * ty) * tcinstance) list + + val hastc : env -> (typeclass list) Mid.t -> ty -> typeclass -> bool end + (* -------------------------------------------------------------------- *) module BaseRw : sig val by_path : path -> env -> Sp.t diff --git a/src/ecScope.ml b/src/ecScope.ml index 4b2b8b9253..9244db77f4 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2425,7 +2425,7 @@ module Search = struct match fp.f_node with | Fop (pf, _) -> (pf :: paths, pts) - | _ -> (paths, (ps, ue, fp) ::pts) + | _ -> (paths, (ps, ue, fp) :: pts) end | _ -> (p :: paths, pts) in diff --git a/src/ecTypeClass.ml b/src/ecTypeClass.ml deleted file mode 100644 index 723440aad8..0000000000 --- a/src/ecTypeClass.ml +++ /dev/null @@ -1,95 +0,0 @@ -(* -------------------------------------------------------------------- - * Copyright (c) - 2012--2016 - IMDEA Software Institute - * Copyright (c) - 2012--2018 - Inria - * Copyright (c) - 2012--2018 - Ecole Polytechnique - * - * Distributed under the terms of the CeCILL-C-V1 license - * -------------------------------------------------------------------- *) - -(* -------------------------------------------------------------------- *) -open EcUtils -open EcPath - -(* -------------------------------------------------------------------- *) -type graph = { - tcg_nodes : Sp.t Mp.t; - tcg_closure : Sp.t Mp.t; -} - -type nodes = { - tcn_graph : graph; - tcn_nodes : Sp.t; -} - -type node = EcPath.path - -exception CycleDetected - -(* -------------------------------------------------------------------- *) -module Graph = struct - let empty : graph = { - tcg_nodes = Mp.empty; - tcg_closure = Mp.empty; - } - - let dump gr = - Printf.sprintf "%s\n" - (String.concat "\n" - (List.map - (fun (p, ps) -> Printf.sprintf "%s -> %s" - (EcPath.tostring p) - (String.concat ", " (List.map EcPath.tostring (Sp.elements ps)))) - (Mp.bindings gr.tcg_nodes))) - - let has_path ~src ~dst g = - if EcPath.p_equal src dst then - true - else - match Mp.find_opt src g.tcg_closure with - | None -> false - | Some m -> Mp.mem dst m - - let add ~src ~dst g = - if has_path dst src g then - raise CycleDetected; - - match Mp.find_opt src g.tcg_nodes with - | Some m when Mp.mem dst m -> g - | _ -> - let up_node m = Sp.add dst (odfl Sp.empty m) - and up_clos m = - Sp.union - (odfl Sp.empty (Mp.find_opt dst g.tcg_closure)) - (Sp.add dst (odfl Sp.empty m)) - in - { g with - tcg_nodes = Mp.change (some -| up_node) src g.tcg_nodes; - tcg_closure = Mp.change (some -| up_clos) src g.tcg_closure; } -end - -(* -------------------------------------------------------------------- *) -module Nodes = struct - let empty g = { - tcn_graph = g; - tcn_nodes = Sp.empty; - } - - let add n nodes = - let module E = struct exception Discard end in - - try - let aout = - Sp.filter - (fun p -> - if Graph.has_path p n nodes.tcn_graph then raise E.Discard; - not (Graph.has_path n p nodes.tcn_graph)) - nodes.tcn_nodes - in - { nodes with tcn_nodes = Sp.add n aout } - with E.Discard -> nodes - - let toset nodes = nodes.tcn_nodes - - let reduce set g = - toset (Sp.fold add set (empty g)) -end diff --git a/src/ecTypeClass.mli b/src/ecTypeClass.mli deleted file mode 100644 index 5afac61332..0000000000 --- a/src/ecTypeClass.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* -------------------------------------------------------------------- - * Copyright (c) - 2012--2016 - IMDEA Software Institute - * Copyright (c) - 2012--2018 - Inria - * Copyright (c) - 2012--2018 - Ecole Polytechnique - * - * Distributed under the terms of the CeCILL-C-V1 license - * -------------------------------------------------------------------- *) - -(* -------------------------------------------------------------------- *) -open EcPath - -type node = path - -type graph -type nodes - -exception CycleDetected - -module Graph : sig - val empty : graph - val add : src:node -> dst:node -> graph -> graph - val has_path : src:node -> dst:node -> graph -> bool - val dump : graph -> string -end - -module Nodes : sig - val empty : graph -> nodes - val add : node -> nodes -> nodes - val toset : nodes -> Sp.t - val reduce : Sp.t -> graph -> Sp.t -end diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 5c416b4aa6..2203fda1a9 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -25,8 +25,6 @@ module Mid = EcIdent.Mid module EqTest = EcReduction.EqTest module NormMp = EcEnv.NormMp -module TC = EcTypeClass - (* -------------------------------------------------------------------- *) type opmatch = [ | `Op of EcPath.path * EcTypes.ty list @@ -788,10 +786,18 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = match EcEnv.TypeClass.lookup_opt (unloc tc_name) env with | None -> tyerror (loc tc_name) env (UnknownTypeClass (unloc tc_name)) + | Some (p, decl) -> let args = List.map (transty tp_tydecl env ue) args in - if List.length decl.tc_tparams <> List.length args then - tyerror (loc tc_name) env (TCArgsCountMismatch (unloc tc_name, decl.tc_tparams, args)); + if List.length decl.tc_tparams <> List.length args then begin + tyerror (loc tc_name) env + (TCArgsCountMismatch (unloc tc_name, decl.tc_tparams, args)); + end; + + (* FIXME: TC *) + List.iter2 + (fun (_, tcs) ty -> EcUnify.hastcs env ue ty tcs) + decl.tc_tparams args; { tc_name = p; tc_args = args; } (* -------------------------------------------------------------------- *) @@ -808,7 +814,7 @@ let transtyvars (env : EcEnv.env) (loc, (tparams : ptyparams option)) = tyerror loc env DuplicatedTyVar; List.rev (List.fold_left for1 [] tparams)) in - EcUnify.UniEnv.create tparams + UE.create tparams (* -------------------------------------------------------------------- *) let transpattern1 env ue (p : EcParsetree.plpattern) = diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 048f2ff3b4..98f14c70a2 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -16,7 +16,6 @@ open EcTypes open EcDecl module Sp = EcPath.Sp -module TC = EcTypeClass (* -------------------------------------------------------------------- *) exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * typeclass] @@ -63,14 +62,14 @@ module UF = EcUFind.Make(UFArgs.I)(UFArgs.D) (* -------------------------------------------------------------------- *) module UnifyCore = struct - let fresh ?(tc = []) ?ty uf = + let fresh ?(tcs = []) ?ty uf = let uid = EcUid.unique () in let uf = match ty with | Some { ty_node = Tunivar id } -> - let uf = UF.set uid (tc, None) uf in + let uf = UF.set uid (tcs, None) uf in fst (UF.union uid id uf) - | None | Some _ -> UF.set uid (tc, ty) uf + | None | Some _ -> UF.set uid (tcs, ty) uf in (uf, tuni uid) end @@ -169,47 +168,33 @@ let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) p end | `TcCtt (ty, tc) -> begin + Format.eprintf "[W]TC: %s / %s[%s]@." + (EcTypes.dump_ty ty) + (EcPath.tostring tc.tc_name) + (String.concat ", " (List.map EcTypes.dump_ty tc.tc_args)); + let tytc, ty = getvar ty in match ty.ty_node with | Tunivar i -> uf := UF.set i (tc :: tytc, None) !uf - | Tvar x -> - let xtcs = odfl [] (Mid.find_opt x tvtc) in - () - | _ -> - if not (has_tcs ~src:tytc ~dst:tc) then - let module E = struct exception Failure end in - - - - let inst = instances_for_tcs tc in (*TODOTCD: ELPI here*) - - let for1 uf p = - let for_inst ((typ, gty), p') = - try - if not (TC.Graph.has_path ~src:p' ~dst:p gr) then - raise E.Failure; - let (uf, gty) = - let (uf, subst) = - List.fold_left - (fun (uf, s) (v, tc) -> (*TODOTCD: typeclass list to use*) - let (uf, uid) = UnifyCore.fresh uf in - (uf, Mid.add v uid s)) - (uf, Mid.empty) typ - in - (uf, Tvar.subst subst gty) - in - try Some (unify_core env tvtc uf (`TyUni (gty, ty))) - with UnificationFailure _ -> raise E.Failure - with E.Failure -> None - in - try List.find_map for_inst inst - with Not_found -> failure () - in - uf := for1 !uf tc + if not (EcEnv.TypeClass.hastc env tvtc ty tc) then + failure () + +(* + let xtcs = odfl [] (Mid.find_opt x tvtc) in + Format.eprintf "[W] TC2: %s (%s)@." + (EcIdent.tostring x) + (String.concat " / " + (List.map (fun tc -> + Format.asprintf "%s[%s]" + (EcPath.tostring tc.tc_name) + (String.concat ", " (List.map EcTypes.dump_ty tc.tc_args)) + ) xtcs)); + () +*) end done in @@ -305,46 +290,48 @@ module UniEnv = struct in ref ue - let fresh ?tc ?ty ue = - let (uf, uid) = UnifyCore.fresh ?tc ?ty (!ue).ue_uf in + let fresh ?tcs ?ty ue = + let (uf, uid) = UnifyCore.fresh ?tcs ?ty (!ue).ue_uf in ue := { !ue with ue_uf = uf }; uid let opentvi ue (params : ty_params) tvi = - match tvi with - | None -> - List.fold_left - (fun s (v, tc) -> Mid.add v (fresh ue) s) (*TODOTCD: typeclass list to use*) - Mid.empty params + let tvi = + match tvi with + | None -> + List.map (fun (v, tc) -> (v, (None, tc))) params - | Some (TVIunamed lt) -> - List.fold_left2 - (fun s (v, tc) ty -> Mid.add v (fresh ~ty ue) s) (*TODOTCD: typeclass list to define*) - Mid.empty params lt + | Some (TVIunamed lt) -> + List.map2 (fun (v, tc) ty -> (v, (Some ty, tc))) params lt | Some (TVInamed lt) -> - let for1 s (v, tc) = - let t = - try fresh ~ty:(List.assoc (EcIdent.name v) lt) ue (*TODOTCD: typeclass list to define*) - with Not_found -> fresh ue (*TODOTCD: typeclass list to define*) - in - Mid.add v t s - in - List.fold_left for1 Mid.empty params + List.map (fun (v, tc) -> + let ty = List.assoc_opt (EcIdent.name v) lt in + (v, (ty, tc)) + ) params in + + List.fold_left (fun s (v, (ty, tcs)) -> + let tcs = + let for1 tc = + { tc_name = tc.tc_name; + tc_args = List.map (Tvar.subst s) tc.tc_args } in + List.map for1 tcs in + Mid.add v (fresh ?ty:ty ~tcs ue) s + ) Mid.empty tvi let subst_tv subst params = List.map (fun (tv, _) -> subst (tvar tv)) params let openty_r ue params tvi = let subst = Tvar.subst (opentvi ue params tvi) in - (subst, subst_tv subst params) + (subst, subst_tv subst params) let opentys ue params tvi tys = let (subst, tvs) = openty_r ue params tvi in - (List.map subst tys, tvs) + (List.map subst tys, tvs) let openty ue params tvi ty = let (subst, tvs) = openty_r ue params tvi in - (subst ty, tvs) + (subst ty, tvs) let rec repr (ue : unienv) (t : ty) : ty = match t.ty_node with @@ -368,11 +355,14 @@ end (* -------------------------------------------------------------------- *) let unify env ue t1 t2 = let uf = unify_core env (!ue).ue_tvtc (!ue).ue_uf (`TyUni (t1, t2)) in - ue := { !ue with ue_uf = uf; } + ue := { !ue with ue_uf = uf; } let hastc env ue ty tc = let uf = unify_core env (!ue).ue_tvtc (!ue).ue_uf (`TcCtt (ty, tc)) in - ue := { !ue with ue_uf = uf; } + ue := { !ue with ue_uf = uf; } + +let hastcs env ue ty tcs = + List.iter (hastc env ue ty) tcs (* -------------------------------------------------------------------- *) let tfun_expected ue psig = @@ -421,22 +411,17 @@ let select_op ?(hidden = false) ?(filter = fun _ -> true) tvi env name ue psig = () | Some (TVIunamed lt) -> - (* List.iter2 - (fun ty (_, tc) -> hastc env subue ty tc) + (fun ty (_, tc) -> hastcs env subue ty tc) lt op.D.op_tparams - *) - () | Some (TVInamed ls) -> let tparams = List.map (fst_map EcIdent.name) op.D.op_tparams in let tparams = Msym.of_list tparams in - (* - List.iter (fun (x, ty) -> - hastc env subue ty (oget (Msym.find_opt x tparams))) - ls - *) - () + List.iter (fun (x, ty) -> + hastcs env subue ty (oget (Msym.find_opt x tparams))) + ls + with UnificationFailure _ -> raise E.Failure end; diff --git a/src/ecUnify.mli b/src/ecUnify.mli index c96ea23bba..eb420cd889 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -29,7 +29,7 @@ module UniEnv : sig val create : (EcIdent.t * typeclass list) list option -> unienv val copy : unienv -> unienv (* constant time *) val restore : dst:unienv -> src:unienv -> unit (* constant time *) - val fresh : ?tc:typeclass list -> ?ty:ty -> unienv -> ty + val fresh : ?tcs:typeclass list -> ?ty:ty -> unienv -> ty val getnamed : unienv -> symbol -> EcIdent.t val repr : unienv -> ty -> ty val opentvi : unienv -> ty_params -> tvi -> ty EcIdent.Mid.t @@ -42,7 +42,9 @@ module UniEnv : sig end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val hastc : EcEnv.env -> unienv -> ty -> typeclass -> unit + +val hastc : EcEnv.env -> unienv -> ty -> typeclass -> unit +val hastcs : EcEnv.env -> unienv -> ty -> typeclass list -> unit val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty From 9303f9a0df7fbf7b4a5efc6db4c9b7f4ecadad9f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Nov 2021 13:45:24 +0100 Subject: [PATCH 016/113] generalize unification API for external constraints --- .merlin | 1 + _tags | 2 + default.nix | 2 +- src/ecEnv.ml | 10 +- src/ecEnv.mli | 5 +- src/ecUnify.ml | 450 ++++++++++++++++++++++++++++++------------------- 6 files changed, 282 insertions(+), 188 deletions(-) diff --git a/.merlin b/.merlin index 83a121262e..ae680ff8f9 100644 --- a/.merlin +++ b/.merlin @@ -16,6 +16,7 @@ PKG pcre PKG inifiles PKG yojson PKG elpi +PKG ppx_deriving.std FLG -rectypes FLG -w Y -w Z -w -23 -w +28 -w +33 diff --git a/_tags b/_tags index fabe9eba94..1eaa4236e4 100644 --- a/_tags +++ b/_tags @@ -18,3 +18,5 @@ true : bin_annot : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson,elpi) : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson,elpi) : package(batteries,menhirLib,why3,inifiles,zarith,pcre,yojson,elpi) + + : package(ppx_deriving.std) diff --git a/default.nix b/default.nix index 89de1b47d6..24b11a4913 100644 --- a/default.nix +++ b/default.nix @@ -7,7 +7,7 @@ stdenv.mkDerivation { name = "easycrypt-1.0"; src = ./.; buildInputs = [ why3 ] - ++ (with ocamlPackages; [ ocaml findlib ocamlbuild batteries menhir menhirLib merlin zarith inifiles yojson]) + ++ (with ocamlPackages; [ ocaml findlib ocamlbuild batteries menhir menhirLib merlin zarith inifiles yojson elpi]) ; installFlags = [ "PREFIX=$(out)" ]; } diff --git a/src/ecEnv.ml b/src/ecEnv.ml index b05e2a4ffc..1bbfea78e7 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -1313,7 +1313,7 @@ module TypeClass = struct let lookup_path name env = fst (lookup name env) - let graph (env : env) = + let get_typeclasses (env : env) = env.env_tc let bind_instance (ty : ty_params * ty) (cr : tcinstance) tci = @@ -1328,14 +1328,6 @@ module TypeClass = struct env_item = mk_citem import (CTh_instance (ty, cr)) :: env.env_item; } let get_instances env = env.env_tci - - let hastc - (env : env) (tvtc : (typeclass list) Mid.t) - (ty : ty) (tc : typeclass) - = (* env.env_tc -> all tc declaration *) - (* env.env_tci -> all tc instances *) - - true end (* -------------------------------------------------------------------- *) diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 7a34bd8f12..2ae554e625 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -7,7 +7,6 @@ * -------------------------------------------------------------------- *) (* -------------------------------------------------------------------- *) -open EcIdent open EcPath open EcSymbols open EcTypes @@ -353,10 +352,10 @@ module TypeClass : sig val lookup_opt : qsymbol -> env -> (path * t) option val lookup_path : qsymbol -> env -> path + val get_typeclasses : env -> t list + val add_instance : ?import:import -> (ty_params * ty) -> tcinstance -> env -> env val get_instances : env -> ((ty_params * ty) * tcinstance) list - - val hastc : env -> (typeclass list) Mid.t -> ty -> typeclass -> bool end (* -------------------------------------------------------------------- *) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 98f14c70a2..dcf845e814 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -22,218 +22,306 @@ exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * typeclass] exception UninstanciateUni (* -------------------------------------------------------------------- *) -type pb = [ `TyUni of ty * ty | `TcCtt of ty * typeclass ] +module TypeClass = struct + let hastc + (env : EcEnv.env) (tvtc : (typeclass list) Mid.t) + (ty : ty ) (tc : typeclass) + = -module UFArgs = struct - module I = struct - type t = uid + let instances = EcEnv.TypeClass.get_instances env in - let equal = uid_equal - let compare = uid_compare - end - - module D = struct - type data = typeclass list * ty option - type effects = pb list + false +end - let default : data = - ([], None) +(* ==================================================================== *) +module type UFRaw = sig + type uf + type data - let isvoid ((_, x) : data) = - (x = None) + val set : uid -> data * ty option -> uf -> uf +end - let noeffects : effects = [] +(* ==================================================================== *) +module type UnifyExtra = sig + type state + type problem - let union d1 d2 = - match d1, d2 with - | (tc1, None), (tc2, None) -> - ((tc1 @ tc2, None), []) + exception Failure - | (tc1, Some ty1), (tc2, Some ty2) -> - ((tc1 @ tc2, Some ty1), [`TyUni (ty1, ty2)]) + module State : sig + val default : state + val union : state * ty option -> state * ty option -> state * problem list + end - | (tc1, None ), (tc2, Some ty) - | (tc2, Some ty), (tc1, None ) -> - ((tc1 @ tc2, Some ty), List.map (fun tc -> `TcCtt (ty, tc)) tc1) + module Problem : sig + val solve : + (module EcUFind.S with type data = state * ty option) -> + EcEnv.env -> state Mid.t -> problem -> problem list end end -module UF = EcUFind.Make(UFArgs.I)(UFArgs.D) +(* ==================================================================== *) +module UnifyGen(X : UnifyExtra) = struct + (* ------------------------------------------------------------------ *) + type pb = [ `TyUni of (ty * ty) | `Other of X.problem ] -(* -------------------------------------------------------------------- *) -module UnifyCore = struct - let fresh ?(tcs = []) ?ty uf = - let uid = EcUid.unique () in - let uf = - match ty with - | Some { ty_node = Tunivar id } -> - let uf = UF.set uid (tcs, None) uf in - fst (UF.union uid id uf) - | None | Some _ -> UF.set uid (tcs, ty) uf - in - (uf, tuni uid) -end + exception UnificationFailure of pb -(* -------------------------------------------------------------------- *) -(*TODOTCC: what is this big function supposed to do?*) -let rec unify_core (env : EcEnv.env) (tvtc : typeclass list Mid.t) (uf : UF.t) pb = - let failure () = raise (UnificationFailure pb) in + module UFArgs = struct + module I = struct + type t = uid - let uf = ref uf in - let pb = let x = Queue.create () in Queue.push pb x; x in + let equal = uid_equal + let compare = uid_compare + end - let ocheck i t = - let i = UF.find i !uf in - let map = Hint.create 0 in + module D = struct + type data = X.state * ty option + type effects = pb list - let rec doit t = - match t.ty_node with - | Tunivar i' -> begin - let i' = UF.find i' !uf in - match i' with - | _ when i = i' -> true - | _ when Hint.mem map i' -> false - | _ -> - match snd (UF.data i' !uf) with - | None -> Hint.add map i' (); false - | Some t -> - match doit t with - | true -> true - | false -> Hint.add map i' (); false - end + let default : data = + (X.State.default, None) - | _ -> EcTypes.ty_sub_exists doit t + let isvoid ((_, x) : data) = + (x = None) + + let noeffects : effects = [] + + let union ((_, ty1) as d1 : data) ((_, ty2) as d2 : data) : data * effects = + let pb, cts_pb = X.State.union d1 d2 in + let ty, cts_ty = + match ty1, ty2 with + | None, None -> + (None, []) + | Some ty1, Some ty2 -> + Some ty1, [(ty1, ty2)] + + | None, Some ty | Some ty, None -> + Some ty, [] in + + let cts = + (List.map (fun x -> `Other x) cts_pb) + @ (List.map (fun x -> `TyUni x) cts_ty) in + + (pb, ty), (cts :> effects) + end + end + + (* ------------------------------------------------------------------ *) + module UF = EcUFind.Make(UFArgs.I)(UFArgs.D) + + (* ------------------------------------------------------------------ *) + module UnifyCore = struct + let fresh ?(extra = X.State.default) ?ty uf = + let uid = EcUid.unique () in + let uf = + match ty with + | Some { ty_node = Tunivar id } -> + let uf = UF.set uid (extra, None) uf in + fst (UF.union uid id uf) + | None | Some _ -> UF.set uid (extra, ty) uf + in + (uf, tuni uid) + end + + (* ------------------------------------------------------------------ *) + let rec unify_core (env : EcEnv.env) (tvtc : X.state Mid.t) (uf : UF.t) pb = + let failure () = raise (UnificationFailure pb) in + + let uf = ref uf in + let pb = let x = Queue.create () in Queue.push pb x; x in + + let ocheck i t = + let i = UF.find i !uf in + let map = Hint.create 0 in + + let rec doit t = + match t.ty_node with + | Tunivar i' -> begin + let i' = UF.find i' !uf in + match i' with + | _ when i = i' -> true + | _ when Hint.mem map i' -> false + | _ -> + match snd (UF.data i' !uf) with + | None -> Hint.add map i' (); false + | Some t -> + match doit t with + | true -> true + | false -> Hint.add map i' (); false + end + + | _ -> EcTypes.ty_sub_exists doit t + in + doit t in - doit t - in - let setvar i t = - let (ti, effects) = UFArgs.D.union (UF.data i !uf) ([], Some t) in - if odfl false (snd ti |> omap (ocheck i)) then failure (); - List.iter (Queue.push^~ pb) effects; - uf := UF.set i ti !uf + let setvar i t = + let (ti, effects) = + UFArgs.D.union (UF.data i !uf) (X.State.default, Some t) + in + if odfl false (snd ti |> omap (ocheck i)) then failure (); + List.iter (Queue.push^~ pb) effects; + uf := UF.set i ti !uf - and getvar t = - match t.ty_node with - | Tunivar i -> snd_map (odfl t) (UF.data i !uf) - | _ -> ([], t) + and getvar t = + match t.ty_node with + | Tunivar i -> snd_map (odfl t) (UF.data i !uf) + | _ -> (X.State.default, t) - in + in - let doit () = - while not (Queue.is_empty pb) do - match Queue.pop pb with - | `TyUni (t1, t2) -> begin - let (t1, t2) = (snd (getvar t1), snd (getvar t2)) in - - match ty_equal t1 t2 with - | true -> () - | false -> begin - match t1.ty_node, t2.ty_node with - | Tunivar id1, Tunivar id2 -> begin - if not (uid_equal id1 id2) then - let effects = reffold (swap |- UF.union id1 id2) uf in + let doit () = + while not (Queue.is_empty pb) do + match Queue.pop pb with + | `TyUni (t1, t2) -> begin + let (t1, t2) = (snd (getvar t1), snd (getvar t2)) in + + match ty_equal t1 t2 with + | true -> () + | false -> begin + match t1.ty_node, t2.ty_node with + | Tunivar id1, Tunivar id2 -> begin + if not (uid_equal id1 id2) then + let effects = reffold (swap |- UF.union id1 id2) uf in List.iter (Queue.push^~ pb) effects - end + end - | Tunivar id, _ -> setvar id t2 - | _, Tunivar id -> setvar id t1 + | Tunivar id, _ -> setvar id t2 + | _, Tunivar id -> setvar id t1 - | Ttuple lt1, Ttuple lt2 -> - if List.length lt1 <> List.length lt2 then failure (); - List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) lt1 lt2 + | Ttuple lt1, Ttuple lt2 -> + if List.length lt1 <> List.length lt2 then failure (); + List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) lt1 lt2 - | Tfun (t1, t2), Tfun (t1', t2') -> - Queue.push (`TyUni (t1, t1')) pb; - Queue.push (`TyUni (t2, t2')) pb + | Tfun (t1, t2), Tfun (t1', t2') -> + Queue.push (`TyUni (t1, t1')) pb; + Queue.push (`TyUni (t2, t2')) pb - | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> - if List.length lt1 <> List.length lt2 then failure (); - List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) lt1 lt2 + | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> + if List.length lt1 <> List.length lt2 then failure (); + List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) lt1 lt2 - | Tconstr (p, lt), _ when EcEnv.Ty.defined p env -> - Queue.push (`TyUni (EcEnv.Ty.unfold p lt env, t2)) pb + | Tconstr (p, lt), _ when EcEnv.Ty.defined p env -> + Queue.push (`TyUni (EcEnv.Ty.unfold p lt env, t2)) pb - | _, Tconstr (p, lt) when EcEnv.Ty.defined p env -> - Queue.push (`TyUni (t1, EcEnv.Ty.unfold p lt env)) pb + | _, Tconstr (p, lt) when EcEnv.Ty.defined p env -> + Queue.push (`TyUni (t1, EcEnv.Ty.unfold p lt env)) pb - | Tglob mp, _ when EcEnv.NormMp.tglob_reducible env mp -> - Queue.push (`TyUni (EcEnv.NormMp.norm_tglob env mp, t2)) pb + | Tglob mp, _ when EcEnv.NormMp.tglob_reducible env mp -> + Queue.push (`TyUni (EcEnv.NormMp.norm_tglob env mp, t2)) pb - | _, Tglob mp when EcEnv.NormMp.tglob_reducible env mp -> - Queue.push (`TyUni (t1, EcEnv.NormMp.norm_tglob env mp)) pb + | _, Tglob mp when EcEnv.NormMp.tglob_reducible env mp -> + Queue.push (`TyUni (t1, EcEnv.NormMp.norm_tglob env mp)) pb - | _, _ -> failure () + | _, _ -> failure () + end end - end - | `TcCtt (ty, tc) -> begin - Format.eprintf "[W]TC: %s / %s[%s]@." - (EcTypes.dump_ty ty) - (EcPath.tostring tc.tc_name) - (String.concat ", " (List.map EcTypes.dump_ty tc.tc_args)); + | `Other pb1 -> + try + List.iter + (fun x -> Queue.push (`Other x) pb) + (X.Problem.solve (module UF) env tvtc pb1) + with X.Failure -> failure () - let tytc, ty = getvar ty in +(* + | `TcCtt (ty, tc) -> begin + Format.eprintf "[W]TC: %s / %s[%s]@." + (EcTypes.dump_ty ty) + (EcPath.tostring tc.tc_name) + (String.concat ", " (List.map EcTypes.dump_ty tc.tc_args)); - match ty.ty_node with - | Tunivar i -> - uf := UF.set i (tc :: tytc, None) !uf + let tytc, ty = getvar ty in - | _ -> - if not (EcEnv.TypeClass.hastc env tvtc ty tc) then - failure () + match ty.ty_node with + | Tunivar i -> + uf := UF.set i (tc :: tytc, None) !uf -(* - let xtcs = odfl [] (Mid.find_opt x tvtc) in - Format.eprintf "[W] TC2: %s (%s)@." - (EcIdent.tostring x) - (String.concat " / " - (List.map (fun tc -> - Format.asprintf "%s[%s]" - (EcPath.tostring tc.tc_name) - (String.concat ", " (List.map EcTypes.dump_ty tc.tc_args)) - ) xtcs)); - () + | _ -> + if not (TypeClass.hastc env tvtc ty tc) then + failure () + + (* + let xtcs = odfl [] (Mid.find_opt x tvtc) in + Format.eprintf "[W] TC2: %s (%s)@." + (EcIdent.tostring x) + (String.concat " / " + (List.map (fun tc -> + Format.asprintf "%s[%s]" + (EcPath.tostring tc.tc_name) + (String.concat ", " (List.map EcTypes.dump_ty tc.tc_args)) + ) xtcs)); + () + *) + end *) + done + in + doit (); !uf + + (* ------------------------------------------------------------------ *) + let close (uf : UF.t) = + let map = Hint.create 0 in + + let rec doit t = + match t.ty_node with + | Tunivar i -> begin + match Hint.find_opt map i with + | Some t -> t + | None -> begin + let t = + match snd (UF.data i uf) with + | None -> tuni (UF.find i uf) + | Some t -> doit t + in + Hint.add map i t; t + end end - done - in - doit (); !uf + + | _ -> ty_map doit t + in + fun t -> doit t + + (* ------------------------------------------------------------------ *) + let subst_of_uf (uf : UF.t) = + let close = close uf in + fun id -> + match close (tuni id) with + | { ty_node = Tunivar id' } when uid_equal id id' -> None + | t -> Some t +end (* -------------------------------------------------------------------- *) -let close (uf : UF.t) = - let map = Hint.create 0 in +module UnifyExtraForTC : + UnifyExtra with type state = typeclass list + and type problem = [ `TcCtt of ty * typeclass ] = +struct + type state = typeclass list + type problem = [ `TcCtt of ty * typeclass ] - let rec doit t = - match t.ty_node with - | Tunivar i -> begin - match Hint.find_opt map i with - | Some t -> t - | None -> begin - let t = - match snd (UF.data i uf) with - | None -> tuni (UF.find i uf) - | Some t -> doit t - in - Hint.add map i t; t - end - end + exception Failure - | _ -> ty_map doit t - in - fun t -> doit t + module State = struct + let default = + assert false + + let union = + assert false + end + + module Problem = struct + let solve = + assert false + end +end (* -------------------------------------------------------------------- *) -let subst_of_uf (uf : UF.t) = - let close = close uf in - fun id -> - match close (tuni id) with - | { ty_node = Tunivar id' } when uid_equal id id' -> None - | t -> Some t +module Unify = UnifyGen(UnifyExtraForTC) (* -------------------------------------------------------------------- *) type unienv_r = { - ue_uf : UF.t; + ue_uf : Unify.UF.t; ue_named : EcIdent.t Mstr.t; ue_tvtc : typeclass list Mid.t; ue_decl : EcIdent.t list; @@ -270,7 +358,7 @@ module UniEnv = struct let create (vd : (EcIdent.t * typeclass list) list option) = let ue = { - ue_uf = UF.initial; + ue_uf = Unify.UF.initial; ue_named = Mstr.empty; ue_tvtc = Mid.empty; ue_decl = []; @@ -291,7 +379,7 @@ module UniEnv = struct ref ue let fresh ?tcs ?ty ue = - let (uf, uid) = UnifyCore.fresh ?tcs ?ty (!ue).ue_uf in + let (uf, uid) = Unify.UnifyCore.fresh ?extra:tcs ?ty (!ue).ue_uf in ue := { !ue with ue_uf = uf }; uid let opentvi ue (params : ty_params) tvi = @@ -335,31 +423,43 @@ module UniEnv = struct let rec repr (ue : unienv) (t : ty) : ty = match t.ty_node with - | Tunivar id -> odfl t (snd (UF.data id (!ue).ue_uf)) + | Tunivar id -> odfl t (snd (Unify.UF.data id (!ue).ue_uf)) | _ -> t let closed (ue : unienv) = - UF.closed (!ue).ue_uf + Unify.UF.closed (!ue).ue_uf let close (ue : unienv) = if not (closed ue) then raise UninstanciateUni; - (subst_of_uf (!ue).ue_uf) + (Unify.subst_of_uf (!ue).ue_uf) - let assubst ue = subst_of_uf (!ue).ue_uf + let assubst ue = Unify.subst_of_uf (!ue).ue_uf let tparams ue = let fortv x = odfl [] (Mid.find_opt x (!ue).ue_tvtc) in List.map (fun x -> (x, fortv x)) (List.rev (!ue).ue_decl) end +(* -------------------------------------------------------------------- *) +let unify_core env ue pb = + let uf = + try + Unify.unify_core env (!ue).ue_tvtc (!ue).ue_uf pb + with Unify.UnificationFailure pb -> begin + match pb with + | `TyUni (ty1, ty2) -> + raise (UnificationFailure (`TyUni (ty1, ty2))) + | `Other (`TcCtt (ty, tc)) -> + raise (UnificationFailure (`TcCtt (ty, tc))) + end + in ue := { !ue with ue_uf = uf; } + (* -------------------------------------------------------------------- *) let unify env ue t1 t2 = - let uf = unify_core env (!ue).ue_tvtc (!ue).ue_uf (`TyUni (t1, t2)) in - ue := { !ue with ue_uf = uf; } + unify_core env ue (`TyUni (t1, t2)) let hastc env ue ty tc = - let uf = unify_core env (!ue).ue_tvtc (!ue).ue_uf (`TcCtt (ty, tc)) in - ue := { !ue with ue_uf = uf; } + unify_core env ue (`Other (`TcCtt (ty, tc))) let hastcs env ue ty tcs = List.iter (hastc env ue ty) tcs @@ -422,7 +522,7 @@ let select_op ?(hidden = false) ?(filter = fun _ -> true) tvi env name ue psig = hastcs env subue ty (oget (Msym.find_opt x tparams))) ls - with UnificationFailure _ -> raise E.Failure + with Unify.UnificationFailure _ -> raise E.Failure end; let (tip, tvs) = UniEnv.openty_r subue op.D.op_tparams tvi in @@ -430,7 +530,7 @@ let select_op ?(hidden = false) ?(filter = fun _ -> true) tvi env name ue psig = let texpected = tfun_expected subue psig in (try unify env subue top texpected - with UnificationFailure _ -> raise E.Failure); + with Unify.UnificationFailure _ -> raise E.Failure); let bd = match op.D.op_kind with From cc70db819995df50925ae9fa5f13c57f7421f99d Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Nov 2021 15:21:23 +0100 Subject: [PATCH 017/113] type class inference --- src/ecCoreEqTest.ml | 57 +++++++++++ src/ecCoreEqTest.mli | 16 +++ src/ecReduction.ml | 47 +-------- src/ecUnify.ml | 234 ++++++++++++++++++++++++++++++------------- 4 files changed, 242 insertions(+), 112 deletions(-) create mode 100644 src/ecCoreEqTest.ml create mode 100644 src/ecCoreEqTest.mli diff --git a/src/ecCoreEqTest.ml b/src/ecCoreEqTest.ml new file mode 100644 index 0000000000..a8a3db81db --- /dev/null +++ b/src/ecCoreEqTest.ml @@ -0,0 +1,57 @@ +(* -------------------------------------------------------------------- + * Copyright (c) - 2012--2016 - IMDEA Software Institute + * Copyright (c) - 2012--2018 - Inria + * Copyright (c) - 2012--2018 - Ecole Polytechnique + * + * Distributed under the terms of the CeCILL-C-V1 license + * -------------------------------------------------------------------- *) + +(* -------------------------------------------------------------------- *) +open EcUtils +open EcTypes +open EcEnv + +(* -------------------------------------------------------------------- *) +type 'a eqtest = env -> 'a -> 'a -> bool + +(* -------------------------------------------------------------------- *) +let rec for_type env t1 t2 = + ty_equal t1 t2 || for_type_r env t1 t2 + +(* -------------------------------------------------------------------- *) +and for_type_r env t1 t2 = + match t1.ty_node, t2.ty_node with + | Tunivar uid1, Tunivar uid2 -> EcUid.uid_equal uid1 uid2 + + | Tvar i1, Tvar i2 -> i1 = i2 + + | Ttuple lt1, Ttuple lt2 -> + List.length lt1 = List.length lt2 + && List.all2 (for_type env) lt1 lt2 + + | Tfun (t1, t2), Tfun (t1', t2') -> + for_type env t1 t1' && for_type env t2 t2' + + | Tglob mp, _ when EcEnv.NormMp.tglob_reducible env mp -> + for_type env (EcEnv.NormMp.norm_tglob env mp) t2 + + | _, Tglob mp when EcEnv.NormMp.tglob_reducible env mp -> + for_type env t1 (EcEnv.NormMp.norm_tglob env mp) + + | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> + if + List.length lt1 = List.length lt2 + && List.all2 (for_type env) lt1 lt2 + then true + else + if Ty.defined p1 env + then for_type env (Ty.unfold p1 lt1 env) (Ty.unfold p2 lt2 env) + else false + + | Tconstr(p1,lt1), _ when Ty.defined p1 env -> + for_type env (Ty.unfold p1 lt1 env) t2 + + | _, Tconstr(p2,lt2) when Ty.defined p2 env -> + for_type env t1 (Ty.unfold p2 lt2 env) + + | _, _ -> false diff --git a/src/ecCoreEqTest.mli b/src/ecCoreEqTest.mli new file mode 100644 index 0000000000..d4b657e7e6 --- /dev/null +++ b/src/ecCoreEqTest.mli @@ -0,0 +1,16 @@ +(* -------------------------------------------------------------------- + * Copyright (c) - 2012--2016 - IMDEA Software Institute + * Copyright (c) - 2012--2018 - Inria + * Copyright (c) - 2012--2018 - Ecole Polytechnique + * + * Distributed under the terms of the CeCILL-C-V1 license + * -------------------------------------------------------------------- *) + +(* -------------------------------------------------------------------- *) +open EcTypes +open EcEnv + +(* -------------------------------------------------------------------- *) +type 'a eqtest = env -> 'a -> 'a -> bool + +val for_type : ty eqtest diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 55b9ad2d48..9e9a5dedc3 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -23,50 +23,13 @@ exception IncompatibleType of env * (ty * ty) exception IncompatibleForm of env * (form * form) exception IncompatibleModuleSig of module_sig * module_sig -(* -------------------------------------------------------------------- *) -type 'a eqtest = env -> 'a -> 'a -> bool +type 'a eqtest = env -> 'a -> 'a -> bool type 'a eqntest = env -> ?norm:bool -> 'a -> 'a -> bool +(* -------------------------------------------------------------------- *) module EqTest_base = struct - let rec for_type env t1 t2 = - ty_equal t1 t2 || for_type_r env t1 t2 - - and for_type_r env t1 t2 = - match t1.ty_node, t2.ty_node with - | Tunivar uid1, Tunivar uid2 -> EcUid.uid_equal uid1 uid2 - - | Tvar i1, Tvar i2 -> i1 = i2 - - | Ttuple lt1, Ttuple lt2 -> - List.length lt1 = List.length lt2 - && List.all2 (for_type env) lt1 lt2 - - | Tfun (t1, t2), Tfun (t1', t2') -> - for_type env t1 t1' && for_type env t2 t2' - - | Tglob mp, _ when EcEnv.NormMp.tglob_reducible env mp -> - for_type env (EcEnv.NormMp.norm_tglob env mp) t2 - - | _, Tglob mp when EcEnv.NormMp.tglob_reducible env mp -> - for_type env t1 (EcEnv.NormMp.norm_tglob env mp) - - | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> - if - List.length lt1 = List.length lt2 - && List.all2 (for_type env) lt1 lt2 - then true - else - if Ty.defined p1 env - then for_type env (Ty.unfold p1 lt1 env) (Ty.unfold p2 lt2 env) - else false - - | Tconstr(p1,lt1), _ when Ty.defined p1 env -> - for_type env (Ty.unfold p1 lt1 env) t2 - - | _, Tconstr(p2,lt2) when Ty.defined p2 env -> - for_type env t1 (Ty.unfold p2 lt2 env) - - | _, _ -> false + (* ------------------------------------------------------------------ *) + let for_type = EcCoreEqTest.for_type (* ------------------------------------------------------------------ *) let is_unit env ty = for_type env tunit ty @@ -192,7 +155,7 @@ end) = struct open EqTest_base open Fe - (* ------------------------------------------------------------------ *) + (* ------------------------------------------------------------------ *) let rec for_stmt env ~norm s1 s2 = s_equal s1 s2 || List.all2 (for_instr env ~norm) s1.s_node s2.s_node diff --git a/src/ecUnify.ml b/src/ecUnify.ml index dcf845e814..d04c84912f 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -21,18 +21,6 @@ module Sp = EcPath.Sp exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * typeclass] exception UninstanciateUni -(* -------------------------------------------------------------------- *) -module TypeClass = struct - let hastc - (env : EcEnv.env) (tvtc : (typeclass list) Mid.t) - (ty : ty ) (tc : typeclass) - = - - let instances = EcEnv.TypeClass.get_instances env in - - false -end - (* ==================================================================== *) module type UFRaw = sig type uf @@ -55,8 +43,11 @@ module type UnifyExtra = sig module Problem : sig val solve : - (module EcUFind.S with type data = state * ty option) -> - EcEnv.env -> state Mid.t -> problem -> problem list + (module EcUFind.S + with type t = 'uf + and type item = uid + and type data = state * ty option) + -> 'uf ref -> EcEnv.env -> state Mid.t -> problem -> problem list end end @@ -111,18 +102,16 @@ module UnifyGen(X : UnifyExtra) = struct module UF = EcUFind.Make(UFArgs.I)(UFArgs.D) (* ------------------------------------------------------------------ *) - module UnifyCore = struct - let fresh ?(extra = X.State.default) ?ty uf = - let uid = EcUid.unique () in - let uf = - match ty with - | Some { ty_node = Tunivar id } -> - let uf = UF.set uid (extra, None) uf in - fst (UF.union uid id uf) - | None | Some _ -> UF.set uid (extra, ty) uf - in - (uf, tuni uid) - end + let fresh ?(extra = X.State.default) ?ty uf = + let uid = EcUid.unique () in + let uf = + match ty with + | Some { ty_node = Tunivar id } -> + let uf = UF.set uid (extra, None) uf in + fst (UF.union uid id uf) + | None | Some _ -> UF.set uid (extra, ty) uf + in + (uf, tuni uid) (* ------------------------------------------------------------------ *) let rec unify_core (env : EcEnv.env) (tvtc : X.state Mid.t) (uf : UF.t) pb = @@ -222,40 +211,8 @@ module UnifyGen(X : UnifyExtra) = struct try List.iter (fun x -> Queue.push (`Other x) pb) - (X.Problem.solve (module UF) env tvtc pb1) + (X.Problem.solve (module UF) uf env tvtc pb1) with X.Failure -> failure () - -(* - | `TcCtt (ty, tc) -> begin - Format.eprintf "[W]TC: %s / %s[%s]@." - (EcTypes.dump_ty ty) - (EcPath.tostring tc.tc_name) - (String.concat ", " (List.map EcTypes.dump_ty tc.tc_args)); - - let tytc, ty = getvar ty in - - match ty.ty_node with - | Tunivar i -> - uf := UF.set i (tc :: tytc, None) !uf - - | _ -> - if not (TypeClass.hastc env tvtc ty tc) then - failure () - - (* - let xtcs = odfl [] (Mid.find_opt x tvtc) in - Format.eprintf "[W] TC2: %s (%s)@." - (EcIdent.tostring x) - (String.concat " / " - (List.map (fun tc -> - Format.asprintf "%s[%s]" - (EcPath.tostring tc.tc_name) - (String.concat ", " (List.map EcTypes.dump_ty tc.tc_args)) - ) xtcs)); - () - *) - end -*) done in doit (); !uf @@ -292,6 +249,107 @@ module UnifyGen(X : UnifyExtra) = struct | t -> Some t end +(* -------------------------------------------------------------------- *) +module UnifyExtraEmpty : + UnifyExtra with type state = unit + and type problem = unit = +struct + type state = unit + type problem = unit + type uparam = state * ty option + + exception Failure + + module State = struct + let default : state = + () + + let union (_ : uparam) (_ : uparam) : state * problem list = + ((), []) + end + + module Problem = struct + let solve (type uf) (module _) + (_ : uf ref) (_ : EcEnv.env) (_ : state Mid.t) (() : problem) + = + [] + end +end + +(* -------------------------------------------------------------------- *) +module UnifyCore = UnifyGen(UnifyExtraEmpty) + +(* -------------------------------------------------------------------- *) +module TypeClass = struct + let hastc + (env : EcEnv.env) (tvtc : (typeclass list) Mid.t) + (ty : ty) (tc : typeclass) + = + + let instances = EcEnv.TypeClass.get_instances env in + + let instances = + List.filter_map + (function (x, `General y) -> Some (x, y) | _ -> None) + instances in + + let instances = + let tvinst = + (List.map + (fun (tv, tcs) -> + List.map + (fun tc -> (([], tvar tv), tc)) + tcs) + (Mid.bindings tvtc)) in + List.flatten tvinst @ instances in + + + let exception Bailout in + + let for1 ((tgparams, tgty), tginst) = + if not (EcPath.p_equal tc.tc_name tginst.tc_name) then + raise Bailout; + + let uf, tvinfo = + List.fold_left_map + (fun uf (tv, tcs) -> + let uf, tvty = UnifyCore.fresh uf in uf, (tv, (tvty, tcs))) + UnifyCore.UF.initial tgparams in + let uf, subst = ref uf, Mid.of_list (List.map (snd_map fst) tvinfo) in + + List.iter2 + (fun pty tgty -> + let tgty = Tvar.subst subst tgty in + try + uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (pty, tgty)) + with UnifyCore.UnificationFailure _ -> + raise Bailout) + tc.tc_args tginst.tc_args; + + let tgty = Tvar.subst subst tgty in + + begin try + uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (ty, tgty)) + with UnifyCore.UnificationFailure _ -> raise Bailout end; + + assert (UnifyCore.UF.closed !uf); + + let subst = UnifyCore.subst_of_uf !uf in + let subst = Tuni.offun subst in + + List.flatten (List.map + (fun (_, (ty, tcs)) -> + List.map (fun tc -> (subst ty, tc)) tcs) + tvinfo) + + in + + let for1 pb = + try Some (for1 pb) with Bailout -> None in + + List.find_map_opt for1 instances +end + (* -------------------------------------------------------------------- *) module UnifyExtraForTC : UnifyExtra with type state = typeclass list @@ -299,20 +357,56 @@ module UnifyExtraForTC : struct type state = typeclass list type problem = [ `TcCtt of ty * typeclass ] + type uparam = state * ty option exception Failure module State = struct - let default = - assert false + let default : state = + [] + + let union (d1 : uparam) (d2 : uparam) = + match d1, d2 with + | (tc1, None), (tc2, None) -> + (tc1 @ tc2), [] - let union = - assert false + | (tc1, Some _), (tc2, Some _) -> + (tc1 @ tc2), [] + + | (tc1, None ), (tc2, Some ty) + | (tc2, Some ty), (tc1, None ) -> + (tc1 @ tc2), List.map (fun tc -> `TcCtt (ty, tc)) tc1 end module Problem = struct - let solve = - assert false + let solve (type uf) + (module UF : EcUFind.S + with type t = uf + and type item = uid + and type data = uparam) + (uf : uf ref) + (env : EcEnv.env) + (tvtc : state Mid.t) + (`TcCtt (ty, tc) : problem) + : problem list + = + let tytc, ty = + match ty.ty_node with + | Tunivar i -> snd_map (odfl ty) (UF.data i !uf) + | _ -> (State.default, ty) in + + match ty.ty_node with + | Tunivar i -> + uf := UF.set i (tc :: tytc, None) !uf; + [] + + | _ -> begin + match TypeClass.hastc env tvtc ty tc with + | None -> + raise Failure + | Some effects -> + List.map (fun (ty, tc) -> `TcCtt (ty, tc)) effects + end end end @@ -379,7 +473,7 @@ module UniEnv = struct ref ue let fresh ?tcs ?ty ue = - let (uf, uid) = Unify.UnifyCore.fresh ?extra:tcs ?ty (!ue).ue_uf in + let (uf, uid) = Unify.fresh ?extra:tcs ?ty (!ue).ue_uf in ue := { !ue with ue_uf = uf }; uid let opentvi ue (params : ty_params) tvi = @@ -391,8 +485,8 @@ module UniEnv = struct | Some (TVIunamed lt) -> List.map2 (fun (v, tc) ty -> (v, (Some ty, tc))) params lt - | Some (TVInamed lt) -> - List.map (fun (v, tc) -> + | Some (TVInamed lt) -> + List.map (fun (v, tc) -> let ty = List.assoc_opt (EcIdent.name v) lt in (v, (ty, tc)) ) params in @@ -522,7 +616,7 @@ let select_op ?(hidden = false) ?(filter = fun _ -> true) tvi env name ue psig = hastcs env subue ty (oget (Msym.find_opt x tparams))) ls - with Unify.UnificationFailure _ -> raise E.Failure + with UnificationFailure _ -> raise E.Failure end; let (tip, tvs) = UniEnv.openty_r subue op.D.op_tparams tvi in @@ -530,7 +624,7 @@ let select_op ?(hidden = false) ?(filter = fun _ -> true) tvi env name ue psig = let texpected = tfun_expected subue psig in (try unify env subue top texpected - with Unify.UnificationFailure _ -> raise E.Failure); + with UnificationFailure _ -> raise E.Failure); let bd = match op.D.op_kind with From 6a7f430197d7ae18d0c4e010bac401935045655c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Tue, 16 Nov 2021 14:42:01 +0100 Subject: [PATCH 018/113] added inherited instances --- examples/typeclass.ec | 8 ++++- src/ecUnify.ml | 68 +++++++++++++++++++++++-------------------- 2 files changed, 44 insertions(+), 32 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index ef162d4eff..4353580d01 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -82,7 +82,7 @@ qed. (* -------------------------------------------------------------------- *) op bool_enum = [true; false]. -instance foo with bool. +(* instance foo with bool. *) instance finite with bool op enum = bool_enum. @@ -102,6 +102,12 @@ instance group with int op (+) = CoreInt.add op ([-]) = CoreInt.opp. +(*TODO: what does Alt-Ergo have to do with this?*) +realize addr0 by []. +realize addrN by []. +realize addrC by []. +realize addrA by []. + op polyZ ['a <: ring] (c : 'a) (p : 'a poly) : 'a poly. instance 'b module_ with ['b <: ring] 'b poly diff --git a/src/ecUnify.ml b/src/ecUnify.ml index d04c84912f..d8c3c2c318 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -297,50 +297,56 @@ module TypeClass = struct let tvinst = (List.map (fun (tv, tcs) -> + (*TODOTCC: does it work as intended? Why are there always no type parameters in these cases?*) + let rec parent_instances_of_tc otc = + match otc with + | Some tc -> (([], tvar tv), tc) :: parent_instances_of_tc (EcEnv.TypeClass.by_path tc.tc_name env).tc_prt + | None -> [] + in List.map - (fun tc -> (([], tvar tv), tc)) + (fun tc -> parent_instances_of_tc (Some tc)) tcs) (Mid.bindings tvtc)) in - List.flatten tvinst @ instances in + List.flatten (List.flatten tvinst) @ instances in - let exception Bailout in + let exception Bailout in - let for1 ((tgparams, tgty), tginst) = - if not (EcPath.p_equal tc.tc_name tginst.tc_name) then - raise Bailout; + let for1 ((tgparams, tgty), tginst) = + if not (EcPath.p_equal tc.tc_name tginst.tc_name) then + raise Bailout; - let uf, tvinfo = - List.fold_left_map - (fun uf (tv, tcs) -> - let uf, tvty = UnifyCore.fresh uf in uf, (tv, (tvty, tcs))) - UnifyCore.UF.initial tgparams in - let uf, subst = ref uf, Mid.of_list (List.map (snd_map fst) tvinfo) in + let uf, tvinfo = + List.fold_left_map + (fun uf (tv, tcs) -> + let uf, tvty = UnifyCore.fresh uf in uf, (tv, (tvty, tcs))) + UnifyCore.UF.initial tgparams in + let uf, subst = ref uf, Mid.of_list (List.map (snd_map fst) tvinfo) in - List.iter2 - (fun pty tgty -> - let tgty = Tvar.subst subst tgty in - try - uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (pty, tgty)) - with UnifyCore.UnificationFailure _ -> - raise Bailout) - tc.tc_args tginst.tc_args; + List.iter2 + (fun pty tgty -> + let tgty = Tvar.subst subst tgty in + try + uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (pty, tgty)) + with UnifyCore.UnificationFailure _ -> + raise Bailout) + tc.tc_args tginst.tc_args; - let tgty = Tvar.subst subst tgty in + let tgty = Tvar.subst subst tgty in - begin try - uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (ty, tgty)) - with UnifyCore.UnificationFailure _ -> raise Bailout end; + begin try + uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (ty, tgty)) + with UnifyCore.UnificationFailure _ -> raise Bailout end; - assert (UnifyCore.UF.closed !uf); + assert (UnifyCore.UF.closed !uf); - let subst = UnifyCore.subst_of_uf !uf in - let subst = Tuni.offun subst in + let subst = UnifyCore.subst_of_uf !uf in + let subst = Tuni.offun subst in - List.flatten (List.map - (fun (_, (ty, tcs)) -> - List.map (fun tc -> (subst ty, tc)) tcs) - tvinfo) + List.flatten (List.map + (fun (_, (ty, tcs)) -> + List.map (fun tc -> (subst ty, tc)) tcs) + tvinfo) in From d68d4cc0ffb8c229855937f3347a800e5f301346 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Nov 2021 16:15:58 +0100 Subject: [PATCH 019/113] fix merge (section / typeclass) --- src/ecSection.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/ecSection.ml b/src/ecSection.ml index 482cd4958c..22a98c1c40 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -488,7 +488,12 @@ let pp_thname scenv = (* -------------------------------------------------------------------- *) let locality (env : EcEnv.env) (who : cbarg) = match who with - | `Type p -> (EcEnv.Ty.by_path p env).tyd_loca + | `Type p -> begin + match EcEnv.TypeClass.by_path_opt p env with + | Some tc -> (tc.tc_loca :> locality) + | _ -> (EcEnv.Ty.by_path p env).tyd_loca + end + | `Op p -> (EcEnv.Op.by_path p env).op_loca | `Ax p -> (EcEnv.Ax.by_path p env).ax_loca | `Typeclass p -> ((EcEnv.TypeClass.by_path p env).tc_loca :> locality) From c13bc354b6f28645d75504ce8ea235e2193cbc98 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Nov 2021 16:28:41 +0100 Subject: [PATCH 020/113] fix type classes resolution for type variables --- src/ecUnify.ml | 33 ++++++++++++++++++++------------- 1 file changed, 20 insertions(+), 13 deletions(-) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index d8c3c2c318..81008fbfc7 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -295,20 +295,27 @@ module TypeClass = struct let instances = let tvinst = - (List.map - (fun (tv, tcs) -> - (*TODOTCC: does it work as intended? Why are there always no type parameters in these cases?*) - let rec parent_instances_of_tc otc = - match otc with - | Some tc -> (([], tvar tv), tc) :: parent_instances_of_tc (EcEnv.TypeClass.by_path tc.tc_name env).tc_prt - | None -> [] - in - List.map - (fun tc -> parent_instances_of_tc (Some tc)) - tcs) - (Mid.bindings tvtc)) in - List.flatten (List.flatten tvinst) @ instances in + List.map + (fun (tv, tcs) -> + let rec parent_instances_of_tc acc tc = + let acc = (([], tvar tv), tc) :: acc in + let tcdecl = EcEnv.TypeClass.by_path tc.tc_name env in + match tcdecl.tc_prt with + | None -> + List.rev acc + + | Some prt -> + let subst = List.combine (List.fst tcdecl.tc_tparams) tc.tc_args in + let subst = Tvar.subst (Mid.of_list subst) in + let prt = { prt with tc_args = List.map subst prt.tc_args } in + + parent_instances_of_tc acc prt + + in List.map (fun tc -> parent_instances_of_tc [] tc) tcs) + (Mid.bindings tvtc) + + in List.flatten (List.flatten tvinst) @ instances in let exception Bailout in From 9c8e4677200df34c215152e8fb5d9d0f9ac36ab9 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Nov 2021 16:40:47 +0100 Subject: [PATCH 021/113] fix instanciation op/axioms in tc instances --- src/ecScope.ml | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index bf5be3a0ff..ea397142dc 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1744,9 +1744,13 @@ module Ty = struct (* ------------------------------------------------------------------ *) let symbols_of_tc (_env : EcEnv.env) ty (tcp, tc) = - (* FIXME: TC: substitute tc.tc_tparams with tcp.tc_args *) (* FIXME: TC: check that tcp.tc_args meets the reqs. of tc.tc_params *) - let subst = { ty_subst_id with ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)] } in + let subst = { ty_subst_id with + ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; + ts_v = + let vsubst = List.combine (List.fst tc.tc_tparams) tcp.tc_args in + Mid.find_opt^~ (Mid.of_list vsubst); + } in List.map (fun (x, opty) -> (EcIdent.name x, (true, ty_subst subst opty))) tc.tc_ops @@ -1781,8 +1785,13 @@ module Ty = struct let tcsyms = Mstr.of_list tcsyms in let symbols = check_tci_operators (env scope) ty tci.pti_ops tcsyms in - let tysubst = - EcSubst.add_tydef (EcSubst.empty ()) tcp.tc_name ([], snd ty) in + let subst = { + ty_subst_id with + ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; + ts_v = + let vsubst = List.combine (List.fst tc.tc_tparams) tcp.tc_args in + Mid.find_opt^~ (Mid.of_list vsubst); + } in let subst = List.fold_left @@ -1790,13 +1799,12 @@ module Ty = struct let oppath = Mstr.find (EcIdent.name opname) symbols in let op = EcFol.f_op oppath [] ty in EcFol.Fsubst.f_bind_local subst opname op) - EcFol.Fsubst.f_subst_id tc.tc_ops in + (EcFol.Fsubst.f_subst_init ~sty:subst ()) tc.tc_ops in let axioms = List.map (fun (name, ax) -> let ax = EcFol.Fsubst.f_subst subst ax in - let ax = EcSubst.subst_form tysubst ax in (name, ax)) tc.tc_axs in From b4f19d5a3fb57f3d1a3ce185e175b2bd0523125a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Nov 2021 16:58:30 +0100 Subject: [PATCH 022/113] better error messages for TC --- src/ecPrinting.ml | 13 +++++++++++++ src/ecPrinting.mli | 19 ++++++++++--------- src/ecScope.ml | 5 +---- src/ecTyping.ml | 6 +++++- src/ecTyping.mli | 1 + src/ecUnify.ml | 15 ++++++++++----- src/ecUnify.mli | 3 +-- src/ecUserMessages.ml | 12 +++++++----- 8 files changed, 48 insertions(+), 26 deletions(-) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 13ebffedba..f18ad7d2c2 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -2049,6 +2049,18 @@ let pp_added_op (ppe : PPEnv.t) fmt op = let pp_opname (ppe : PPEnv.t) fmt (p : EcPath.path) = pp_opname fmt (PPEnv.op_symb ppe p None) +(* -------------------------------------------------------------------- *) +let pp_typeclass (ppe : PPEnv.t) fmt (tc : typeclass) = + match tc.tc_args with + | [] -> + Format.fprintf fmt "%a" (pp_tcname ppe) tc.tc_name + | [ty] -> + Format.fprintf fmt "%a %a" + (pp_type ppe) ty (pp_tcname ppe) tc.tc_name + | tys -> + Format.fprintf fmt "(%a) %a" + (pp_list ", " (pp_type ppe)) tys + (pp_tcname ppe) tc.tc_name (* -------------------------------------------------------------------- *) let string_of_axkind = function @@ -2231,6 +2243,7 @@ let pp_i_blk (_ppe : PPEnv.t) fmt _ = let pp_i_abstract (_ppe : PPEnv.t) fmt id = Format.fprintf fmt "%s" (EcIdent.name id) + (* -------------------------------------------------------------------- *) let c_ppnode1 ~width ppe (pp1 : ppnode1) = match pp1 with diff --git a/src/ecPrinting.mli b/src/ecPrinting.mli index 954f619fda..611528fd9b 100644 --- a/src/ecPrinting.mli +++ b/src/ecPrinting.mli @@ -67,15 +67,16 @@ val pp_tyunivar : PPEnv.t -> EcUid.uid pp val pp_path : path pp (* -------------------------------------------------------------------- *) -val pp_typedecl : PPEnv.t -> (path * tydecl ) pp -val pp_opdecl : ?long:bool -> PPEnv.t -> (path * operator) pp -val pp_added_op : PPEnv.t -> operator pp -val pp_axiom : ?long:bool -> PPEnv.t -> (path * axiom ) pp -val pp_theory : PPEnv.t -> (path * ctheory ) pp -val pp_modtype1 : PPEnv.t -> module_type pp -val pp_modtype : PPEnv.t -> (module_type * mod_restr ) pp -val pp_modexp : PPEnv.t -> (mpath * module_expr ) pp -val pp_modsig : PPEnv.t -> (path * module_sig ) pp +val pp_typedecl : PPEnv.t -> (path * tydecl ) pp +val pp_opdecl : ?long:bool -> PPEnv.t -> (path * operator) pp +val pp_added_op : PPEnv.t -> operator pp +val pp_axiom : ?long:bool -> PPEnv.t -> (path * axiom ) pp +val pp_theory : PPEnv.t -> (path * ctheory ) pp +val pp_modtype1 : PPEnv.t -> module_type pp +val pp_modtype : PPEnv.t -> (module_type * mod_restr ) pp +val pp_modexp : PPEnv.t -> (mpath * module_expr ) pp +val pp_modsig : PPEnv.t -> (path * module_sig ) pp +val pp_typeclass : PPEnv.t -> typeclass pp (* -------------------------------------------------------------------- *) val pp_hoareS : PPEnv.t -> ?prpo:prpo_display -> hoareS pp diff --git a/src/ecScope.ml b/src/ecScope.ml index ea397142dc..5b3040d517 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1744,7 +1744,6 @@ module Ty = struct (* ------------------------------------------------------------------ *) let symbols_of_tc (_env : EcEnv.env) ty (tcp, tc) = - (* FIXME: TC: check that tcp.tc_args meets the reqs. of tc.tc_params *) let subst = { ty_subst_id with ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; ts_v = @@ -1775,12 +1774,10 @@ module Ty = struct tc.tc_prt |> oiter (fun prt -> let ue = EcUnify.UniEnv.create (Some typarams) in - try EcUnify.hastc (env scope) ue (snd ty) prt - with EcUnify.UnificationFailure _ -> + if not (EcUnify.hastc (env scope) ue (snd ty) prt) then hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) ); - let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in let symbols = check_tci_operators (env scope) ty tci.pti_ops tcsyms in diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 58c51d5f10..0284df4129 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -121,6 +121,7 @@ type tyerror = | FilterMatchFailure | LvMapOnNonAssign | TCArgsCountMismatch of qsymbol * ty_params * ty list +| CannotInferTC of ty * typeclass exception TyError of EcLocation.t * EcEnv.env * tyerror @@ -796,7 +797,10 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = (* FIXME: TC *) List.iter2 - (fun (_, tcs) ty -> EcUnify.hastcs env ue ty tcs) + (fun (_, tcs) ty -> + List.iter (fun tc -> + if not (EcUnify.hastc env ue ty tc) then + tyerror (loc tc_name) env (CannotInferTC (ty, tc))) tcs) decl.tc_tparams args; { tc_name = p; tc_args = args; } diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 7ad67d230d..e3c7787792 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -113,6 +113,7 @@ type tyerror = | FilterMatchFailure | LvMapOnNonAssign | TCArgsCountMismatch of qsymbol * ty_params * ty list +| CannotInferTC of ty * typeclass exception TymodCnvFailure of tymod_cnv_failure exception TyError of EcLocation.t * env * tyerror diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 81008fbfc7..7019cc1511 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -565,11 +565,16 @@ let unify_core env ue pb = let unify env ue t1 t2 = unify_core env ue (`TyUni (t1, t2)) -let hastc env ue ty tc = +let hastc_r env ue ty tc = unify_core env ue (`Other (`TcCtt (ty, tc))) -let hastcs env ue ty tcs = - List.iter (hastc env ue ty) tcs +let hastcs_r env ue ty tcs = + List.iter (hastc_r env ue ty) tcs + +(* -------------------------------------------------------------------- *) +let hastc env ue ty tc = + try hastc_r env ue ty tc; true + with UnificationFailure _ -> false (* -------------------------------------------------------------------- *) let tfun_expected ue psig = @@ -619,14 +624,14 @@ let select_op ?(hidden = false) ?(filter = fun _ -> true) tvi env name ue psig = | Some (TVIunamed lt) -> List.iter2 - (fun ty (_, tc) -> hastcs env subue ty tc) + (fun ty (_, tc) -> hastcs_r env subue ty tc) lt op.D.op_tparams | Some (TVInamed ls) -> let tparams = List.map (fst_map EcIdent.name) op.D.op_tparams in let tparams = Msym.of_list tparams in List.iter (fun (x, ty) -> - hastcs env subue ty (oget (Msym.find_opt x tparams))) + hastcs_r env subue ty (oget (Msym.find_opt x tparams))) ls with UnificationFailure _ -> raise E.Failure diff --git a/src/ecUnify.mli b/src/ecUnify.mli index eb420cd889..634d807ed3 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -43,8 +43,7 @@ end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val hastc : EcEnv.env -> unienv -> ty -> typeclass -> unit -val hastcs : EcEnv.env -> unienv -> ty -> typeclass list -> unit +val hastc : EcEnv.env -> unienv -> ty -> typeclass -> bool val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index a5a928a002..9f698d2af1 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -365,11 +365,13 @@ end = struct | LvMapOnNonAssign -> msg "map-style left-value cannot be used with assignments" - | TCArgsCountMismatch (sc, typarams, tys) -> - msg "different number of typeclass type parameters and arguments provided in %a:@\n - %a @\n - %a" - pp_qsymbol sc - (EcPrinting.pp_list "@, " (fun fmt (id, _) -> pp_symbol fmt (EcIdent.name id))) typarams - (EcPrinting.pp_list "@, " pp_type) tys + | TCArgsCountMismatch (_, typarams, tys) -> + msg "typeclass expects %d arguments, got %d" + (List.length typarams) (List.length tys) + + | CannotInferTC (ty, tc) -> + msg "cannot infer typeclass `%a' for type `%a'" + (EcPrinting.pp_typeclass env) tc pp_type ty let pp_restr_error env fmt (w, e) = let ppe = EcPrinting.PPEnv.ofenv env in From 674e283049bb84fbd470d1a0ff49cfa53e97f0ba Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Nov 2021 17:13:42 +0100 Subject: [PATCH 023/113] TC: fix parsing --- src/ecParser.mly | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index 690dd0c1fc..0be75915f1 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1606,9 +1606,8 @@ signature_item: | lc=loc(locality) { locality_as_local lc } tcparam: -| x=lqident { (x, []) } -| ty=loc(simpl_type_exp) x=lqident { (x, [ty]) } -| tys=paren(plist1(loc(type_exp), COMMA)) x=lqident { (x, tys) } +| tys=ioption(type_args) x=lqident + { (x, odfl [] tys) } typaram: | x=tident { (x, []) } From 2ce431bd575b9804f0ef48b2f3fcb92d4da87e90 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Nov 2021 17:22:01 +0100 Subject: [PATCH 024/113] better formatting of error msgs --- src/ecScope.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 5b3040d517..f6f878e6c9 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1574,7 +1574,10 @@ module Ty = struct | Some (loc, (p, opty)) -> if not (EcReduction.EqTest.for_type env ty opty) then begin let ppe = EcPrinting.PPEnv.ofenv env in - hierror ~loc "invalid type for operator `%s': %a / %a" + hierror ~loc +"invalid type for operator `%s':@\n\ +\ - expected: %a@\n\ +\ - got : %a" x (EcPrinting.pp_type ppe) ty (EcPrinting.pp_type ppe) opty end; Mstr.add x p m) reqs Mstr.empty From 8fd25e45c934e6e90521dffbc306de070296968c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Nov 2021 17:23:33 +0100 Subject: [PATCH 025/113] --- examples/typeclass.ec | 110 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 110 insertions(+) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 4353580d01..4f9b462078 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -126,6 +126,115 @@ typeclass witness = { instance ['a] 'a <: witness = { }. +require import AllCore. + +type class tc = {}. + +type class ['a <: tc] foo = { + op bar : 'a -> foo -> bool + axiom barL : forall x f, bar x f +}. + +op mybar (x : bool) (b : bool) = false. + +instance tc with int. + +type ('a, 'b) t = 'a * 'b. + +type u = (bool, int) t. + +instance int foo with bool + op bar = mybar. + +(* +type class foo = {}. + +type class tc = { + op foo : tc -> bool + + axiom foo_lemma : forall x, foo x +}. + +op foo_int (x : int) = true. + +instance tc with int + op foo = foo_int. + +realize foo_lemma. +proof. done. qed. + +type class ['a <: foo] tc2 <: tc = { + op bar : tc2 -> bool + + axiom bar_lemma : forall x, foo x => !bar x +}. + +op bar_int (x : int) = false. + +instance foo with bool. + +instance bool tc2 with int + op bar = bar_int. (* BUG *) + +realize bar_lemma. +proof. done. qed. + +op foo_2 ['a <: foo, 'b <: 'a tc2] = 0. +*) + + +type class tc = {}. +type class tc2 <: tc = {}. + +(* instance tc with int (* as tc_int *). *) +(* instance tc2 with int (* as tc2_int *). *) + +(* instance tc with ['a <: tc2] 'a. (* as myinstance. *)*) + +op foo ['a <: tc] = 0. + +op bar ['a <: tc2] = foo<:'a>. + +lemma addrC ['a <: group] : associative (+)<:'a>. + +forall x y : int, x + y = y + x. + +(+)<:'a> ~ Int.(+) + +(+)<:int_group> -> Int.(+) + +rewrite addrC. +apply addrC. + +op foo ['a <: tc2] = 0. + +tc_int +parent(tc2_int) --> tc_int + +tc2_int -> mysinstance + +op bar = foo<: int[tc2 -> myinstance]>. + + +(* +*) + + +instance tc with int. + +op bar = foo<:int>. + +type t <: tc, tc2. + +op bar2 = foo<:t>. + +type t <: foo. + +type class ['a <: tc2] bar = {}. + +op foo ['a <: foo, 'b <: 'a bar] : 'a -> 'b -> int. + + (* -------------------------------------------------------------------- *) 1. typage -> selection des operateurs / inference des instances de tc @@ -200,3 +309,4 @@ instance ['a] 'a <: witness = { c. ne pas envoyer certaines instances (e.g. int est un groupe) -> instance [nosmt] e.g. + From dd3f68eb6749dda297acbe46df49d30d0d7a4f2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Wed, 17 Nov 2021 20:11:57 +0100 Subject: [PATCH 026/113] Cleaned up examples/typeclass.ec --- examples/typeclass.ec | 320 +++++++++++++++++++++++++----------------- 1 file changed, 190 insertions(+), 130 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 4f9b462078..f8f8f55103 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -1,25 +1,70 @@ -(* -------------------------------------------------------------------- *) +(* =====================================================================*) require import AllCore List. + +(* ==================================================================== *) +(* Typeclass examples *) + +(* -------------------------------------------------------------------- *) +(* Set theory *) + type class finite = { op enum : finite list axiom enumP : forall (x : finite), x \in enum }. -type class foo <: finite = { +type class countable = { + op count : int -> countable + axiom countP : forall (x : countable), exists (n : int), x = count n +}. + +(* -------------------------------------------------------------------- *) +(* Simple algebraic structures *) + +type class magma = { + op mmul : magma -> magma -> magma +}. + +(* TODO: no explicit error message, and why is this not working but ring is? *) +(* +type class semigroup <: magma = { + axiom maddA : associative mmul +}. + +type class monoid <: semigroup = { + op mid : monoid + + axiom mmulr0 : left_id mid mmul + axiom mmul0r : right_id mid mmul +}. + +type class group <: monoid = { + op minv : group -> group + + axiom mmulN : left_inverse mid minv mmul }. -type class monoid = { - op mzero : monoid - op madd : monoid -> monoid -> monoid +type class ['a <: group] action = { + op amul : 'a -> action -> action + + axiom identity : + forall (x : action), amul mid x = x + axiom compatibility : + forall (g h : 'a) (x : action), amul (mmul g h) x = amul g (amul h x) }. +*) -(* instance monoid with int ... *) +(* TODO: make one of these work, and then finish the hierarchy here: + https://en.wikipedia.org/wiki/Magma_(algebra) *) +(* type fingroup <: group & finite. *) +(* type fingroup <: group & finite = {}. *) +(* type class fingroup = group & finite. *) -type class group = { - op zero : group - op ([-]) : group -> group - op ( + ) : group -> group -> group +(* TODO: we may want to rename mmul to ( + ) and build this from group *) +type class comgroup = { + op zero : comgroup + op ([-]) : comgroup -> comgroup + op ( + ) : comgroup -> comgroup -> comgroup axiom addr0 : left_id zero (+) axiom addrN : left_inverse zero ([-]) (+) @@ -27,11 +72,12 @@ type class group = { axiom addrA : associative (+) }. -(* instance ['a <: group] monoid with 'a ... *) +(* -------------------------------------------------------------------- *) +(* Advanced algebraic structures *) -type class ring <: group = { - op one : ring - op ( * ) : ring -> ring -> ring +type class comring <: comgroup = { + op one : comring + op ( * ) : comring -> comring -> comring axiom mulr1 : left_id one ( * ) axiom mulrC : commutative ( * ) @@ -39,114 +85,179 @@ type class ring <: group = { axiom mulrDl : left_distributive ( * ) ( + ) }. -(* instance group with int ... *) - -type class ['a <: ring] module_ <: group = { - op ( ** ) : 'a -> module_ -> module_ +type class ['a <: comring] commodule <: comgroup = { + op ( ** ) : 'a -> commodule -> commodule - axiom scalerDl : forall (a b : 'a) (x : module_), + axiom scalerDl : forall (a b : 'a) (x : commodule), (a + b) ** x = a ** x + b ** x - - axiom scalerDr : forall (a : 'a) (x y : module_), + axiom scalerDr : forall (a : 'a) (x y : commodule), a ** (x + y) = a ** x + a ** y }. -print ( ** ). -(* -type class A = ... -type class B1 <: A -type class B2 <: A -type class C <: B1 & B2 +(* ==================================================================== *) +(* Operator examples *) -op ['a <: B1 & B2] +(* -------------------------------------------------------------------- *) +(* Set theory *) -int -> group -> monoid -int -> monoid -*) +op all_finite ['a <: finite] (p : 'a -> bool) = + all p enum<:'a>. + +op all_countable ['a <: countable] (p : 'a -> bool) = + forall (n : int), p (count<:'a> n). -type 'a poly = 'a list. -op foo ['a <: group] (x y : 'a) = x + y. +(* ==================================================================== *) +(* Lemma examples *) -lemma add0r ['a <: group] : right_id<:'a, 'a> zero (+). +(* -------------------------------------------------------------------- *) +(* Set theory *) + +(* TODO: why is the rewrite/all_finite needed? *) +lemma all_finiteP ['a <: finite] p : (all_finite p) <=> (forall (x : 'a), p x). +proof. by rewrite/all_finite allP; split => Hp x; rewrite Hp // enumP. qed. + +lemma all_countableP ['a <: countable] p : (all_countable p) <=> (forall (x : 'a), p x). proof. - (* Works for bad reasons *) - by move=> x /=; rewrite addrC addr0. + rewrite/all_countable; split => [Hp x|Hp n]. + by case (countP x) => n ->>; rewrite Hp. + by rewrite Hp. qed. -(* type fingroup <: group & finite. *) +lemma all_finite_countable ['a <: finite & countable] (p : 'a -> bool) : (all_finite p) <=> (all_countable p). +proof. by rewrite all_finiteP all_countableP. qed. -(* type class fingroup = group & finite *) +(* ==================================================================== *) +(* Instance examples *) (* -------------------------------------------------------------------- *) -op bool_enum = [true; false]. +(* Set theory *) -(* instance foo with bool. *) +op bool_enum = [true; false]. +(* TODO: we want to be ale to give the list directly.*) instance finite with bool op enum = bool_enum. realize enumP. proof. by case. qed. - -op all ['a <: finite] (p : 'a -> bool) = - all p enum<:'a>. - (* -------------------------------------------------------------------- *) +(* Simple algebraic structures *) + op izero = 0. -instance group with int +instance comgroup with int op zero = izero op (+) = CoreInt.add op ([-]) = CoreInt.opp. -(*TODO: what does Alt-Ergo have to do with this?*) -realize addr0 by []. -realize addrN by []. -realize addrC by []. -realize addrA by []. +realize addr0 by trivial. +realize addrN by trivial. +(* TODO: what? *) +(* +realize addrC by apply addrC. +realize addrC by apply Ring.IntID.addrC. +*) +realize addrC by rewrite addrC. +realize addrA by rewrite addrA. -op polyZ ['a <: ring] (c : 'a) (p : 'a poly) : 'a poly. +(* -------------------------------------------------------------------- *) +(* Advanced algebraic structures *) + +op ione = 1. + +(* TODO: this automatically fetches the only instance of comgroup we have defined for int. + We should give the choice of which instance to use, by adding as desired_name after the with. + Also we should give the choice to define directly an instance of comring with int. *) +instance comring with int + op one = ione + op ( * ) = CoreInt.mul. + +realize mulr1 by trivial. +realize mulrC by rewrite mulrC. +realize mulrA by rewrite mulrA. +realize mulrDl. + print mulrDl. + (* TODO: what? *) + admit. +qed. -instance 'b module_ with ['b <: ring] 'b poly - op ( ** ) = polyZ<:'b>. +type 'a poly = 'a list. -instance ['a <: group & ...] 'a <: ... = { -} +op pzero ['a] : 'a poly = []. +op padd ['a <: comgroup] p q = + mkseq (fun n => (nth zero<:'a> p n) + (nth zero<:'a> q n)) (max (size p) (size q)). +op pinv ['a <: comgroup] = map [-]<:'a>. +op pone ['a <: comring] = [one <:'a>]. +op pmul ['a <: comring] : 'a poly -> 'a poly -> 'a poly. +op ipmul ['a <: comring] (x : 'a) = map (( * ) x). + +(* TODO: we may not need to specify the <:'a>. *) +instance comgroup with ['a <: comring] 'a poly + op zero = pzero<:'a> + op (+) = padd<:'a> + op ([-]) = pinv<:'a>. + +realize addr0. +proof. + (* TODO: error message. *) + move => x (*y*). + (* TODO: error message. *) + (*rewrite //.*) + (* TODO: wow I just broke something. *) + (* rewrite /padd /pzero. *) + admit. +qed. -instance ['a <: group] 'a <: monoid = { -}. +realize addrN. +proof. + (* TODO: all truly is broken. *) + (*rewrite /pzero /padd.*) + admit. +qed. -typeclass witness = { - op witness : witness; -}. +realize addrC by admit. +realize addrA by admit. -instance ['a] 'a <: witness = { -}. +instance comring with ['a <: comring] 'a poly + op one = pone<:'a> + op ( * ) = pmul<:'a>. -require import AllCore. +realize mulr1 by admit. +realize mulrC by admit. +realize mulrA by admit. +realize mulrDl by admit. -type class tc = {}. +instance 'a commodule with ['a <: comring] 'a poly + op ( ** ) = ipmul<:'a>. -type class ['a <: tc] foo = { - op bar : 'a -> foo -> bool - axiom barL : forall x f, bar x f -}. +realize scalerDl by admit. +realize scalerDr by admit. -op mybar (x : bool) (b : bool) = false. -instance tc with int. -type ('a, 'b) t = 'a * 'b. -type u = (bool, int) t. -instance int foo with bool - op bar = mybar. -(* +(* ==================================================================== *) +(* Misc *) + +(* -------------------------------------------------------------------- *) +(* TODO: which instance is kept in memory after this? *) + +op bool_enum_alt = [true; false]. + +instance finite with bool + op enum = bool_enum_alt. + +realize enumP. +proof. by case. qed. + +(* -------------------------------------------------------------------- *) +(* TODO: some old bug that maybe already is fixed? *) + type class foo = {}. type class tc = { @@ -171,6 +282,7 @@ type class ['a <: foo] tc2 <: tc = { op bar_int (x : int) = false. +instance foo with bool. instance foo with bool. instance bool tc2 with int @@ -180,71 +292,19 @@ realize bar_lemma. proof. done. qed. op foo_2 ['a <: foo, 'b <: 'a tc2] = 0. -*) - - -type class tc = {}. -type class tc2 <: tc = {}. - -(* instance tc with int (* as tc_int *). *) -(* instance tc2 with int (* as tc2_int *). *) - -(* instance tc with ['a <: tc2] 'a. (* as myinstance. *)*) - -op foo ['a <: tc] = 0. -op bar ['a <: tc2] = foo<:'a>. -lemma addrC ['a <: group] : associative (+)<:'a>. - -forall x y : int, x + y = y + x. - -(+)<:'a> ~ Int.(+) - -(+)<:int_group> -> Int.(+) - -rewrite addrC. -apply addrC. - -op foo ['a <: tc2] = 0. - -tc_int -parent(tc2_int) --> tc_int - -tc2_int -> mysinstance - -op bar = foo<: int[tc2 -> myinstance]>. +(* ==================================================================== *) +(* Old TODO list *) (* -*) - - -instance tc with int. - -op bar = foo<:int>. - -type t <: tc, tc2. - -op bar2 = foo<:t>. - -type t <: foo. - -type class ['a <: tc2] bar = {}. - -op foo ['a <: foo, 'b <: 'a bar] : 'a -> 'b -> int. - - -(* -------------------------------------------------------------------- *) - 1. typage -> selection des operateurs / inference des instances de tc 2. reduction 3. unification (tactiques) 4. clonage 5. envoi au SMT - 0. Define or find tcname - 1. Fop : -(old) path * ty list -> form @@ -309,4 +369,4 @@ op foo ['a <: foo, 'b <: 'a bar] : 'a -> 'b -> int. c. ne pas envoyer certaines instances (e.g. int est un groupe) -> instance [nosmt] e.g. - +*) From 1d6dc3d2b57115f4783c1150888fc73fe9cc02f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Fri, 19 Nov 2021 12:03:34 +0100 Subject: [PATCH 027/113] Bugs found --- examples/typeclass.ec | 43 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 35 insertions(+), 8 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index f8f8f55103..a051b64d4e 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -25,23 +25,32 @@ type class magma = { op mmul : magma -> magma -> magma }. -(* TODO: no explicit error message, and why is this not working but ring is? *) -(* +(* TODO: when removing the type argument of associative, no explicit error message. + Should work anyway and if not, have a readable error message.*) type class semigroup <: magma = { - axiom maddA : associative mmul + axiom mmulA : associative<:semigroup> mmul }. +(* TODO: why do I need this instead of using left_id and right_id directly? + Or even specifying the type? + Or even specifying semigroup and not magma? *) +pred left_id_mmul ['a <: semigroup] (e : 'a) = left_id e mmul. +pred right_id_mmul ['a <: semigroup] (e : 'a) = right_id e mmul. + type class monoid <: semigroup = { op mid : monoid - axiom mmulr0 : left_id mid mmul - axiom mmul0r : right_id mid mmul + axiom mmulr0 : left_id_mmul mid + axiom mmul0r : right_id_mmul mid }. +(* TODO: same. *) +pred left_inverse_mid_mmul ['a <: monoid] (inv : 'a -> 'a) = left_inverse mid inv mmul. + type class group <: monoid = { op minv : group -> group - axiom mmulN : left_inverse mid minv mmul + axiom mmulN : left_inverse_mid_mmul minv }. type class ['a <: group] action = { @@ -52,7 +61,6 @@ type class ['a <: group] action = { axiom compatibility : forall (g h : 'a) (x : action), amul (mmul g h) x = amul g (amul h x) }. -*) (* TODO: make one of these work, and then finish the hierarchy here: https://en.wikipedia.org/wiki/Magma_(algebra) *) @@ -75,6 +83,9 @@ type class comgroup = { (* -------------------------------------------------------------------- *) (* Advanced algebraic structures *) +(*TODO: we don't have here the issues we had with semigroup and monoid, + probably because left_distributive was adequatly typed by ( * ) + before beign applied to ( + ). *) type class comring <: comgroup = { op one : comring op ( * ) : comring -> comring -> comring @@ -179,7 +190,11 @@ realize mulr1 by trivial. realize mulrC by rewrite mulrC. realize mulrA by rewrite mulrA. realize mulrDl. +proof. print mulrDl. + move => x y z. + move: (Ring.IntID.mulrDl x y z). + move => HmulrDl. (* TODO: what? *) admit. qed. @@ -204,6 +219,7 @@ realize addr0. proof. (* TODO: error message. *) move => x (*y*). + (* Top.Logic turned into top... *) (* TODO: error message. *) (*rewrite //.*) (* TODO: wow I just broke something. *) @@ -255,6 +271,17 @@ instance finite with bool realize enumP. proof. by case. qed. +type class find_out <: finite = { + axiom rev_enum : rev<:find_out> enum = enum +}. + +instance find_out with bool. + +realize rev_enum. +proof. + admit. +qed. + (* -------------------------------------------------------------------- *) (* TODO: some old bug that maybe already is fixed? *) @@ -296,7 +323,7 @@ op foo_2 ['a <: foo, 'b <: 'a tc2] = 0. (* ==================================================================== *) -(* Old TODO list *) +(* Old TODO list: 1-3 are done, modulo bugs, 4 is to be done, 5 will be done later. *) (* 1. typage -> selection des operateurs / inference des instances de tc From 54bb1fc896f432b195d17689d32502952fc11b51 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 19 Nov 2021 16:50:50 +0100 Subject: [PATCH 028/113] WIP --- examples/typeclass.ec | 18 +++---- src/ecCoreFol.ml | 6 +-- src/ecEnv.ml | 10 ++-- src/ecParser.mly | 2 +- src/ecScope.ml | 14 +++-- src/ecSubst.ml | 119 ++++++++++++++++++++---------------------- src/ecTypes.ml | 22 ++++---- src/ecTypes.mli | 4 +- src/ecUnify.ml | 45 ++++++++++++++-- 9 files changed, 138 insertions(+), 102 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index a051b64d4e..ef1671a630 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -64,18 +64,16 @@ type class ['a <: group] action = { (* TODO: make one of these work, and then finish the hierarchy here: https://en.wikipedia.org/wiki/Magma_(algebra) *) -(* type fingroup <: group & finite. *) -(* type fingroup <: group & finite = {}. *) -(* type class fingroup = group & finite. *) +type fingroup <: group & finite. (* TODO: we may want to rename mmul to ( + ) and build this from group *) type class comgroup = { - op zero : comgroup + op gzero : comgroup op ([-]) : comgroup -> comgroup op ( + ) : comgroup -> comgroup -> comgroup - axiom addr0 : left_id zero (+) - axiom addrN : left_inverse zero ([-]) (+) + axiom addr0 : left_id gzero (+) + axiom addrN : left_inverse gzero ([-]) (+) axiom addrC : commutative (+) axiom addrA : associative (+) }. @@ -160,10 +158,12 @@ proof. by case. qed. op izero = 0. instance comgroup with int - op zero = izero + op gzero = izero op (+) = CoreInt.add op ([-]) = CoreInt.opp. +locate addr0. + realize addr0 by trivial. realize addrN by trivial. (* TODO: what? *) @@ -171,8 +171,8 @@ realize addrN by trivial. realize addrC by apply addrC. realize addrC by apply Ring.IntID.addrC. *) -realize addrC by rewrite addrC. -realize addrA by rewrite addrA. +realize addrC by admit. +realize addrA by admit. (* -------------------------------------------------------------------- *) (* Advanced algebraic structures *) diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 5957d891cb..906963a193 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -1646,7 +1646,7 @@ module Fsubst = struct let e = let sty = Tvar.init tyids tys in - let sty = ty_subst { ty_subst_id with ts_v = Mid.find_opt^~ sty; } in + let sty = ty_subst { ty_subst_id with ts_v = sty; } in let sty = { e_subst_id with es_freshen = freshen; es_ty = sty ; } in e_subst sty e in @@ -1671,7 +1671,7 @@ module Fsubst = struct let f = let sty = Tvar.init tyids tys in - let sty = ty_subst { ty_subst_id with ts_v = Mid.find_opt^~ sty; } in + let sty = ty_subst { ty_subst_id with ts_v = sty; } in let sty = { f_subst_id with fs_freshen = true; fs_ty = sty; } in f_subst ~tx sty f in @@ -1732,7 +1732,7 @@ module Fsubst = struct (* ------------------------------------------------------------------ *) let init_subst_tvar s = - let sty = { ty_subst_id with ts_v = Mid.find_opt^~ s } in + let sty = { ty_subst_id with ts_v = s } in { f_subst_id with fs_freshen = true; fs_sty = sty; fs_ty = ty_subst sty } diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 217ca45067..e20120faf2 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -1564,13 +1564,15 @@ module Ty = struct match ty.tyd_type with | `Abstract tcs -> + (* FIXME: TC: refresh? *) let myty = - let myp = EcPath.pqname (root env) name in - let typ = List.map (fst_map EcIdent.fresh) ty.tyd_params in - (typ, EcTypes.tconstr myp (List.map (tvar |- fst) typ)) in + let myp = EcPath.pqname (root env) name in + let myty = EcTypes.tconstr myp (List.map (tvar |- fst) ty.tyd_params) in + (ty.tyd_params, myty) in let env_tci = List.fold - (fun inst (tc : typeclass) -> TypeClass.bind_instance myty (`General tc) inst) + (fun inst (tc : typeclass) -> + TypeClass.bind_instance myty (`General tc) inst) env.env_tci tcs in { env with env_tci } diff --git a/src/ecParser.mly b/src/ecParser.mly index 271e7cbdb7..25de0ab0a4 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1639,7 +1639,7 @@ typedecl: | locality=locality TYPE td=rlist1(tyd_name, COMMA) { List.map (fun x -> mk_tydecl ~locality x (PTYD_Abstract [])) td } -| locality=locality TYPE td=tyd_name LTCOLON tcs=rlist1(tcparam, COMMA) +| locality=locality TYPE td=tyd_name LTCOLON tcs=rlist1(tcparam, AMP) { [mk_tydecl ~locality td (PTYD_Abstract tcs)] } | locality=locality TYPE td=tyd_name EQ te=loc(type_exp) diff --git a/src/ecScope.ml b/src/ecScope.ml index 6a11f7136e..efdd09c91e 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1435,9 +1435,15 @@ module Ty = struct | PTYD_Abstract tcs -> let ue = TT.transtyvars env (loc, Some args) in let tcs = List.map (TT.transtc env ue) tcs in - EcUnify.UniEnv.tparams ue, `Abstract tcs + let tp = EcUnify.UniEnv.tparams ue in - | PTYD_Alias bd -> + begin match tp, tcs with + | [(x, [])], [{ tc_args = [ty] }] -> + Format.eprintf "[W]%s %s@." (EcIdent.tostring x) (EcTypes.dump_ty ty) + | _ -> () end; + tp, `Abstract tcs + + | PTYD_Alias bd -> let ue = TT.transtyvars env (loc, Some args) in let body = transty tp_tydecl env ue bd in EcUnify.UniEnv.tparams ue, `Concrete body @@ -1751,7 +1757,7 @@ module Ty = struct ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; ts_v = let vsubst = List.combine (List.fst tc.tc_tparams) tcp.tc_args in - Mid.find_opt^~ (Mid.of_list vsubst); + Mid.of_list vsubst; } in List.map (fun (x, opty) -> (EcIdent.name x, (true, ty_subst subst opty))) @@ -1790,7 +1796,7 @@ module Ty = struct ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; ts_v = let vsubst = List.combine (List.fst tc.tc_tparams) tcp.tc_args in - Mid.find_opt^~ (Mid.of_list vsubst); + Mid.of_list vsubst; } in let subst = diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 240fbcfcc7..6e643e8b89 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -282,72 +282,65 @@ let subst_top_module (s : _subst) (m : top_module_expr) = { tme_expr = subst_module s m.tme_expr; tme_loca = m.tme_loca; } -(* -------------------------------------------------------------------- *) -let add_tparams (s : _subst) (params : ty_params) tys = - match params with - | [] -> assert (tys = []); s - | _ -> - let styv = - List.fold_left2 (fun m (p, _) ty -> Mid.add p ty m) - Mid.empty params tys in - let sty = - { ty_subst_id with - ts_def = s.s_sty.ts_def; - ts_p = s.s_p; - ts_mp = s.s_fmp; - ts_v = Mid.find_opt^~ styv; } - in - { s with s_sty = sty; s_ty = EcTypes.ty_subst sty } - -let init_tparams (s : _subst) (params : ty_params) (params' : ty_params) = - add_tparams s params (List.map (fun (p', _) -> tvar p') params') - (* -------------------------------------------------------------------- *) let subst_typeclass s tc = { tc_name = s.s_p tc.tc_name; - tc_args = List.map s.s_ty tc.tc_args; } + tc_args = List.map (EcTypes.ty_subst s.s_sty) tc.tc_args; } (* -------------------------------------------------------------------- *) -let subst_typaram (s : _subst) ((id, tc) : ty_param) : ty_param = - (EcIdent.fresh id, List.map (subst_typeclass s) tc) +let fresh_tparam (s : _subst) ((x, tcs) : ty_param) = + let newx = EcIdent.fresh x in + let sty = { s.s_sty with ts_v = Mid.add x (tvar newx) s.s_sty.ts_v } in + let s = { s with s_sty = sty; s_ty = EcTypes.ty_subst sty } in + let tcs = List.map (subst_typeclass s) tcs in +(* + Format.eprintf + "[W]RENAME: %s -> %s@." + (EcIdent.tostring x) (EcIdent.tostring newx);*) + (s, (newx, tcs)) -let subst_typarams (s : _subst) (typ : ty_params) = - List.map (subst_typaram s) typ +(* -------------------------------------------------------------------- *) +let fresh_tparams (s : _subst) (tparams : ty_params) = + List.fold_left_map fresh_tparam s tparams (* -------------------------------------------------------------------- *) -let subst_genty (s : _subst) (typ, ty) = - let typ' = subst_typarams s typ in - let s = init_tparams s typ typ' in - (typ', s.s_ty ty) +let init_tparams (params : (EcIdent.t * ty) list) : _subst = + let s = _subst_of_subst (empty ()) in + let sty = { s.s_sty with ts_v = Mid.of_list params } in + { s with s_sty = sty; s_ty = EcTypes.ty_subst sty; } (* -------------------------------------------------------------------- *) -let open_tydecl (s : _subst) (tyd : tydecl) tys = - let sty = add_tparams s tyd.tyd_params tys in +let subst_genty (s : _subst) (tparams, ty) = + let s, tparams = fresh_tparams s tparams in + let ty = s.s_ty ty in + (tparams, ty) - match tyd.tyd_type with +(* -------------------------------------------------------------------- *) +let subst_tydecl_body (s : _subst) (tyd : ty_body) = + match tyd with | `Abstract tc -> `Abstract (List.map (subst_typeclass s) tc) | `Concrete ty -> - `Concrete (sty.s_ty ty) + `Concrete (s.s_ty ty) | `Datatype dtype -> let dtype = - { tydt_ctors = List.map (snd_map (List.map sty.s_ty)) dtype.tydt_ctors; - tydt_schelim = Fsubst.f_subst (f_subst_of_subst sty) dtype.tydt_schelim; - tydt_schcase = Fsubst.f_subst (f_subst_of_subst sty) dtype.tydt_schcase; } + { tydt_ctors = List.map (snd_map (List.map s.s_ty)) dtype.tydt_ctors; + tydt_schelim = Fsubst.f_subst (f_subst_of_subst s) dtype.tydt_schelim; + tydt_schcase = Fsubst.f_subst (f_subst_of_subst s) dtype.tydt_schcase; } in `Datatype dtype | `Record (scheme, fields) -> - `Record (Fsubst.f_subst (f_subst_of_subst sty) scheme, - List.map (snd_map sty.s_ty) fields) + `Record (Fsubst.f_subst (f_subst_of_subst s) scheme, + List.map (snd_map s.s_ty) fields) +(* -------------------------------------------------------------------- *) let subst_tydecl (s : _subst) (tyd : tydecl) = - let params' = List.map (subst_typaram s) tyd.tyd_params in - let tys = List.map (fun (id, _) -> tvar id) params' in - let body = open_tydecl s tyd tys in + let s, tparams = fresh_tparams s tyd.tyd_params in + let body = subst_tydecl_body s tyd.tyd_type in - { tyd_params = params'; + { tyd_params = tparams; tyd_type = body; tyd_resolve = tyd.tyd_resolve; tyd_loca = tyd.tyd_loca; } @@ -432,20 +425,15 @@ and subst_pr_body (s : _subst) (bd : prbody) = in PR_Ind { pri_args = args; pri_ctors = ctors; } -(* -------------------------------------------------------------------- *) -let open_oper (s:_subst) (op:operator) tys = - let sty = add_tparams s op.op_tparams tys in - let ty = sty.s_ty op.op_ty in - let kind = subst_op_kind sty op.op_kind in - ty, kind +(* -------------------------------------------------------------------- *) let subst_op (s : _subst) (op : operator) = - let tparams = List.map (subst_typaram s) op.op_tparams in - let tys = (List.map (fun (p', _) -> tvar p') tparams) in - let ty, kind = open_oper s op tys in + let s, tparams = fresh_tparams s op.op_tparams in + let opty = s.s_ty op.op_ty in + let kind = subst_op_kind s op.op_kind in { op_tparams = tparams ; - op_ty = ty ; + op_ty = opty ; op_kind = kind ; op_loca = op.op_loca ; op_opaque = op.op_opaque ; @@ -453,11 +441,10 @@ let subst_op (s : _subst) (op : operator) = (* -------------------------------------------------------------------- *) let subst_ax (s : _subst) (ax : axiom) = - let params = List.map (subst_typaram s) ax.ax_tparams in - let s = init_tparams s ax.ax_tparams params in - let spec = Fsubst.f_subst (f_subst_of_subst s) ax.ax_spec in + let s, tparams = fresh_tparams s ax.ax_tparams in + let spec = Fsubst.f_subst (f_subst_of_subst s) ax.ax_spec in - { ax_tparams = params; + { ax_tparams = tparams; ax_spec = spec; ax_kind = ax.ax_kind; ax_loca = ax.ax_loca; @@ -497,8 +484,8 @@ let subst_instance (s : _subst) tci = (* -------------------------------------------------------------------- *) let subst_tc (s : _subst) tc = + let s, tc_tparams = fresh_tparams s tc.tc_tparams in let tc_prt = omap (subst_typeclass s) tc.tc_prt in - let tc_tparams = List.map (subst_typaram s) tc.tc_tparams in let tc_ops = List.map (snd_map s.s_ty) tc.tc_ops in let tc_axs = List.map (snd_map (subst_form s)) tc.tc_axs in { tc_tparams; tc_prt; tc_ops; tc_axs; tc_loca = tc.tc_loca } @@ -596,12 +583,18 @@ let subst_genty s = fun t -> (subst_genty (_subst_of_subst s) t) let subst_instance s = subst_instance (_subst_of_subst s) -let open_oper = open_oper (_subst_of_subst (empty ())) -let open_tydecl = open_tydecl (_subst_of_subst (empty ())) +let open_oper op tys = + let s = List.combine (List.fst op.op_tparams) tys in + let s = init_tparams s in + (s.s_ty op.op_ty, subst_op_kind s op.op_kind) + +let open_tydecl tyd tys = + let s = List.combine (List.fst tyd.tyd_params) tys in + let s = init_tparams s in + subst_tydecl_body s tyd.tyd_type (* -------------------------------------------------------------------- *) -let freshen_type (typ, ty) = +let freshen_type (tparams, ty) = let empty = _subst_of_subst (empty ()) in - let typ' = List.map (subst_typaram empty) typ in - let s = init_tparams empty typ typ' in - (typ', s.s_ty ty) + let s, tparams = fresh_tparams empty tparams in + (tparams, s.s_ty ty) diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 61687f6d8f..6d409f6a12 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -260,21 +260,21 @@ type ty_subst = { ts_mp : EcPath.mpath -> EcPath.mpath; ts_def : (EcIdent.t list * ty) EcPath.Mp.t; ts_u : EcUid.uid -> ty option; - ts_v : EcIdent.t -> ty option; + ts_v : ty Mid.t; } let ty_subst_id = - { ts_p = identity; - ts_mp = identity; - ts_def = Mp.empty; - ts_u = funnone ; - ts_v = funnone ; } + { ts_p = identity ; + ts_mp = identity ; + ts_def = Mp.empty ; + ts_u = funnone ; + ts_v = Mid.empty; } let is_ty_subst_id s = s.ts_p == identity && s.ts_mp == identity && s.ts_u == funnone - && s.ts_v == funnone + && Mid.is_empty s.ts_v && Mp.is_empty s.ts_def let rec ty_subst s = @@ -284,7 +284,7 @@ let rec ty_subst s = match ty.ty_node with | Tglob m -> TySmart.tglob (ty, m) (s.ts_mp m) | Tunivar id -> odfl ty (s.ts_u id) - | Tvar id -> odfl ty (s.ts_v id) + | Tvar id -> Mid.find_def ty id s.ts_v | Ttuple lty -> TySmart.ttuple (ty, lty) (List.Smart.map aux lty) | Tfun (t1, t2) -> TySmart.tfun (ty, (t1, t2)) (aux t1, aux t2) @@ -300,7 +300,7 @@ let rec ty_subst s = try Mid.of_list (List.combine args (List.map aux lty)) with Failure _ -> assert false in - ty_subst { ty_subst_id with ts_v = Mid.find_opt^~ s; } body + ty_subst { ty_subst_id with ts_v = s; } body end) (* -------------------------------------------------------------------- *) @@ -346,7 +346,7 @@ end (* -------------------------------------------------------------------- *) module Tvar = struct let subst (s : ty Mid.t) = - ty_subst { ty_subst_id with ts_v = Mid.find_opt^~ s } + ty_subst { ty_subst_id with ts_v = s } let subst1 (id,t) = subst (Mid.singleton id t) @@ -1010,7 +1010,7 @@ and e_subst_op ~freshen ety tys args (tyids, e) = let e = let sty = Tvar.init tyids tys in - let sty = ty_subst { ty_subst_id with ts_v = Mid.find_opt^~ sty; } in + let sty = ty_subst { ty_subst_id with ts_v = sty; } in let sty = { e_subst_id with es_freshen = freshen; es_ty = sty } in diff --git a/src/ecTypes.mli b/src/ecTypes.mli index 20e5b6b566..cece6e700a 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -83,8 +83,8 @@ type ty_subst = { ts_p : EcPath.path -> EcPath.path; ts_mp : EcPath.mpath -> EcPath.mpath; ts_def : (EcIdent.t list * ty) EcPath.Mp.t; - ts_u : EcUid.uid -> ty option; - ts_v : EcIdent.t -> ty option; + ts_u : (uid -> ty option); + ts_v : ty Mid.t; } val ty_subst_id : ty_subst diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 7c46489ff6..2f75c8d23b 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -114,7 +114,7 @@ module UnifyGen(X : UnifyExtra) = struct (uf, tuni uid) (* ------------------------------------------------------------------ *) - let rec unify_core (env : EcEnv.env) (tvtc : X.state Mid.t) (uf : UF.t) pb = + let unify_core (env : EcEnv.env) (tvtc : X.state Mid.t) (uf : UF.t) pb = let failure () = raise (UnificationFailure pb) in let uf = ref uf in @@ -294,6 +294,14 @@ module TypeClass = struct instances in let instances = + let tvinst = + List.map + (fun (tv, tcs) -> + List.map (fun tc -> (([], tvar tv), tc)) tcs) + (Mid.bindings tvtc) + in List.flatten tvinst @ instances in + +(* let tvinst = List.map (fun (tv, tcs) -> @@ -316,19 +324,46 @@ module TypeClass = struct (Mid.bindings tvtc) in List.flatten (List.flatten tvinst) @ instances in +*) let exception Bailout in + let rec find_tc_in_parent acc tginst = + if EcPath.p_equal tc.tc_name tginst.tc_name then + Some (tginst.tc_args, List.rev acc) + else + let tcdecl = EcEnv.TypeClass.by_path tginst.tc_name env in + tcdecl.tc_prt |> obind (fun prt -> + let acc = (tcdecl.tc_tparams, tginst.tc_args) :: acc in + find_tc_in_parent acc prt) in + let for1 ((tgparams, tgty), tginst) = - if not (EcPath.p_equal tc.tc_name tginst.tc_name) then - raise Bailout; + let tgi_args, tgparams_prt = + oget ~exn:Bailout (find_tc_in_parent [] tginst) in let uf, tvinfo = List.fold_left_map (fun uf (tv, tcs) -> let uf, tvty = UnifyCore.fresh uf in uf, (tv, (tvty, tcs))) UnifyCore.UF.initial tgparams in - let uf, subst = ref uf, Mid.of_list (List.map (snd_map fst) tvinfo) in + + let subst = + Mid.of_list (List.map (snd_map fst) tvinfo) in + + let subst = + let tcsubst = + List.fold_left + (fun subst (tparams, args) -> + let args = List.map (Tvar.subst subst) args in + let subst = List.combine (List.fst tparams) args in + Mid.of_list subst) + subst tgparams_prt in + + Mid.fold + (fun x ty subst -> Mid.add x ty subst) + tcsubst subst in + + let uf, tgi_args = ref uf, List.map (Tvar.subst subst) tgi_args in List.iter2 (fun pty tgty -> @@ -337,7 +372,7 @@ module TypeClass = struct uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (pty, tgty)) with UnifyCore.UnificationFailure _ -> raise Bailout) - tc.tc_args tginst.tc_args; + tc.tc_args tgi_args; let tgty = Tvar.subst subst tgty in From 6b929c7862c27d37695956e536f38793a98bf143 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 19 Nov 2021 23:36:16 +0100 Subject: [PATCH 029/113] fix op types in typeclasses instances --- examples/typeclass.ec | 36 +++++++++++++++++++++++------------- src/ecPrinting.ml | 11 ++++++----- src/ecScope.ml | 6 +++--- src/ecUnify.mli | 2 +- 4 files changed, 33 insertions(+), 22 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index ef1671a630..0520953c71 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -69,13 +69,13 @@ type fingroup <: group & finite. (* TODO: we may want to rename mmul to ( + ) and build this from group *) type class comgroup = { op gzero : comgroup - op ([-]) : comgroup -> comgroup - op ( + ) : comgroup -> comgroup -> comgroup + op gopp : comgroup -> comgroup + op gadd : comgroup -> comgroup -> comgroup - axiom addr0 : left_id gzero (+) - axiom addrN : left_inverse gzero ([-]) (+) - axiom addrC : commutative (+) - axiom addrA : associative (+) + axiom addr0 : left_id gzero gadd + axiom addrN : left_inverse gzero gopp gadd + axiom addrC : commutative gadd + axiom addrA : associative gadd }. (* -------------------------------------------------------------------- *) @@ -91,16 +91,16 @@ type class comring <: comgroup = { axiom mulr1 : left_id one ( * ) axiom mulrC : commutative ( * ) axiom mulrA : associative ( * ) - axiom mulrDl : left_distributive ( * ) ( + ) + axiom mulrDl : left_distributive ( * ) gadd }. type class ['a <: comring] commodule <: comgroup = { op ( ** ) : 'a -> commodule -> commodule axiom scalerDl : forall (a b : 'a) (x : commodule), - (a + b) ** x = a ** x + b ** x + (gadd a b) ** x = gadd (a ** x) (b ** x) axiom scalerDr : forall (a : 'a) (x y : commodule), - a ** (x + y) = a ** x + a ** y + a ** (gadd x y) = gadd (a ** x) (a ** y) }. @@ -157,14 +157,24 @@ proof. by case. qed. op izero = 0. + instance comgroup with int op gzero = izero - op (+) = CoreInt.add - op ([-]) = CoreInt.opp. + op gadd = CoreInt.add + op gopp = CoreInt.opp. + +realize addr0. + +have : left_id izero Int.(+). + +locate left_id. -locate addr0. +rewrite /left_id. +rewrite /izero. +move=> x /=. +rewrite /izero. -realize addr0 by trivial. + by trivial. realize addrN by trivial. (* TODO: what? *) (* diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index bd0fcae2d0..1394305f13 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -849,7 +849,7 @@ let pp_opname_with_tvi ppe fmt (nm, op, tvi) = | Some tvi -> Format.fprintf fmt "%a<:%a>" pp_opname (nm, op) - (pp_list "@, " (pp_type ppe)) tvi + (pp_list ",@ " (pp_type ppe)) tvi let pp_opapp (ppe : PPEnv.t) @@ -918,12 +918,13 @@ let pp_opapp fun () -> match es with | [] -> - pp_opname fmt (nm, opname) + pp_opname_with_tvi ppe fmt (nm, opname, Some tvi) | _ -> - let pp_subs = ((fun _ _ -> pp_opname), pp_sub) in - let pp fmt () = pp_app ppe pp_subs outer fmt (([], opname), es) in - maybe_paren outer (inm, max_op_prec) pp fmt () + let pp_subs = ((fun ppe _ -> pp_opname_with_tvi ppe), pp_sub) in + let pp fmt () = + pp_app ppe pp_subs outer fmt (([], opname, Some tvi), es) + in maybe_paren outer (inm, max_op_prec) pp fmt () and try_pp_as_uniop () = match es with diff --git a/src/ecScope.ml b/src/ecScope.ml index a8994baf01..9daec82cd9 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1792,7 +1792,7 @@ module Ty = struct let tcsyms = Mstr.of_list tcsyms in let symbols = check_tci_operators (env scope) ty tci.pti_ops tcsyms in - let subst = { + let tysubst = { ty_subst_id with ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; ts_v = @@ -1804,9 +1804,9 @@ module Ty = struct List.fold_left (fun subst (opname, ty) -> let oppath = Mstr.find (EcIdent.name opname) symbols in - let op = EcFol.f_op oppath [] ty in + let op = EcFol.f_op oppath [] (ty_subst tysubst ty) in EcFol.Fsubst.f_bind_local subst opname op) - (EcFol.Fsubst.f_subst_init ~sty:subst ()) tc.tc_ops in + (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in let axioms = List.map diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 471a43a6a8..33fb453a09 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -51,7 +51,7 @@ type sbody = ((EcIdent.t * ty) list * expr) Lazy.t val select_op : ?hidden:bool - -> ?filter:(path -> operator -> bool) + -> ?filter:(EcPath.path -> operator -> bool) -> tvi -> EcEnv.env -> qsymbol From 6561b69dcc30a72b8a78c97019cfc46e4df655f0 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 19 Nov 2021 23:43:31 +0100 Subject: [PATCH 030/113] prune virtual tc --- examples/typeclass.ec | 2 +- src/ecUnify.ml | 32 +++++++------------------------- 2 files changed, 8 insertions(+), 26 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 0520953c71..ac9502e945 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -164,7 +164,7 @@ instance comgroup with int op gopp = CoreInt.opp. realize addr0. - +apply: addr0. have : left_id izero Int.(+). locate left_id. diff --git a/src/ecUnify.ml b/src/ecUnify.ml index f47f5054ee..977a335659 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -293,6 +293,13 @@ module TypeClass = struct (function (x, `General y) -> Some (x, y) | _ -> None) instances in + let instances = + (* FIXME:TC *) + let ring = EcPath.fromqsymbol ([EcCoreLib.i_top], "Ring") in + List.filter + (fun (_, tc) -> not (EcPath.isprefix ring tc.tc_name)) + instances in + let instances = let tvinst = List.map @@ -301,31 +308,6 @@ module TypeClass = struct (Mid.bindings tvtc) in List.flatten tvinst @ instances in -(* - let tvinst = - List.map - (fun (tv, tcs) -> - let rec parent_instances_of_tc acc tc = - let acc = (([], tvar tv), tc) :: acc in - let tcdecl = EcEnv.TypeClass.by_path tc.tc_name env in - - match tcdecl.tc_prt with - | None -> - List.rev acc - - | Some prt -> - let subst = List.combine (List.fst tcdecl.tc_tparams) tc.tc_args in - let subst = Tvar.subst (Mid.of_list subst) in - let prt = { prt with tc_args = List.map subst prt.tc_args } in - - parent_instances_of_tc acc prt - - in List.map (fun tc -> parent_instances_of_tc [] tc) tcs) - (Mid.bindings tvtc) - - in List.flatten (List.flatten tvinst) @ instances in -*) - let exception Bailout in let rec find_tc_in_parent acc tginst = From a1342af5d979cf4e1a89f788e88b715b6943451d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Sun, 21 Nov 2021 16:03:50 +0100 Subject: [PATCH 031/113] typeclass.ec comments --- examples/typeclass.ec | 51 ++++++------------------------------------- 1 file changed, 7 insertions(+), 44 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index a051b64d4e..39157c8215 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -26,22 +26,23 @@ type class magma = { }. (* TODO: when removing the type argument of associative, no explicit error message. - Should work anyway and if not, have a readable error message.*) + Any inherited operator should have self as type argument. + Type error slicing to do as well.*) type class semigroup <: magma = { - axiom mmulA : associative<:semigroup> mmul + axiom mmulA : associative mmul<:semigroup> }. (* TODO: why do I need this instead of using left_id and right_id directly? Or even specifying the type? Or even specifying semigroup and not magma? *) -pred left_id_mmul ['a <: semigroup] (e : 'a) = left_id e mmul. -pred right_id_mmul ['a <: semigroup] (e : 'a) = right_id e mmul. + +op mmul_ ['a <: semigroup] = mmul<:'a>. type class monoid <: semigroup = { op mid : monoid - axiom mmulr0 : left_id_mmul mid - axiom mmul0r : right_id_mmul mid + axiom mmulr0 : left_id<:monoid, monoid> mid mmul_<:monoid> + axiom mmul0r : right_id<:monoid, monoid> mid mmul_<:monoid> }. (* TODO: same. *) @@ -282,44 +283,6 @@ proof. admit. qed. -(* -------------------------------------------------------------------- *) -(* TODO: some old bug that maybe already is fixed? *) - -type class foo = {}. - -type class tc = { - op foo : tc -> bool - - axiom foo_lemma : forall x, foo x -}. - -op foo_int (x : int) = true. - -instance tc with int - op foo = foo_int. - -realize foo_lemma. -proof. done. qed. - -type class ['a <: foo] tc2 <: tc = { - op bar : tc2 -> bool - - axiom bar_lemma : forall x, foo x => !bar x -}. - -op bar_int (x : int) = false. - -instance foo with bool. -instance foo with bool. - -instance bool tc2 with int - op bar = bar_int. (* BUG *) - -realize bar_lemma. -proof. done. qed. - -op foo_2 ['a <: foo, 'b <: 'a tc2] = 0. - (* ==================================================================== *) From 7e9fa8bf10eea6ccda95a552d6adffdd736a0b34 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 21 Nov 2021 17:18:13 +0100 Subject: [PATCH 032/113] add tc witnesses info in operators --- src/#ecMatching.ml# | 1226 ----------------------------------------- src/ecCallbyValue.ml | 8 +- src/ecCoreEqTest.ml | 19 +- src/ecCoreEqTest.mli | 1 + src/ecCoreFol.ml | 117 ++-- src/ecCoreFol.mli | 10 +- src/ecEnv.ml | 4 +- src/ecEnv.mli | 2 +- src/ecFol.ml | 2 +- src/ecFol.mli | 2 +- src/ecHiGoal.ml | 6 +- src/ecLowGoal.ml | 14 +- src/ecMatching.ml | 2 + src/ecPV.ml | 4 +- src/ecPrinting.ml | 6 +- src/ecReduction.ml | 36 +- src/ecReduction.mli | 19 +- src/ecSection.ml | 32 +- src/ecSmt.ml | 1 + src/ecTheory.ml | 2 +- src/ecTheory.mli | 2 +- src/ecTheoryReplay.ml | 4 +- src/ecTypes.ml | 141 +++-- src/ecTypes.mli | 25 +- src/ecTyping.ml | 4 +- src/ecUtils.ml | 6 + src/ecUtils.mli | 5 + src/phl/ecPhlWhile.ml | 2 +- 28 files changed, 328 insertions(+), 1374 deletions(-) delete mode 100644 src/#ecMatching.ml# diff --git a/src/#ecMatching.ml# b/src/#ecMatching.ml# deleted file mode 100644 index 6b33564d8a..0000000000 --- a/src/#ecMatching.ml# +++ /dev/null @@ -1,1226 +0,0 @@ -(* -------------------------------------------------------------------- - * Copyright (c) - 2012--2016 - IMDEA Software Institute - * Copyright (c) - 2012--2018 - Inria - * Copyright (c) - 2012--2018 - Ecole Polytechnique - * - * Distributed under the terms of the CeCILL-C-V1 license - * -------------------------------------------------------------------- *) - -(* -------------------------------------------------------------------- *) -(* Expressions / formulas matching for tactics *) -(* -------------------------------------------------------------------- *) - -(* -------------------------------------------------------------------- *) -open EcUtils -open EcMaps -open EcIdent -open EcParsetree -open EcEnv -open EcTypes -open EcModules -open EcFol -open EcGenRegexp - -(* -------------------------------------------------------------------- *) -module Zipper = struct - exception InvalidCPos - - module P = EcPath - - type ('a, 'state) folder = - 'a -> 'state -> instr -> 'state * instr list - - type ipath = - | ZTop - | ZWhile of expr * spath - | ZIfThen of expr * spath * stmt - | ZIfElse of expr * stmt * spath - - and spath = (instr list * instr list) * ipath - - type zipper = { - z_head : instr list; (* instructions on my left (rev) *) - z_tail : instr list; (* instructions on my right (me incl.) *) - z_path : ipath; (* path (zipper) leading to me *) - } - - let cpos (i : int) : codepos1 = (0, `ByPos i) - - let zipper hd tl zpr = { z_head = hd; z_tail = tl; z_path = zpr; } - - let find_by_cp_match ((i, cm) : int option * cp_match) (s : stmt) = - let rec progress (acc : instr list) (s : instr list) (i : int) = - if i <= 0 then - let shd = oget (List.Exceptionless.hd acc) in - let stl = oget (List.Exceptionless.tl acc) in - (stl, shd, s) - else - - let ir, s = - match s with [] -> raise InvalidCPos | ir :: s -> (ir, s) - in - - let i = - match ir.i_node, cm with - | Swhile _, `While -> i-1 - | Sif _, `If -> i-1 - | Sasgn _, `Assign -> i-1 - | Srnd _, `Sample -> i-1 - | Scall _, `Call -> i-1 - | _ , _ -> i - - in progress (ir :: acc) s i - - in - - let i = odfl 1 i in if i = 0 then raise InvalidCPos; - let rev, i = (i < 0), abs i in - - let s1, ir, s2 = - progress [] (if rev then List.rev s.s_node else s.s_node) i in - - match rev with - | false -> (s1, ir, s2) - | true -> (s2, ir, s1) - - let split_at_cp_base ~after (cb : cp_base) (s : stmt) = - match cb with - | `ByPos i -> begin - let i = if i < 0 then List.length s.s_node + i else i in - try List.takedrop (i - if after then 0 else 1) s.s_node - with (Invalid_argument _ | Not_found) -> raise InvalidCPos - end - - | `ByMatch (i, cm) -> - let (s1, i, s2) = find_by_cp_match (i, cm) s in - - match after with - | false -> (List.rev s1, i :: s2) - | true -> (List.rev_append s1 [i], s2) - - let split_at_cpos1 ~after ((ipos, cb) : codepos1) s = - let (s1, s2) = split_at_cp_base ~after cb s in - - let (s1, s2) = - match ipos with - | off when off > 0 -> - let (ss1, ss2) = - try List.takedrop off s2 - with (Invalid_argument _ | Not_found) -> raise InvalidCPos in - (s1 @ ss1, ss2) - - | off when off < 0 -> - let (ss1, ss2) = - try List.takedrop (List.length s1 + off) s1 - with (Invalid_argument _ | Not_found) -> raise InvalidCPos in - (ss1, ss2 @ s2) - - | _ -> (s1, s2) - - in (s1, s2) - - let find_by_cpos1 ?(rev = true) (cpos1 : codepos1) s = - match split_at_cpos1 ~after:false cpos1 s with - | (s1, i :: s2) -> ((if rev then List.rev s1 else s1), i, s2) - | _ -> raise InvalidCPos - - let zipper_at_nm_cpos1 ((cp1, sub) : codepos1 * int) s zpr = - let (s1, i, s2) = find_by_cpos1 cp1 s in - - match i.i_node, sub with - | Swhile (e, sw), 0 -> - (ZWhile (e, ((s1, s2), zpr)), sw) - - | Sif (e, ifs1, ifs2), 0 -> - (ZIfThen (e, ((s1, s2), zpr), ifs2), ifs1) - - | Sif (e, ifs1, ifs2), 1 -> - (ZIfElse (e, ifs1, ((s1, s2), zpr)), ifs2) - - | _ -> raise InvalidCPos - - let zipper_of_cpos ((nm, cp1) : codepos) s = - let zpr, s = - List.fold_left - (fun (zpr, s) nm1 -> zipper_at_nm_cpos1 nm1 s zpr) - (ZTop, s) nm in - - let s1, i, s2 = find_by_cpos1 cp1 s in - - zipper s1 (i :: s2) zpr - - let split_at_cpos1 cpos1 s = - split_at_cpos1 ~after:true cpos1 s - - let may_split_at_cpos1 ?(rev = false) cpos1 s = - ofdfl - (fun () -> if rev then (s.s_node, []) else ([], s.s_node)) - (omap (split_at_cpos1^~ s) cpos1) - - let rec zip i ((hd, tl), ip) = - let s = stmt (List.rev_append hd (List.ocons i tl)) in - - match ip with - | ZTop -> s - | ZWhile (e, sp) -> zip (Some (i_while (e, s))) sp - | ZIfThen (e, sp, se) -> zip (Some (i_if (e, s, se))) sp - | ZIfElse (e, se, sp) -> zip (Some (i_if (e, se, s))) sp - - let zip zpr = zip None ((zpr.z_head, zpr.z_tail), zpr.z_path) - - let after ~strict zpr = - let rec doit acc ip = - match ip with - | ZTop -> acc - | ZWhile (_, ((_, is), ip)) -> doit (is :: acc) ip - | ZIfThen (_, ((_, is), ip), _) -> doit (is :: acc) ip - | ZIfElse (_, _, ((_, is), ip)) -> doit (is :: acc) ip - in - - let after = - match zpr.z_tail, strict with - | [] , _ -> doit [[]] zpr.z_path - | is , false -> doit [is] zpr.z_path - | _ :: is, true -> doit [is] zpr.z_path - in - List.rev after - - let rec fold env cpos f state s = - let zpr = zipper_of_cpos cpos s in - - match zpr.z_tail with - | [] -> raise InvalidCPos - | i :: tl -> begin - match f env state i with - | (state', [i']) when i == i' && state == state' -> (state, s) - | (state', si ) -> (state', zip { zpr with z_tail = si @ tl }) - end -end - -(* -------------------------------------------------------------------- *) -type 'a evmap = { - ev_map : ('a option) Mid.t; - ev_unset : int; -} - -module EV = struct - let empty : 'a evmap = { - ev_map = Mid.empty; - ev_unset = 0; - } - - let add (x : ident) (m : 'a evmap) = - let chg = function Some _ -> assert false | None -> Some None in - let map = Mid.change chg x m.ev_map in - { ev_map = map; ev_unset = m.ev_unset + 1; } - - let mem (x : ident) (m : 'a evmap) = - EcUtils.is_some (Mid.find_opt x m.ev_map) - - let set (x : ident) (v : 'a) (m : 'a evmap) = - let chg = function - | None | Some (Some _) -> assert false - | Some None -> Some (Some v) - in - { ev_map = Mid.change chg x m.ev_map; ev_unset = m.ev_unset - 1; } - - let get (x : ident) (m : 'a evmap) = - match Mid.find_opt x m.ev_map with - | None -> None - | Some None -> Some `Unset - | Some (Some a) -> Some (`Set a) - - let isset (x : ident) (m : 'a evmap) = - match get x m with - | Some (`Set _) -> true - | _ -> false - - let doget (x : ident) (m : 'a evmap) = - match get x m with - | Some (`Set a) -> a - | _ -> assert false - - let of_idents (ids : ident list) : 'a evmap = - List.fold_left ((^~) add) empty ids - - let fold (f : ident -> 'a -> 'b -> 'b) ev state = - Mid.fold - (fun x t s -> match t with Some t -> f x t s | None -> s) - ev.ev_map state - - let filled (m : 'a evmap) = (m.ev_unset = 0) -end - -(* -------------------------------------------------------------------- *) -type mevmap = { - evm_form : form evmap; - evm_mem : EcMemory.memory evmap; - evm_mod : EcPath.mpath evmap; -} - -(* -------------------------------------------------------------------- *) -module MEV = struct - type item = [ - | `Form of form - | `Mem of EcMemory.memory - | `Mod of EcPath.mpath - ] - - type kind = [ `Form | `Mem | `Mod ] - - let empty : mevmap = { - evm_form = EV.empty; - evm_mem = EV.empty; - evm_mod = EV.empty; - } - - let of_idents ids k = - match k with - | `Form -> { empty with evm_form = EV.of_idents ids } - | `Mem -> { empty with evm_mem = EV.of_idents ids } - | `Mod -> { empty with evm_mod = EV.of_idents ids } - - let add x k m = - match k with - | `Form -> { m with evm_form = EV.add x m.evm_form } - | `Mem -> { m with evm_mem = EV.add x m.evm_mem } - | `Mod -> { m with evm_mod = EV.add x m.evm_mod } - - let mem x k m = - match k with - | `Form -> EV.mem x m.evm_form - | `Mem -> EV.mem x m.evm_mem - | `Mod -> EV.mem x m.evm_mod - - let set x v m = - match v with - | `Form v -> { m with evm_form = EV.set x v m.evm_form } - | `Mem v -> { m with evm_mem = EV.set x v m.evm_mem } - | `Mod v -> { m with evm_mod = EV.set x v m.evm_mod } - - let get x k m = - let tx f = function `Unset -> `Unset | `Set x -> `Set (f x) in - - match k with - | `Form -> omap (tx (fun x -> `Form x)) (EV.get x m.evm_form) - | `Mem -> omap (tx (fun x -> `Mem x)) (EV.get x m.evm_mem ) - | `Mod -> omap (tx (fun x -> `Mod x)) (EV.get x m.evm_mod ) - - let isset x k m = - match k with - | `Form -> EV.isset x m.evm_form - | `Mem -> EV.isset x m.evm_mem - | `Mod -> EV.isset x m.evm_mod - - let filled m = - EV.filled m.evm_form - && EV.filled m.evm_mem - && EV.filled m.evm_mod - - let fold (f : _ -> item -> _ -> _) m v = - let v = EV.fold (fun x k v -> f x (`Form k) v) m.evm_form v in - let v = EV.fold (fun x k v -> f x (`Mem k) v) m.evm_mem v in - let v = EV.fold (fun x k v -> f x (`Mod k) v) m.evm_mod v in - v - - let assubst ue ev = - let tysubst = { ty_subst_id with ts_u = EcUnify.UniEnv.assubst ue } in - let subst = Fsubst.f_subst_init ~sty:tysubst () in - let subst = EV.fold (fun x m s -> Fsubst.f_bind_mem s x m) ev.evm_mem subst in - let subst = EV.fold (fun x m s -> Fsubst.f_bind_mod s x m) ev.evm_mod subst in - let seen = ref Sid.empty in - - let rec for_ident x binding subst = - if Sid.mem x !seen then subst else begin - seen := Sid.add x !seen; - match binding with None -> subst | Some f -> - let subst = - Mid.fold2_inter (fun x bdx _ -> for_ident x bdx) - ev.evm_form.ev_map f.f_fv subst in - Fsubst.f_bind_local subst x (Fsubst.f_subst subst f) - end - in - - Mid.fold_left - (fun acc x bd -> for_ident x bd acc) - subst ev.evm_form.ev_map -end - -(* -------------------------------------------------------------------- *) -exception MatchFailure - -type fmoptions = { - fm_delta : bool; - fm_conv : bool; - fm_horder : bool; -} - -let fmsearch = - { fm_delta = false; - fm_conv = false; - fm_horder = true ; } - -let fmrigid = { - fm_delta = false; - fm_conv = true ; - fm_horder = true ; } - -let fmdelta = { - fm_delta = true ; - fm_conv = true ; - fm_horder = true ; } - -let fmnotation = { - fm_delta = false; - fm_conv = false; - fm_horder = false; } - -(* -------------------------------------------------------------------- *) -(* Rigid unification *) -let f_match_core opts hyps (ue, ev) ~ptn subject = - let ue = EcUnify.UniEnv.copy ue in - let ev = ref ev in - - let iscvar = function - | { f_node = Flocal x } -> is_none (EV.get x !ev.evm_form) - | _ -> false - in - - let conv = - match opts.fm_conv with - | true -> EcReduction.is_conv ~ri:EcReduction.full_compat hyps - | false -> EcReduction.is_alpha_eq hyps - in - - let rec doit env ((subst, mxs) as ilc) ptn subject = - let failure = - let oue, oev = (EcUnify.UniEnv.copy ue, !ev) in - fun () -> - EcUnify.UniEnv.restore ~dst:ue ~src:oue; ev := oev; - raise MatchFailure - in - - let default () = - if opts.fm_conv then begin - let subject = Fsubst.f_subst subst subject in - let ptn = Fsubst.f_subst (MEV.assubst ue !ev) ptn in - if not (conv ptn subject) then - failure () - end else failure () - in - - try - match ptn.f_node, subject.f_node with - | Flocal x1, Flocal x2 when Mid.mem x1 mxs -> begin - if not (id_equal (oget (Mid.find_opt x1 mxs)) x2) then - failure (); - try EcUnify.unify env ue ptn.f_ty subject.f_ty - with EcUnify.UnificationFailure _ -> failure () - end - - | Flocal x1, Flocal x2 when id_equal x1 x2 -> begin - try EcUnify.unify env ue ptn.f_ty subject.f_ty - with EcUnify.UnificationFailure _ -> failure () - end - - | Flocal x, _ -> begin - match EV.get x !ev.evm_form with - | None -> - raise MatchFailure - - | Some `Unset -> - let ssbj = Fsubst.f_subst subst subject in - let ssbj = Fsubst.f_subst (MEV.assubst ue !ev) ssbj in - if not (Mid.set_disjoint mxs ssbj.f_fv) then - raise MatchFailure; - begin - try EcUnify.unify env ue ptn.f_ty subject.f_ty - with EcUnify.UnificationFailure _ -> failure (); - end; - ev := { !ev with evm_form = EV.set x ssbj !ev.evm_form } - - | Some (`Set a) -> begin - let ssbj = Fsubst.f_subst subst subject in - - if not (conv ssbj a) then - let ssbj = Fsubst.f_subst (MEV.assubst ue !ev) subject in - if not (conv ssbj a) then - doit env ilc a ssbj - else - try EcUnify.unify env ue ptn.f_ty subject.f_ty - with EcUnify.UnificationFailure _ -> failure () - else - try EcUnify.unify env ue ptn.f_ty subject.f_ty - with EcUnify.UnificationFailure _ -> failure () - end - end - - | Fapp (f1, fs1), _ -> begin - try - match subject.f_node with - | Fapp (f2, fs2) -> begin - try doit_args env ilc (f1::fs1) (f2::fs2) - with MatchFailure when opts.fm_conv -> - let rptn = f_betared ptn in - if (ptn.f_tag <> rptn.f_tag) - then doit env ilc rptn subject - else failure () - end - | _ -> failure () - - with MatchFailure when opts.fm_horder -> - match f1.f_node with - | Flocal f when - not (Mid.mem f mxs) - && (EV.get f !ev.evm_form = Some `Unset) - && List.for_all iscvar fs1 - -> - - let oargs = List.map destr_local fs1 in - - if not (List.is_unique ~eq:id_equal oargs) then - failure (); - - let xsubst, bindings = - List.map_fold - (fun xsubst x -> - let x, xty = (destr_local x, x.f_ty) in - let nx = EcIdent.fresh x in - let xsubst = - Mid.find_opt x mxs - |> omap (fun y -> Fsubst.f_bind_rename xsubst y nx xty) - |> odfl xsubst - in (xsubst, (nx, GTty xty))) - Fsubst.f_subst_id fs1 in - - let ssbj = Fsubst.f_subst xsubst subject in - let ssbj = Fsubst.f_subst subst ssbj in - - if not (Mid.set_disjoint mxs ssbj.f_fv) then - failure (); - - begin - let fty = toarrow (List.map f_ty fs1) ssbj.f_ty in - - try EcUnify.unify env ue f1.f_ty fty - with EcUnify.UnificationFailure _ -> failure (); - end; - - let ssbj = f_lambda bindings ssbj in - - ev := { !ev with evm_form = EV.set f ssbj !ev.evm_form } - - | _ -> default () - end - - | Fquant (b1, q1, f1), Fquant (b2, q2, f2) when b1 = b2 -> - let n1, n2 = List.length q1, List.length q2 in - let q1, r1 = List.split_at (min n1 n2) q1 in - let q2, r2 = List.split_at (min n1 n2) q2 in - let (env, subst, mxs) = doit_bindings env (subst, mxs) q1 q2 in - doit env (subst, mxs) (f_quant b1 r1 f1) (f_quant b2 r2 f2) - - | Fquant _, Fquant _ -> - failure (); - - | Fpvar (pv1, m1), Fpvar (pv2, m2) -> - let pv1 = EcEnv.NormMp.norm_pvar env pv1 in - let pv2 = EcEnv.NormMp.norm_pvar env pv2 in - if not (EcTypes.pv_equal pv1 pv2) then - failure (); - doit_mem env mxs m1 m2 - - | Fif (c1, t1, e1), Fif (c2, t2, e2) -> - List.iter2 (doit env ilc) [c1; t1; e1] [c2; t2; e2] - - | Fmatch (b1, fs1, ty1), Fmatch (b2, fs2, ty2) -> begin - (try EcUnify.unify env ue ty1 ty2 - with EcUnify.UnificationFailure _ -> failure ()); - if List.length fs1 <> List.length fs2 then - failure (); - List.iter2 (doit env ilc) (b1 :: fs1) (b2 :: fs2) - end - - | Fint i1, Fint i2 -> - if not (EcBigInt.equal i1 i2) then failure (); - - | Fglob (mp1, me1), Fglob (mp2, me2) -> - let mp1 = EcEnv.NormMp.norm_mpath env mp1 in - let mp2 = EcEnv.NormMp.norm_mpath env mp2 in - if not (EcPath.m_equal mp1 mp2) then - failure (); - doit_mem env mxs me1 me2 - - | Ftuple fs1, Ftuple fs2 -> - if List.length fs1 <> List.length fs2 then - failure (); - List.iter2 (doit env ilc) fs1 fs2 - - | Fproj (f1, i), Fproj (f2, j) -> - if i <> j then failure () else doit env ilc f1 f2 - - | Fop (op1, tys1), Fop (op2, tys2) -> begin - if not (EcPath.p_equal op1 op2) then - failure (); - try List.iter2 (EcUnify.unify env ue) tys1 tys2 - with EcUnify.UnificationFailure _ -> failure () - end - - | FhoareF hf1, FhoareF hf2 -> begin - if not (EcReduction.EqTest.for_xp env hf1.hf_f hf2.hf_f) then - failure (); - let mxs = Mid.add EcFol.mhr EcFol.mhr mxs in - List.iter2 (doit env (subst, mxs)) - [hf1.hf_pr; hf1.hf_po] [hf2.hf_pr; hf2.hf_po] - end - - | FbdHoareF hf1, FbdHoareF hf2 -> begin - if not (EcReduction.EqTest.for_xp env hf1.bhf_f hf2.bhf_f) then - failure (); - if hf1.bhf_cmp <> hf2.bhf_cmp then - failure (); - let mxs = Mid.add EcFol.mhr EcFol.mhr mxs in - List.iter2 (doit env (subst, mxs)) - [hf1.bhf_pr; hf1.bhf_po; hf1.bhf_bd] - [hf2.bhf_pr; hf2.bhf_po; hf2.bhf_bd] - end - - | FequivF hf1, FequivF hf2 -> begin - if not (EcReduction.EqTest.for_xp env hf1.ef_fl hf2.ef_fl) then - failure (); - if not (EcReduction.EqTest.for_xp env hf1.ef_fr hf2.ef_fr) then - failure(); - let mxs = Mid.add EcFol.mleft EcFol.mleft mxs in - let mxs = Mid.add EcFol.mright EcFol.mright mxs in - List.iter2 - (doit env (subst, mxs)) - [hf1.ef_pr; hf1.ef_po] [hf2.ef_pr; hf2.ef_po] - end - - | Fpr pr1, Fpr pr2 -> begin - if not (EcReduction.EqTest.for_xp env pr1.pr_fun pr2.pr_fun) then - failure (); - doit_mem env mxs pr1.pr_mem pr2.pr_mem; - let mxs = Mid.add EcFol.mhr EcFol.mhr mxs in - List.iter2 - (doit env (subst, mxs)) - [pr1.pr_args; pr1.pr_event] [pr2.pr_args; pr2.pr_event] - end - - | _, _ -> default () - - with MatchFailure when opts.fm_delta -> - match fst_map f_node (destr_app ptn), - fst_map f_node (destr_app subject) - with - | (Fop (op1, tys1), args1), (Fop (op2, tys2), args2) -> begin -(* try - if not (EcPath.p_equal op1 op2) then - failure (); - try - List.iter2 (EcUnify.unify env ue) tys1 tys2; - doit_args env ilc args1 args2 - with EcUnify.UnificationFailure _ -> failure () - with MatchFailure -> *) -(* Benj: Fixme user reduction ... *) - if EcEnv.Op.reducible env op1 then - doit_reduce env ((doit env ilc)^~ subject) ptn.f_ty op1 tys1 args1 - else if EcEnv.Op.reducible env op2 then - doit_reduce env (doit env ilc ptn) subject.f_ty op2 tys2 args2 - else - failure () - end - - | (Flocal x1, args1), _ when LDecl.can_unfold x1 hyps -> - doit_lreduce env ((doit env ilc)^~ subject) ptn.f_ty x1 args1 - - | _, (Flocal x2, args2) when LDecl.can_unfold x2 hyps -> - doit_lreduce env (doit env ilc ptn) subject.f_ty x2 args2 - - | (Fop (op1, tys1), args1), _ when EcEnv.Op.reducible env op1 -> - doit_reduce env ((doit env ilc)^~ subject) ptn.f_ty op1 tys1 args1 - - | _, (Fop (op2, tys2), args2) when EcEnv.Op.reducible env op2 -> - doit_reduce env (doit env ilc ptn) subject.f_ty op2 tys2 args2 - - | _, _ -> failure () - - and doit_args env ilc fs1 fs2 = - if List.length fs1 <> List.length fs2 then - raise MatchFailure; - List.iter2 (doit env ilc) fs1 fs2 - - and doit_reduce env cb ty op tys args = - let reduced = - try f_app (EcEnv.Op.reduce env op tys) args ty - with NotReducible -> raise MatchFailure in - cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) - - and doit_lreduce _env cb ty x args = - let reduced = - try f_app (LDecl.unfold x hyps) args ty - with LookupFailure _ -> raise MatchFailure in - cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) - - and doit_mem _env mxs m1 m2 = - match EV.get m1 !ev.evm_mem with - | None -> - if not (EcMemory.mem_equal m1 m2) then - raise MatchFailure - - | Some `Unset -> - if Mid.mem m2 mxs then - raise MatchFailure; - ev := { !ev with evm_mem = EV.set m1 m2 !ev.evm_mem } - - | Some (`Set m1) -> - if not (EcMemory.mem_equal m1 m2) then - raise MatchFailure - - and doit_bindings env (subst, mxs) q1 q2 = - let doit_binding (env, subst, mxs) (x1, gty1) (x2, gty2) = - let gty2 = Fsubst.gty_subst subst gty2 in - - assert (not (Mid.mem x1 mxs) && not (Mid.mem x2 mxs)); - - let env, subst = - match gty1, gty2 with - | GTty ty1, GTty ty2 -> - begin - try EcUnify.unify env ue ty1 ty2 - with EcUnify.UnificationFailure _ -> raise MatchFailure - end; - - let subst = - if id_equal x1 x2 - then subst - else Fsubst.f_bind_rename subst x2 x1 ty2 - - and env = EcEnv.Var.bind_local x1 ty1 env in - - (env, subst) - - | GTmem None, GTmem None -> - (env, subst) - - | GTmem (Some m1), GTmem (Some m2) -> - let xp1 = EcMemory.lmt_xpath m1 in - let xp2 = EcMemory.lmt_xpath m2 in - let m1 = EcMemory.lmt_bindings m1 in - let m2 = EcMemory.lmt_bindings m2 in - - if not (EcPath.x_equal xp1 xp2) then - raise MatchFailure; - if not ( - try - EcSymbols.Msym.equal - (fun (p1,ty1) (p2,ty2) -> - if p1 <> p2 then raise MatchFailure; - EcUnify.unify env ue ty1 ty2; true) - m1 m2 - with EcUnify.UnificationFailure _ -> raise MatchFailure) - then - raise MatchFailure; - - let subst = - if id_equal x1 x2 - then subst - else Fsubst.f_bind_mem subst x2 x1 - in (env, subst) - - | GTmodty (p1, r1), GTmodty (p2, r2) -> - if not (ModTy.mod_type_equiv env p1 p2) then - raise MatchFailure; - if not (NormMp.equal_restr env r1 r2) then - raise MatchFailure; - - let subst = - if id_equal x1 x2 - then subst - else Fsubst.f_bind_mod subst x2 (EcPath.mident x1) - - and env = EcEnv.Mod.bind_local x1 p1 r1 env in - - (env, subst) - - | _, _ -> raise MatchFailure - in - (env, subst, Mid.add x1 x2 mxs) - in - List.fold_left2 doit_binding (env, subst, mxs) q1 q2 - - in - doit (EcEnv.LDecl.toenv hyps) (Fsubst.f_subst_id, Mid.empty) ptn subject; - (ue, !ev) - -let f_match opts hyps (ue, ev) ~ptn subject = - let (ue, ev) = f_match_core opts hyps (ue, ev) ~ptn subject in - if not (MEV.filled ev) then - raise MatchFailure; - let clue = - try EcUnify.UniEnv.close ue - with EcUnify.UninstanciateUni -> raise MatchFailure - in - (ue, clue, ev) - -(* -------------------------------------------------------------------- *) -type ptnpos = [`Select of int | `Sub of ptnpos] Mint.t -type occ = [`Inclusive | `Exclusive] * Sint.t - -exception InvalidPosition -exception InvalidOccurence - -module FPosition = struct - type select = [`Accept of int | `Continue] - - (* ------------------------------------------------------------------ *) - let empty : ptnpos = Mint.empty - - (* ------------------------------------------------------------------ *) - let is_empty (p : ptnpos) = Mint.is_empty p - - (* ------------------------------------------------------------------ *) - let rec tostring (p : ptnpos) = - let items = Mint.bindings p in - let items = - List.map - (fun (i, p) -> Printf.sprintf "%d[%s]" i (tostring1 p)) - items - in - String.concat ", " items - - (* ------------------------------------------------------------------ *) - and tostring1 = function - | `Select i when i < 0 -> "-" - | `Select i -> Printf.sprintf "-(%d)" i - | `Sub p -> tostring p - - (* ------------------------------------------------------------------ *) - let occurences = - let rec doit1 n p = - match p with - | `Select _ -> n+1 - | `Sub p -> doit n p - - and doit n (ps : ptnpos) = - Mint.fold (fun _ p n -> doit1 n p) ps n - - in - fun p -> doit 0 p - - (* ------------------------------------------------------------------ *) - let filter ((mode, s) : occ) = - let rec doit1 n p = - match p with - | `Select _ -> begin - match mode with - | `Inclusive -> (n+1, if Sint.mem n s then Some p else None ) - | `Exclusive -> (n+1, if Sint.mem n s then None else Some p) - end - - | `Sub p -> begin - match doit n p with - | (n, sub) when Mint.is_empty sub -> (n, None) - | (n, sub) -> (n, Some (`Sub sub)) - end - - and doit n (ps : ptnpos) = - Mint.mapi_filter_fold (fun _ p n -> doit1 n p) ps n - - in - fun p -> snd (doit 1 p) - - (* ------------------------------------------------------------------ *) - let is_occurences_valid o cpos = - let (min, max) = (Sint.min_elt o, Sint.max_elt o) in - not (min < 1 || max > occurences cpos) - - (* ------------------------------------------------------------------ *) - let select ?o test = - let rec doit1 ctxt pos fp = - match test ctxt fp with - | `Accept i -> Some (`Select i) - | `Continue -> begin - let subp = - match fp.f_node with - | Fif (c, f1, f2) -> doit pos (`WithCtxt (ctxt, [c; f1; f2])) - | Fapp (f, fs) -> doit pos (`WithCtxt (ctxt, f :: fs)) - | Ftuple fs -> doit pos (`WithCtxt (ctxt, fs)) - - | Fmatch (b, fs, _) -> - doit pos (`WithCtxt (ctxt, b :: fs)) - - | Fquant (_, b, f) -> - let xs = List.pmap (function (x, GTty _) -> Some x | _ -> None) b in - let ctxt = List.fold_left ((^~) Sid.add) ctxt xs in - doit pos (`WithCtxt (ctxt, [f])) - - | Flet (lp, f1, f2) -> - let subctxt = List.fold_left ((^~) Sid.add) ctxt (lp_ids lp) in - doit pos (`WithSubCtxt [(ctxt, f1); (subctxt, f2)]) - - | Fproj (f, _) -> - doit pos (`WithCtxt (ctxt, [f])) - - | Fpr pr -> - let subctxt = Sid.add pr.pr_mem ctxt in - doit pos (`WithSubCtxt [(ctxt, pr.pr_args); (subctxt, pr.pr_event)]) - - | FhoareF hs -> - doit pos (`WithCtxt (Sid.add EcFol.mhr ctxt, [hs.hf_pr; hs.hf_po])) - - | FbdHoareF hs -> - let subctxt = Sid.add EcFol.mhr ctxt in - doit pos (`WithSubCtxt ([(subctxt, hs.bhf_pr); - (subctxt, hs.bhf_po); - ( ctxt, hs.bhf_bd)])) - - | FequivF es -> - let ctxt = Sid.add EcFol.mleft ctxt in - let ctxt = Sid.add EcFol.mright ctxt in - doit pos (`WithCtxt (ctxt, [es.ef_pr; es.ef_po])) - - | _ -> None - in - omap (fun p -> `Sub p) subp - end - - and doit pos fps = - let fps = - match fps with - | `WithCtxt (ctxt, fps) -> - List.mapi - (fun i fp -> - doit1 ctxt (i::pos) fp |> omap (fun p -> (i, p))) - fps - - | `WithSubCtxt fps -> - List.mapi - (fun i (ctxt, fp) -> - doit1 ctxt (i::pos) fp |> omap (fun p -> (i, p))) - fps - in - - let fps = List.pmap identity fps in - match fps with - | [] -> None - | _ -> Some (Mint.of_list fps) - - in - fun fp -> - let cpos = - match doit [] (`WithCtxt (Sid.empty, [fp])) with - | None -> Mint.empty - | Some p -> p - in - match o with - | None -> cpos - | Some o -> - if not (is_occurences_valid (snd o) cpos) then - raise InvalidOccurence; - filter o cpos - - (* ------------------------------------------------------------------ *) - let select_form ?(xconv = `Conv) ?(keyed = false) hyps o p target = - let na = List.length (snd (EcFol.destr_app p)) in - - let kmatch key tp = - match key, (fst (destr_app tp)).f_node with - | `NoKey , _ -> true - | `Path p, Fop (p', _) -> EcPath.p_equal p p' - | `Path _, _ -> false - | `Var x, Flocal x' -> id_equal x x' - | `Var _, _ -> false - in - - let keycheck tp key = not keyed || kmatch key tp in - - let key = - match (fst (destr_app p)).f_node with - | Fop (p, _) -> `Path p - | Flocal x -> `Var x - | _ -> `NoKey - in - - let test xconv _ tp = - if not (keycheck tp key) then `Continue else begin - let (tp, ti) = - match tp.f_node with - | Fapp (h, hargs) when List.length hargs > na -> - let (a1, a2) = List.takedrop na hargs in - (f_app h a1 (toarrow (List.map f_ty a2) tp.f_ty), na) - | _ -> (tp, -1) - in - if EcReduction.xconv xconv hyps p tp then `Accept ti else `Continue - end - - in select ?o (test xconv) target - - (* ------------------------------------------------------------------ *) - let map (p : ptnpos) (tx : form -> form) (f : form) = - let rec doit1 p fp = - match p with - | `Select i when i < 0 -> tx fp - - | `Select i -> begin - let (f, fs) = EcFol.destr_app fp in - if List.length fs < i then raise InvalidPosition; - let (fs1, fs2) = List.takedrop i fs in - let f' = f_app f fs1 (toarrow (List.map f_ty fs2) fp.f_ty) in - f_app (tx f') fs2 fp.f_ty - end - - | `Sub p -> begin - match fp.f_node with - | Flocal _ -> raise InvalidPosition - | Fpvar _ -> raise InvalidPosition - | Fglob _ -> raise InvalidPosition - | Fop _ -> raise InvalidPosition - | Fint _ -> raise InvalidPosition - - | Fquant (q, b, f) -> - let f' = as_seq1 (doit p [f]) in - FSmart.f_quant (fp, (q, b, f)) (q, b, f') - - | Fif (c, f1, f2) -> - let (c', f1', f2') = as_seq3 (doit p [c; f1; f2]) in - FSmart.f_if (fp, (c, f1, f2)) (c', f1', f2') - - | Fmatch (b, fs, ty) -> - let bfs = doit p (b :: fs) in - FSmart.f_match (fp, (b, fs, ty)) (List.hd bfs, List.tl bfs, ty) - - | Fapp (f, fs) -> begin - match doit p (f :: fs) with - | [] -> assert false - | f' :: fs' -> - FSmart.f_app (fp, (f, fs, fp.f_ty)) (f', fs', fp.f_ty) - end - - | Ftuple fs -> - let fs' = doit p fs in - FSmart.f_tuple (fp, fs) fs' - - | Fproj (f, i) -> - FSmart.f_proj (fp, (f, fp.f_ty)) (as_seq1 (doit p [f]), fp.f_ty) i - - | Flet (lv, f1, f2) -> - let (f1', f2') = as_seq2 (doit p [f1; f2]) in - FSmart.f_let (fp, (lv, f1, f2)) (lv, f1', f2') - - | Fpr pr -> - let (args', event') = as_seq2 (doit p [pr.pr_args; pr.pr_event]) in - f_pr pr.pr_mem pr.pr_fun args' event' - - | FhoareF hf -> - let (hf_pr, hf_po) = as_seq2 (doit p [hf.hf_pr; hf.hf_po]) in - f_hoareF_r { hf with hf_pr; hf_po; } - - | FbdHoareF hf -> - let sub = doit p [hf.bhf_pr; hf.bhf_po; hf.bhf_bd] in - let (bhf_pr, bhf_po, bhf_bd) = as_seq3 sub in - f_bdHoareF_r { hf with bhf_pr; bhf_po; bhf_bd; } - - | FequivF ef -> - let (ef_pr, ef_po) = as_seq2 (doit p [ef.ef_pr; ef.ef_po]) in - f_equivF_r { ef with ef_pr; ef_po; } - - | FhoareS _ -> raise InvalidPosition - | FbdHoareS _ -> raise InvalidPosition - | FequivS _ -> raise InvalidPosition - | FeagerF _ -> raise InvalidPosition - end - - and doit ps fps = - match Mint.is_empty ps with - | true -> fps - | false -> - let imin = fst (Mint.min_binding ps) - and imax = fst (Mint.max_binding ps) in - if imin < 0 || imax >= List.length fps then - raise InvalidPosition; - let fps = List.mapi (fun i x -> (x, Mint.find_opt i ps)) fps in - let fps = List.map (function (f, None) -> f | (f, Some p) -> doit1 p f) fps in - fps - - in - as_seq1 (doit p [f]) - - (* ------------------------------------------------------------------ *) - let topattern ?x (p : ptnpos) (f : form) = - let x = match x with None -> EcIdent.create "_p" | Some x -> x in - let tx fp = f_local x fp.f_ty in (x, map p tx f) -end - -(* -------------------------------------------------------------------- *) -type cptenv = CPTEnv of f_subst - -let can_concretize ev ue = - EcUnify.UniEnv.closed ue && MEV.filled ev - -(* -------------------------------------------------------------------------- *) -type regexp_instr = regexp1_instr gen_regexp - -and regexp1_instr = - | RAssign (*of lvalue * expr*) - | RSample (*of lvalue * expr*) - | RCall (*of lvalue option * EcPath.xpath * expr list*) - | RIf of (*expr *) regexp_instr * regexp_instr - | RWhile of (*expr *) regexp_instr - - -module RegexpBaseInstr = struct - open Zipper - - type regexp = regexp_instr - type regexp1 = regexp1_instr - - type pos = int - type path = int list - - type subject = instr list - - type engine = { - e_zipper : zipper; - e_pos : pos; - e_path : pos list; - } - - let mkengine (s : subject) = { - e_zipper = zipper [] s ZTop; - e_pos = 0; - e_path = []; - } - - let position (e : engine) = - e.e_pos - - let at_start (e : engine) = - List.is_empty e.e_zipper.z_head - - let at_end (e : engine) = - List.is_empty e.e_zipper.z_tail - - let path (e : engine) = - e.e_pos :: e.e_path - - let eat_option (f : 'a -> 'a -> unit) (x : 'a option) (xn : 'a option) = - match x, xn with - | None , Some _ -> raise NoMatch - | Some _, None -> raise NoMatch - | None , None -> () - | Some x, Some y -> f x y - - let eat_list (f : 'a -> 'a -> unit) (x : 'a list) (xn : 'a list) = - try List.iter2 f x xn - with Invalid_argument _ -> raise NoMatch (* FIXME *) - - let eat_lvalue (lv : lvalue) (lvn : lvalue) = - if not (lv_equal lv lvn) then raise NoMatch - - let eat_expr (e : expr) (en : expr) = - if not (e_equal e en) then raise NoMatch - - let eat_xpath (f : EcPath.xpath) (fn : EcPath.xpath) = - if not (EcPath.x_equal f fn) then raise NoMatch - - let rec eat_base (eng : engine) (r : regexp1) = - let z = eng.e_zipper in - - match z.z_tail with - | [] -> raise NoMatch - - | i :: tail -> begin - match (i.i_node,r) with - | Sasgn _, RAssign - | Srnd _, RSample - | Scall _, RCall -> (eat eng, []) - - | Sif (e, st, sf), RIf (stn, sfn) -> begin - let e_t = mkengine st.s_node in - let e_t = - let zp = ZIfThen (e, ((z.z_head, tail), z.z_path), sf) in - let zp = { e_t.e_zipper with z_path = zp; } in - { e_t with e_path = 0 :: eng.e_pos :: eng.e_path; e_zipper = zp; } in - - let e_f = mkengine sf.s_node in - let e_f = - let zp = ZIfElse (e, st, ((z.z_head, tail), z.z_path)) in - let zp = { e_f.e_zipper with z_path = zp; } in - { e_f with e_path = 1 :: eng.e_pos :: eng.e_path; e_zipper = zp; } in - - (eat eng, [(e_t, stn); (e_f, sfn)]) - end - - | Swhile (e, s), RWhile sn -> begin - let es = mkengine s.s_node in - let es = - let zp = ZWhile (e, ((z.z_head, tail), z.z_path)) in - let zp = { es.e_zipper with z_path = zp; } in - { es with e_path = 0 :: eng.e_pos :: eng.e_path; e_zipper = zp; } in - - (eat eng, [(es, sn)]) - end - - | _, _ -> raise NoMatch - end - - and eat (e : engine) = { - e with e_zipper = zip_eat e.e_zipper; - e_pos = e.e_pos + 1; - } - - and zip_eat (z : zipper) = - match z.z_tail with - | [] -> raise NoMatch - | i :: tail -> zipper (i :: z.z_head) tail z.z_path - - let extract (e : engine) ((lo, hi) : pos * pos) = - if hi <= lo then [] else - - let s = List.rev_append e.e_zipper.z_head e.e_zipper.z_tail in - List.of_enum (List.enum s |> Enum.skip lo |> Enum.take (hi-lo)) - - let rec next_zipper (z : zipper) = - match z.z_tail with - | i :: tail -> - begin match i.i_node with - | Sif (e, stmttrue, stmtfalse) -> - let z = (i::z.z_head, tail), z.z_path in - let path = ZIfThen (e, z, stmtfalse) in - let z' = zipper [] stmttrue.s_node path in - Some z' - - | Swhile (e, block) -> - let z = (i::z.z_head, tail), z.z_path in - let path = ZWhile (e, z) in - let z' = zipper [] block.s_node path in - Some z' - - | Sasgn _ | Srnd _ | Scall _ | _ -> - Some { z with z_head = i :: z.z_head ; z_tail = tail } - end - - | [] -> - match z.z_path with - | ZTop -> None - - | ZWhile (_e, ((head, tail), path)) -> - let z' = zipper head tail path in - next_zipper z' - - | ZIfThen (e, father, stmtfalse) -> - let stmttrue = stmt (List.rev z.z_head) in - let z' = zipper [] stmtfalse.s_node (ZIfElse (e, stmttrue, father)) in - next_zipper z' - - | ZIfElse (_e, _stmttrue, ((head, tail), path)) -> - let z' = zipper head tail path in - next_zipper z' - - let next (e : engine) = - next_zipper e.e_zipper |> omap (fun z -> - { e with e_zipper = z; e_pos = List.length z.z_head }) -end - -module RegexpStmt = EcGenRegexp.Regexp(RegexpBaseInstr) diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index c20a274a0f..e78a476db1 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -292,7 +292,9 @@ and app_red st f1 args = let body = EcFol.form_of_expr EcFol.mhr body in let body = EcFol.Fsubst.subst_tvar - (EcTypes.Tvar.init (List.map fst op.EcDecl.op_tparams) tys) body in + (EcTypes.Tvar.init + (List.map fst op.EcDecl.op_tparams) + (List.fst tys) (* FIXME:TC *)) body in cbv st subst body (mk_args eargs (Aempty ty)) with E.NoCtor -> @@ -351,7 +353,9 @@ and reduce_logic st f = | Some (`Real_mul ), [f1;f2] -> f_real_mul_simpl f1 f2 | Some (`Real_inv ), [f] -> f_real_inv_simpl f | Some (`Eq ), [f1;f2] -> f_eq_simpl st f1 f2 - | Some (`Map_get ), [f1;f2] -> f_map_get_simpl st f1 f2 (snd (as_seq2 tys)) + + | Some (`Map_get ), [f1;f2] -> + f_map_get_simpl st f1 f2 (fst (snd (as_seq2 tys))) (* FIXME:TC *) | _, _ -> f in if f_equal f f' then raise NotReducible diff --git a/src/ecCoreEqTest.ml b/src/ecCoreEqTest.ml index a8a3db81db..a69bfd4942 100644 --- a/src/ecCoreEqTest.ml +++ b/src/ecCoreEqTest.ml @@ -48,10 +48,25 @@ and for_type_r env t1 t2 = then for_type env (Ty.unfold p1 lt1 env) (Ty.unfold p2 lt2 env) else false - | Tconstr(p1,lt1), _ when Ty.defined p1 env -> + | Tconstr (p1, lt1), _ when Ty.defined p1 env -> for_type env (Ty.unfold p1 lt1 env) t2 - | _, Tconstr(p2,lt2) when Ty.defined p2 env -> + | _, Tconstr (p2, lt2) when Ty.defined p2 env -> for_type env t1 (Ty.unfold p2 lt2 env) | _, _ -> false + +(* -------------------------------------------------------------------- *) +let rec for_etyarg env ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = + for_type env ty1 ty2 && for_tcws env tcws1 tcws2 + +and for_etyargs env (tyargs1 : etyarg list) (tyargs2 : etyarg list) = + List.length tyargs1 = List.length tyargs2 + && List.for_all2 (for_etyarg env) tyargs1 tyargs2 + +and for_tcw env ((tyargs1, p1) : tcwitness) ((tyargs2, p2) : tcwitness) = + EcPath.p_equal p1 p2 && for_etyargs env tyargs1 tyargs2 + +and for_tcws env (tcws1 : tcwitness list) (tcws2 : tcwitness list) = + List.length tcws1 = List.length tcws2 + && List.for_all2 (for_tcw env) tcws1 tcws2 diff --git a/src/ecCoreEqTest.mli b/src/ecCoreEqTest.mli index 9d73401c39..e9fab08594 100644 --- a/src/ecCoreEqTest.mli +++ b/src/ecCoreEqTest.mli @@ -14,3 +14,4 @@ open EcEnv type 'a eqtest = env -> 'a -> 'a -> bool val for_type : ty eqtest +val for_etyarg : etyarg eqtest diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 906963a193..7a98243658 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -58,8 +58,8 @@ and f_node = | Fint of BI.zint | Flocal of EcIdent.t | Fpvar of EcTypes.prog_var * memory - | Fglob of EcPath.mpath * memory - | Fop of EcPath.path * ty list + | Fglob of EcPath.mpath * memory + | Fop of EcPath.path * etyarg list | Fapp of form * form list | Ftuple of form list | Fproj of form * int @@ -343,7 +343,7 @@ module Hsform = Why3.Hashcons.Make (struct EcPath.m_equal mp1 mp2 && EcIdent.id_equal m1 m2 | Fop(p1,lty1), Fop(p2,lty2) -> - EcPath.p_equal p1 p2 && List.all2 ty_equal lty1 lty2 + EcPath.p_equal p1 p2 && List.all2 etyarg_equal lty1 lty2 | Fapp(f1,args1), Fapp(f2,args2) -> f_equal f1 f2 && List.all2 f_equal args1 args2 @@ -395,8 +395,10 @@ module Hsform = Why3.Hashcons.Make (struct | Fglob(mp, m) -> Why3.Hashcons.combine (EcPath.m_hash mp) (EcIdent.id_hash m) - | Fop(p, lty) -> - Why3.Hashcons.combine_list ty_hash (EcPath.p_hash p) lty + | Fop(p, tyargs) -> + Why3.Hashcons.combine_list + etyarg_hash (EcPath.p_hash p) + tyargs | Fapp(f, args) -> Why3.Hashcons.combine_list f_hash (f_hash f) args @@ -424,7 +426,7 @@ module Hsform = Why3.Hashcons.Make (struct match f with | Fint _ -> Mid.empty - | Fop (_, tys) -> union (fun a -> a.ty_fv) tys + | Fop (_, tyargs) -> union etyarg_fv tyargs | Fpvar (pv,m) -> EcPath.x_fv (fv_add m Mid.empty) pv.pv_name | Fglob (mp,m) -> EcPath.m_fv (fv_add m Mid.empty) mp | Flocal id -> fv_singleton id @@ -526,7 +528,12 @@ let mk_form node ty = let f_node { f_node = form } = form (* -------------------------------------------------------------------- *) -let f_op x tys ty = mk_form (Fop (x, tys)) ty +let f_op_tc x tyargs ty = + mk_form (Fop (x, tyargs)) ty + +let f_op x tyargs ty = + let tyargs = List.map (fun ty -> (ty, [])) tyargs in + f_op_tc x tyargs ty let f_app f args ty = let f, args' = @@ -716,7 +723,7 @@ module FSmart = struct type a_if = form tuple3 type a_match = form * form list * ty type a_let = lpattern * form * form - type a_op = EcPath.path * ty list * ty + type a_op = EcPath.path * etyarg list * ty type a_tuple = form list type a_app = form * form list * ty type a_proj = form * ty @@ -760,7 +767,7 @@ module FSmart = struct let f_op (fp, (op, tys, ty)) (op', tys', ty') = if op == op' && tys == tys' && ty == ty' then fp - else f_op op' tys' ty' + else f_op_tc op' tys' ty' let f_app (fp, (f, fs, ty)) (f', fs', ty') = if f == f' && fs == fs' && ty == ty' @@ -839,10 +846,10 @@ let f_map gt g fp = let ty' = gt fp.f_ty in FSmart.f_pvar (fp, (id, fp.f_ty, s)) (id, ty', s) - | Fop (p, tys) -> - let tys' = List.Smart.map gt tys in - let ty' = gt fp.f_ty in - FSmart.f_op (fp, (p, tys, fp.f_ty)) (p, tys', ty') + | Fop (p, tyargs) -> + let tyargs' = List.Smart.map (etyarg_map gt) tyargs in + let ty' = gt fp.f_ty in + FSmart.f_op (fp, (p, tyargs, fp.f_ty)) (p, tyargs', ty') | Fapp (f, fs) -> let f' = g f in @@ -1263,7 +1270,7 @@ let rec form_of_expr mem (e : expr) = f_pvar pv e.e_ty mem | Eop (op, tys) -> - f_op op tys e.e_ty + f_op_tc op tys e.e_ty | Eapp (ef, es) -> f_app (form_of_expr mem ef) (List.map (form_of_expr mem) es) e.e_ty @@ -1479,6 +1486,11 @@ module Fsubst = struct let subst_ty s ty = s.fs_ty ty + let esubst_of_fsubst (s : f_subst) = + e_subst_init + s.fs_freshen s.fs_sty.ts_p + s.fs_ty s.fs_opdef s.fs_mp s.fs_esloc + (* ------------------------------------------------------------------ *) let rec f_subst ~tx s fp = tx fp (match fp.f_node with @@ -1501,35 +1513,40 @@ module Fsubst = struct FSmart.f_local (fp, (id, fp.f_ty)) (id, ty') end - | Fop (p, tys) when Mp.mem p s.fs_opdef -> - let ty = s.fs_ty fp.f_ty in - let tys = List.Smart.map s.fs_ty tys in - let body = oget (Mp.find_opt p s.fs_opdef) in - f_subst_op ~tx s.fs_freshen ty tys [] body - - | Fop (p, tys) when Mp.mem p s.fs_pddef -> - let ty = s.fs_ty fp.f_ty in - let tys = List.Smart.map s.fs_ty tys in - let body = oget (Mp.find_opt p s.fs_pddef) in + | Fop (p, tyargs) when Mp.mem p s.fs_opdef -> + let esubst = esubst_of_fsubst s in + let ty = s.fs_ty fp.f_ty in + let tyargs = List.Smart.map (etyarg_subst esubst) tyargs in + let body = oget (Mp.find_opt p s.fs_opdef) in + f_subst_op ~tx s.fs_freshen ty tyargs [] body + + | Fop (p, tyargs) when Mp.mem p s.fs_pddef -> + let esubst = esubst_of_fsubst s in + let ty = s.fs_ty fp.f_ty in + let tys = List.Smart.map (etyarg_subst esubst) tyargs in + let body = oget (Mp.find_opt p s.fs_pddef) in f_subst_pd ~tx ty tys [] body - | Fapp ({ f_node = Fop (p, tys) }, args) when Mp.mem p s.fs_opdef -> - let ty = s.fs_ty fp.f_ty in - let tys = List.Smart.map s.fs_ty tys in - let body = oget (Mp.find_opt p s.fs_opdef) in - f_subst_op ~tx s.fs_freshen ty tys (List.map (f_subst ~tx s) args) body - - | Fapp ({ f_node = Fop (p, tys) }, args) when Mp.mem p s.fs_pddef -> - let ty = s.fs_ty fp.f_ty in - let tys = List.Smart.map s.fs_ty tys in - let body = oget (Mp.find_opt p s.fs_pddef) in - f_subst_pd ~tx ty tys (List.map (f_subst ~tx s) args) body - - | Fop (p, tys) -> - let ty' = s.fs_ty fp.f_ty in - let tys' = List.Smart.map s.fs_ty tys in - let p' = s.fs_sty.ts_p p in - FSmart.f_op (fp, (p, tys, fp.f_ty)) (p', tys', ty') + | Fapp ({ f_node = Fop (p, tyargs) }, args) when Mp.mem p s.fs_opdef -> + let esubst = esubst_of_fsubst s in + let ty = s.fs_ty fp.f_ty in + let tyargs = List.Smart.map (etyarg_subst esubst) tyargs in + let body = oget (Mp.find_opt p s.fs_opdef) in + f_subst_op ~tx s.fs_freshen ty tyargs (List.map (f_subst ~tx s) args) body + + | Fapp ({ f_node = Fop (p, tyargs) }, args) when Mp.mem p s.fs_pddef -> + let esubst = esubst_of_fsubst s in + let ty = s.fs_ty fp.f_ty in + let tyargs = List.Smart.map (etyarg_subst esubst) tyargs in + let body = oget (Mp.find_opt p s.fs_pddef) in + f_subst_pd ~tx ty tyargs (List.map (f_subst ~tx s) args) body + + | Fop (p, tyargs) -> + let esubst = esubst_of_fsubst s in + let ty' = s.fs_ty fp.f_ty in + let tyargs' = List.Smart.map (etyarg_subst esubst) tyargs in + let p' = s.fs_sty.ts_p p in + FSmart.f_op (fp, (p, tyargs, fp.f_ty)) (p', tyargs', ty') | Fpvar (pv, m) -> let pv' = pv_subst (EcPath.x_substm s.fs_sty.ts_p s.fs_mp) pv in @@ -1551,8 +1568,7 @@ module Fsubst = struct | FhoareS hs -> assert (not (Mid.mem (fst hs.hs_m) s.fs_mem)); - let es = e_subst_init s.fs_freshen s.fs_sty.ts_p - s.fs_ty s.fs_opdef s.fs_mp s.fs_esloc in + let es = esubst_of_fsubst s in let pr' = f_subst ~tx s hs.hs_pr in let po' = f_subst ~tx s hs.hs_po in let st' = EcModules.s_subst es hs.hs_s in @@ -1572,8 +1588,7 @@ module Fsubst = struct | FbdHoareS bhs -> assert (not (Mid.mem (fst bhs.bhs_m) s.fs_mem)); - let es = e_subst_init s.fs_freshen s.fs_sty.ts_p s.fs_ty - s.fs_opdef s.fs_mp s.fs_esloc in + let es = esubst_of_fsubst s in let pr' = f_subst ~tx s bhs.bhs_pr in let po' = f_subst ~tx s bhs.bhs_po in let st' = EcModules.s_subst es bhs.bhs_s in @@ -1596,8 +1611,7 @@ module Fsubst = struct | FequivS eqs -> assert (not (Mid.mem (fst eqs.es_ml) s.fs_mem) && not (Mid.mem (fst eqs.es_mr) s.fs_mem)); - let es = e_subst_init s.fs_freshen s.fs_sty.ts_p s.fs_ty - s.fs_opdef s.fs_mp s.fs_esloc in + let es = esubst_of_fsubst s in let s_subst = EcModules.s_subst es in let pr' = f_subst ~tx s eqs.es_pr in let po' = f_subst ~tx s eqs.es_po in @@ -1619,8 +1633,7 @@ module Fsubst = struct let fl' = m_subst eg.eg_fl in let fr' = m_subst eg.eg_fr in - let es = e_subst_init s.fs_freshen s.fs_sty.ts_p s.fs_ty - s.fs_opdef s.fs_mp s.fs_esloc in + let es = esubst_of_fsubst s in let s_subst = EcModules.s_subst es in let sl' = s_subst eg.eg_sl in let sr' = s_subst eg.eg_sr in @@ -1645,9 +1658,9 @@ module Fsubst = struct (* FIXME: is [mhr] good as a default? *) let e = - let sty = Tvar.init tyids tys in + let sty = Tvar.init tyids (List.fst tys) in (* FIXME:TC *) let sty = ty_subst { ty_subst_id with ts_v = sty; } in - let sty = { e_subst_id with es_freshen = freshen; es_ty = sty ; } in + let sty = { e_subst_id with es_freshen = freshen; es_ty = sty; } in e_subst sty e in @@ -1670,7 +1683,7 @@ module Fsubst = struct (* FIXME: is fd_freshen value correct? *) let f = - let sty = Tvar.init tyids tys in + let sty = Tvar.init tyids (List.fst tys) in (* FIXME:TC *) let sty = ty_subst { ty_subst_id with ts_v = sty; } in let sty = { f_subst_id with fs_freshen = true; fs_ty = sty; } in f_subst ~tx sty f diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 06d43f46ae..05f4ca8fae 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -59,7 +59,7 @@ and f_node = | Flocal of EcIdent.t | Fpvar of EcTypes.prog_var * memory | Fglob of mpath * memory - | Fop of path * ty list + | Fop of path * etyarg list | Fapp of form * form list | Ftuple of form list | Fproj of form * int @@ -280,7 +280,7 @@ module FSmart : sig type a_if = form tuple3 type a_match = form * form list * ty type a_let = lpattern * form * form - type a_op = path * ty list * ty + type a_op = path * etyarg list * ty type a_tuple = form list type a_app = form * form list * ty type a_proj = form * ty @@ -319,13 +319,13 @@ val destr_app2 : name:string -> (path -> bool) -> form -> form * form val destr_app1_eq : name:string -> path -> form -> form val destr_app2_eq : name:string -> path -> form -> form * form -val destr_op : form -> EcPath.path * ty list +val destr_op : form -> EcPath.path * etyarg list val destr_local : form -> EcIdent.t val destr_pvar : form -> prog_var * memory val destr_proj : form -> form * int val destr_tuple : form -> form list val destr_app : form -> form * form list -val destr_op_app : form -> (EcPath.path * ty list) * form list +val destr_op_app : form -> (EcPath.path * etyarg list) * form list val destr_not : form -> form val destr_nots : form -> bool * form val destr_and : form -> form * form @@ -449,6 +449,8 @@ module Fsubst : sig val subst_me : f_subst -> EcMemory.memenv -> EcMemory.memenv val subst_m : f_subst -> EcIdent.t -> EcIdent.t val subst_ty : f_subst -> ty -> ty + + val esubst_of_fsubst : f_subst -> e_subst end (* -------------------------------------------------------------------- *) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 3759819b5f..46908d85a3 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -2734,7 +2734,9 @@ module Op = struct | _ -> raise NotReducible in EcCoreFol.Fsubst.subst_tvar - (EcTypes.Tvar.init (List.map fst op.op_tparams) tys) f + (EcTypes.Tvar.init + (List.fst op.op_tparams) + (List.fst tys) (* FIXM:TC *)) f let is_projection env p = try EcDecl.is_proj (by_path p env) diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 7a883ab833..d3eea892d6 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -291,7 +291,7 @@ module Op : sig val bind : ?import:import -> symbol -> operator -> env -> env val reducible : ?force:bool -> env -> path -> bool - val reduce : ?force:bool -> env -> path -> ty list -> form + val reduce : ?force:bool -> env -> path -> etyarg list -> form val is_projection : env -> path -> bool val is_record_ctor : env -> path -> bool diff --git a/src/ecFol.ml b/src/ecFol.ml index 575e2902ba..739b98a1af 100644 --- a/src/ecFol.ml +++ b/src/ecFol.ml @@ -797,7 +797,7 @@ type sform = | SFimp of form * form | SFiff of form * form | SFeq of form * form - | SFop of (EcPath.path * ty list) * (form list) + | SFop of (EcPath.path * etyarg list) * (form list) | SFhoareF of hoareF | SFhoareS of hoareS diff --git a/src/ecFol.mli b/src/ecFol.mli index 0a48629aed..a4f14d8238 100644 --- a/src/ecFol.mli +++ b/src/ecFol.mli @@ -192,7 +192,7 @@ type sform = | SFimp of form * form | SFiff of form * form | SFeq of form * form - | SFop of (path * ty list) * (form list) + | SFop of (path * etyarg list) * (form list) | SFhoareF of hoareF | SFhoareS of hoareS diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index 22ac84ce7a..6942014121 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -624,7 +624,7 @@ let process_delta ?target (s, o, p) tc = match sform_of_form fp with | SFop ((_, tvi), []) -> begin (* FIXME: TC HOOK *) - let subst = EcTypes.Tvar.init (List.map fst tparams) tvi in + let subst = EcTypes.Tvar.init (List.fst tparams) (List.fst tvi) in let body = EcFol.Fsubst.subst_tvar subst body in let body = f_app body args topfp.f_ty in try EcReduction.h_red EcReduction.beta_red hyps body @@ -647,8 +647,8 @@ let process_delta ?target (s, o, p) tc = | `RtoL -> let fp = - (* FIXME: TC HOOK *) - let subst = EcTypes.Tvar.init (List.map fst tparams) tvi in + (* FIXME:TC *) + let subst = EcTypes.Tvar.init (List.fst tparams) (List.fst tvi) in let body = EcFol.Fsubst.subst_tvar subst body in let fp = f_app body args p.f_ty in try EcReduction.h_red EcReduction.beta_red hyps fp diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 57dc0487aa..5758a1172c 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -1387,9 +1387,10 @@ let t_elim_prind_r ?reduce ?accept (_mode : [`Case | `Ind]) tc = end; (oget (EcEnv.Op.scheme_of_prind env `Case p), tv, args) - | _ -> raise InvalidGoalShape + | _ -> raise InvalidGoalShape in - in t_apply_s p tv ~args:(args @ [f2]) ~sk tc + (* FIXME:TC *) + t_apply_s p (List.fst tv) ~args:(args @ [f2]) ~sk tc | _ -> raise TTC.NoMatch @@ -1469,7 +1470,8 @@ let t_split_prind ?reduce (tc : tcenv1) = | None -> raise InvalidGoalShape | Some (x, sk) -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + (* FIXME:TC *) + t_apply_s p (List.fst tv) ~args ~sk tc in t_lazy_match ?reduce t_split_r tc @@ -1489,10 +1491,12 @@ let t_or_intro_prind ?reduce (side : side) (tc : tcenv1) = match EcInductive.prind_is_iso_ors pri with | Some ((x, sk), _) when side = `Left -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + (* FIXME:TC *) + t_apply_s p (List.fst tv) ~args ~sk tc | Some (_, (x, sk)) when side = `Right -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + (* FIXME:TC *) + t_apply_s p (List.fst tv) ~args ~sk tc | _ -> raise InvalidGoalShape in t_lazy_match ?reduce t_split_r tc diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 150efddf1b..5bbd05225c 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -562,6 +562,8 @@ let f_match_core opts hyps (ue, ev) ~ptn subject = | Fop (op1, tys1), Fop (op2, tys2) -> begin if not (EcPath.p_equal op1 op2) then failure (); + let tys1 = List.fst tys1 in (* FIXME:TC *) + let tys2 = List.fst tys2 in (* FIXME:TC *) try List.iter2 (EcUnify.unify env ue) tys1 tys2 with EcUnify.UnificationFailure _ -> failure () end diff --git a/src/ecPV.ml b/src/ecPV.ml index fceadf797e..49e3e0fa43 100644 --- a/src/ecPV.ml +++ b/src/ecPV.ml @@ -840,7 +840,7 @@ module Mpv2 = struct if f_equal f1 f1' && f_equal f2 f2' then add_glob env mp1 mp2 eqs else add_eq local eqs f1' f2' | Fop(op1,tys1), Fop(op2,tys2) when EcPath.p_equal op1 op2 && - List.all2 (EcReduction.EqTest.for_type env) tys1 tys2 -> eqs + List.all2 (EcReduction.EqTest.for_etyarg env) tys1 tys2 -> eqs | Fapp(f1,a1), Fapp(f2,a2) -> List.fold_left2 (add_eq local) eqs (f1::a1) (f2::a2) | Ftuple es1, Ftuple es2 -> @@ -939,7 +939,7 @@ module Mpv2 = struct I postpone this for latter *) | Eop(op1,tys1), Eop(op2,tys2) when EcPath.p_equal op1 op2 && - List.all2 (EcReduction.EqTest.for_type env) tys1 tys2 -> eqs + List.all2 (EcReduction.EqTest.for_etyarg env) tys1 tys2 -> eqs | Eapp(f1,a1), Eapp(f2,a2) -> List.fold_left2 (add_eqs env local) eqs (f1::a1) (f2::a2) | Elet(lp1,a1,b1), Elet(lp2,a2,b2) -> diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 1394305f13..fd18688773 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -1135,6 +1135,7 @@ let pp_chained_orderings (ppe : PPEnv.t) t_ty pp_sub outer fmt (f, fs) = (fun fmt -> ignore (List.fold_left (fun fe (op, tvi, f) -> + let tvi = List.fst tvi (* FIXME:TC *) in let (nm, opname) = PPEnv.op_symb ppe op (Some (`Form, tvi, [t_ty fe; t_ty f])) in @@ -1478,7 +1479,8 @@ and try_pp_chained_orderings (ppe : PPEnv.t) outer fmt f = match collect [] None f with | None | Some (_, ([] | [_])) -> false | Some (f, fs) -> - pp_chained_orderings ppe f_ty pp_form_r outer fmt (f, fs); + pp_chained_orderings + ppe f_ty pp_form_r outer fmt (f, fs); true and try_pp_lossless (ppe : PPEnv.t) outer fmt f = @@ -1556,6 +1558,8 @@ and try_pp_notations (ppe : PPEnv.t) outer fmt f = and pp_form_core_r (ppe : PPEnv.t) outer fmt f = let pp_opapp ppe outer fmt (op, tys, es) = + let tys = List.fst tys in (* FIXME:TC *) + let rec dt_sub f = match destr_app f with | ({ f_node = Fop (p, tvi) }, args) -> Some (p, tvi, args) diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 98dedc9c87..b7a619ba9f 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -29,6 +29,7 @@ type 'a eqntest = env -> ?norm:bool -> 'a -> 'a -> bool module EqTest_base = struct (* ------------------------------------------------------------------ *) let for_type = EcCoreEqTest.for_type + let for_etyarg = EcCoreEqTest.for_etyarg (* ------------------------------------------------------------------ *) let is_unit env ty = for_type env tunit ty @@ -107,7 +108,7 @@ module EqTest_base = struct for_pv env ~norm p1 p2 | Eop(o1,ty1), Eop(o2,ty2) -> - p_equal o1 o2 && List.all2 (for_type env) ty1 ty2 + p_equal o1 o2 && List.all2 (for_etyarg env) ty1 ty2 | Equant(q1,b1,e1), Equant(q2,b2,e2) when qt_equal q1 q2 -> let alpha = check_bindings env alpha b1 b2 in @@ -344,6 +345,10 @@ let ensure b = if b then () else raise NotConv let check_ty env subst ty1 ty2 = ensure (EqTest_base.for_type env ty1 (subst.fs_ty ty2)) +let check_etyarg env subst etyarg1 etyarg2 = + let subst = Fsubst.esubst_of_fsubst subst in + ensure (EqTest_base.for_etyarg env etyarg1 (etyarg_subst subst etyarg2)) + let add_local (env, subst) (x1, ty1) (x2, ty2) = check_ty env subst ty1 ty2; env, @@ -456,7 +461,7 @@ let check_alpha_eq hyps f1 f2 = check_mp env subst p1 p2 | Fop(p1, ty1), Fop(p2, ty2) when EcPath.p_equal p1 p2 -> - List.iter2 (check_ty env subst) ty1 ty2 + List.iter2 (check_etyarg env subst) ty1 ty2 | Fapp(f1',args1), Fapp(f2',args2) when List.length args1 = List.length args2 -> @@ -657,6 +662,8 @@ let reduce_user_gen simplify ri env hyps f = let tys' = List.map (EcTypes.Tvar.subst tvi) tys' in + let tys = List.fst tys in (* FIXME:TC *) + begin try List.iter2 (EcUnify.unify env ue) tys tys' with EcUnify.UnificationFailure _ -> raise NotReducible end; @@ -915,7 +922,10 @@ let reduce_head simplify ri env hyps f = let body = EcFol.form_of_expr EcFol.mhr body in let body = EcFol.Fsubst.subst_tvar - (EcTypes.Tvar.init (List.map fst op.EcDecl.op_tparams) tys) body in + (EcTypes.Tvar.init + (List.map fst op.EcDecl.op_tparams) + (List.fst tys)) (* FIXME:TC *) + body in f_app (Fsubst.f_subst subst body) eargs f.f_ty @@ -1256,7 +1266,8 @@ let rec conv ri env f1 f2 stk = end | Fop(p1, ty1), Fop(p2,ty2) - when EcPath.p_equal p1 p2 && List.all2 (EqTest_i.for_type env) ty1 ty2 -> + when EcPath.p_equal p1 p2 + && List.all2 (EqTest_i.for_etyarg env) ty1 ty2 -> conv_next ri env f1 stk | Fapp(f1', args1), Fapp(f2', args2) @@ -1462,8 +1473,10 @@ module User = struct let rule = let rec rule (f : form) : EcTheory.rule_pattern = match EcFol.destr_app f with - | { f_node = Fop (p, tys) }, args -> - R.Rule (`Op (p, tys), List.map rule args) + | { f_node = Fop (p, etyargs) }, args + when List.for_all (fun (_, ws) -> List.is_empty ws) etyargs + -> (* FIXME: TC *) + R.Rule (`Op (p, List.fst etyargs), List.map rule args) | { f_node = Ftuple args }, [] -> R.Rule (`Tuple, List.map rule args) | { f_node = Fint i }, [] -> @@ -1542,15 +1555,12 @@ let check_bindings exn env s bd1 bd2 = let rec conv_oper env ob1 ob2 = match ob1, ob2 with | OP_Plain(e1,_), OP_Plain(e2,_) -> - Format.eprintf "[W]: ICI1@."; conv_expr env Fsubst.f_subst_id e1 e2 | OP_Plain({e_node = Eop(p,tys)},_), _ -> - Format.eprintf "[W]: ICI2@."; - let ob1 = get_open_oper env p tys in + let ob1 = get_open_oper env p (List.fst tys) in (* FIXME:TC *) conv_oper env ob1 ob2 | _, OP_Plain({e_node = Eop(p,tys)}, _) -> - Format.eprintf "[W]: ICI3@."; - let ob2 = get_open_oper env p tys in + let ob2 = get_open_oper env p (List.fst tys) in (* FIXME:TC *) conv_oper env ob1 ob2 | OP_Constr(p1,i1), OP_Constr(p2,i2) -> error_body (EcPath.p_equal p1 p2 && i1 = i2) @@ -1605,10 +1615,10 @@ let rec conv_pred env pb1 pb2 = match pb1, pb2 with | PR_Plain f1, PR_Plain f2 -> error_body (is_conv (LDecl.init env []) f1 f2) | PR_Plain {f_node = Fop(p,tys)}, _ -> - let pb1 = get_open_pred env p tys in + let pb1 = get_open_pred env p (List.fst tys) in (* FIXME:TC *) conv_pred env pb1 pb2 | _, PR_Plain {f_node = Fop(p,tys)} -> - let pb2 = get_open_pred env p tys in + let pb2 = get_open_pred env p (List.fst tys) in (* FIXME:TC *) conv_pred env pb1 pb2 | PR_Ind pr1, PR_Ind pr2 -> conv_ind env pr1 pr2 diff --git a/src/ecReduction.mli b/src/ecReduction.mli index 0f6ade878b..6c5e4be87e 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -25,15 +25,16 @@ type 'a eqntest = env -> ?norm:bool -> 'a -> 'a -> bool module EqTest : sig val for_type_exn : env -> ty -> ty -> unit - val for_type : ty eqtest - val for_pv : prog_var eqntest - val for_xp : xpath eqntest - val for_mp : mpath eqntest - val for_instr : instr eqntest - val for_stmt : stmt eqntest - val for_expr : expr eqntest - val for_msig : module_sig eqntest - val for_mexpr : module_expr eqntest + val for_type : ty eqtest + val for_etyarg : etyarg eqtest + val for_pv : prog_var eqntest + val for_xp : xpath eqntest + val for_mp : mpath eqntest + val for_instr : instr eqntest + val for_stmt : stmt eqntest + val for_expr : expr eqntest + val for_msig : module_sig eqntest + val for_mexpr : module_expr eqntest val is_unit : env -> ty -> bool val is_bool : env -> ty -> bool diff --git a/src/ecSection.ml b/src/ecSection.ml index 43e8a522f0..6a916fd09b 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -125,6 +125,14 @@ let on_binding (cb : cb) ((_, ty) : (EcIdent.t * ty)) = let on_bindings (cb : cb) (bds : (EcIdent.t * ty) list) = List.iter (on_binding cb) bds +let rec on_etyarg cb ((ty, tcw) : etyarg) = + on_ty cb ty; + List.iter (on_tcwitness cb) tcw + +and on_tcwitness cb ((args, p) : tcwitness) = + List.iter (on_etyarg cb) args; + cb (`Type p) (* FIXME:TC *) + let rec on_expr (cb : cb) (e : expr) = let cbrec = on_expr cb in @@ -136,7 +144,7 @@ let rec on_expr (cb : cb) (e : expr) = | Evar pv -> on_pv cb pv | Elet (lp, e1, e2) -> on_lp cb lp; List.iter cbrec [e1; e2] | Etuple es -> List.iter cbrec es - | Eop (p, tys) -> cb (`Op p); List.iter (on_ty cb) tys + | Eop (p, tys) -> cb (`Op p); List.iter (on_etyarg cb) tys | Eapp (e, es) -> List.iter cbrec (e :: es) | Eif (c, e1, e2) -> List.iter cbrec [c; e1; e2] | Ematch (e, es, ty) -> on_ty cb ty; List.iter cbrec (e :: es) @@ -222,7 +230,7 @@ let rec on_form (cb : cb) (f : EcFol.form) = | EcFol.Fif (f1, f2, f3) -> List.iter cbrec [f1; f2; f3] | EcFol.Fmatch (b, fs, ty) -> on_ty cb ty; List.iter cbrec (b :: fs) | EcFol.Flet (lp, f1, f2) -> on_lp cb lp; List.iter cbrec [f1; f2] - | EcFol.Fop (p, tys) -> cb (`Op p); List.iter (on_ty cb) tys + | EcFol.Fop (p, tys) -> cb (`Op p); List.iter (on_etyarg cb) tys | EcFol.Fapp (f, fs) -> List.iter cbrec (f :: fs) | EcFol.Ftuple fs -> List.iter cbrec fs | EcFol.Fproj (f, _) -> cbrec f @@ -594,15 +602,24 @@ let add_declared_op to_gen path opdecl = | OB_pred _ -> EcSubst.add_pddef to_gen.tg_subst path ([], f_local id ty) | _ -> assert false } - let tvar_fv ty = Mid.map (fun () -> 1) (Tvar.fv ty) + and tvar_fv ty = + Mid.map (fun () -> 1) (Tvar.fv ty) + + and etyargs_tvar_fv etyargs = + Mid.map (fun () -> 1) (EcTypes.etyargs_tvar_fv etyargs) + let fv_and_tvar_e e = let rec aux fv e = let fv = EcIdent.fv_union fv (tvar_fv e.e_ty) in match e.e_node with - | Eop(_, tys) -> List.fold_left (fun fv ty -> EcIdent.fv_union fv (tvar_fv ty)) fv tys + | Eop(_, etyargs) -> + EcIdent.fv_union fv (etyargs_tvar_fv etyargs) | Equant(_,d,e) -> - let fv = List.fold_left (fun fv (_,ty) -> EcIdent.fv_union fv (tvar_fv ty)) fv d in - aux fv e + let fv = + List.fold_left + (fun fv (_,ty) -> EcIdent.fv_union fv (tvar_fv ty)) + fv d + in aux fv e | _ -> e_fold aux fv e in aux e.e_fv e @@ -612,7 +629,8 @@ let fv_and_tvar_f f = let rec aux f = fv := EcIdent.fv_union !fv (tvar_fv f.f_ty); match f.f_node with - | Fop(_, tys) -> fv := List.fold_left (fun fv ty -> EcIdent.fv_union fv (tvar_fv ty)) !fv tys + | Fop(_, tys) -> + fv := EcIdent.fv_union !fv (etyargs_tvar_fv tys) | Fquant(_, d, f) -> fv := List.fold_left (fun fv (_,gty) -> EcIdent.fv_union fv (gty_fv_and_tvar gty)) !fv d; aux f diff --git a/src/ecSmt.ml b/src/ecSmt.ml index 4bfe27c791..e6794a77ac 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -699,6 +699,7 @@ and trans_app ((genv, lenv) as env : tenv * lenv) (f : form) args = | Fop (p, ts) -> let wop = trans_op genv p in + let ts = List.fst ts in (* FIXME:TC *) let tys = List.map (trans_ty (genv,lenv)) ts in apply_wop genv wop tys args diff --git a/src/ecTheory.ml b/src/ecTheory.ml index 2bd1a062e0..a70c648f12 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -66,7 +66,7 @@ and rule_pattern = | Var of EcIdent.t and top_rule_pattern = - [`Op of (EcPath.path * EcTypes.ty list) | `Tuple] + [`Op of (EcPath.path * ty list) | `Tuple] and rule = { rl_tyd : EcDecl.ty_params; diff --git a/src/ecTheory.mli b/src/ecTheory.mli index 07128363c6..edcf3637a2 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -63,7 +63,7 @@ and rule_pattern = | Var of EcIdent.t and top_rule_pattern = - [`Op of (EcPath.path * EcTypes.ty list) | `Tuple] + [`Op of (EcPath.path * ty list) | `Tuple] and rule = { rl_tyd : EcDecl.ty_params; diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 1fbb334036..052a1c9d68 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -135,7 +135,7 @@ let expr_compatible exn env s e1 e2 = let get_open_oper exn env p tys = let oper = EcEnv.Op.by_path p env in - let _, okind = EcSubst.open_oper oper tys in + let _, okind = EcSubst.open_oper oper (List.fst tys) in (* FIXME:TC *) match okind with | OB_oper (Some ob) -> ob | _ -> raise exn @@ -194,7 +194,7 @@ and opbranch_compatible exn env s ob1 ob2 = let get_open_pred exn env p tys = let oper = EcEnv.Op.by_path p env in - let _, okind = EcSubst.open_oper oper tys in + let _, okind = EcSubst.open_oper oper (List.fst tys) in (* FIXME:TC *) match okind with | OB_pred (Some pb) -> pb | _ -> raise exn diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 6d409f6a12..08b3eeab26 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -493,7 +493,7 @@ and expr_node = | Eint of BI.zint (* int. literal *) | Elocal of EcIdent.t (* let-variables *) | Evar of prog_var (* module variable *) - | Eop of EcPath.path * ty list (* op apply to type args *) + | Eop of EcPath.path * etyarg list (* op apply to type args *) | Eapp of expr * expr list (* op. application *) | Equant of equantif * ebindings * expr (* fun/forall/exists *) | Elet of lpattern * expr * expr (* let binding *) @@ -502,12 +502,49 @@ and expr_node = | Ematch of expr * expr list * ty (* match _ with _ *) | Eproj of expr * int (* projection of a tuple *) +and etyarg = ty * tcwitness list and equantif = [ `ELambda | `EForall | `EExists ] and ebinding = EcIdent.t * ty and ebindings = ebinding list +and tcwitness = + (ty * tcwitness list) list * EcPath.path + type closure = (EcIdent.t * ty) list * expr +(* -------------------------------------------------------------------- *) +let rec tcw_fv ((ws, _) : tcwitness) = + List.fold_left + (fun fv (ty, tcws) -> fv_union fv (fv_union ty.ty_fv (tcws_fv tcws))) + Mid.empty ws + +and tcws_fv (tcws : tcwitness list) = + List.fold_left + (fun fv tcw -> fv_union fv (tcw_fv tcw)) + Mid.empty tcws + +let etyarg_fv ((ty, tcws) : etyarg) = + fv_union ty.ty_fv (tcws_fv tcws) + +let etyargs_fv (tyargs : etyarg list) = + List.fold_left + (fun fv tyarg -> fv_union fv (etyarg_fv tyarg)) + Mid.empty tyargs + +(* -------------------------------------------------------------------- *) +let rec tcw_equal ((tcw1, p1) : tcwitness) ((tcw2, p2) : tcwitness) = + EcPath.p_equal p1 p2 && List.all2 etyarg_equal tcw1 tcw2 + +and etyarg_equal ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = + ty_equal ty1 ty2 && List.all2 tcw_equal tcws1 tcws2 + +(* -------------------------------------------------------------------- *) +let rec tcw_hash ((tcw, p) : tcwitness) = + Why3.Hashcons.combine_list etyarg_hash (p_hash p) tcw + +and etyarg_hash ((ty, tcws) : etyarg) = + Why3.Hashcons.combine_list tcw_hash (ty_hash ty) tcws + (* -------------------------------------------------------------------- *) let e_equal = ((==) : expr -> expr -> bool) let e_hash = fun e -> e.e_tag @@ -532,12 +569,11 @@ let pv_fv pv = EcPath.x_fv Mid.empty pv.pv_name let fv_node e = let union ex = - List.fold_left (fun s e -> fv_union s (ex e)) Mid.empty - in + List.fold_left (fun s e -> fv_union s (ex e)) Mid.empty in match e with | Eint _ -> Mid.empty - | Eop (_, tys) -> union (fun a -> a.ty_fv) tys + | Eop (_, tyargs) -> etyargs_fv tyargs | Evar v -> pv_fv v | Elocal id -> fv_singleton id | Eapp (e, es) -> union e_fv (e :: es) @@ -569,7 +605,7 @@ module Hexpr = Why3.Hashcons.Make (struct | Eop (p1, tys1), Eop (p2, tys2) -> (EcPath.p_equal p1 p2) - && (List.all2 ty_equal tys1 tys2) + && (List.all2 etyarg_equal tys1 tys2) | Eapp (e1, es1), Eapp (e2, es2) -> (e_equal e1 e2) @@ -612,9 +648,8 @@ module Hexpr = Why3.Hashcons.Make (struct | Elocal x -> Hashtbl.hash x | Evar x -> pv_hash x - | Eop (p, tys) -> - Why3.Hashcons.combine_list ty_hash - (EcPath.p_hash p) tys + | Eop (p, tyargs) -> + Why3.Hashcons.combine_list etyarg_hash (EcPath.p_hash p) tyargs | Eapp (e, es) -> Why3.Hashcons.combine_list e_hash (e_hash e) es @@ -654,7 +689,13 @@ let e_tt = mk_expr (Eop (EcCoreLib.CI_Unit.p_tt, [])) tunit let e_int = fun i -> mk_expr (Eint i) tint let e_local = fun x ty -> mk_expr (Elocal x) ty let e_var = fun x ty -> mk_expr (Evar x) ty -let e_op = fun x targs ty -> mk_expr (Eop (x, targs)) ty + +let e_op_tc x targs ty = + mk_expr (Eop (x, targs)) ty + +let e_op x targs ty = + e_op_tc x (List.map (fun ty -> (ty, [])) targs) ty + let e_let = fun pt e1 e2 -> mk_expr (Elet (pt, e1, e2)) e2.e_ty let e_tuple = fun es -> match es with @@ -762,7 +803,7 @@ module ExprSmart = struct let e_op (e, (p, tys, ty)) (p', tys', ty') = if p == p' && tys == tys' && ty == ty' then e - else e_op p' tys' ty' + else e_op_tc p' tys' ty' let e_app (e, (x, args, ty)) (x', args', ty') = if x == x' && args == args' && ty == ty' @@ -803,29 +844,37 @@ module ExprSmart = struct else e_quantif q' b' body' end +let rec tcw_map fty ((w, p) as wp : tcwitness) : tcwitness= + let for1 ((ty, ws) as arg) = + SmartPair.mk arg (fty ty) (List.Smart.map (tcw_map fty) ws) + in SmartPair.mk wp (List.map for1 w) p + +let etyarg_map fty ((ty, tcw) as arg : etyarg) : etyarg = + SmartPair.mk arg (fty ty) (List.Smart.map (tcw_map fty) tcw) + let e_map fty fe e = match e.e_node with | Eint _ | Elocal _ | Evar _ -> e - | Eop (p, tys) -> - let tys' = List.Smart.map fty tys in - let ty' = fty e.e_ty in - ExprSmart.e_op (e, (p, tys, e.e_ty)) (p, tys', ty') + | Eop (p, tyargs) -> + let tyargs' = List.Smart.map (etyarg_map fty) tyargs in + let ty' = fty e.e_ty in + ExprSmart.e_op (e, (p, tyargs, e.e_ty)) (p, tyargs', ty') | Eapp (e1, args) -> let e1' = fe e1 in let args' = List.Smart.map fe args in let ty' = fty e.e_ty in - ExprSmart.e_app (e, (e1, args, e.e_ty)) (e1', args', ty') + ExprSmart.e_app (e, (e1, args, e.e_ty)) (e1', args', ty') | Elet (lp, e1, e2) -> let e1' = fe e1 in let e2' = fe e2 in - ExprSmart.e_let (e, (lp, e1, e2)) (lp, e1', e2') + ExprSmart.e_let (e, (lp, e1, e2)) (lp, e1', e2') | Etuple le -> let le' = List.Smart.map fe le in - ExprSmart.e_tuple (e, le) le' + ExprSmart.e_tuple (e, le) le' | Eproj (e1, i) -> let e' = fe e1 in @@ -957,6 +1006,34 @@ let subst_lpattern (s: e_subst) (lp:lpattern) = in (s, ExprSmart.l_record (lp, (p, xs)) (s.es_p p, xs')) +(* -------------------------------------------------------------------- *) +let rec tcw_subst (s : e_subst) ((tcws, p) as tcw : tcwitness) : tcwitness = + let tcws' = List.Smart.map (etyarg_subst s) tcws in + let p' = s.es_p p in + SmartPair.mk tcw tcws' p' + +and etyarg_subst (s : e_subst) ((ty, tcws) as tyarg : etyarg) : etyarg = + let ty' = s.es_ty ty in + let tcws' = List.Smart.map (tcw_subst s) tcws in + SmartPair.mk tyarg ty' tcws' + +(* -------------------------------------------------------------------- *) +let rec etyargs_tvar_fv (etyargs : etyarg list) = + List.fold_left + (fun fv etyarg -> Sid.union fv (etyarg_tvar_fv etyarg)) + Sid.empty etyargs + +and etyarg_tvar_fv ((ty, tcws) : etyarg) : Sid.t = + Sid.union (Tvar.fv ty) (tcws_tvar_fv tcws) + +and tcws_tvar_fv (tcws : tcwitness list) = + List.fold_left + (fun fv tcw -> Sid.union fv (tcw_tvar_fv tcw)) + Sid.empty tcws + +and tcw_tvar_fv ((etyargs, _) : tcwitness) : Sid.t = + etyargs_tvar_fv etyargs + (* -------------------------------------------------------------------- *) let rec e_subst (s: e_subst) e = match e.e_node with @@ -971,36 +1048,36 @@ let rec e_subst (s: e_subst) e = | Evar pv -> let pv' = pv_subst s.es_xp pv in let ty' = s.es_ty e.e_ty in - ExprSmart.e_var (e, (pv, e.e_ty)) (pv', ty') + ExprSmart.e_var (e, (pv, e.e_ty)) (pv', ty') - | Eapp ({ e_node = Eop (p, tys) }, args) when Mp.mem p s.es_opdef -> - let tys = List.Smart.map s.es_ty tys in + | Eapp ({ e_node = Eop (p, tyargs) }, args) when Mp.mem p s.es_opdef -> + let tys = List.Smart.map (etyarg_subst s) tyargs in let ty = s.es_ty e.e_ty in let body = oget (Mp.find_opt p s.es_opdef) in - e_subst_op ~freshen:s.es_freshen ty tys (List.map (e_subst s) args) body + e_subst_op ~freshen:s.es_freshen ty tys (List.map (e_subst s) args) body - | Eop (p, tys) when Mp.mem p s.es_opdef -> - let tys = List.Smart.map s.es_ty tys in + | Eop (p, tyargs) when Mp.mem p s.es_opdef -> + let tys = List.Smart.map (etyarg_subst s) tyargs in let ty = s.es_ty e.e_ty in let body = oget (Mp.find_opt p s.es_opdef) in - e_subst_op ~freshen:s.es_freshen ty tys [] body + e_subst_op ~freshen:s.es_freshen ty tys [] body - | Eop (p, tys) -> - let p' = s.es_p p in - let tys' = List.Smart.map s.es_ty tys in - let ty' = s.es_ty e.e_ty in - ExprSmart.e_op (e, (p, tys, e.e_ty)) (p', tys', ty') + | Eop (p, tyargs) -> + let p' = s.es_p p in + let tyargs' = List.Smart.map (etyarg_subst s) tyargs in + let ty' = s.es_ty e.e_ty in + ExprSmart.e_op (e, (p, tyargs, e.e_ty)) (p', tyargs', ty') | Elet (lp, e1, e2) -> let e1' = e_subst s e1 in let s, lp' = subst_lpattern s lp in let e2' = e_subst s e2 in - ExprSmart.e_let (e, (lp, e1, e2)) (lp', e1', e2') + ExprSmart.e_let (e, (lp, e1, e2)) (lp', e1', e2') | Equant (q, b, e1) -> let s, b' = add_locals s b in let e1' = e_subst s e1 in - ExprSmart.e_quant (e, (q, b, e1)) (q, b', e1') + ExprSmart.e_quant (e, (q, b, e1)) (q, b', e1') | _ -> e_map s.es_ty (e_subst s) e @@ -1009,7 +1086,7 @@ and e_subst_op ~freshen ety tys args (tyids, e) = (* FIXME: is es_freshen value correct? *) let e = - let sty = Tvar.init tyids tys in + let sty = Tvar.init tyids (List.fst tys) in (* FIXME *) let sty = ty_subst { ty_subst_id with ts_v = sty; } in let sty = { e_subst_id with es_freshen = freshen; diff --git a/src/ecTypes.mli b/src/ecTypes.mli index cece6e700a..b984d87250 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -106,10 +106,10 @@ module Tuni : sig end module Tvar : sig - val subst1 : (EcIdent.t * ty) -> ty -> ty - val subst : ty Mid.t -> ty -> ty - val init : EcIdent.t list -> ty list -> ty Mid.t - val fv : ty -> Sid.t + val subst1 : (EcIdent.t * ty) -> ty -> ty + val subst : ty Mid.t -> ty -> ty + val init : EcIdent.t list -> ty list -> ty Mid.t + val fv : ty -> Sid.t end (* -------------------------------------------------------------------- *) @@ -183,7 +183,7 @@ and expr_node = | Eint of zint (* int. literal *) | Elocal of EcIdent.t (* let-variables *) | Evar of prog_var (* module variable *) - | Eop of EcPath.path * ty list (* op apply to type args *) + | Eop of EcPath.path * etyarg list (* op apply to type args *) | Eapp of expr * expr list (* op. application *) | Equant of equantif * ebindings * expr (* fun/forall/exists *) | Elet of lpattern * expr * expr (* let binding *) @@ -192,16 +192,26 @@ and expr_node = | Ematch of expr * expr list * ty (* match _ with _ *) | Eproj of expr * int (* projection of a tuple *) +and etyarg = ty * tcwitness list and equantif = [ `ELambda | `EForall | `EExists ] and ebinding = EcIdent.t * ty and ebindings = ebinding list +and tcwitness = + (ty * tcwitness list) list * EcPath.path + type closure = (EcIdent.t * ty) list * expr (* -------------------------------------------------------------------- *) val qt_equal : equantif -> equantif -> bool (* -------------------------------------------------------------------- *) +val etyarg_fv : etyarg -> int Mid.t +val etyargs_fv : etyarg list -> int Mid.t +val etyarg_hash : etyarg -> int +val etyarg_equal : etyarg -> etyarg -> bool +val etyarg_map : (ty -> ty) -> etyarg -> etyarg + val e_equal : expr -> expr -> bool val e_compare : expr -> expr -> int val e_hash : expr -> int @@ -214,6 +224,7 @@ val e_int : zint -> expr val e_decimal : zint * (int * zint) -> expr val e_local : EcIdent.t -> ty -> expr val e_var : prog_var -> ty -> expr +val e_op_tc : EcPath.path -> etyarg list -> ty -> expr val e_op : EcPath.path -> ty list -> ty -> expr val e_app : expr -> expr list -> ty -> expr val e_let : lpattern -> expr -> expr -> expr @@ -282,3 +293,7 @@ val e_subst : e_subst -> expr -> expr val e_mapty : (ty -> ty) -> expr -> expr val e_uni : (uid -> ty option) -> expr -> expr + +val etyarg_tvar_fv : etyarg -> Sid.t +val etyargs_tvar_fv : etyarg list -> Sid.t +val etyarg_subst : e_subst -> etyarg -> etyarg diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 3db1e3bb31..23235f9429 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -340,14 +340,14 @@ let gen_select_op [ flc (id, ty, ue) ] | None -> - let ops () = + let ops () : (OpSelect.opsel * ty * EcUnify.unienv * opmatch) list = let ops = EcUnify.select_op ~filter:ue_filter tvi env name ue psig in let ops = opsc |> ofold (fun opsc -> List.mbfilter (by_scope opsc)) ops in let ops = match List.mbfilter by_current ops with [] -> ops | ops -> ops in let ops = match List.mbfilter by_tc ops with [] -> ops | ops -> ops in (List.map fop ops) - and pvs () = + and pvs () : (OpSelect.opsel * ty * EcUnify.unienv * opmatch) list = let me, pvs = match EcEnv.Memory.get_active env, actonly with | None, true -> (None, []) diff --git a/src/ecUtils.ml b/src/ecUtils.ml index 10a7d054bd..e5d68d074e 100644 --- a/src/ecUtils.ml +++ b/src/ecUtils.ml @@ -113,6 +113,12 @@ type 'a tuple8 = 'a * 'a * 'a * 'a * 'a * 'a * 'a * 'a type 'a tuple9 = 'a * 'a * 'a * 'a * 'a * 'a * 'a * 'a * 'a type 'a pair = 'a * 'a +(* -------------------------------------------------------------------- *) +module SmartPair = struct + let mk ((a, b) as p) a' b' = + if a == a' && b == b' then p else (a', b') +end + (* -------------------------------------------------------------------- *) let t2_map (f : 'a -> 'b) (x, y) = (f x, f y) diff --git a/src/ecUtils.mli b/src/ecUtils.mli index f670b77705..3ab055c879 100644 --- a/src/ecUtils.mli +++ b/src/ecUtils.mli @@ -68,6 +68,11 @@ type 'a tuple8 = 'a * 'a * 'a * 'a * 'a * 'a * 'a * 'a type 'a tuple9 = 'a * 'a * 'a * 'a * 'a * 'a * 'a * 'a * 'a type 'a pair = 'a tuple2 +(* -------------------------------------------------------------------- *) +module SmartPair : sig + val mk : 'a * 'b -> 'a -> 'b -> 'a * 'b +end + (* -------------------------------------------------------------------- *) val in_seq1: ' a -> 'a list diff --git a/src/phl/ecPhlWhile.ml b/src/phl/ecPhlWhile.ml index e56caedebb..e8dd5f2d0b 100644 --- a/src/phl/ecPhlWhile.ml +++ b/src/phl/ecPhlWhile.ml @@ -394,7 +394,7 @@ module ASyncWhile = struct | Fint z -> e_int z | Flocal x -> e_local x fp.f_ty - | Fop (p, tys) -> e_op p tys fp.f_ty + | Fop (p, tys) -> e_op_tc p tys fp.f_ty | Fapp (f, fs) -> e_app (aux f) (List.map aux fs) fp.f_ty | Ftuple fs -> e_tuple (List.map aux fs) | Fproj (f, i) -> e_proj (aux f) i fp.f_ty From 07dc332d7ac5d77d94284bc77c10614176303277 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Wed, 24 Nov 2021 17:22:36 +0000 Subject: [PATCH 033/113] Added normalize to typeclass --- examples/typeclass.ec | 102 +++++++++++++++--------------------------- 1 file changed, 36 insertions(+), 66 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 85289b47b2..9bb50af094 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -24,34 +24,21 @@ type class countable = { type class magma = { op mmul : magma -> magma -> magma }. - -(* TODO: when removing the type argument of associative, no explicit error message. - Any inherited operator should have self as type argument. - Type error slicing to do as well.*) type class semigroup <: magma = { axiom mmulA : associative mmul<:semigroup> }. -(* TODO: why do I need this instead of using left_id and right_id directly? - Or even specifying the type? - Or even specifying semigroup and not magma? *) - -op mmul_ ['a <: semigroup] = mmul<:'a>. - type class monoid <: semigroup = { op mid : monoid - axiom mmulr0 : left_id<:monoid, monoid> mid mmul_<:monoid> - axiom mmul0r : right_id<:monoid, monoid> mid mmul_<:monoid> + axiom mmulr0 : right_id mid mmul<:monoid> + axiom mmul0r : left_id mid mmul<:monoid> }. -(* TODO: same. *) -pred left_inverse_mid_mmul ['a <: monoid] (inv : 'a -> 'a) = left_inverse mid inv mmul. - type class group <: monoid = { op minv : group -> group - axiom mmulN : left_inverse_mid_mmul minv + axiom mmulN : left_inverse mid minv mmul }. type class ['a <: group] action = { @@ -63,45 +50,41 @@ type class ['a <: group] action = { forall (g h : 'a) (x : action), amul (mmul g h) x = amul g (amul h x) }. -(* TODO: make one of these work, and then finish the hierarchy here: +(* TODO: finish the hierarchy here: https://en.wikipedia.org/wiki/Magma_(algebra) *) type fingroup <: group & finite. -(* TODO: we may want to rename mmul to ( + ) and build this from group *) -type class comgroup = { - op gzero : comgroup - op gopp : comgroup -> comgroup - op gadd : comgroup -> comgroup -> comgroup - - axiom addr0 : left_id gzero gadd - axiom addrN : left_inverse gzero gopp gadd - axiom addrC : commutative gadd - axiom addrA : associative gadd -}. - (* -------------------------------------------------------------------- *) (* Advanced algebraic structures *) -(*TODO: we don't have here the issues we had with semigroup and monoid, - probably because left_distributive was adequatly typed by ( * ) - before beign applied to ( + ). *) +type class comgroup = { + op zero : comgroup + op ([-]) : comgroup -> comgroup + op ( + ) : comgroup -> comgroup -> comgroup + + axiom addr0 : right_id zero ( + ) + axiom addrN : left_inverse zero ([-]) ( + ) + axiom addrC : commutative ( + ) + axiom addrA : associative ( + ) +}. + type class comring <: comgroup = { op one : comring op ( * ) : comring -> comring -> comring - axiom mulr1 : left_id one ( * ) + axiom mulr1 : right_id one ( * ) axiom mulrC : commutative ( * ) axiom mulrA : associative ( * ) - axiom mulrDl : left_distributive ( * ) gadd + axiom mulrDl : left_distributive ( * ) ( + ) }. type class ['a <: comring] commodule <: comgroup = { op ( ** ) : 'a -> commodule -> commodule axiom scalerDl : forall (a b : 'a) (x : commodule), - (gadd a b) ** x = gadd (a ** x) (b ** x) + (a + b) ** x = (a ** x) + (b ** x) axiom scalerDr : forall (a : 'a) (x y : commodule), - a ** (gadd x y) = gadd (a ** x) (a ** y) + a ** (x + y) = (a ** x) + (a ** y) }. @@ -124,7 +107,6 @@ op all_countable ['a <: countable] (p : 'a -> bool) = (* -------------------------------------------------------------------- *) (* Set theory *) -(* TODO: why is the rewrite/all_finite needed? *) lemma all_finiteP ['a <: finite] p : (all_finite p) <=> (forall (x : 'a), p x). proof. by rewrite/all_finite allP; split => Hp x; rewrite Hp // enumP. qed. @@ -146,7 +128,7 @@ proof. by rewrite all_finiteP all_countableP. qed. op bool_enum = [true; false]. -(* TODO: we want to be ale to give the list directly.*) +(* TODO: we want to be able to give the list directly.*) instance finite with bool op enum = bool_enum. @@ -154,39 +136,20 @@ realize enumP. proof. by case. qed. (* -------------------------------------------------------------------- *) -(* Simple algebraic structures *) +(* Advanced algebraic structures *) op izero = 0. - instance comgroup with int - op gzero = izero - op gadd = CoreInt.add - op gopp = CoreInt.opp. + op zero = izero + op ( + ) = CoreInt.add + op ([-]) = CoreInt.opp. -realize addr0. -apply: addr0. -have : left_id izero Int.(+). - -locate left_id. - -rewrite /left_id. -rewrite /izero. -move=> x /=. -rewrite /izero. - - by trivial. +(* TODO: might be any of the two addr0, also apply fails but rewrite works. *) +realize addr0 by rewrite addr0. realize addrN by trivial. -(* TODO: what? *) -(* -realize addrC by apply addrC. -realize addrC by apply Ring.IntID.addrC. -*) -realize addrC by admit. -realize addrA by admit. - -(* -------------------------------------------------------------------- *) -(* Advanced algebraic structures *) +realize addrC by rewrite addrC. +realize addrA by rewrite addrA. op ione = 1. @@ -200,6 +163,7 @@ instance comring with int realize mulr1 by trivial. realize mulrC by rewrite mulrC. realize mulrA by rewrite mulrA. + realize mulrDl. proof. print mulrDl. @@ -212,9 +176,15 @@ qed. type 'a poly = 'a list. +op rev_normalize_rev ['a <: comgroup] (p : 'a poly) : 'a poly = + with p = "[]" => [] + with p = h :: t => if h = zero<:'a> then rev_normalize_rev t else p. + +op normalize ['a <: comgroup] (p : 'a poly) : 'a poly = rev (rev_normalize_rev (rev p)). + op pzero ['a] : 'a poly = []. op padd ['a <: comgroup] p q = - mkseq (fun n => (nth zero<:'a> p n) + (nth zero<:'a> q n)) (max (size p) (size q)). + normalize (mkseq (fun n => (nth zero<:'a> p n) + (nth zero<:'a> q n)) (max (size p) (size q))). op pinv ['a <: comgroup] = map [-]<:'a>. op pone ['a <: comring] = [one <:'a>]. op pmul ['a <: comring] : 'a poly -> 'a poly -> 'a poly. From 64a620f335e5cef1840ab7533dace00ff670cec8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Tue, 30 Nov 2021 10:48:42 +0100 Subject: [PATCH 034/113] Added typeclass examples modifications --- examples/typeclass.ec | 134 +++++++++++++++++++++--------------------- 1 file changed, 67 insertions(+), 67 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 9bb50af094..65ba6f068e 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -8,26 +8,42 @@ require import AllCore List. (* -------------------------------------------------------------------- *) (* Set theory *) +type class witness = { + op witness : witness +}. + +print witness. + type class finite = { op enum : finite list axiom enumP : forall (x : finite), x \in enum }. +print enumP. + type class countable = { op count : int -> countable axiom countP : forall (x : countable), exists (n : int), x = count n }. +(* TODO: printing typeclasses *) +(* print countable. *) + (* -------------------------------------------------------------------- *) (* Simple algebraic structures *) type class magma = { op mmul : magma -> magma -> magma }. + +print mmul. + type class semigroup <: magma = { axiom mmulA : associative mmul<:semigroup> }. +print associative. + type class monoid <: semigroup = { op mid : monoid @@ -41,18 +57,31 @@ type class group <: monoid = { axiom mmulN : left_inverse mid minv mmul }. -type class ['a <: group] action = { - op amul : 'a -> action -> action +print minv. + +type class ['a <: semigroup] semigroup_action = { + op amul : 'a -> semigroup_action -> semigroup_action - axiom identity : - forall (x : action), amul mid x = x axiom compatibility : - forall (g h : 'a) (x : action), amul (mmul g h) x = amul g (amul h x) + forall (g h : 'a) (x : semigroup_action), amul (mmul g h) x = amul g (amul h x) }. -(* TODO: finish the hierarchy here: - https://en.wikipedia.org/wiki/Magma_(algebra) *) -type fingroup <: group & finite. +print compatibility. + +(* TODO: nice error message, already known *) +(* +type class ['a <: monoid] monoid_action <: 'a semigroup_action = { + axiom identity : + forall (x : id_action), amul mid x = x +}. +*) + +type class ['a <: monoid] monoid_action <: 'a semigroup_action = { + axiom identity : forall (x : monoid_action), amul mid<:'a> x = x +}. + +(* TODO: why again is this not possible/a good idea? *) +(* type class finite_group <: group & finite = {}. *) (* -------------------------------------------------------------------- *) (* Advanced algebraic structures *) @@ -88,6 +117,15 @@ type class ['a <: comring] commodule <: comgroup = { }. +(* ==================================================================== *) +(* Abstract type examples *) + +(* TODO: finish the hierarchy here: + https://en.wikipedia.org/wiki/Magma_(algebra) *) +type foo <: witness. +type fingroup <: group & finite. + + (* ==================================================================== *) (* Operator examples *) @@ -100,6 +138,21 @@ op all_finite ['a <: finite] (p : 'a -> bool) = op all_countable ['a <: countable] (p : 'a -> bool) = forall (n : int), p (count<:'a> n). +(* -------------------------------------------------------------------- *) +(* Simple algebraic structures *) + +(* TODO: weird issue and/or inapropriate error message *) +(* +print amul. + +op foo1 ['a <: semigroup, 'b <: 'a semigroup_action] = amul<:'a,'b>. +op foo2 ['a <: semigroup, 'b <: 'a semigroup_action] (g : 'a) (x : 'b) = amul g x. +op foo3 ['a <: semigroup, 'b <: 'a semigroup_action] (g : 'a) (x : 'b) = amul<:'a,'b> g x. +*) + +op big ['a, 'b <: monoid] (P : 'a -> bool) (F : 'a -> 'b) (r : 'a list) = + foldr mmul mid (map F (filter P r)). + (* ==================================================================== *) (* Lemma examples *) @@ -120,6 +173,7 @@ qed. lemma all_finite_countable ['a <: finite & countable] (p : 'a -> bool) : (all_finite p) <=> (all_countable p). proof. by rewrite all_finiteP all_countableP. qed. + (* ==================================================================== *) (* Instance examples *) @@ -151,6 +205,11 @@ realize addrN by trivial. realize addrC by rewrite addrC. realize addrA by rewrite addrA. +op foo = 1 + 3. + +print ( + ). +print foo. + op ione = 1. (* TODO: this automatically fetches the only instance of comgroup we have defined for int. @@ -174,65 +233,6 @@ proof. admit. qed. -type 'a poly = 'a list. - -op rev_normalize_rev ['a <: comgroup] (p : 'a poly) : 'a poly = - with p = "[]" => [] - with p = h :: t => if h = zero<:'a> then rev_normalize_rev t else p. - -op normalize ['a <: comgroup] (p : 'a poly) : 'a poly = rev (rev_normalize_rev (rev p)). - -op pzero ['a] : 'a poly = []. -op padd ['a <: comgroup] p q = - normalize (mkseq (fun n => (nth zero<:'a> p n) + (nth zero<:'a> q n)) (max (size p) (size q))). -op pinv ['a <: comgroup] = map [-]<:'a>. -op pone ['a <: comring] = [one <:'a>]. -op pmul ['a <: comring] : 'a poly -> 'a poly -> 'a poly. -op ipmul ['a <: comring] (x : 'a) = map (( * ) x). - -(* TODO: we may not need to specify the <:'a>. *) -instance comgroup with ['a <: comring] 'a poly - op zero = pzero<:'a> - op (+) = padd<:'a> - op ([-]) = pinv<:'a>. - -realize addr0. -proof. - (* TODO: error message. *) - move => x (*y*). - (* Top.Logic turned into top... *) - (* TODO: error message. *) - (*rewrite //.*) - (* TODO: wow I just broke something. *) - (* rewrite /padd /pzero. *) - admit. -qed. - -realize addrN. -proof. - (* TODO: all truly is broken. *) - (*rewrite /pzero /padd.*) - admit. -qed. - -realize addrC by admit. -realize addrA by admit. - -instance comring with ['a <: comring] 'a poly - op one = pone<:'a> - op ( * ) = pmul<:'a>. - -realize mulr1 by admit. -realize mulrC by admit. -realize mulrA by admit. -realize mulrDl by admit. - -instance 'a commodule with ['a <: comring] 'a poly - op ( ** ) = ipmul<:'a>. - -realize scalerDl by admit. -realize scalerDr by admit. - From bb7e662a3d302667a9ca71e2ac5bd85de315d269 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 16 Feb 2022 14:38:13 +0100 Subject: [PATCH 035/113] Fails gracefully when applying a tactic on a completed proof. fix #133 --- src/ecHiTacticals.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/ecHiTacticals.ml b/src/ecHiTacticals.ml index 582cd1f1d9..8221eca6cf 100644 --- a/src/ecHiTacticals.ml +++ b/src/ecHiTacticals.ml @@ -343,6 +343,9 @@ and process1 (ttenv : ttenv) (t : ptactic) (tc : tcenv1) = (* -------------------------------------------------------------------- *) let process (ttenv : ttenv) (t : ptactic list) (pf : proof) = + if EcCoreGoal.closed pf then + tc_error (proofenv_of_proof pf) "all goals are closed"; + let tc = tcenv1_of_proof pf in let hd = FApi.tc1_handle tc in let tc = process1_seq ttenv t tc in From 2aab4c9e0d98850f0b80f9c2c534175067a4ee99 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 16 Feb 2022 21:39:51 +0100 Subject: [PATCH 036/113] Unfold non-transparent operators in `case` & `elim`. When `case` or `elim` search for a redex, allows the reduction to unfold non-transparent operators. This does not affect tactics that does case/elim internally (e.g., />). fix #132 --- src/ecHiGoal.ml | 27 +++++++++++++++++++-------- src/ecLowGoal.ml | 36 ++++++++++++++++++------------------ src/ecLowGoal.mli | 3 +-- src/ecProofTyping.ml | 2 +- src/ecReduction.ml | 12 +++++++----- src/ecReduction.mli | 2 +- src/phl/ecPhlLoopTx.ml | 4 ++-- 7 files changed, 49 insertions(+), 37 deletions(-) diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index fa0f87e8db..163e276556 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -270,7 +270,7 @@ module LowRewrite = struct else None else None and pt2 = obind base - (EcReduction.h_red_opt EcReduction.full_red hyps ax) + (EcReduction.h_red_opt (EcReduction.full_red ~opaque:false) hyps ax) in (otolist pt1) @ (otolist pt2)) in let rec doit reduce = @@ -585,8 +585,9 @@ let process_delta ?target (s, o, p) tc = in - let ri = { EcReduction.full_red with - delta_p = (fun p -> if Some p = dp then `Force else `Yes)} in + let ri = + let delta_p p = if Some p = dp then `Force else `Yes in + { (EcReduction.full_red ~opaque:false) with delta_p } in let na = List.length args in match s with @@ -1191,7 +1192,7 @@ let rec process_mintros_1 ?(cf = true) ttenv pis gs = | SFimp (_, fp) -> ("H", None, `Hyp, fp) | _ -> begin - match EcReduction.h_red_opt EcReduction.full_red hyps fp with + match EcReduction.h_red_opt (EcReduction.full_red ~opaque:false) hyps fp with | None -> ("_", None, `None, f_true) | Some f -> destruct f end @@ -1342,7 +1343,10 @@ let rec process_mintros_1 ?(cf = true) ttenv pis gs = end in - let tc = t_ors [t_elimT_ind `Case; t_elim; t_elim_prind `Case] in + let tc = t_ors [ + t_elimT_ind ~reduce:(`Full true) `Case; + t_elim ~reduce:(`Full true); + t_elim_prind ~reduce:(`Full true) `Case] in let tc = fun g -> try tc g @@ -1360,7 +1364,7 @@ let rec process_mintros_1 ?(cf = true) ttenv pis gs = ((prind, delta), withor, (cnt : icasemode_full option)) pis tc = let cnt = cnt |> odfl (`AtMost 1) in - let red = if delta then `Full else `NoDelta in + let red = if delta then `Full true else `NoDelta in let t_case = let t_and, t_or = @@ -1873,7 +1877,11 @@ let process_split (tc : tcenv1) = let process_elim (pe, qs) tc = let doelim tc = match qs with - | None -> t_or (t_elimT_ind `Ind) t_elim tc + | None -> + t_or + (t_elimT_ind ~reduce:(`Full true) `Ind) + (t_elim ~reduce:(`Full true)) + tc | Some qs -> let qs = { fp_mode = `Implicit; @@ -1919,7 +1927,10 @@ let process_case ?(doeq = false) gp tc = with E.LEMFailure -> try FApi.t_last - (t_ors [t_elimT_ind `Case; t_elim; t_elim_prind `Case]) + (t_ors [ + t_elimT_ind ~reduce:(`Full true) `Case; + t_elim ~reduce:(`Full true); + t_elim_prind ~reduce:(`Full true) `Case]) (process_move ~doeq gp.pr_view gp.pr_rev tc) with EcCoreGoal.InvalidGoalShape -> diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 57dc0487aa..9d657b0f82 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -50,7 +50,7 @@ let (@~+) (tt : FApi.tactical) (ts : FApi.backward list) = exception InvalidProofTerm type side = [`Left|`Right] -type lazyred = [`Full | `NoDelta | `None] +type lazyred = [`Full of bool | `NoDelta | `None] (* -------------------------------------------------------------------- *) module LowApply = struct @@ -333,7 +333,7 @@ let t_cbv_with_info ?target (ri : reduction_info) (tc : tcenv1) = (* -------------------------------------------------------------------- *) let t_cbv ?target ?(delta = true) ?(logic = Some `Full) (tc : tcenv1) = - let ri = if delta then full_red else nodelta in + let ri = if delta then full_red ~opaque:false else nodelta in let ri = { ri with logic } in t_cbv_with_info ?target ri tc @@ -344,7 +344,7 @@ let t_cbn_with_info ?target (ri : reduction_info) (tc : tcenv1) = (* -------------------------------------------------------------------- *) let t_cbn ?target ?(delta = true) ?(logic = Some `Full) (tc : tcenv1) = - let ri = if delta then full_red else nodelta in + let ri = if delta then full_red ~opaque:false else nodelta in let ri = { ri with logic } in t_cbv_with_info ?target ri tc @@ -354,16 +354,16 @@ let t_hred_with_info ?target (ri : reduction_info) (tc : tcenv1) = FApi.tcenv_of_tcenv1 (t_change_r ~fail:true ?target action tc) (* -------------------------------------------------------------------- *) -let rec t_lazy_match ?(reduce = `Full) (tx : form -> FApi.backward) +let rec t_lazy_match ?(reduce = `Full false) (tx : form -> FApi.backward) (tc : tcenv1) = let concl = FApi.tc1_goal tc in try tx concl tc with TTC.NoMatch -> let strategy = match reduce with - | `None -> raise InvalidGoalShape - | `Full -> EcReduction.full_red - | `NoDelta -> EcReduction.nodelta in + | `None -> raise InvalidGoalShape + | `Full b -> EcReduction.full_red ~opaque:b + | `NoDelta -> EcReduction.nodelta in FApi.t_seq (t_hred_with_info strategy) (t_lazy_match ~reduce tx) tc (* -------------------------------------------------------------------- *) @@ -508,7 +508,7 @@ let t_intros_x (ids : (ident option) mloc list) (tc : tcenv1) = intro1 ((hyps, concl), Fsubst.f_subst_id) id | _ -> - match h_red_opt full_red hyps concl with + match h_red_opt (full_red ~opaque:false) hyps concl with | None -> LowIntro.tc_no_product !!tc ?loc:(tg_tag id) () | Some concl -> intro1 ((hyps, concl), sbt) id in @@ -1030,7 +1030,7 @@ let t_tuple_intro ?reduce (tc : tcenv1) = t_lazy_match ?reduce t_tuple_intro_r tc (* -------------------------------------------------------------------- *) -let t_elim_r ?(reduce = (`Full : lazyred)) txs tc = +let t_elim_r ?(reduce = (`Full false : lazyred)) txs tc = match sform_of_form (FApi.tc1_goal tc) with | SFimp (f1, f2) -> let rec aux f1 = @@ -1046,9 +1046,9 @@ let t_elim_r ?(reduce = (`Full : lazyred)) txs tc = | None -> begin let strategy = match reduce with - | `None -> raise InvalidGoalShape - | `Full -> EcReduction.full_red - | `NoDelta -> EcReduction.nodelta in + | `None -> raise InvalidGoalShape + | `Full b -> EcReduction.full_red ~opaque:b + | `NoDelta -> EcReduction.nodelta in match h_red_opt strategy (FApi.tc1_hyps tc) f1 with | None -> raise InvalidGoalShape @@ -2100,7 +2100,7 @@ let t_progress ?options ?ti (tt : FApi.backward) (tc : tcenv1) = in let reduce = - if options.pgo_delta.pgod_case then `Full else `NoDelta in + if options.pgo_delta.pgod_case then `Full false else `NoDelta in FApi.t_switch ~on:`All (t_elim_r ~reduce elims) ~ifok:aux0 ~iffail tc end @@ -2108,11 +2108,11 @@ let t_progress ?options ?ti (tt : FApi.backward) (tc : tcenv1) = | _ when options.pgo_split -> let thesplit = match options.pgo_delta.pgod_split with - | true -> t_split ~closeonly:false ~reduce:`Full + | true -> t_split ~closeonly:false ~reduce:(`Full false) | false -> FApi.t_or (t_split ~reduce:`NoDelta) - (t_split ~closeonly:true ~reduce:`Full) in + (t_split ~closeonly:true ~reduce:(`Full false)) in FApi.t_try (FApi.t_seq thesplit aux0) tc @@ -2197,7 +2197,7 @@ let t_crush ?(delta = true) ?tsolve (tc : tcenv1) = let iffail = t_crush_subst st id1 in let elims = PGInternals.pg_cnj_elims in - let reduce = if delta then `Full else `NoDelta in + let reduce = if delta then `Full false else `NoDelta in FApi.t_onall (FApi.t_switch ~on:`All ~ifok:(aux0 st) ~iffail (t_elim_r ~reduce elims)) @@ -2205,7 +2205,7 @@ let t_crush ?(delta = true) ?tsolve (tc : tcenv1) = end | _ -> - let reduce = if delta then `Full else `NoDelta in + let reduce = if delta then `Full false else `NoDelta in let thesplit tc = t_split ~closeonly:false ~reduce tc in let hyps0 = FApi.tc1_hyps tc in let shuffle = List.rev_map fst (LDecl.tohyps (FApi.tc1_hyps tc)).h_local in @@ -2478,7 +2478,7 @@ let t_crush_fwd ?(delta = true) nb_intros (tc : tcenv1) = (tc, aux0 (incr n)) in let elims = [ t_elim_false_r; t_elim_and_r; t_elim_eq_tuple_r; ] in - let reduce = if delta then `Full else `NoDelta in + let reduce = if delta then `Full false else `NoDelta in FApi.t_onall (FApi.t_xswitch ~on:`All ~iffail (t_elim_r ~reduce elims)) diff --git a/src/ecLowGoal.mli b/src/ecLowGoal.mli index afa0b4a98c..5513facdc3 100644 --- a/src/ecLowGoal.mli +++ b/src/ecLowGoal.mli @@ -24,8 +24,7 @@ open EcCoreGoal exception InvalidProofTerm (* invalid proof term *) type side = [`Left|`Right] -type lazyred = [`Full | `NoDelta | `None] - +type lazyred = [`Full of bool | `NoDelta | `None] (* -------------------------------------------------------------------- *) val (@!) : FApi.backward -> FApi.backward -> FApi.backward diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 89485d39ad..63e93af9da 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -186,7 +186,7 @@ let rec lazy_destruct ?(reduce = true) hyps tx fp = with | NoMatch when not reduce -> None | NoMatch -> - match EcReduction.h_red_opt EcReduction.full_red hyps fp with + match EcReduction.h_red_opt (EcReduction.full_red ~opaque:false) hyps fp with | None -> None | Some fp -> lazy_destruct ~reduce hyps tx fp diff --git a/src/ecReduction.ml b/src/ecReduction.ml index cb4294d6ec..0ebd63fc46 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -619,9 +619,9 @@ and deltap = [`Yes | `No | `Force] and rlogic_info = [`Full | `ProductCompat] option (* -------------------------------------------------------------------- *) -let full_red = { +let full_red ~opaque = { beta = true; - delta_p = (fun _ -> `Yes); + delta_p = (fun _ -> if opaque then `Force else `Yes); delta_h = EcUtils.predT; zeta = true; iota = true; @@ -647,13 +647,15 @@ let beta_red = { no_red with beta = true; } let betaiota_red = { no_red with beta = true; iota = true; } let nodelta = - { full_red with + { (full_red ~opaque:false) with delta_h = EcUtils.pred0; delta_p = (fun _ -> `No); } let delta = { no_red with delta_p = (fun _ -> `Yes); } -let full_compat = { full_red with logic = Some `ProductCompat; } +let full_compat = { + (full_red ~opaque:false) with + logic = Some `ProductCompat; } (* -------------------------------------------------------------------- *) type not_reducible = NoHead | NeedSubTerm @@ -1476,7 +1478,7 @@ let reduce_user_gen simplify ri env hyps f = with NotRed _ -> raise NotReducible (* -------------------------------------------------------------------- *) -let is_conv ?(ri = full_red) hyps f1 f2 = +let is_conv ?(ri = full_red ~opaque:false) hyps f1 f2 = if f_equal f1 f2 then true else let ri, env = init_redinfo ri hyps in diff --git a/src/ecReduction.mli b/src/ecReduction.mli index 0f6ade878b..4f8eb07ab8 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -80,7 +80,7 @@ type reduction_info = { and deltap = [`Yes | `No | `Force] and rlogic_info = [`Full | `ProductCompat] option -val full_red : reduction_info +val full_red : opaque:bool -> reduction_info val full_compat : reduction_info val no_red : reduction_info val beta_red : reduction_info diff --git a/src/phl/ecPhlLoopTx.ml b/src/phl/ecPhlLoopTx.ml index 628478216e..2ae10fda96 100644 --- a/src/phl/ecPhlLoopTx.ml +++ b/src/phl/ecPhlLoopTx.ml @@ -238,7 +238,7 @@ let process_unroll_for side cpos tc = let fincr = form_of_expr mhr eincr in fun z0 -> let f = PVM.subst1 env x mhr (f_int z0) fincr in - match (simplify full_red hyps f).f_node with + match (simplify (full_red ~opaque:false) hyps f).f_node with | Fint z0 -> z0 | _ -> tc_error !!tc "loop increment does not reduce to a constant" in @@ -247,7 +247,7 @@ let process_unroll_for side cpos tc = let ftest = form_of_expr mhr t in fun z0 -> let cond = PVM.subst1 env x mhr (f_int z0) ftest in - match sform_of_form (simplify full_red hyps cond) with + match sform_of_form (simplify (full_red ~opaque:false) hyps cond) with | SFtrue -> true | SFfalse -> false | _ -> tc_error !!tc "while loop condition does not reduce to a constant" in From 89a0c209de08aae73bbaea29ce940deb7f0f63ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Fri, 8 Apr 2022 10:41:38 +0200 Subject: [PATCH 037/113] Working on typeclass examples --- examples/typeclass.ec | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 65ba6f068e..63f954e944 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -27,7 +27,7 @@ type class countable = { }. (* TODO: printing typeclasses *) -(* print countable. *) +print countable. (* -------------------------------------------------------------------- *) (* Simple algebraic structures *) From 9c584d7a41e8c2ff99218ed6fc72c92f67aa6009 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Wed, 20 Apr 2022 11:40:37 +0200 Subject: [PATCH 038/113] Printing typeclasses partly done --- examples/typeclass.ec | 26 +++++++++----------------- src/ecPrinting.ml | 16 +++++++++++++++- 2 files changed, 24 insertions(+), 18 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 63f954e944..1fab2af9e4 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -57,8 +57,6 @@ type class group <: monoid = { axiom mmulN : left_inverse mid minv mmul }. -print minv. - type class ['a <: semigroup] semigroup_action = { op amul : 'a -> semigroup_action -> semigroup_action @@ -66,22 +64,12 @@ type class ['a <: semigroup] semigroup_action = { forall (g h : 'a) (x : semigroup_action), amul (mmul g h) x = amul g (amul h x) }. -print compatibility. - -(* TODO: nice error message, already known *) -(* -type class ['a <: monoid] monoid_action <: 'a semigroup_action = { - axiom identity : - forall (x : id_action), amul mid x = x -}. -*) - type class ['a <: monoid] monoid_action <: 'a semigroup_action = { axiom identity : forall (x : monoid_action), amul mid<:'a> x = x }. (* TODO: why again is this not possible/a good idea? *) -(* type class finite_group <: group & finite = {}. *) +(*type class finite_group <: group & finite = {}.*) (* -------------------------------------------------------------------- *) (* Advanced algebraic structures *) @@ -141,12 +129,14 @@ op all_countable ['a <: countable] (p : 'a -> bool) = (* -------------------------------------------------------------------- *) (* Simple algebraic structures *) -(* TODO: weird issue and/or inapropriate error message *) -(* -print amul. +(* TODO: weird issue and/or inapropriate error message : bug in ecUnify select_op*) +print amul. +(* op foo1 ['a <: semigroup, 'b <: 'a semigroup_action] = amul<:'a,'b>. +*) op foo2 ['a <: semigroup, 'b <: 'a semigroup_action] (g : 'a) (x : 'b) = amul g x. +(* op foo3 ['a <: semigroup, 'b <: 'a semigroup_action] (g : 'a) (x : 'b) = amul<:'a,'b> g x. *) @@ -199,7 +189,8 @@ instance comgroup with int op ( + ) = CoreInt.add op ([-]) = CoreInt.opp. -(* TODO: might be any of the two addr0, also apply fails but rewrite works. *) +(* TODO: might be any of the two addr0, also apply fails but rewrite works. + In ecScope, where instances are declared. *) realize addr0 by rewrite addr0. realize addrN by trivial. realize addrC by rewrite addrC. @@ -229,6 +220,7 @@ proof. move => x y z. move: (Ring.IntID.mulrDl x y z). move => HmulrDl. + rewrite HmulrDl. (* TODO: what? *) admit. qed. diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 24f567eebd..2721071088 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -2884,6 +2884,12 @@ let pp_rwbase ppe fmt (p, rws) = Format.fprintf fmt "%a = %a@\n%!" (pp_rwname ppe) p (pp_list ", " (pp_axname ppe)) (Sp.elements rws) +(* -------------------------------------------------------------------- *) +(*TODOTC*) +let pp_tcbase ppe fmt (p, tcdecl) = + Format.fprintf fmt "%a = %a@\n%!" + (pp_tcname ppe) p (pp_option (pp_typeclass ppe)) (tcdecl.tc_prt) + (* -------------------------------------------------------------------- *) let pp_solvedb ppe fmt db = List.iter (fun (lvl, ps) -> @@ -3544,6 +3550,13 @@ module ObjectInfo = struct | `Rewrite name -> pr_rw fmt env name | `Solve name -> pr_at fmt env name + (* ------------------------------------------------------------------ *) + (*TODOTC: the printing of a typeclass*) + let pr_tc_r = + { od_name = "typeclasses"; + od_lookup = EcEnv.TypeClass.lookup; + od_printer = pp_tcbase; } + (* ------------------------------------------------------------------ *) let pr_any fmt env qs = let printers = [pr_gen_r ~prcat:true pr_ty_r ; @@ -3554,7 +3567,8 @@ module ObjectInfo = struct pr_gen_r ~prcat:true pr_mod_r; pr_gen_r ~prcat:true pr_mty_r; pr_gen_r ~prcat:true pr_rw_r ; - pr_gen_r ~prcat:true pr_at_r ; ] in + pr_gen_r ~prcat:true pr_at_r ; + pr_gen_r ~prcat:true pr_tc_r ; ] in let ok = ref (List.length printers) in From d61cdfc9ac0d1d56397249da66e92db59ca5e0ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Wed, 20 Apr 2022 12:03:14 +0200 Subject: [PATCH 039/113] Added ppx deriving --- dune-project | 4 +- easycrypt.opam | 1 + src/dune | 3 +- src/ecCoreFol.ml | 161 ++++++++++++++++++++++++++--------------------- 4 files changed, 96 insertions(+), 73 deletions(-) diff --git a/dune-project b/dune-project index 23396bd751..e598329681 100644 --- a/dune-project +++ b/dune-project @@ -19,7 +19,9 @@ dune-site (ocaml-inifiles (>= 1.2)) (pcre (>= 7)) + (ppx_deriving (>= 5.2.0)) (why3 (and (>= 1.4.0) (< 1.5))) yojson (zarith (>= 1.10)) -)) + ) +) \ No newline at end of file diff --git a/easycrypt.opam b/easycrypt.opam index a165131545..0802996191 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -8,6 +8,7 @@ depends: [ "dune-site" "ocaml-inifiles" {>= "1.2"} "pcre" {>= "7"} + "ppx_deriving" {>= "5.2.0"} "why3" {>= "1.4.0" & < "1.5"} "yojson" "zarith" {>= "1.10"} diff --git a/src/dune b/src/dune index 104ba0ba36..d0cf895673 100644 --- a/src/dune +++ b/src/dune @@ -9,7 +9,8 @@ (public_name easycrypt) (name ec) (promote (until-clean)) - (libraries batteries dune-build-info inifiles why3 yojson zarith)) + (libraries batteries dune-build-info inifiles why3 yojson zarith) + (preprocess (pps ppx_deriving.show))) (ocamllex ecLexer) diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 457ea4a6a0..9d666546c2 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -24,30 +24,34 @@ type quantif = type hoarecmp = FHle | FHeq | FHge type gty = - | GTty of EcTypes.ty - | GTmodty of module_type - | GTmem of EcMemory.memtype + | GTty of (EcTypes.ty [@opaque]) + | GTmodty of (module_type [@opaque]) + | GTmem of (EcMemory.memtype [@opaque]) +[@@deriving show] -and binding = (EcIdent.t * gty) -and bindings = binding list +and binding = ((EcIdent.t * gty) [@opaque]) +[@@deriving show] +and bindings = (binding list [@opaque]) +[@@deriving show] and form = { f_node : f_node; - f_ty : ty; - f_fv : int EcIdent.Mid.t; (* local, memory, module ident *) - f_tag : int; + f_ty : (ty [@opaque]); + f_fv : (int EcIdent.Mid.t [@opaque]); (* local, memory, module ident *) + f_tag : (int [@opaque]); } +[@@deriving show] and f_node = - | Fquant of quantif * bindings * form + | Fquant of (quantif [@opaque]) * bindings * form | Fif of form * form * form - | Fmatch of form * form list * ty - | Flet of lpattern * form * form - | Fint of BI.zint - | Flocal of EcIdent.t - | Fpvar of EcTypes.prog_var * memory - | Fglob of EcPath.mpath * memory - | Fop of EcPath.path * ty list + | Fmatch of form * form list * (ty [@opaque]) + | Flet of (lpattern [@opaque]) * form * form + | Fint of (BI.zint [@opaque]) + | Flocal of (EcIdent.t [@opaque]) + | Fpvar of (EcTypes.prog_var [@opaque]) * (memory [@opaque]) + | Fglob of (EcPath.mpath [@opaque]) * (memory [@opaque]) + | Fop of (EcPath.path [@opaque]) * (ty [@opaque]) list | Fapp of form * form list | Ftuple of form list | Fproj of form * int @@ -69,103 +73,118 @@ and f_node = | Fcoe of coe | Fpr of pr (* hr *) +[@@deriving show] and eagerF = { - eg_pr : form; - eg_sl : stmt; (* No local program variables *) - eg_fl : EcPath.xpath; - eg_fr : EcPath.xpath; - eg_sr : stmt; (* No local program variables *) - eg_po : form + eg_pr : (form [@opaque]); + eg_sl : (stmt [@opaque]); (* No local program variables *) + eg_fl : (EcPath.xpath [@opaque]); + eg_fr : (EcPath.xpath [@opaque]); + eg_sr : (stmt [@opaque]); (* No local program variables *) + eg_po : (form [@opaque]) } +[@@deriving show] and equivF = { - ef_pr : form; - ef_fl : EcPath.xpath; - ef_fr : EcPath.xpath; - ef_po : form; + ef_pr : (form [@opaque]); + ef_fl : (EcPath.xpath [@opaque]); + ef_fr : (EcPath.xpath [@opaque]); + ef_po : (form [@opaque]); } +[@@deriving show] and equivS = { - es_ml : EcMemory.memenv; - es_mr : EcMemory.memenv; - es_pr : form; - es_sl : stmt; - es_sr : stmt; - es_po : form; } + es_ml : (EcMemory.memenv [@opaque]); + es_mr : (EcMemory.memenv [@opaque]); + es_pr : (form [@opaque]); + es_sl : (stmt [@opaque]); + es_sr : (stmt [@opaque]); + es_po : (form [@opaque]); } +[@@deriving show] and sHoareF = { - hf_pr : form; - hf_f : EcPath.xpath; - hf_po : form; + hf_pr : (form [@opaque]); + hf_f : (EcPath.xpath [@opaque]); + hf_po : (form [@opaque]); } +[@@deriving show] and sHoareS = { - hs_m : EcMemory.memenv; - hs_pr : form; - hs_s : stmt; - hs_po : form; } + hs_m : (EcMemory.memenv [@opaque]); + hs_pr : (form [@opaque]); + hs_s : (stmt [@opaque]); + hs_po : (form [@opaque]); } +[@@deriving show] and cHoareF = { - chf_pr : form; - chf_f : EcPath.xpath; - chf_po : form; - chf_co : cost; + chf_pr : (form [@opaque]); + chf_f : (EcPath.xpath [@opaque]); + chf_po : (form [@opaque]); + chf_co : (cost [@opaque]); } +[@@deriving show] and cHoareS = { - chs_m : EcMemory.memenv; - chs_pr : form; - chs_s : stmt; - chs_po : form; - chs_co : cost; } + chs_m : (EcMemory.memenv [@opaque]); + chs_pr : (form [@opaque]); + chs_s : (stmt [@opaque]); + chs_po : (form [@opaque]); + chs_co : (cost [@opaque]); } +[@@deriving show] and bdHoareF = { - bhf_pr : form; - bhf_f : EcPath.xpath; - bhf_po : form; - bhf_cmp : hoarecmp; - bhf_bd : form; + bhf_pr : (form [@opaque]); + bhf_f : (EcPath.xpath [@opaque]); + bhf_po : (form [@opaque]); + bhf_cmp : (hoarecmp [@opaque]); + bhf_bd : (form [@opaque]); } +[@@deriving show] and bdHoareS = { - bhs_m : EcMemory.memenv; - bhs_pr : form; - bhs_s : stmt; - bhs_po : form; - bhs_cmp : hoarecmp; - bhs_bd : form; + bhs_m : (EcMemory.memenv [@opaque]); + bhs_pr : (form [@opaque]); + bhs_s : (stmt [@opaque]); + bhs_po : (form [@opaque]); + bhs_cmp : (hoarecmp [@opaque]); + bhs_bd : (form [@opaque]); } +[@@deriving show] and pr = { - pr_mem : memory; - pr_fun : EcPath.xpath; - pr_args : form; - pr_event : form; + pr_mem : (memory [@opaque]); + pr_fun : (EcPath.xpath [@opaque]); + pr_args : (form [@opaque]); + pr_event : (form [@opaque]); } +[@@deriving show] and coe = { - coe_pre : form; - coe_mem : EcMemory.memenv; - coe_e : expr; + coe_pre : (form [@opaque]); + coe_mem : (EcMemory.memenv [@opaque]); + coe_e : (expr [@opaque]); } +[@@deriving show] (* Invariant: keys of c_calls are functions of local modules, with no arguments. *) and cost = { - c_self : form; (* of type xint *) - c_calls : call_bound EcPath.Mx.t; + c_self : (form [@opaque]); (* of type xint *) + c_calls : (call_bound EcPath.Mx.t [@opaque]); } +[@@deriving show] (* Call with cost at most [cb_cost], called at mist [cb_called]. [cb_cost] is here to properly handle substsitution when instantiating an abstract module by a concrete one. *) and call_bound = { - cb_cost : form; (* of type xint *) - cb_called : form; (* of type int *) + cb_cost : (form [@opaque]); (* of type xint *) + cb_called : (form [@opaque]); (* of type int *) } +[@@deriving show] -and module_type = form p_module_type +and module_type = (form p_module_type [@opaque]) +[@@deriving show] type mod_restr = form p_mod_restr From 9f4d3bc3bab05e2d1e7c327415f5d9b895b0ec75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Thu, 28 Apr 2022 16:09:53 +0200 Subject: [PATCH 040/113] Printing typeclass issue --- examples/typeclass.ec | 17 +++- src/ecBigInt.ml | 3 + src/ecBigIntCore.ml | 1 + src/ecCoreFol.ml | 46 ++++++----- src/ecCoreFol.mli | 184 +++++++++++++++++++++++------------------- src/ecEnv.ml | 8 ++ src/ecEnv.mli | 1 + src/ecIdent.ml | 1 + src/ecIdent.mli | 1 + src/ecMemory.ml | 3 + src/ecMemory.mli | 2 + src/ecPath.ml | 9 +++ src/ecPath.mli | 6 ++ src/ecPrinting.ml | 108 +++++++++++++++++-------- src/ecPrinting.mli | 2 +- src/ecScope.ml | 42 ++++++++-- src/ecSection.ml | 2 +- src/ecTypes.ml | 9 ++- src/ecTypes.mli | 4 + src/ecUid.ml | 3 + src/ecUid.mli | 1 + src/ecUnify.ml | 2 +- 22 files changed, 301 insertions(+), 154 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 1fab2af9e4..6b25c49a3e 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -26,9 +26,6 @@ type class countable = { axiom countP : forall (x : countable), exists (n : int), x = count n }. -(* TODO: printing typeclasses *) -print countable. - (* -------------------------------------------------------------------- *) (* Simple algebraic structures *) @@ -114,6 +111,17 @@ type foo <: witness. type fingroup <: group & finite. + +(* TODO: printing typeclasses *) +print countable. +print magma. +print semigroup. +print monoid. +print group. +print semigroup_action. +print monoid_action. + + (* ==================================================================== *) (* Operator examples *) @@ -216,10 +224,13 @@ realize mulrA by rewrite mulrA. realize mulrDl. proof. + (*TODO: in the goal, the typeclass operator + should have been replaced with the + from CoreInt, but has not been.*) print mulrDl. move => x y z. move: (Ring.IntID.mulrDl x y z). move => HmulrDl. + have: false. + move: HmulrDl. rewrite HmulrDl. (* TODO: what? *) admit. diff --git a/src/ecBigInt.ml b/src/ecBigInt.ml index a9a8b5a845..85d741e473 100644 --- a/src/ecBigInt.ml +++ b/src/ecBigInt.ml @@ -71,6 +71,7 @@ module ZImpl : EcBigIntCore.TheInterface = struct with Failure _ -> raise InvalidString let pp_print = (Z.pp_print : Format.formatter -> zint -> unit) + let pp_zint = pp_print let to_why3 (x : zint) = Why3.BigInt.of_string (to_string x) @@ -148,6 +149,8 @@ module BigNumImpl : EcBigIntCore.TheInterface = struct let pp_print fmt x = Format.fprintf fmt "%s" (B.string_of_big_int x) + let pp_zint = pp_print + let to_why3 (x : zint) = Why3.BigInt.of_string (to_string x) end diff --git a/src/ecBigIntCore.ml b/src/ecBigIntCore.ml index 39d9391478..1b7de0b7e7 100644 --- a/src/ecBigIntCore.ml +++ b/src/ecBigIntCore.ml @@ -62,6 +62,7 @@ module type TheInterface = sig val to_string : zint -> string val pp_print : Format.formatter -> zint -> unit + val pp_zint : Format.formatter -> zint -> unit val to_why3 : zint -> Why3.BigInt.t end diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 9d666546c2..e1f8cc7a63 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -6,6 +6,7 @@ open EcTypes open EcCoreModules type memory = EcMemory.memory +[@@deriving show] module BI = EcBigInt module Mp = EcPath.Mp @@ -20,18 +21,19 @@ type quantif = | Lforall | Lexists | Llambda +[@@deriving show] type hoarecmp = FHle | FHeq | FHge type gty = - | GTty of (EcTypes.ty [@opaque]) + | GTty of EcTypes.ty | GTmodty of (module_type [@opaque]) | GTmem of (EcMemory.memtype [@opaque]) [@@deriving show] -and binding = ((EcIdent.t * gty) [@opaque]) +and binding = (EcIdent.t * gty) [@@deriving show] -and bindings = (binding list [@opaque]) +and bindings = binding list [@@deriving show] and form = { @@ -43,36 +45,36 @@ and form = { [@@deriving show] and f_node = - | Fquant of (quantif [@opaque]) * bindings * form + | Fquant of quantif * bindings * form | Fif of form * form * form - | Fmatch of form * form list * (ty [@opaque]) - | Flet of (lpattern [@opaque]) * form * form - | Fint of (BI.zint [@opaque]) - | Flocal of (EcIdent.t [@opaque]) - | Fpvar of (EcTypes.prog_var [@opaque]) * (memory [@opaque]) - | Fglob of (EcPath.mpath [@opaque]) * (memory [@opaque]) - | Fop of (EcPath.path [@opaque]) * (ty [@opaque]) list + | Fmatch of form * form list * ty + | Flet of lpattern * form * form + | Fint of BI.zint + | Flocal of EcIdent.t + | Fpvar of EcTypes.prog_var * memory + | Fglob of EcPath.mpath * memory + | Fop of EcPath.path * ty list | Fapp of form * form list | Ftuple of form list | Fproj of form * int - | FhoareF of sHoareF (* $hr / $hr *) - | FhoareS of sHoareS + | FhoareF of (sHoareF [@opaque]) (* $hr / $hr *) + | FhoareS of (sHoareS [@opaque]) - | FcHoareF of cHoareF (* $hr / $hr *) - | FcHoareS of cHoareS + | FcHoareF of (cHoareF [@opaque]) (* $hr / $hr *) + | FcHoareS of (cHoareS [@opaque]) - | FbdHoareF of bdHoareF (* $hr / $hr *) - | FbdHoareS of bdHoareS + | FbdHoareF of (bdHoareF [@opaque]) (* $hr / $hr *) + | FbdHoareS of (bdHoareS [@opaque]) - | FequivF of equivF (* $left,$right / $left,$right *) - | FequivS of equivS + | FequivF of (equivF [@opaque]) (* $left,$right / $left,$right *) + | FequivS of (equivS [@opaque]) - | FeagerF of eagerF + | FeagerF of (eagerF [@opaque]) - | Fcoe of coe + | Fcoe of (coe [@opaque]) - | Fpr of pr (* hr *) + | Fpr of (pr [@opaque]) (* hr *) [@@deriving show] and eagerF = { diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index f72852802e..1be24d7171 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -22,150 +22,168 @@ type quantif = type hoarecmp = FHle | FHeq | FHge type gty = - | GTty of EcTypes.ty - | GTmodty of module_type - | GTmem of EcMemory.memtype + | GTty of (EcTypes.ty [@opaque]) + | GTmodty of (module_type [@opaque]) + | GTmem of (EcMemory.memtype [@opaque]) +[@@deriving show] -and binding = (EcIdent.t * gty) -and bindings = binding list +and binding = ((EcIdent.t * gty) [@opaque]) +[@@deriving show] +and bindings = (binding list [@opaque]) +[@@deriving show] and form = private { f_node : f_node; - f_ty : ty; - f_fv : int Mid.t; - f_tag : int; + f_ty : (ty [@opaque]); + f_fv : (int EcIdent.Mid.t [@opaque]); (* local, memory, module ident *) + f_tag : (int [@opaque]); } +[@@deriving show] and f_node = - | Fquant of quantif * bindings * form + | Fquant of (quantif [@opaque]) * (bindings [@opaque]) * form | Fif of form * form * form - | Fmatch of form * form list * ty - | Flet of lpattern * form * form - | Fint of zint - | Flocal of EcIdent.t - | Fpvar of EcTypes.prog_var * memory - | Fglob of mpath * memory - | Fop of path * ty list + | Fmatch of form * form list * (ty [@opaque]) + | Flet of (lpattern [@opaque]) * form * form + | Fint of (zint [@opaque]) + | Flocal of (EcIdent.t [@opaque]) + | Fpvar of (EcTypes.prog_var [@opaque]) * (memory [@opaque]) + | Fglob of (EcPath.mpath [@opaque]) * (memory [@opaque]) + | Fop of (EcPath.path [@opaque]) * (ty list [@opaque]) | Fapp of form * form list | Ftuple of form list | Fproj of form * int - | FhoareF of sHoareF (* $hr / $hr *) - | FhoareS of sHoareS + | FhoareF of (sHoareF [@opaque]) (* $hr / $hr *) + | FhoareS of (sHoareS [@opaque]) - | FcHoareF of cHoareF (* $hr / $hr *) - | FcHoareS of cHoareS + | FcHoareF of (cHoareF [@opaque]) (* $hr / $hr *) + | FcHoareS of (cHoareS [@opaque]) - | FbdHoareF of bdHoareF (* $hr / $hr *) - | FbdHoareS of bdHoareS (* $hr / $hr *) + | FbdHoareF of (bdHoareF [@opaque]) (* $hr / $hr *) + | FbdHoareS of (bdHoareS [@opaque]) - | FequivF of equivF (* $left,$right / $left,$right *) - | FequivS of equivS (* $left,$right / $left,$right *) + | FequivF of (equivF [@opaque]) (* $left,$right / $left,$right *) + | FequivS of (equivS [@opaque]) - | FeagerF of eagerF + | FeagerF of (eagerF [@opaque]) - | Fcoe of coe + | Fcoe of (coe [@opaque]) - | Fpr of pr (* hr *) + | Fpr of (pr [@opaque]) (* hr *) +[@@deriving show] and eagerF = { - eg_pr : form; - eg_sl : stmt; (* No local program variables *) - eg_fl : xpath; - eg_fr : xpath; - eg_sr : stmt; (* No local program variables *) - eg_po : form + eg_pr : (form [@opaque]); + eg_sl : (stmt [@opaque]); (* No local program variables *) + eg_fl : (EcPath.xpath [@opaque]); + eg_fr : (EcPath.xpath [@opaque]); + eg_sr : (stmt [@opaque]); (* No local program variables *) + eg_po : (form [@opaque]) } +[@@deriving show] and equivF = { - ef_pr : form; - ef_fl : xpath; - ef_fr : xpath; - ef_po : form; + ef_pr : (form [@opaque]); + ef_fl : (EcPath.xpath [@opaque]); + ef_fr : (EcPath.xpath [@opaque]); + ef_po : (form [@opaque]); } +[@@deriving show] and equivS = { - es_ml : EcMemory.memenv; - es_mr : EcMemory.memenv; - es_pr : form; - es_sl : stmt; - es_sr : stmt; - es_po : form; -} + es_ml : (EcMemory.memenv [@opaque]); + es_mr : (EcMemory.memenv [@opaque]); + es_pr : (form [@opaque]); + es_sl : (stmt [@opaque]); + es_sr : (stmt [@opaque]); + es_po : (form [@opaque]); } +[@@deriving show] and sHoareF = { - hf_pr : form; - hf_f : EcPath.xpath; - hf_po : form; + hf_pr : (form [@opaque]); + hf_f : (EcPath.xpath [@opaque]); + hf_po : (form [@opaque]); } +[@@deriving show] and sHoareS = { - hs_m : EcMemory.memenv; - hs_pr : form; - hs_s : stmt; - hs_po : form; } + hs_m : (EcMemory.memenv [@opaque]); + hs_pr : (form [@opaque]); + hs_s : (stmt [@opaque]); + hs_po : (form [@opaque]); } +[@@deriving show] and cHoareF = { - chf_pr : form; - chf_f : EcPath.xpath; - chf_po : form; - chf_co : cost; + chf_pr : (form [@opaque]); + chf_f : (EcPath.xpath [@opaque]); + chf_po : (form [@opaque]); + chf_co : (cost [@opaque]); } +[@@deriving show] and cHoareS = { - chs_m : EcMemory.memenv; - chs_pr : form; - chs_s : stmt; - chs_po : form; - chs_co : cost; } + chs_m : (EcMemory.memenv [@opaque]); + chs_pr : (form [@opaque]); + chs_s : (stmt [@opaque]); + chs_po : (form [@opaque]); + chs_co : (cost [@opaque]); } +[@@deriving show] and bdHoareF = { - bhf_pr : form; - bhf_f : xpath; - bhf_po : form; - bhf_cmp : hoarecmp; - bhf_bd : form; + bhf_pr : (form [@opaque]); + bhf_f : (EcPath.xpath [@opaque]); + bhf_po : (form [@opaque]); + bhf_cmp : (hoarecmp [@opaque]); + bhf_bd : (form [@opaque]); } +[@@deriving show] and bdHoareS = { - bhs_m : EcMemory.memenv; - bhs_pr : form; - bhs_s : stmt; - bhs_po : form; - bhs_cmp : hoarecmp; - bhs_bd : form; + bhs_m : (EcMemory.memenv [@opaque]); + bhs_pr : (form [@opaque]); + bhs_s : (stmt [@opaque]); + bhs_po : (form [@opaque]); + bhs_cmp : (hoarecmp [@opaque]); + bhs_bd : (form [@opaque]); } +[@@deriving show] and coe = { - coe_pre : form; - coe_mem : EcMemory.memenv; - coe_e : expr; + coe_pre : (form [@opaque]); + coe_mem : (EcMemory.memenv [@opaque]); + coe_e : (expr [@opaque]); } +[@@deriving show] and pr = { - pr_mem : memory; - pr_fun : xpath; - pr_args : form; - pr_event : form; + pr_mem : (memory [@opaque]); + pr_fun : (EcPath.xpath [@opaque]); + pr_args : (form [@opaque]); + pr_event : (form [@opaque]); } +[@@deriving show] (* Invariant: keys of c_calls are functions of local modules, with no arguments. *) and cost = private { - c_self : form; - c_calls : call_bound EcPath.Mx.t; + c_self : (form [@opaque]); (* of type xint *) + c_calls : (call_bound EcPath.Mx.t [@opaque]); } +[@@deriving show] (* Call with cost at most [cb_cost], called at mist [cb_called]. [cb_cost] is here to properly handle substsitution when instantiating an abstract module by a concrete one. *) and call_bound = private { - cb_cost : form; - cb_called : form; + cb_cost : (form [@opaque]); + cb_called : (form [@opaque]); } +[@@deriving show] -and module_type = form p_module_type +and module_type = (form p_module_type [@opaque]) +[@@deriving show] type mod_restr = form p_mod_restr diff --git a/src/ecEnv.ml b/src/ecEnv.ml index d7c3d57b68..728c0d4762 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -1418,6 +1418,14 @@ module TypeClass = struct env_item = mkitem import (Th_instance (ty, cr, lc)) :: env.env_item; } let get_instances env = env.env_tci + + let get_instance env tc = + List.find_opt + (fun p -> + match (snd p) with + | `General tc' -> tc = tc' + | _ -> false ) + (get_instances env) end (* -------------------------------------------------------------------- *) diff --git a/src/ecEnv.mli b/src/ecEnv.mli index cabd4eb64a..708a87fc6b 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -398,6 +398,7 @@ module TypeClass : sig val add_instance : ?import:import -> (ty_params * ty) -> tcinstance -> is_local -> env -> env val get_instances : env -> ((ty_params * ty) * tcinstance) list + val get_instance : env -> typeclass -> ((ty_params * ty) * tcinstance) option end (* -------------------------------------------------------------------- *) diff --git a/src/ecIdent.ml b/src/ecIdent.ml index 60ab346526..3b2e29a0a3 100644 --- a/src/ecIdent.ml +++ b/src/ecIdent.ml @@ -57,3 +57,4 @@ let tostring (id : t) = (* -------------------------------------------------------------------- *) let pp_ident fmt id = Format.fprintf fmt "%s" (name id) +let pp = pp_ident diff --git a/src/ecIdent.mli b/src/ecIdent.mli index 988430a72e..2c3d5d6046 100644 --- a/src/ecIdent.mli +++ b/src/ecIdent.mli @@ -38,3 +38,4 @@ val fv_add : ident -> int Mid.t -> int Mid.t (* -------------------------------------------------------------------- *) val pp_ident : Format.formatter -> t -> unit +val pp : Format.formatter -> t -> unit diff --git a/src/ecMemory.ml b/src/ecMemory.ml index c0bc63ccce..945fa78325 100644 --- a/src/ecMemory.ml +++ b/src/ecMemory.ml @@ -8,6 +8,9 @@ module Msym = EcSymbols.Msym (* -------------------------------------------------------------------- *) type memory = EcIdent.t +let pp_memory fmt m = + Format.fprintf fmt "&%a" EcIdent.pp m + let mem_equal = EcIdent.id_equal (* -------------------------------------------------------------------- *) diff --git a/src/ecMemory.mli b/src/ecMemory.mli index b7f5ba98e5..10c2f0998a 100644 --- a/src/ecMemory.mli +++ b/src/ecMemory.mli @@ -4,6 +4,8 @@ open EcTypes (* -------------------------------------------------------------------- *) type memory = EcIdent.t +val pp_memory : Format.formatter -> memory -> unit + val mem_equal : memory -> memory -> bool (* -------------------------------------------------------------------- *) diff --git a/src/ecPath.ml b/src/ecPath.ml index 4fa7421552..b603234650 100644 --- a/src/ecPath.ml +++ b/src/ecPath.ml @@ -93,6 +93,9 @@ let rec tostring p = | Psymbol x -> x | Pqname (p,x) -> Printf.sprintf "%s.%s" (tostring p) x +let pp_path fmt p = + Format.fprintf fmt "%s" (tostring p) + let tolist = let rec aux l p = match p.p_node with @@ -371,10 +374,16 @@ let rec m_tostring (m : mpath) = in Printf.sprintf "%s%s%s" top args sub +let pp_mpath fmt p = + Format.fprintf fmt "%s" (m_tostring p) + let x_tostring x = Printf.sprintf "%s./%s" (m_tostring x.x_top) x.x_sub +let pp_xpath fmt x = + Format.fprintf fmt "%s" (x_tostring x) + (* -------------------------------------------------------------------- *) let p_subst (s : path Mp.t) = if Mp.is_empty s then identity diff --git a/src/ecPath.mli b/src/ecPath.mli index 7adec46bba..2b905dc126 100644 --- a/src/ecPath.mli +++ b/src/ecPath.mli @@ -13,6 +13,8 @@ and path_node = | Psymbol of symbol | Pqname of path * symbol +val pp_path : Format.formatter -> path -> unit + (* -------------------------------------------------------------------- *) val psymbol : symbol -> path val pqname : path -> symbol -> path @@ -58,6 +60,8 @@ and mpath_top = [ | `Local of ident | `Concrete of path * path option ] +val pp_mpath : Format.formatter -> mpath -> unit + (* -------------------------------------------------------------------- *) val mpath : mpath_top -> mpath list -> mpath val mpath_abs : ident -> mpath list -> mpath @@ -88,6 +92,8 @@ type xpath = private { x_tag : int; } +val pp_xpath : Format.formatter -> xpath -> unit + val xpath : mpath -> symbol -> xpath val xastrip : xpath -> xpath diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 2721071088..10906d2ffb 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -153,7 +153,7 @@ module PPEnv = struct let ty_symb (ppe : t) p = let exists sm = - try EcPath.p_equal (EcEnv.Ty.lookup_path sm ppe.ppe_env) p + try EcPath.p_equal (EcEnv.Ty.lookup_path sm ppe.ppe_env) p || (lookup) with EcEnv.LookupFailure _ -> false in p_shorten exists p @@ -327,7 +327,7 @@ module PPEnv = struct let tyvar (ppe : t) x = match Mid.find_opt x ppe.ppe_locals with - | None -> EcIdent.tostring x + | None -> EcIdent.name x | Some x -> x exception FoundUnivarSym of symbol @@ -359,6 +359,15 @@ module PPEnv = struct end; oget (Mint.find_opt i (fst !(ppe.ppe_univar))) + + (*TODOTC: must add the path to the local types*) + let tc_add_ty ppe p = + (* + let ppe = {ppe with ppe_env = EcEnv.Ty.add p ppe.ppe_env} in + ppe, EcEnv.Ty.lookup_path (EcPath.toqsymbol p) ppe.ppe_env + *) + ppe, p + end (* -------------------------------------------------------------------- *) @@ -406,6 +415,14 @@ let pp_paren pp fmt x = let pp_maybe_paren c pp = pp_maybe c pp_paren pp +(* -------------------------------------------------------------------- *) +let pp_bracket pp fmt x = + pp_enclose ~pre:"[" ~post:"]" pp fmt x + +(* -------------------------------------------------------------------- *) +let pp_maybe_bracket c pp = + pp_maybe c pp_bracket pp + (* -------------------------------------------------------------------- *) let pp_string fmt x = Format.fprintf fmt "%s" x @@ -432,7 +449,7 @@ let pp_tyname ppe fmt p = Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.ty_symb ppe p) (* -------------------------------------------------------------------- *) -let pp_tcname ppe fmt p = +let pp_tc_name ppe fmt p = Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.tc_symb ppe p) (* -------------------------------------------------------------------- *) @@ -2066,18 +2083,16 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = in Format.fprintf fmt "@[%a%t%t.@]" pp_locality tyd.tyd_loca pp_prelude pp_body - - (* -------------------------------------------------------------------- *) -let pp_tc (ppe : PPEnv.t) fmt tc = +let pp_typeclass (ppe : PPEnv.t) fmt tc = match tc.tc_args with - | [] -> pp_tcname ppe fmt tc.tc_name + | [] -> pp_tc_name ppe fmt tc.tc_name | [ty] -> Format.fprintf fmt "%a %a" (pp_type ppe) ty - (pp_tcname ppe) tc.tc_name + (pp_tc_name ppe) tc.tc_name | tys -> Format.fprintf fmt "(%a) %a" (pp_list ",@ " (pp_type ppe)) tys - (pp_tcname ppe) tc.tc_name + (pp_tc_name ppe) tc.tc_name (* -------------------------------------------------------------------- *) let pp_tyvar_ctt (ppe : PPEnv.t) fmt (tvar, ctt) = @@ -2086,7 +2101,7 @@ let pp_tyvar_ctt (ppe : PPEnv.t) fmt (tvar, ctt) = | ctt -> Format.fprintf fmt "%a <: %a" (pp_tyvar ppe) tvar - (pp_list " &@ " (fun fmt tc -> pp_tc ppe fmt tc)) ctt + (pp_list " &@ " (fun fmt tc -> pp_typeclass ppe fmt tc)) ctt (* -------------------------------------------------------------------- *) let pp_tyvarannot (ppe : PPEnv.t) fmt ids = @@ -2322,19 +2337,6 @@ let pp_added_op (ppe : PPEnv.t) fmt op = let pp_opname (ppe : PPEnv.t) fmt (p : EcPath.path) = pp_opname fmt (PPEnv.op_symb ppe p None) -(* -------------------------------------------------------------------- *) -let pp_typeclass (ppe : PPEnv.t) fmt (tc : typeclass) = - match tc.tc_args with - | [] -> - Format.fprintf fmt "%a" (pp_tcname ppe) tc.tc_name - | [ty] -> - Format.fprintf fmt "%a %a" - (pp_type ppe) ty (pp_tcname ppe) tc.tc_name - | tys -> - Format.fprintf fmt "(%a) %a" - (pp_list ", " (pp_type ppe)) tys - (pp_tcname ppe) tc.tc_name - (* -------------------------------------------------------------------- *) let string_of_axkind = function | `Axiom _ -> "axiom" @@ -2885,10 +2887,49 @@ let pp_rwbase ppe fmt (p, rws) = (pp_rwname ppe) p (pp_list ", " (pp_axname ppe)) (Sp.elements rws) (* -------------------------------------------------------------------- *) -(*TODOTC*) -let pp_tcbase ppe fmt (p, tcdecl) = - Format.fprintf fmt "%a = %a@\n%!" - (pp_tcname ppe) p (pp_option (pp_typeclass ppe)) (tcdecl.tc_prt) +(* +TODOTC: +- remove the Top. (in ppe) +*) +let pp_tparam ppe fmt (id, tcs) = + Format.fprintf fmt "%a <: %a" + pp_symbol (EcIdent.name id) + (pp_list " &@ " (pp_typeclass ppe)) tcs + +let pp_tparams ppe fmt tparams = + Format.fprintf fmt "%a" + (pp_maybe (List.length tparams != 0) (pp_enclose ~pre:"[" ~post:"] ") (pp_list ",@ " (pp_tparam ppe))) tparams + +let pp_prt ppe = + pp_option (pp_enclose ~pre:" <: " ~post:"" (pp_typeclass ppe)) + +let pp_op ppe fmt (t, ty) = + Format.fprintf fmt " @[op %s :@ %a.@]" + (EcIdent.name t) + (pp_type ppe) ty + +let pp_ops ppe fmt ops = + pp_maybe (List.length ops != 0) (pp_enclose ~pre:"" ~post:"@,@,") (pp_list "@,@," (pp_op ppe)) fmt ops + +let pp_ax ppe fmt (s, f) = + Format.fprintf fmt " @[axiom %s :@ %a.@]" + s (pp_form ppe) f + +let pp_axs ppe fmt axs = + pp_maybe (List.length axs != 0) (pp_enclose ~pre:"" ~post:"@,@,") (pp_list "@,@," (pp_ax ppe)) fmt axs + +let pp_ops_axs ppe fmt (ops, axs) = + Format.fprintf fmt "%a%a" + (pp_maybe (List.length ops + List.length axs != 0) (pp_enclose ~pre:"@,@," ~post:"") (pp_ops ppe)) ops + (pp_axs ppe) axs + +let pp_tc_decl ppe fmt (p, tcdecl) = + let ppe, p = PPEnv.tc_add_ty ppe p in + Format.fprintf fmt "@[type class %a%a%a = {%a}.@]" + (pp_tparams ppe) tcdecl.tc_tparams + (pp_tc_name ppe) p + (pp_prt ppe) tcdecl.tc_prt + (pp_ops_axs ppe) (tcdecl.tc_ops, tcdecl.tc_axs) (* -------------------------------------------------------------------- *) let pp_solvedb ppe fmt db = @@ -3012,7 +3053,7 @@ module PPGoal = struct | FhoareS hs -> pp_hoareS ?prpo ppe fmt hs | FequivF ef -> pp_equivF ppe fmt ef | FequivS es -> pp_equivS ?prpo ppe fmt es - | _ -> Format.fprintf fmt "%a@\n%!" (pp_form ppe) concl + | _ -> Format.fprintf fmt "%a@\n%!" EcFol.pp_form concl end (* -------------------------------------------------------------------- *) @@ -3377,7 +3418,7 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = | `General tc -> Format.fprintf fmt "%ainstance %a with %a." - pp_locality lc (pp_type ppe) ty (pp_tc ppe) tc + pp_locality lc (pp_type ppe) ty (pp_typeclass ppe) tc end | EcTheory.Th_baserw (name, _lc) -> @@ -3551,11 +3592,10 @@ module ObjectInfo = struct | `Solve name -> pr_at fmt env name (* ------------------------------------------------------------------ *) - (*TODOTC: the printing of a typeclass*) let pr_tc_r = - { od_name = "typeclasses"; + { od_name = "type classes"; od_lookup = EcEnv.TypeClass.lookup; - od_printer = pp_tcbase; } + od_printer = pp_tc_decl; } (* ------------------------------------------------------------------ *) let pr_any fmt env qs = @@ -3657,5 +3697,5 @@ let pp_use_restr env ~print_abstract fmt ur = let () = EcEnv.pp_debug_form := (fun env fmt f -> - let ppe = PPEnv.ofenv env in - pp_form ppe fmt f) + let _ (*ppe*) = PPEnv.ofenv env in + EcCoreFol.pp_form fmt f) diff --git a/src/ecPrinting.mli b/src/ecPrinting.mli index 32dfc7fc87..63093adfca 100644 --- a/src/ecPrinting.mli +++ b/src/ecPrinting.mli @@ -52,7 +52,7 @@ val pp_type : PPEnv.t -> ty pp val pp_tyname : PPEnv.t -> path pp val pp_axname : PPEnv.t -> path pp val pp_scname : PPEnv.t -> path pp -val pp_tcname : PPEnv.t -> path pp +val pp_tc_name : PPEnv.t -> path pp val pp_thname : PPEnv.t -> path pp val pp_mem : PPEnv.t -> EcIdent.t pp diff --git a/src/ecScope.ml b/src/ecScope.ml index 37e82f498d..e9282b321c 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1829,6 +1829,8 @@ module Ty = struct tc.tc_ops (* ------------------------------------------------------------------ *) + (*TODOTC: we have to consider the operators of the parent typeclass instance, and also the types. + How can I find this instance?*) let add_generic_instance ~import (scope : scope) mode { pl_desc = tci; pl_loc = loc; } = @@ -1845,12 +1847,17 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in - tc.tc_prt |> oiter (fun prt -> - let ue = EcUnify.UniEnv.create (Some typarams) in - - if not (EcUnify.hastc (env scope) ue (snd ty) prt) then - hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) - ); + let prti = + Option.map + (fun prt -> + let ue = EcUnify.UniEnv.create (Some typarams) in + if not (EcUnify.hastc (env scope) ue (snd ty) prt) then + hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name); + let oprti = EcEnv.TypeClass.get_instance (env scope) prt in + match oprti with + | Some prti -> prti + | _ -> hierror "instance of `%s' was said to be in the env, but was not found" (EcPath.tostring tcp.tc_name) ) + tc.tc_prt in let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in @@ -1861,6 +1868,14 @@ module Ty = struct ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; ts_v = let vsubst = List.combine (List.fst tc.tc_tparams) tcp.tc_args in +(* + let vsubst = + ofold + (fun tcp_prt vs -> + let tc_prt = EcEnv.TypeClass.by_path tcp_prt.tc_name (env scope) in + List.combine (List.fst tc_prt.tc_tparams) tcp_prt.tc_args @ vs) + vsubst tc.tc_prt in +*) Mid.of_list vsubst; } in @@ -1872,13 +1887,26 @@ module Ty = struct EcFol.Fsubst.f_bind_local subst opname op) (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in +(* + let subst = + ofold + (fun tcp_prt s -> + let tc_prt = EcEnv.TypeClass.by_path tcp_prt.tc_name (env scope) in + List.fold_left + (fun subst (opname, ty) -> + let oppath = Mstr.find (EcIdent.name opname) symbols in + let op = EcFol.f_op oppath [] (ty_subst tysubst ty) in + EcFol.Fsubst.f_bind_local subst opname op) + s tc_prt.tc_ops) + subst tc.tc_prt in +*) + let axioms = List.map (fun (name, ax) -> let ax = EcFol.Fsubst.f_subst subst ax in (name, ax)) tc.tc_axs in - let lc = (tci.pti_loca :> locality) in let inter = check_tci_axioms scope mode tci.pti_axs axioms lc in diff --git a/src/ecSection.ml b/src/ecSection.ml index dc4dfb7a3d..2dc39b7f01 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -45,7 +45,7 @@ let pp_cbarg env fmt (who : cbarg) = let mty = EcEnv.ModTy.modtype p env in Format.fprintf fmt "module type %a" (EcPrinting.pp_modtype1 ppe) mty | `Typeclass p -> - Format.fprintf fmt "typeclass %a" (EcPrinting.pp_tcname ppe) p + Format.fprintf fmt "typeclass %a" (EcPrinting.pp_tc_name ppe) p | `Instance tci -> match tci with | `Ring _ -> Format.fprintf fmt "ring instance" diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 7283bdc75a..46b0d1ccc3 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -18,9 +18,10 @@ let local_of_locality = function (* -------------------------------------------------------------------- *) type ty = { ty_node : ty_node; - ty_fv : int EcIdent.Mid.t; (* only ident appearing in path *) - ty_tag : int; + ty_fv : (int EcIdent.Mid.t [@opaque]); (* only ident appearing in path *) + ty_tag : (int [@opaque]); } +[@@deriving show] and ty_node = | Tglob of EcPath.mpath (* The tuple of global variable of the module *) @@ -29,6 +30,7 @@ and ty_node = | Ttuple of ty list | Tconstr of EcPath.path * ty list | Tfun of ty * ty +[@@deriving show] type dom = ty list @@ -383,10 +385,12 @@ let ty_fv_and_tvar (ty : ty) = type pvar_kind = | PVKglob | PVKloc +[@@deriving show] type prog_var = | PVglob of EcPath.xpath | PVloc of EcSymbols.symbol +[@@deriving show] let pv_equal v1 v2 = match v1, v2 with | PVglob x1, PVglob x2 -> @@ -473,6 +477,7 @@ type lpattern = | LSymbol of (EcIdent.t * ty) | LTuple of (EcIdent.t * ty) list | LRecord of EcPath.path * (EcIdent.t option * ty) list +[@@deriving show] let idty_equal (x1,t1) (x2,t2) = EcIdent.id_equal x1 x2 && ty_equal t1 t2 diff --git a/src/ecTypes.mli b/src/ecTypes.mli index 75f04d70a2..0b9ca0fd4f 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -19,6 +19,7 @@ type ty = private { ty_fv : int Mid.t; ty_tag : int; } +[@@deriving show] and ty_node = | Tglob of EcPath.mpath (* The tuple of global variable of the module *) @@ -125,6 +126,7 @@ type lpattern = | LSymbol of (EcIdent.t * ty) | LTuple of (EcIdent.t * ty) list | LRecord of EcPath.path * (EcIdent.t option * ty) list +[@@deriving show] val lp_equal : lpattern -> lpattern -> bool val lp_hash : lpattern -> int @@ -146,10 +148,12 @@ val v_equal : variable -> variable -> bool type pvar_kind = | PVKglob | PVKloc +[@@deriving show] type prog_var = private | PVglob of EcPath.xpath | PVloc of EcSymbols.symbol +[@@deriving show] val pv_equal : prog_var -> prog_var -> bool val pv_compare : prog_var -> prog_var -> int diff --git a/src/ecUid.ml b/src/ecUid.ml index 6e9124b62c..7af9496cb5 100644 --- a/src/ecUid.ml +++ b/src/ecUid.ml @@ -31,6 +31,9 @@ let forsym (um : uidmap) (x : symbol) = Hashtbl.add um.um_tbl x uid; uid +let pp_uid fmt u = + Format.fprintf fmt "#%d" u + (* -------------------------------------------------------------------- *) let uid_equal x y = x == y let uid_compare x y = x - y diff --git a/src/ecUid.mli b/src/ecUid.mli index 885bcbd99f..1fc50b33a9 100644 --- a/src/ecUid.mli +++ b/src/ecUid.mli @@ -12,6 +12,7 @@ type uidmap val create : unit -> uidmap val lookup : uidmap -> symbol -> uid option val forsym : uidmap -> symbol -> uid +val pp_uid : Format.formatter -> uid -> unit (* -------------------------------------------------------------------- *) val uid_equal : uid -> uid -> bool diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 5d107602b1..71d3fbba75 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -375,7 +375,7 @@ end (* -------------------------------------------------------------------- *) module UnifyExtraForTC : UnifyExtra with type state = typeclass list - and type problem = [ `TcCtt of ty * typeclass ] = + and type problem = [ `TcCtt of ty * typeclass] = struct type state = typeclass list type problem = [ `TcCtt of ty * typeclass ] From 1e291193e648ecbfe22b45215e52b23ec94f1f4b Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 28 Apr 2022 16:25:12 +0200 Subject: [PATCH 041/113] fix printing of type-classes names --- examples/typeclass.ec | 1 + src/ecPrinting.ml | 54 +++++++++++++++---------------------------- src/ecPrinting.mli | 1 - src/ecSection.ml | 17 +++++++------- 4 files changed, 29 insertions(+), 44 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 6b25c49a3e..32889c825f 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -19,6 +19,7 @@ type class finite = { axiom enumP : forall (x : finite), x \in enum }. +print enum. print enumP. type class countable = { diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 10906d2ffb..e98d803cdc 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -152,16 +152,13 @@ module PPEnv = struct shorten (List.rev nm) ([], x) let ty_symb (ppe : t) p = - let exists sm = - try EcPath.p_equal (EcEnv.Ty.lookup_path sm ppe.ppe_env) p || (lookup) - with EcEnv.LookupFailure _ -> false - in - p_shorten exists p + let exists sm = + let p1 = Option.map fst (EcEnv.Ty.lookup_opt sm ppe.ppe_env) in + let p2 = Option.map fst (EcEnv.TypeClass.lookup_opt sm ppe.ppe_env) in - let tc_symb (ppe : t) p = - let exists sm = - try EcPath.p_equal (EcEnv.TypeClass.lookup_path sm ppe.ppe_env) p - with EcEnv.LookupFailure _ -> false + List.exists + (EcPath.p_equal p) + (Option.to_list p1 @ Option.to_list p2) in p_shorten exists p @@ -359,15 +356,6 @@ module PPEnv = struct end; oget (Mint.find_opt i (fst !(ppe.ppe_univar))) - - (*TODOTC: must add the path to the local types*) - let tc_add_ty ppe p = - (* - let ppe = {ppe with ppe_env = EcEnv.Ty.add p ppe.ppe_env} in - ppe, EcEnv.Ty.lookup_path (EcPath.toqsymbol p) ppe.ppe_env - *) - ppe, p - end (* -------------------------------------------------------------------- *) @@ -448,10 +436,6 @@ let pp_tyunivar ppe fmt x = let pp_tyname ppe fmt p = Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.ty_symb ppe p) -(* -------------------------------------------------------------------- *) -let pp_tc_name ppe fmt p = - Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.tc_symb ppe p) - (* -------------------------------------------------------------------- *) let pp_rwname ppe fmt p = Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.rw_symb ppe p) @@ -2086,13 +2070,18 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = (* -------------------------------------------------------------------- *) let pp_typeclass (ppe : PPEnv.t) fmt tc = match tc.tc_args with - | [] -> pp_tc_name ppe fmt tc.tc_name - | [ty] -> Format.fprintf fmt "%a %a" - (pp_type ppe) ty - (pp_tc_name ppe) tc.tc_name - | tys -> Format.fprintf fmt "(%a) %a" - (pp_list ",@ " (pp_type ppe)) tys - (pp_tc_name ppe) tc.tc_name + | [] -> + pp_tyname ppe fmt tc.tc_name + + | [ty] -> + Format.fprintf fmt "%a %a" + (pp_type ppe) ty + (pp_tyname ppe) tc.tc_name + + | tys -> + Format.fprintf fmt "(%a) %a" + (pp_list ",@ " (pp_type ppe)) tys + (pp_tyname ppe) tc.tc_name (* -------------------------------------------------------------------- *) let pp_tyvar_ctt (ppe : PPEnv.t) fmt (tvar, ctt) = @@ -2887,10 +2876,6 @@ let pp_rwbase ppe fmt (p, rws) = (pp_rwname ppe) p (pp_list ", " (pp_axname ppe)) (Sp.elements rws) (* -------------------------------------------------------------------- *) -(* -TODOTC: -- remove the Top. (in ppe) -*) let pp_tparam ppe fmt (id, tcs) = Format.fprintf fmt "%a <: %a" pp_symbol (EcIdent.name id) @@ -2924,10 +2909,9 @@ let pp_ops_axs ppe fmt (ops, axs) = (pp_axs ppe) axs let pp_tc_decl ppe fmt (p, tcdecl) = - let ppe, p = PPEnv.tc_add_ty ppe p in Format.fprintf fmt "@[type class %a%a%a = {%a}.@]" (pp_tparams ppe) tcdecl.tc_tparams - (pp_tc_name ppe) p + (pp_tyname ppe) p (pp_prt ppe) tcdecl.tc_prt (pp_ops_axs ppe) (tcdecl.tc_ops, tcdecl.tc_axs) diff --git a/src/ecPrinting.mli b/src/ecPrinting.mli index 63093adfca..be4dc553c1 100644 --- a/src/ecPrinting.mli +++ b/src/ecPrinting.mli @@ -52,7 +52,6 @@ val pp_type : PPEnv.t -> ty pp val pp_tyname : PPEnv.t -> path pp val pp_axname : PPEnv.t -> path pp val pp_scname : PPEnv.t -> path pp -val pp_tc_name : PPEnv.t -> path pp val pp_thname : PPEnv.t -> path pp val pp_mem : PPEnv.t -> EcIdent.t pp diff --git a/src/ecSection.ml b/src/ecSection.ml index 2dc39b7f01..76700e8ecf 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -36,16 +36,17 @@ type dep_error = let pp_cbarg env fmt (who : cbarg) = let ppe = EcPrinting.PPEnv.ofenv env in match who with - | `Type p -> Format.fprintf fmt "type %a" (EcPrinting.pp_tyname ppe) p - | `Op p -> Format.fprintf fmt "operator %a" (EcPrinting.pp_opname ppe) p - | `Ax p -> Format.fprintf fmt "lemma/axiom %a" (EcPrinting.pp_axname ppe) p - | `Sc p -> Format.fprintf fmt "schema %a" (EcPrinting.pp_scname ppe) p - | `Module mp -> Format.fprintf fmt "module %a" (EcPrinting.pp_topmod ppe) mp + | `Type p -> Format.fprintf fmt "type %a" (EcPrinting.pp_tyname ppe) p + | `Op p -> Format.fprintf fmt "operator %a" (EcPrinting.pp_opname ppe) p + | `Ax p -> Format.fprintf fmt "lemma/axiom %a" (EcPrinting.pp_axname ppe) p + | `Sc p -> Format.fprintf fmt "schema %a" (EcPrinting.pp_scname ppe) p + | `Module p -> Format.fprintf fmt "module %a" (EcPrinting.pp_topmod ppe) p | `ModuleType p -> - let mty = EcEnv.ModTy.modtype p env in - Format.fprintf fmt "module type %a" (EcPrinting.pp_modtype1 ppe) mty + Format.fprintf fmt "module type %a" + (EcPrinting.pp_modtype1 ppe) + (EcEnv.ModTy.modtype p env) | `Typeclass p -> - Format.fprintf fmt "typeclass %a" (EcPrinting.pp_tc_name ppe) p + Format.fprintf fmt "typeclass %a" (EcPrinting.pp_tyname ppe) p | `Instance tci -> match tci with | `Ring _ -> Format.fprintf fmt "ring instance" From f01c06d69475e2e48367671abaf2bd4b00a5d83e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 28 Apr 2022 16:50:23 +0200 Subject: [PATCH 042/113] record typeclass instances operators --- src/ecEnv.ml | 21 ++++----------------- src/ecEnv.mli | 1 - src/ecPrinting.ml | 2 +- src/ecScope.ml | 8 +++++--- src/ecSection.ml | 12 ++++++++---- src/ecSubst.ml | 11 ++++++++--- src/ecTheory.ml | 10 ++++++++-- src/ecTheory.mli | 10 ++++++++-- src/ecTheoryReplay.ml | 16 +++++++++++----- src/ecUnify.ml | 2 +- 10 files changed, 54 insertions(+), 39 deletions(-) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 728c0d4762..ff75d5e341 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -205,12 +205,6 @@ and scope = [ | `Fun of EcPath.xpath ] -and tcinstance = [ - | `Ring of EcDecl.ring - | `Field of EcDecl.field - | `General of typeclass -] - and redinfo = { ri_priomap : (EcTheory.rule list) Mint.t; ri_list : (EcTheory.rule list) Lazy.t; } @@ -1418,14 +1412,6 @@ module TypeClass = struct env_item = mkitem import (Th_instance (ty, cr, lc)) :: env.env_item; } let get_instances env = env.env_tci - - let get_instance env tc = - List.find_opt - (fun p -> - match (snd p) with - | `General tc' -> tc = tc' - | _ -> false ) - (get_instances env) end (* -------------------------------------------------------------------- *) @@ -1675,7 +1661,7 @@ module Ty = struct let env_tci = List.fold (fun inst (tc : typeclass) -> - TypeClass.bind_instance myty (`General tc) inst) + TypeClass.bind_instance myty (`General (tc, None)) inst) env.env_tci tcs in { env with env_tci } @@ -3160,13 +3146,14 @@ module Theory = struct | Th_type (x, tyd) -> begin match tyd.tyd_type with - | `Abstract tcs -> (* FIXME: this code is a duplicate *) + | `Abstract tcs -> (* FIXME:TC this code is a duplicate *) let myty = let typ = List.map (fst_map EcIdent.fresh) tyd.tyd_params in (typ, EcTypes.tconstr (xpath x) (List.map (tvar |- fst) typ)) in List.fold - (fun inst tc -> TypeClass.bind_instance myty (`General tc) inst) + (fun inst tc -> + TypeClass.bind_instance myty (`General (tc, None)) inst) inst tcs | _ -> inst diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 708a87fc6b..cabd4eb64a 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -398,7 +398,6 @@ module TypeClass : sig val add_instance : ?import:import -> (ty_params * ty) -> tcinstance -> is_local -> env -> env val get_instances : env -> ((ty_params * ty) * tcinstance) list - val get_instance : env -> typeclass -> ((ty_params * ty) * tcinstance) option end (* -------------------------------------------------------------------- *) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index e98d803cdc..f1bebeb844 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -3400,7 +3400,7 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = ops end - | `General tc -> + | `General (tc, _) -> Format.fprintf fmt "%ainstance %a with %a." pp_locality lc (pp_type ppe) ty (pp_typeclass ppe) tc end diff --git a/src/ecScope.ml b/src/ecScope.ml index e9282b321c..2b59ab7c73 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1754,7 +1754,7 @@ module Ty = struct let add env p = let item = { tc_name = p; tc_args = []; } in - let item = EcTheory.Th_instance (ty, `General item, tci.pti_loca) in + let item = EcTheory.Th_instance (ty, `General (item, None), tci.pti_loca) in let item = EcTheory.mkitem import item in EcSection.add_item item env in @@ -1800,7 +1800,7 @@ module Ty = struct let add env p = let item = { tc_name = p; tc_args = [] } in - let item = EcTheory.Th_instance(ty, `General item, tci.pti_loca) in + let item = EcTheory.Th_instance(ty, `General (item, None), tci.pti_loca) in let item = EcTheory.mkitem import item in EcSection.add_item item env in @@ -1847,6 +1847,7 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in +(* let prti = Option.map (fun prt -> @@ -1858,6 +1859,7 @@ module Ty = struct | Some prti -> prti | _ -> hierror "instance of `%s' was said to be in the env, but was not found" (EcPath.tostring tcp.tc_name) ) tc.tc_prt in +*) let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in @@ -1911,7 +1913,7 @@ module Ty = struct let inter = check_tci_axioms scope mode tci.pti_axs axioms lc in let add env = - let item = EcTheory.Th_instance(ty, `General tcp, tci.pti_loca) in + let item = EcTheory.Th_instance (ty, `General (tcp, Some symbols), tci.pti_loca) in let item = EcTheory.mkitem import item in EcSection.add_item item env in diff --git a/src/ecSection.ml b/src/ecSection.ml index 76700e8ecf..8781cd63da 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -1,6 +1,7 @@ (* -------------------------------------------------------------------- *) open EcUtils open EcSymbols +open EcMaps open EcPath open EcTypes open EcDecl @@ -387,7 +388,7 @@ let on_typeclasses cb tcs = List.iter (on_typeclass cb) tcs let on_typarams cb typarams = - List.iter (fun (_,tc) -> on_typeclasses cb tc) typarams + List.iter (fun (_, tc) -> on_typeclasses cb tc) typarams (* -------------------------------------------------------------------- *) let on_tydecl (cb : cb) (tyd : tydecl) = @@ -488,9 +489,12 @@ let on_instance cb ty tci = on_ty cb (snd ty); (* FIXME section: ring/field use type class that do not exists *) match tci with - | `Ring r -> on_ring cb r - | `Field f -> on_field cb f - | `General tci -> on_typeclass cb tci + | `Ring r -> on_ring cb r + | `Field f -> on_field cb f + + | `General (tci, syms) -> + on_typeclass cb tci; + Option.iter (Mstr.iter (fun _ p -> cb (`Op p))) syms (* -------------------------------------------------------------------- *) diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 36cdaea546..3ca34ff8dd 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -1,5 +1,6 @@ (* -------------------------------------------------------------------- *) open EcUtils +open EcMaps open EcTypes open EcDecl open EcCoreFol @@ -501,9 +502,13 @@ let subst_field (s : _subst) cr = (* -------------------------------------------------------------------- *) let subst_instance (s : _subst) tci = match tci with - | `Ring cr -> `Ring (subst_ring s cr) - | `Field cr -> `Field (subst_field s cr) - | `General tc -> `General (subst_typeclass s tc) + | `Ring cr -> `Ring (subst_ring s cr) + | `Field cr -> `Field (subst_field s cr) + + | `General (tc, syms) -> + let tc = subst_typeclass s tc in + let syms = Option.map (Mstr.map s.s_p) syms in + `General (tc, syms) (* -------------------------------------------------------------------- *) let subst_tc (s : _subst) tc = diff --git a/src/ecTheory.ml b/src/ecTheory.ml index 8e2f5b802e..92a0b7908e 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -1,6 +1,7 @@ (* -------------------------------------------------------------------- *) open EcUtils open EcSymbols +open EcMaps open EcPath open EcTypes open EcDecl @@ -50,8 +51,13 @@ and ctheory = { cth_source : thsource option; } -and tcinstance = [ `Ring of ring | `Field of field | `General of typeclass ] -and thmode = [ `Abstract | `Concrete ] +and tcinstance = [ + | `Ring of ring + | `Field of field + | `General of typeclass * (path Mstr.t) option +] + +and thmode = [ `Abstract | `Concrete ] and rule_pattern = | Rule of top_rule_pattern * rule_pattern list diff --git a/src/ecTheory.mli b/src/ecTheory.mli index 21e1a6a3c0..d114537dd1 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -1,5 +1,6 @@ (* -------------------------------------------------------------------- *) open EcSymbols +open EcMaps open EcPath open EcTypes open EcDecl @@ -47,8 +48,13 @@ and ctheory = { cth_source : thsource option; } -and tcinstance = [ `Ring of ring | `Field of field | `General of typeclass ] -and thmode = [ `Abstract | `Concrete ] +and tcinstance = [ + | `Ring of ring + | `Field of field + | `General of typeclass * (path Mstr.t) option +] + +and thmode = [ `Abstract | `Concrete ] (* For cost judgement, we have higher-order pattern. *) and rule_pattern = diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index dca0150edf..3275ac8524 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -1,5 +1,6 @@ (* ------------------------------------------------------------------ *) open EcSymbols +open EcMaps open EcUtils open EcLocation open EcParsetree @@ -938,13 +939,18 @@ and replay_instance f_div = cr.f_div |> omap forpath; } in match tc with - | `Ring cr -> `Ring (doring cr) - | `Field cr -> `Field (dofield cr) - | `General p -> `General (fortypeclass p) + | `Ring cr -> `Ring (doring cr) + | `Field cr -> `Field (dofield cr) + + | `General (tc, syms) -> + let tc = fortypeclass tc in + let syms = Option.map (Mstr.map forpath) syms in + `General (tc, syms) in - let scope = ove.ovre_hooks.hadd_item scope import (Th_instance ((typ, ty), tc, lc)) in - (subst, ops, proofs, scope) + let scope = + ove.ovre_hooks.hadd_item scope import (Th_instance ((typ, ty), tc, lc)) + in (subst, ops, proofs, scope) with E.InvInstPath -> (subst, ops, proofs, scope) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 71d3fbba75..c49ba4b7ab 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -282,7 +282,7 @@ module TypeClass = struct let instances = List.filter_map - (function (x, `General y) -> Some (x, y) | _ -> None) + (function (x, `General (y, _)) -> Some (x, y) | _ -> None) instances in let instances = From f58252d7aac27602bc609974f0032b11c265e672 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 28 Apr 2022 17:02:26 +0200 Subject: [PATCH 043/113] EcUnify.hastc returns the instance operators --- src/ecTyping.ml | 2 +- src/ecUnify.ml | 67 +++++++++++++++++++++++++++++++++---------------- src/ecUnify.mli | 4 ++- 3 files changed, 49 insertions(+), 24 deletions(-) diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 67095bf193..07678a67a4 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -1206,7 +1206,7 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = List.iter2 (fun (_, tcs) ty -> List.iter (fun tc -> - if not (EcUnify.hastc env ue ty tc) then + if Option.is_none (EcUnify.hastc env ue ty tc) then tyerror (loc tc_name) env (CannotInferTC (ty, tc))) tcs) decl.tc_tparams args; { tc_name = p; tc_args = args; } diff --git a/src/ecUnify.ml b/src/ecUnify.ml index c49ba4b7ab..4b0369b968 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -282,21 +282,26 @@ module TypeClass = struct let instances = List.filter_map - (function (x, `General (y, _)) -> Some (x, y) | _ -> None) + (function (x, `General (y, syms)) -> Some (x, y, syms) | _ -> None) instances in let instances = (* FIXME:TC *) - let ring = EcPath.fromqsymbol ([EcCoreLib.i_top], "Ring") in + let ring = EcPath.fromqsymbol ([EcCoreLib.i_top], "Ring" ) in + let field = EcPath.fromqsymbol ([EcCoreLib.i_top], "Field") in + List.filter - (fun (_, tc) -> not (EcPath.isprefix ring tc.tc_name)) + (fun (_, tc, _) -> + List.for_all + (fun p -> not (EcPath.isprefix p tc.tc_name)) + [ring; field]) instances in let instances = let tvinst = List.map (fun (tv, tcs) -> - List.map (fun tc -> (([], tvar tv), tc)) tcs) + List.map (fun tc -> (([], tvar tv), tc, None)) tcs) (Mid.bindings tvtc) in List.flatten tvinst @ instances in @@ -311,7 +316,7 @@ module TypeClass = struct let acc = (tcdecl.tc_tparams, tginst.tc_args) :: acc in find_tc_in_parent acc prt) in - let for1 ((tgparams, tgty), tginst) = + let for1 ((tgparams, tgty), tginst, opsyms) = let tgi_args, tgparams_prt = oget ~exn:Bailout (find_tc_in_parent [] tginst) in @@ -359,10 +364,13 @@ module TypeClass = struct let subst = UnifyCore.subst_of_uf !uf in let subst = Tuni.offun subst in - List.flatten (List.map - (fun (_, (ty, tcs)) -> - List.map (fun tc -> (subst ty, tc)) tcs) - tvinfo) + let effects = + List.flatten (List.map + (fun (_, (ty, tcs)) -> + List.map (fun tc -> (subst ty, tc)) tcs) + tvinfo) + + in (effects, opsyms) in @@ -373,12 +381,16 @@ module TypeClass = struct end (* -------------------------------------------------------------------- *) +type tcproblem = [ + `TcCtt of ty * typeclass * (EcPath.path Mstr.t) option ref +] + module UnifyExtraForTC : UnifyExtra with type state = typeclass list - and type problem = [ `TcCtt of ty * typeclass] = + and type problem = tcproblem = struct type state = typeclass list - type problem = [ `TcCtt of ty * typeclass ] + type problem = tcproblem type uparam = state * ty option exception Failure @@ -397,7 +409,7 @@ struct | (tc1, None ), (tc2, Some ty) | (tc2, Some ty), (tc1, None ) -> - (tc1 @ tc2), List.map (fun tc -> `TcCtt (ty, tc)) tc1 + (tc1 @ tc2), List.map (fun tc -> `TcCtt (ty, tc, ref None)) tc1 end module Problem = struct @@ -406,12 +418,14 @@ struct with type t = uf and type item = uid and type data = uparam) - (uf : uf ref) - (env : EcEnv.env) - (tvtc : state Mid.t) - (`TcCtt (ty, tc) : problem) + (uf : uf ref) + (env : EcEnv.env) + (tvtc : state Mid.t) + (pb : problem) : problem list = + let `TcCtt (ty, tc, tcrec) = pb in + let tytc, ty = match ty.ty_node with | Tunivar i -> snd_map (odfl ty) (UF.data i !uf) @@ -426,8 +440,9 @@ struct match TypeClass.hastc env tvtc ty tc with | None -> raise Failure - | Some effects -> - List.map (fun (ty, tc) -> `TcCtt (ty, tc)) effects + | Some (effects, opsyms) -> + tcrec := opsyms; + List.map (fun (ty, tc) -> `TcCtt (ty, tc, ref None)) effects end end end @@ -565,7 +580,7 @@ let unify_core env ue pb = match pb with | `TyUni (ty1, ty2) -> raise (UnificationFailure (`TyUni (ty1, ty2))) - | `Other (`TcCtt (ty, tc)) -> + | `Other (`TcCtt (ty, tc, _)) -> raise (UnificationFailure (`TcCtt (ty, tc))) end in ue := { !ue with ue_uf = uf; } @@ -574,16 +589,24 @@ let unify_core env ue pb = let unify env ue t1 t2 = unify_core env ue (`TyUni (t1, t2)) +let xhastc_r env ue ty tc = + let instance = ref None in + unify_core env ue (`Other (`TcCtt (ty, tc, instance))); + !instance + let hastc_r env ue ty tc = - unify_core env ue (`Other (`TcCtt (ty, tc))) + ignore (xhastc_r env ue ty tc : _ option) + +let xhastcs_r env ue ty tcs = + List.map (hastc_r env ue ty) tcs let hastcs_r env ue ty tcs = List.iter (hastc_r env ue ty) tcs (* -------------------------------------------------------------------- *) let hastc env ue ty tc = - try hastc_r env ue ty tc; true - with UnificationFailure _ -> false + try Some (xhastc_r env ue ty tc) + with UnificationFailure _ -> None (* -------------------------------------------------------------------- *) let tfun_expected ue psig = diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 5062065f6e..fcfa9bdd18 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -1,6 +1,8 @@ (* -------------------------------------------------------------------- *) open EcUid +open EcPath open EcSymbols +open EcMaps open EcTypes open EcDecl @@ -35,7 +37,7 @@ end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val hastc : EcEnv.env -> unienv -> ty -> typeclass -> bool +val hastc : EcEnv.env -> unienv -> ty -> typeclass -> (path Mstr.t) option option val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty From 9af95eeb26bf3888de404def8839bf97e2f37514 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Mon, 9 May 2022 15:16:11 +0200 Subject: [PATCH 044/113] Added modification to susbt --- src/ecScope.ml | 34 +++++++++++++--------------------- src/ecTyping.ml | 2 +- src/ecUnify.ml | 25 ++++++++++++++----------- src/ecUnify.mli | 4 +++- 4 files changed, 31 insertions(+), 34 deletions(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 2b59ab7c73..5c36bf1bc5 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1847,19 +1847,14 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in -(* - let prti = + let opstc_prt = Option.map (fun prt -> let ue = EcUnify.UniEnv.create (Some typarams) in - if not (EcUnify.hastc (env scope) ue (snd ty) prt) then - hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name); - let oprti = EcEnv.TypeClass.get_instance (env scope) prt in - match oprti with - | Some prti -> prti - | _ -> hierror "instance of `%s' was said to be in the env, but was not found" (EcPath.tostring tcp.tc_name) ) + match EcUnify.opstc (env scope) ue (snd ty) prt with + | Some ops -> ops + | None -> hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) ) tc.tc_prt in -*) let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in @@ -1889,19 +1884,16 @@ module Ty = struct EcFol.Fsubst.f_bind_local subst opname op) (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in -(* + (*TODO: Must find a way to add the substitution oppath -> oppath' to subst. + Must create a form? If so, where to find the type?*) let subst = - ofold - (fun tcp_prt s -> - let tc_prt = EcEnv.TypeClass.by_path tcp_prt.tc_name (env scope) in - List.fold_left - (fun subst (opname, ty) -> - let oppath = Mstr.find (EcIdent.name opname) symbols in - let op = EcFol.f_op oppath [] (ty_subst tysubst ty) in - EcFol.Fsubst.f_bind_local subst opname op) - s tc_prt.tc_ops) - subst tc.tc_prt in -*) + let add_op subst opid oppath = + let ooppath = Mstr.find_opt opid symbols in + ofold + (fun oppath' subst -> + subst) + subst ooppath in + ofold (fun otc subst -> ofold (fun ops subst -> Mstr.fold_left add_op subst ops) subst otc) subst opstc_prt in let axioms = List.map diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 07678a67a4..67095bf193 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -1206,7 +1206,7 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = List.iter2 (fun (_, tcs) ty -> List.iter (fun tc -> - if Option.is_none (EcUnify.hastc env ue ty tc) then + if not (EcUnify.hastc env ue ty tc) then tyerror (loc tc_name) env (CannotInferTC (ty, tc))) tcs) decl.tc_tparams args; { tc_name = p; tc_args = args; } diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 4b0369b968..23226ed3a0 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -589,25 +589,28 @@ let unify_core env ue pb = let unify env ue t1 t2 = unify_core env ue (`TyUni (t1, t2)) -let xhastc_r env ue ty tc = +let xopstc_r env ue ty tc = let instance = ref None in unify_core env ue (`Other (`TcCtt (ty, tc, instance))); !instance -let hastc_r env ue ty tc = - ignore (xhastc_r env ue ty tc : _ option) +let opstc_r env ue ty tc = + ignore (xopstc_r env ue ty tc : _ option) -let xhastcs_r env ue ty tcs = - List.map (hastc_r env ue ty) tcs +let xopstcs_r env ue ty tcs = + List.map (opstc_r env ue ty) tcs -let hastcs_r env ue ty tcs = - List.iter (hastc_r env ue ty) tcs +let opstcs_r env ue ty tcs = + List.iter (opstc_r env ue ty) tcs (* -------------------------------------------------------------------- *) -let hastc env ue ty tc = - try Some (xhastc_r env ue ty tc) +let opstc env ue ty tc = + try Some (xopstc_r env ue ty tc) with UnificationFailure _ -> None +let hastc env ue ty tc = + Option.is_some (opstc env ue ty tc) + (* -------------------------------------------------------------------- *) let tfun_expected ue psig = let tres = UniEnv.fresh ue in @@ -656,14 +659,14 @@ let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig | Some (TVIunamed lt) -> List.iter2 - (fun ty (_, tc) -> hastcs_r env subue ty tc) + (fun ty (_, tc) -> opstcs_r env subue ty tc) lt op.D.op_tparams | Some (TVInamed ls) -> let tparams = List.map (fst_map EcIdent.name) op.D.op_tparams in let tparams = Msym.of_list tparams in List.iter (fun (x, ty) -> - hastcs_r env subue ty (oget (Msym.find_opt x tparams))) + opstcs_r env subue ty (oget (Msym.find_opt x tparams))) ls with UnificationFailure _ -> raise E.Failure diff --git a/src/ecUnify.mli b/src/ecUnify.mli index fcfa9bdd18..91d542f06e 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -37,7 +37,9 @@ end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val hastc : EcEnv.env -> unienv -> ty -> typeclass -> (path Mstr.t) option option +val opstc : EcEnv.env -> unienv -> ty -> typeclass -> (path Mstr.t) option option + +val hastc : EcEnv.env -> unienv -> ty -> typeclass -> bool val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty From c5682fefcc5e7e5cbee94f63677fb45d3c9eb10a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 5 May 2022 08:55:44 +0200 Subject: [PATCH 045/113] Bump Why3 version from 1.4.x to 1.5.0 fix #184 --- dune-project | 4 ++-- easycrypt.opam | 2 +- src/ecProvers.ml | 15 ++++++++++----- 3 files changed, 13 insertions(+), 8 deletions(-) diff --git a/dune-project b/dune-project index e598329681..f93d868746 100644 --- a/dune-project +++ b/dune-project @@ -20,8 +20,8 @@ (ocaml-inifiles (>= 1.2)) (pcre (>= 7)) (ppx_deriving (>= 5.2.0)) - (why3 (and (>= 1.4.0) (< 1.5))) + (why3 (and (>= 1.5.0) (< 1.6))) yojson (zarith (>= 1.10)) ) -) \ No newline at end of file +) diff --git a/easycrypt.opam b/easycrypt.opam index 0802996191..98f39076e9 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -9,7 +9,7 @@ depends: [ "ocaml-inifiles" {>= "1.2"} "pcre" {>= "7"} "ppx_deriving" {>= "5.2.0"} - "why3" {>= "1.4.0" & < "1.5"} + "why3" {>= "1.5.0" & < "1.6"} "yojson" "zarith" {>= "1.10"} "odoc" {with-doc} diff --git a/src/ecProvers.ml b/src/ecProvers.ml index 5bfe5ebe4f..1a1dd2c49e 100644 --- a/src/ecProvers.ml +++ b/src/ecProvers.ml @@ -358,7 +358,11 @@ let run_prover } in let rec doit gcdone = - try Driver.prove_task ~command ~limit dr task + try + Driver.prove_task + ~libdir:Why3.Config.libdir + ~datadir:Why3.Config.datadir + ~command ~limit dr task with Unix.Unix_error (Unix.ENOMEM, "fork", _) when not gcdone -> Gc.compact (); doit true in @@ -434,9 +438,10 @@ let execute_task ?(notify : notify option) (pi : prover_infos) task = match pcs.(i) with | None -> () | Some (prover, pc) -> - let myinfos = List.pmap - (fun (pc', upd) -> if pc = pc' then Some upd else None) - infos in + let myinfos = + List.pmap + (fun (pc', upd) -> if pc = pc' then Some upd else None) + infos in let handle_answer = function | CP.Valid -> @@ -499,6 +504,6 @@ let execute_task ?(notify : notify option) (pi : prover_infos) task = match pcs.(i) with | None -> () | Some (_prover, pc) -> - CP.interrupt_call pc; + CP.interrupt_call ~libdir:Why3.Config.libdir pc; (try ignore (CP.wait_on_call pc : CP.prover_result) with _ -> ()); done) From 37dbab833fa936c14d8e006c9a64eec5ab0a8aed Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 9 May 2022 16:13:27 +0200 Subject: [PATCH 046/113] WIP --- examples/typeclass.ec | 2 -- src/ecScope.ml | 44 +++++++++++++++++++++++-------------------- src/ecTheory.ml | 4 +++- src/ecTheory.mli | 4 +++- src/ecUnify.ml | 14 +++++++------- src/ecUnify.mli | 4 +--- 6 files changed, 38 insertions(+), 34 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 32889c825f..b16b0526f1 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -230,8 +230,6 @@ proof. move => x y z. move: (Ring.IntID.mulrDl x y z). move => HmulrDl. - have: false. - move: HmulrDl. rewrite HmulrDl. (* TODO: what? *) admit. diff --git a/src/ecScope.ml b/src/ecScope.ml index 5c36bf1bc5..895952767c 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1847,14 +1847,17 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in - let opstc_prt = + let prt = Option.map (fun prt -> let ue = EcUnify.UniEnv.create (Some typarams) in match EcUnify.opstc (env scope) ue (snd ty) prt with - | Some ops -> ops - | None -> hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) ) - tc.tc_prt in + | None -> + hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) + | Some (_, symbs) -> + let prtdecl = EcEnv.TypeClass.by_path prt.tc_name (env scope) in + (prt, prtdecl, symbols_of_tc (env scope) ty (prt, prtdecl), symbs) + ) tc.tc_prt in let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in @@ -1865,14 +1868,14 @@ module Ty = struct ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; ts_v = let vsubst = List.combine (List.fst tc.tc_tparams) tcp.tc_args in -(* let vsubst = - ofold - (fun tcp_prt vs -> - let tc_prt = EcEnv.TypeClass.by_path tcp_prt.tc_name (env scope) in - List.combine (List.fst tc_prt.tc_tparams) tcp_prt.tc_args @ vs) - vsubst tc.tc_prt in -*) + vsubst @ ( + prt + |> Option.map (fun (prt, prtdecl, _, _) -> + List.combine (List.fst prtdecl.tc_tparams) prt.tc_args + ) + |> odfl [] + ) in Mid.of_list vsubst; } in @@ -1884,16 +1887,17 @@ module Ty = struct EcFol.Fsubst.f_bind_local subst opname op) (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in - (*TODO: Must find a way to add the substitution oppath -> oppath' to subst. - Must create a form? If so, where to find the type?*) let subst = - let add_op subst opid oppath = - let ooppath = Mstr.find_opt opid symbols in - ofold - (fun oppath' subst -> - subst) - subst ooppath in - ofold (fun otc subst -> ofold (fun ops subst -> Mstr.fold_left add_op subst ops) subst otc) subst opstc_prt in + match prt with None -> subst | Some (_, ptrdecl, _, symbs) -> + match symbs with None -> subst | Some symbs -> + + List.fold_left (fun subst (opname, ty) -> + let path = Mstr.find (EcIdent.name opname) symbs in + let form = EcFol.f_op path [] (ty_subst tysubst ty) in + EcFol.Fsubst. subst opname form + ) subst ptrdecl.tc_ops + + in let axioms = List.map diff --git a/src/ecTheory.ml b/src/ecTheory.ml index 92a0b7908e..33a5e255c9 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -54,9 +54,11 @@ and ctheory = { and tcinstance = [ | `Ring of ring | `Field of field - | `General of typeclass * (path Mstr.t) option + | `General of tcsolution ] +and tcsolution = typeclass * (path Mstr.t) option + and thmode = [ `Abstract | `Concrete ] and rule_pattern = diff --git a/src/ecTheory.mli b/src/ecTheory.mli index d114537dd1..6b8b4eb7b8 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -51,9 +51,11 @@ and ctheory = { and tcinstance = [ | `Ring of ring | `Field of field - | `General of typeclass * (path Mstr.t) option + | `General of tcsolution ] +and tcsolution = typeclass * (path Mstr.t) option + and thmode = [ `Abstract | `Concrete ] (* For cost judgement, we have higher-order pattern. *) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 23226ed3a0..e172d0f740 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -1,7 +1,7 @@ (* -------------------------------------------------------------------- *) open EcSymbols -open EcIdent open EcMaps +open EcIdent open EcUtils open EcUid open EcTypes @@ -370,7 +370,7 @@ module TypeClass = struct List.map (fun tc -> (subst ty, tc)) tcs) tvinfo) - in (effects, opsyms) + in (effects, (tginst, opsyms)) in @@ -382,7 +382,7 @@ end (* -------------------------------------------------------------------- *) type tcproblem = [ - `TcCtt of ty * typeclass * (EcPath.path Mstr.t) option ref + `TcCtt of ty * typeclass * EcTheory.tcsolution option ref ] module UnifyExtraForTC : @@ -440,8 +440,8 @@ struct match TypeClass.hastc env tvtc ty tc with | None -> raise Failure - | Some (effects, opsyms) -> - tcrec := opsyms; + | Some (effects, solution) -> + tcrec := Some solution; List.map (fun (ty, tc) -> `TcCtt (ty, tc, ref None)) effects end end @@ -592,10 +592,10 @@ let unify env ue t1 t2 = let xopstc_r env ue ty tc = let instance = ref None in unify_core env ue (`Other (`TcCtt (ty, tc, instance))); - !instance + oget !instance let opstc_r env ue ty tc = - ignore (xopstc_r env ue ty tc : _ option) + ignore (xopstc_r env ue ty tc : EcTheory.tcsolution) let xopstcs_r env ue ty tcs = List.map (opstc_r env ue ty) tcs diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 91d542f06e..26c83b245a 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -1,8 +1,6 @@ (* -------------------------------------------------------------------- *) open EcUid -open EcPath open EcSymbols -open EcMaps open EcTypes open EcDecl @@ -37,7 +35,7 @@ end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val opstc : EcEnv.env -> unienv -> ty -> typeclass -> (path Mstr.t) option option +val opstc : EcEnv.env -> unienv -> ty -> typeclass -> EcTheory.tcsolution option val hastc : EcEnv.env -> unienv -> ty -> typeclass -> bool From 8da9dfcadff69e00db40d6b252f1aecaa36361c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Tue, 10 May 2022 16:03:56 +0200 Subject: [PATCH 047/113] added operators in tcsyms --- src/ecScope.ml | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 895952767c..3f471f3314 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1829,8 +1829,7 @@ module Ty = struct tc.tc_ops (* ------------------------------------------------------------------ *) - (*TODOTC: we have to consider the operators of the parent typeclass instance, and also the types. - How can I find this instance?*) + (*TODOTC*) let add_generic_instance ~import (scope : scope) mode { pl_desc = tci; pl_loc = loc; } = @@ -1859,10 +1858,6 @@ module Ty = struct (prt, prtdecl, symbols_of_tc (env scope) ty (prt, prtdecl), symbs) ) tc.tc_prt in - let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in - let tcsyms = Mstr.of_list tcsyms in - let symbols = check_tci_operators (env scope) ty tci.pti_ops tcsyms in - let tysubst = { ty_subst_id with ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; @@ -1879,6 +1874,12 @@ module Ty = struct Mid.of_list vsubst; } in + let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in + let tcsyms = prt |> (tcsyms |> ofold + (fun (_, _, prtsymbs, _) tcsymbs -> prtsymbs @ tcsymbs)) in + let tcsyms = Mstr.of_list tcsyms in + let symbols = check_tci_operators (env scope) ty tci.pti_ops tcsyms in + let subst = List.fold_left (fun subst (opname, ty) -> @@ -1888,16 +1889,16 @@ module Ty = struct (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in let subst = - match prt with None -> subst | Some (_, ptrdecl, _, symbs) -> - match symbs with None -> subst | Some symbs -> - - List.fold_left (fun subst (opname, ty) -> - let path = Mstr.find (EcIdent.name opname) symbs in - let form = EcFol.f_op path [] (ty_subst tysubst ty) in - EcFol.Fsubst. subst opname form - ) subst ptrdecl.tc_ops - - in + prt |> (subst |> ofold + (fun (_, ptrdecl, _, symbs) subst -> + symbs |> (subst |> ofold + (fun symbs subst -> + List.fold_left + (fun subst (opname, ty) -> + let path = Mstr.find (EcIdent.name opname) symbs in + let form = EcFol.f_op path [] (ty_subst tysubst ty) in + EcFol.Fsubst.f_bind_local subst opname form) + subst ptrdecl.tc_ops )))) in let axioms = List.map From 8033da4fcc324cadc484834550b14ce70268a3f7 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 11 May 2022 09:24:39 +0200 Subject: [PATCH 048/113] Revert "added operators in tcsyms" This reverts commit 8da9dfcadff69e00db40d6b252f1aecaa36361c1. --- src/ecScope.ml | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 3f471f3314..895952767c 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1829,7 +1829,8 @@ module Ty = struct tc.tc_ops (* ------------------------------------------------------------------ *) - (*TODOTC*) + (*TODOTC: we have to consider the operators of the parent typeclass instance, and also the types. + How can I find this instance?*) let add_generic_instance ~import (scope : scope) mode { pl_desc = tci; pl_loc = loc; } = @@ -1858,6 +1859,10 @@ module Ty = struct (prt, prtdecl, symbols_of_tc (env scope) ty (prt, prtdecl), symbs) ) tc.tc_prt in + let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in + let tcsyms = Mstr.of_list tcsyms in + let symbols = check_tci_operators (env scope) ty tci.pti_ops tcsyms in + let tysubst = { ty_subst_id with ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; @@ -1874,12 +1879,6 @@ module Ty = struct Mid.of_list vsubst; } in - let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in - let tcsyms = prt |> (tcsyms |> ofold - (fun (_, _, prtsymbs, _) tcsymbs -> prtsymbs @ tcsymbs)) in - let tcsyms = Mstr.of_list tcsyms in - let symbols = check_tci_operators (env scope) ty tci.pti_ops tcsyms in - let subst = List.fold_left (fun subst (opname, ty) -> @@ -1889,16 +1888,16 @@ module Ty = struct (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in let subst = - prt |> (subst |> ofold - (fun (_, ptrdecl, _, symbs) subst -> - symbs |> (subst |> ofold - (fun symbs subst -> - List.fold_left - (fun subst (opname, ty) -> - let path = Mstr.find (EcIdent.name opname) symbs in - let form = EcFol.f_op path [] (ty_subst tysubst ty) in - EcFol.Fsubst.f_bind_local subst opname form) - subst ptrdecl.tc_ops )))) in + match prt with None -> subst | Some (_, ptrdecl, _, symbs) -> + match symbs with None -> subst | Some symbs -> + + List.fold_left (fun subst (opname, ty) -> + let path = Mstr.find (EcIdent.name opname) symbs in + let form = EcFol.f_op path [] (ty_subst tysubst ty) in + EcFol.Fsubst. subst opname form + ) subst ptrdecl.tc_ops + + in let axioms = List.map From b1e4ba7a12e9e82dc11f67bfe75007c27c21e0f1 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 11 May 2022 09:24:41 +0200 Subject: [PATCH 049/113] Revert "WIP" This reverts commit 37dbab833fa936c14d8e006c9a64eec5ab0a8aed. --- examples/typeclass.ec | 2 ++ src/ecScope.ml | 44 ++++++++++++++++++++----------------------- src/ecTheory.ml | 4 +--- src/ecTheory.mli | 4 +--- src/ecUnify.ml | 14 +++++++------- src/ecUnify.mli | 4 +++- 6 files changed, 34 insertions(+), 38 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index b16b0526f1..32889c825f 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -230,6 +230,8 @@ proof. move => x y z. move: (Ring.IntID.mulrDl x y z). move => HmulrDl. + have: false. + move: HmulrDl. rewrite HmulrDl. (* TODO: what? *) admit. diff --git a/src/ecScope.ml b/src/ecScope.ml index 895952767c..5c36bf1bc5 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1847,17 +1847,14 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in - let prt = + let opstc_prt = Option.map (fun prt -> let ue = EcUnify.UniEnv.create (Some typarams) in match EcUnify.opstc (env scope) ue (snd ty) prt with - | None -> - hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) - | Some (_, symbs) -> - let prtdecl = EcEnv.TypeClass.by_path prt.tc_name (env scope) in - (prt, prtdecl, symbols_of_tc (env scope) ty (prt, prtdecl), symbs) - ) tc.tc_prt in + | Some ops -> ops + | None -> hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) ) + tc.tc_prt in let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in @@ -1868,14 +1865,14 @@ module Ty = struct ts_def = Mp.of_list [tcp.tc_name, ([], snd ty)]; ts_v = let vsubst = List.combine (List.fst tc.tc_tparams) tcp.tc_args in +(* let vsubst = - vsubst @ ( - prt - |> Option.map (fun (prt, prtdecl, _, _) -> - List.combine (List.fst prtdecl.tc_tparams) prt.tc_args - ) - |> odfl [] - ) in + ofold + (fun tcp_prt vs -> + let tc_prt = EcEnv.TypeClass.by_path tcp_prt.tc_name (env scope) in + List.combine (List.fst tc_prt.tc_tparams) tcp_prt.tc_args @ vs) + vsubst tc.tc_prt in +*) Mid.of_list vsubst; } in @@ -1887,17 +1884,16 @@ module Ty = struct EcFol.Fsubst.f_bind_local subst opname op) (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in + (*TODO: Must find a way to add the substitution oppath -> oppath' to subst. + Must create a form? If so, where to find the type?*) let subst = - match prt with None -> subst | Some (_, ptrdecl, _, symbs) -> - match symbs with None -> subst | Some symbs -> - - List.fold_left (fun subst (opname, ty) -> - let path = Mstr.find (EcIdent.name opname) symbs in - let form = EcFol.f_op path [] (ty_subst tysubst ty) in - EcFol.Fsubst. subst opname form - ) subst ptrdecl.tc_ops - - in + let add_op subst opid oppath = + let ooppath = Mstr.find_opt opid symbols in + ofold + (fun oppath' subst -> + subst) + subst ooppath in + ofold (fun otc subst -> ofold (fun ops subst -> Mstr.fold_left add_op subst ops) subst otc) subst opstc_prt in let axioms = List.map diff --git a/src/ecTheory.ml b/src/ecTheory.ml index 33a5e255c9..92a0b7908e 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -54,11 +54,9 @@ and ctheory = { and tcinstance = [ | `Ring of ring | `Field of field - | `General of tcsolution + | `General of typeclass * (path Mstr.t) option ] -and tcsolution = typeclass * (path Mstr.t) option - and thmode = [ `Abstract | `Concrete ] and rule_pattern = diff --git a/src/ecTheory.mli b/src/ecTheory.mli index 6b8b4eb7b8..d114537dd1 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -51,11 +51,9 @@ and ctheory = { and tcinstance = [ | `Ring of ring | `Field of field - | `General of tcsolution + | `General of typeclass * (path Mstr.t) option ] -and tcsolution = typeclass * (path Mstr.t) option - and thmode = [ `Abstract | `Concrete ] (* For cost judgement, we have higher-order pattern. *) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index e172d0f740..23226ed3a0 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -1,7 +1,7 @@ (* -------------------------------------------------------------------- *) open EcSymbols -open EcMaps open EcIdent +open EcMaps open EcUtils open EcUid open EcTypes @@ -370,7 +370,7 @@ module TypeClass = struct List.map (fun tc -> (subst ty, tc)) tcs) tvinfo) - in (effects, (tginst, opsyms)) + in (effects, opsyms) in @@ -382,7 +382,7 @@ end (* -------------------------------------------------------------------- *) type tcproblem = [ - `TcCtt of ty * typeclass * EcTheory.tcsolution option ref + `TcCtt of ty * typeclass * (EcPath.path Mstr.t) option ref ] module UnifyExtraForTC : @@ -440,8 +440,8 @@ struct match TypeClass.hastc env tvtc ty tc with | None -> raise Failure - | Some (effects, solution) -> - tcrec := Some solution; + | Some (effects, opsyms) -> + tcrec := opsyms; List.map (fun (ty, tc) -> `TcCtt (ty, tc, ref None)) effects end end @@ -592,10 +592,10 @@ let unify env ue t1 t2 = let xopstc_r env ue ty tc = let instance = ref None in unify_core env ue (`Other (`TcCtt (ty, tc, instance))); - oget !instance + !instance let opstc_r env ue ty tc = - ignore (xopstc_r env ue ty tc : EcTheory.tcsolution) + ignore (xopstc_r env ue ty tc : _ option) let xopstcs_r env ue ty tcs = List.map (opstc_r env ue ty) tcs diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 26c83b245a..91d542f06e 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -1,6 +1,8 @@ (* -------------------------------------------------------------------- *) open EcUid +open EcPath open EcSymbols +open EcMaps open EcTypes open EcDecl @@ -35,7 +37,7 @@ end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val opstc : EcEnv.env -> unienv -> ty -> typeclass -> EcTheory.tcsolution option +val opstc : EcEnv.env -> unienv -> ty -> typeclass -> (path Mstr.t) option option val hastc : EcEnv.env -> unienv -> ty -> typeclass -> bool From 02f837839495c8803e9e189d2b060453c58e7d05 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 11 May 2022 09:24:49 +0200 Subject: [PATCH 050/113] Revert "Added modification to susbt" This reverts commit 9af95eeb26bf3888de404def8839bf97e2f37514. --- src/ecScope.ml | 34 +++++++++++++++++++++------------- src/ecTyping.ml | 2 +- src/ecUnify.ml | 25 +++++++++++-------------- src/ecUnify.mli | 4 +--- 4 files changed, 34 insertions(+), 31 deletions(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 5c36bf1bc5..2b59ab7c73 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1847,14 +1847,19 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in - let opstc_prt = +(* + let prti = Option.map (fun prt -> let ue = EcUnify.UniEnv.create (Some typarams) in - match EcUnify.opstc (env scope) ue (snd ty) prt with - | Some ops -> ops - | None -> hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name) ) + if not (EcUnify.hastc (env scope) ue (snd ty) prt) then + hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name); + let oprti = EcEnv.TypeClass.get_instance (env scope) prt in + match oprti with + | Some prti -> prti + | _ -> hierror "instance of `%s' was said to be in the env, but was not found" (EcPath.tostring tcp.tc_name) ) tc.tc_prt in +*) let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in @@ -1884,16 +1889,19 @@ module Ty = struct EcFol.Fsubst.f_bind_local subst opname op) (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in - (*TODO: Must find a way to add the substitution oppath -> oppath' to subst. - Must create a form? If so, where to find the type?*) +(* let subst = - let add_op subst opid oppath = - let ooppath = Mstr.find_opt opid symbols in - ofold - (fun oppath' subst -> - subst) - subst ooppath in - ofold (fun otc subst -> ofold (fun ops subst -> Mstr.fold_left add_op subst ops) subst otc) subst opstc_prt in + ofold + (fun tcp_prt s -> + let tc_prt = EcEnv.TypeClass.by_path tcp_prt.tc_name (env scope) in + List.fold_left + (fun subst (opname, ty) -> + let oppath = Mstr.find (EcIdent.name opname) symbols in + let op = EcFol.f_op oppath [] (ty_subst tysubst ty) in + EcFol.Fsubst.f_bind_local subst opname op) + s tc_prt.tc_ops) + subst tc.tc_prt in +*) let axioms = List.map diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 67095bf193..07678a67a4 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -1206,7 +1206,7 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = List.iter2 (fun (_, tcs) ty -> List.iter (fun tc -> - if not (EcUnify.hastc env ue ty tc) then + if Option.is_none (EcUnify.hastc env ue ty tc) then tyerror (loc tc_name) env (CannotInferTC (ty, tc))) tcs) decl.tc_tparams args; { tc_name = p; tc_args = args; } diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 23226ed3a0..4b0369b968 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -589,27 +589,24 @@ let unify_core env ue pb = let unify env ue t1 t2 = unify_core env ue (`TyUni (t1, t2)) -let xopstc_r env ue ty tc = +let xhastc_r env ue ty tc = let instance = ref None in unify_core env ue (`Other (`TcCtt (ty, tc, instance))); !instance -let opstc_r env ue ty tc = - ignore (xopstc_r env ue ty tc : _ option) +let hastc_r env ue ty tc = + ignore (xhastc_r env ue ty tc : _ option) -let xopstcs_r env ue ty tcs = - List.map (opstc_r env ue ty) tcs +let xhastcs_r env ue ty tcs = + List.map (hastc_r env ue ty) tcs -let opstcs_r env ue ty tcs = - List.iter (opstc_r env ue ty) tcs +let hastcs_r env ue ty tcs = + List.iter (hastc_r env ue ty) tcs (* -------------------------------------------------------------------- *) -let opstc env ue ty tc = - try Some (xopstc_r env ue ty tc) - with UnificationFailure _ -> None - let hastc env ue ty tc = - Option.is_some (opstc env ue ty tc) + try Some (xhastc_r env ue ty tc) + with UnificationFailure _ -> None (* -------------------------------------------------------------------- *) let tfun_expected ue psig = @@ -659,14 +656,14 @@ let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig | Some (TVIunamed lt) -> List.iter2 - (fun ty (_, tc) -> opstcs_r env subue ty tc) + (fun ty (_, tc) -> hastcs_r env subue ty tc) lt op.D.op_tparams | Some (TVInamed ls) -> let tparams = List.map (fst_map EcIdent.name) op.D.op_tparams in let tparams = Msym.of_list tparams in List.iter (fun (x, ty) -> - opstcs_r env subue ty (oget (Msym.find_opt x tparams))) + hastcs_r env subue ty (oget (Msym.find_opt x tparams))) ls with UnificationFailure _ -> raise E.Failure diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 91d542f06e..fcfa9bdd18 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -37,9 +37,7 @@ end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val opstc : EcEnv.env -> unienv -> ty -> typeclass -> (path Mstr.t) option option - -val hastc : EcEnv.env -> unienv -> ty -> typeclass -> bool +val hastc : EcEnv.env -> unienv -> ty -> typeclass -> (path Mstr.t) option option val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty From 2505d15cebb7cf4e6fc94ad09144b056b0ee7061 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 12 May 2022 10:02:04 +0200 Subject: [PATCH 051/113] TC: reduction/cnv + various bug fixes --- examples/typeclass.ec | 28 ++++++++++-- src/ecCallbyValue.ml | 4 ++ src/ecCoreFol.ml | 2 +- src/ecCoreFol.mli | 6 +-- src/ecDecl.ml | 12 ++++- src/ecDecl.mli | 4 +- src/ecEnv.ml | 9 +++- src/ecEnv.mli | 1 + src/ecHiGoal.ml | 21 ++++----- src/ecParser.mly | 33 +++++++++----- src/ecParsetree.ml | 1 + src/ecPrinting.ml | 12 ++--- src/ecReduction.ml | 100 ++++++++++++++++++++++++++---------------- src/ecReduction.mli | 22 +++++----- src/ecScope.ml | 49 +++++++++++---------- src/ecSection.ml | 10 +++-- src/ecSubst.ml | 7 ++- src/ecTheory.ml | 2 +- src/ecTheory.mli | 2 +- src/ecTheoryReplay.ml | 12 +++-- src/ecTyping.ml | 7 +-- src/ecUnify.ml | 51 ++++++++++----------- src/ecUnify.mli | 6 +-- 23 files changed, 246 insertions(+), 155 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 32889c825f..9dea589e57 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -1,17 +1,36 @@ -(* =====================================================================*) -require import AllCore List. - - (* ==================================================================== *) (* Typeclass examples *) (* -------------------------------------------------------------------- *) (* Set theory *) +type class ['a] foo = { + op bar : foo * 'a +}. + +op bari ['a] : int * 'a = (0, witness<:'a>). + +instance 'b foo with ['b] int + op bar = bari<:'b>. + +lemma L : bar<:bool, int> = (0, witness). +proof. +class. + +reflexivity. + + + +(* + + + type class witness = { op witness : witness }. + + print witness. type class finite = { @@ -344,3 +363,4 @@ qed. c. ne pas envoyer certaines instances (e.g. int est un groupe) -> instance [nosmt] e.g. *) +*) diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index 3ef8c5f0ba..12540851fe 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -325,6 +325,10 @@ and reduce_user_delta st f1 p tys args = if mode <> `No && Op.reducible ~force:(mode = `Force) st.st_env p then let f = Op.reduce ~force:(mode = `Force) st.st_env p tys in cbv st Subst.subst_id f args + else if st.st_ri.delta_tc then + match EcReduction.reduce_tc st.st_env p tys with + | None -> f2 + | Some f -> cbv st Subst.subst_id f args else f2 (* -------------------------------------------------------------------- *) diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index e1f8cc7a63..674282e6f8 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -38,7 +38,7 @@ and bindings = binding list and form = { f_node : f_node; - f_ty : (ty [@opaque]); + f_ty : ty; f_fv : (int EcIdent.Mid.t [@opaque]); (* local, memory, module ident *) f_tag : (int [@opaque]); } diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 1be24d7171..5248d1cec4 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -34,9 +34,9 @@ and bindings = (binding list [@opaque]) and form = private { f_node : f_node; - f_ty : (ty [@opaque]); - f_fv : (int EcIdent.Mid.t [@opaque]); (* local, memory, module ident *) - f_tag : (int [@opaque]); + f_ty : ty; + f_fv : int EcIdent.Mid.t; (* local, memory, module ident *) + f_tag : int; } [@@deriving show] diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 245d3025be..b45b0b0c27 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -86,7 +86,7 @@ and opbody = | OP_Record of EcPath.path | OP_Proj of EcPath.path * int * int | OP_Fix of opfix - | OP_TC + | OP_TC of EcPath.path * string and prbody = | PR_Plain of form @@ -231,6 +231,11 @@ let is_rcrd op = | OB_oper (Some (OP_Record _)) -> true | _ -> false +let is_tc_op op = + match op.op_kind with + | OB_oper (Some (OP_TC _)) -> true + | _ -> false + let is_fix op = match op.op_kind with | OB_oper (Some (OP_Fix _)) -> true @@ -300,6 +305,11 @@ let operator_as_prind (op : operator) = | OB_pred (Some (PR_Ind pri)) -> pri | _ -> assert false +let operator_as_tc (op : operator) = + match op.op_kind with + | OB_oper (Some OP_TC (tcpath, name)) -> (tcpath, name) + | _ -> assert false + (* -------------------------------------------------------------------- *) let axiomatized_op ?(nargs = 0) ?(nosmt = false) path (tparams, bd) lc = let axbd = EcCoreFol.form_of_expr EcCoreFol.mhr bd in diff --git a/src/ecDecl.mli b/src/ecDecl.mli index c5f620108b..26c933a3c9 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -58,7 +58,7 @@ and opbody = | OP_Record of EcPath.path | OP_Proj of EcPath.path * int * int | OP_Fix of opfix - | OP_TC + | OP_TC of EcPath.path * string and prbody = | PR_Plain of form @@ -114,6 +114,7 @@ val is_oper : operator -> bool val is_ctor : operator -> bool val is_proj : operator -> bool val is_rcrd : operator -> bool +val is_tc_op : operator -> bool val is_fix : operator -> bool val is_abbrev : operator -> bool val is_prind : operator -> bool @@ -130,6 +131,7 @@ val operator_as_rcrd : operator -> EcPath.path val operator_as_proj : operator -> EcPath.path * int * int val operator_as_fix : operator -> opfix val operator_as_prind : operator -> prind +val operator_as_tc : operator -> EcPath.path * string (* -------------------------------------------------------------------- *) type axiom_kind = [`Axiom of (Ssym.t * bool) | `Lemma] diff --git a/src/ecEnv.ml b/src/ecEnv.ml index ff75d5e341..9b85b61b84 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -914,9 +914,10 @@ module MC = struct let opname = EcIdent.name opid in let optype = ty_subst tsubst optype in let tcargs = List.map (fun (a, _) -> tvar a) tc.tc_tparams in - let opargs = (self, [{tc_name = mypath; tc_args = tcargs}]) in + let opargs = (self, [{tc_name = mypath; tc_args = tcargs;}]) in let opargs = tc.tc_tparams @ [opargs] in - let opdecl = mk_op ~opaque:false opargs optype (Some OP_TC) loca in + let opdecl = OP_TC (mypath, opname) in + let opdecl = mk_op ~opaque:false opargs optype (Some opdecl) loca in (opid, xpath opname, optype, opdecl) in List.map on1 tc.tc_ops @@ -2900,6 +2901,10 @@ module Op = struct try EcDecl.is_rcrd (by_path p env) with LookupFailure _ -> false + let is_tc_op env p = + try EcDecl.is_tc_op (by_path p env) + with LookupFailure _ -> false + let is_dtype_ctor ?nargs env p = try match (by_path p env).op_kind with diff --git a/src/ecEnv.mli b/src/ecEnv.mli index cabd4eb64a..6f73bab25e 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -327,6 +327,7 @@ module Op : sig val is_projection : env -> path -> bool val is_record_ctor : env -> path -> bool val is_dtype_ctor : ?nargs:int -> env -> path -> bool + val is_tc_op : env -> path -> bool val is_fix_def : env -> path -> bool val is_abbrev : env -> path -> bool val is_prind : env -> path -> bool diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index 53505181df..f2652bd803 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -112,16 +112,17 @@ let process_simplify_info ri (tc : tcenv1) = in { - EcReduction.beta = ri.pbeta; - EcReduction.delta_p = delta_p; - EcReduction.delta_h = delta_h; - EcReduction.zeta = ri.pzeta; - EcReduction.iota = ri.piota; - EcReduction.eta = ri.peta; - EcReduction.logic = if ri.plogic then Some `Full else None; - EcReduction.modpath = ri.pmodpath; - EcReduction.user = ri.puser; - EcReduction.cost = ri.pcost; + EcReduction.beta = ri.pbeta; + EcReduction.delta_p = delta_p; + EcReduction.delta_h = delta_h; + EcReduction.delta_tc = ri.pdeltatc; + EcReduction.zeta = ri.pzeta; + EcReduction.iota = ri.piota; + EcReduction.eta = ri.peta; + EcReduction.logic = if ri.plogic then Some `Full else None; + EcReduction.modpath = ri.pmodpath; + EcReduction.user = ri.puser; + EcReduction.cost = ri.pcost; } (*-------------------------------------------------------------------- *) diff --git a/src/ecParser.mly b/src/ecParser.mly index a66828cb57..bb3e13472f 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -94,18 +94,23 @@ let mk_simplify l = if l = [] then - { pbeta = true; pzeta = true; - piota = true; peta = true; - plogic = true; pdelta = None; - pmodpath = true; puser = true; - pcost = false; } + { pbeta = true; + pzeta = true; + piota = true; + peta = true; + plogic = true; + pdelta = None; + pdeltatc = true; + pmodpath = true; + puser = true; + pcost = false; } else let doarg acc = function | `Delta l -> if l = [] || acc.pdelta = None then { acc with pdelta = None } else { acc with pdelta = Some (oget acc.pdelta @ l) } - + | `DeltaTC -> { acc with pdeltatc = true } | `Zeta -> { acc with pzeta = true } | `Iota -> { acc with piota = true } | `Beta -> { acc with pbeta = true } @@ -116,11 +121,16 @@ | `Cost -> { acc with pcost = true } in List.fold_left doarg - { pbeta = false; pzeta = false; - piota = false; peta = false; - plogic = false; pdelta = Some []; - pmodpath = false; puser = false; - pcost = false; } l + { pbeta = false; + pzeta = false; + piota = false; + peta = false; + plogic = false; + pdelta = Some []; + pdeltatc = false; + pmodpath = false; + puser = false; + pcost = false; } l let simplify_red = [`Zeta; `Iota; `Beta; `Eta; `Logic; `ModPath; `User; `Cost] @@ -2644,6 +2654,7 @@ genpattern: simplify_arg: | DELTA l=qoident* { `Delta l } +| CLASS { `DeltaTC } | ZETA { `Zeta } | IOTA { `Iota } | BETA { `Beta } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index a01839e376..15e929e7e8 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -495,6 +495,7 @@ type pcutdef_schema = { type preduction = { pbeta : bool; (* β-reduction *) pdelta : pqsymbol list option; (* definition unfolding *) + pdeltatc : bool; pzeta : bool; (* let-reduction *) piota : bool; (* case/if-reduction *) peta : bool; (* η-reduction *) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index f1bebeb844..ba50e50ab8 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -2260,9 +2260,9 @@ let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = (pp_type ppe) fix.opf_resty (pp_list "@\n" pp_branch) cfix - | Some (OP_TC) -> - Format.fprintf fmt ": %a = < type-class-operator >" - (pp_type ppe) ty + | Some (OP_TC (path, name)) -> + Format.fprintf fmt ": %a = < type-class operator `%s' of `%a'>" + (pp_type ppe) ty name (pp_tyname ppe) path in match ts with @@ -2839,8 +2839,8 @@ let pp_equivS (ppe : PPEnv.t) ?prpo fmt es = let insync = EcMemory.mt_equal (snd es.es_ml) (snd es.es_mr) - && EcReduction.EqTest.for_stmt - ppe.PPEnv.ppe_env ~norm:false es.es_sl es.es_sr in +(* && EcReduction.EqTest.for_stmt + ppe.PPEnv.ppe_env ~norm:false es.es_sl es.es_sr in *) in let ppnode = if insync then begin @@ -3037,7 +3037,7 @@ module PPGoal = struct | FhoareS hs -> pp_hoareS ?prpo ppe fmt hs | FequivF ef -> pp_equivF ppe fmt ef | FequivS es -> pp_equivS ?prpo ppe fmt es - | _ -> Format.fprintf fmt "%a@\n%!" EcFol.pp_form concl + | _ -> Format.fprintf fmt "%a@\n%!" (pp_form ppe) concl end (* -------------------------------------------------------------------- *) diff --git a/src/ecReduction.ml b/src/ecReduction.ml index e82dc0e97f..e6f643a424 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -605,16 +605,17 @@ let is_alpha_eq hyps f1 f2 = (* -------------------------------------------------------------------- *) type reduction_info = { - beta : bool; - delta_p : (path -> deltap); (* reduce operators *) - delta_h : (ident -> bool); (* reduce local definitions *) - zeta : bool; - iota : bool; - eta : bool; - logic : rlogic_info; - modpath : bool; - user : bool; - cost : bool; + beta : bool; + delta_p : (path -> deltap); (* reduce operators *) + delta_h : (ident -> bool); (* reduce local definitions *) + delta_tc : bool; + zeta : bool; + iota : bool; + eta : bool; + logic : rlogic_info; + modpath : bool; + user : bool; + cost : bool; } and deltap = [`Yes | `No | `Force] @@ -622,29 +623,31 @@ and rlogic_info = [`Full | `ProductCompat] option (* -------------------------------------------------------------------- *) let full_red ~opaque = { - beta = true; - delta_p = (fun _ -> if opaque then `Force else `Yes); - delta_h = EcUtils.predT; - zeta = true; - iota = true; - eta = true; - logic = Some `Full; - modpath = true; - user = true; - cost = true; + beta = true; + delta_p = (fun _ -> if opaque then `Force else `Yes); + delta_h = EcUtils.predT; + delta_tc = true; + zeta = true; + iota = true; + eta = true; + logic = Some `Full; + modpath = true; + user = true; + cost = true; } let no_red = { - beta = false; - delta_p = (fun _ -> `No); - delta_h = EcUtils.pred0; - zeta = false; - iota = false; - eta = false; - logic = None; - modpath = false; - user = false; - cost = false; + beta = false; + delta_p = (fun _ -> `No); + delta_h = EcUtils.pred0; + delta_tc = false; + zeta = false; + iota = false; + eta = false; + logic = None; + modpath = false; + user = false; + cost = false; } let beta_red = { no_red with beta = true; } @@ -652,8 +655,9 @@ let betaiota_red = { no_red with beta = true; iota = true; } let nodelta = { (full_red ~opaque:false) with - delta_h = EcUtils.pred0; - delta_p = (fun _ -> `No); } + delta_h = EcUtils.pred0; + delta_p = (fun _ -> `No); + delta_tc = false; } let delta = { no_red with delta_p = (fun _ -> `Yes); } @@ -682,6 +686,27 @@ let reduce_op ri env p tys = with NotReducible -> raise nohead else raise nohead +let reduce_tc env p tys = + if not (EcEnv.Op.is_tc_op env p) then None else + + let tys = List.rev tys in + let tcty, tys = List.hd tys, List.rev (List.tl tys) in + let (tcp, opname) = EcDecl.operator_as_tc (EcEnv.Op.by_path p env) in + let ue = EcUnify.UniEnv.create None in + let syms = oget (EcUnify.hastc env ue tcty { tc_name = tcp; tc_args = tys }) in + + match syms with None -> None | Some syms -> + + let optg, opargs = EcMaps.Mstr.find opname syms in + let opargs = List.map (Tuni.offun (EcUnify.UniEnv.assubst ue)) opargs in + let optg_decl = EcEnv.Op.by_path optg env in + let tysubst = Tvar.init (List.fst optg_decl.op_tparams) opargs in + + Some (EcFol.f_op optg opargs (Tvar.subst tysubst optg_decl.op_ty)) + +let may_reduce_tc ri env p tys = + if ri.delta_tc then oget ~exn:nohead (reduce_tc env p tys) else raise nohead + let is_record env f = match EcFol.destr_app f with | { f_node = Fop (p, _) }, _ -> EcEnv.Op.is_record_ctor env p @@ -993,6 +1018,9 @@ let reduce_logic ri env hyps f p args = (* -------------------------------------------------------------------- *) let reduce_delta ri env _hyps f = match f.f_node with + | Fop (p, tys) when ri.delta_tc && EcEnv.Op.is_tc_op env p -> + may_reduce_tc ri env p tys + | Fop (p, tys) when ri.delta_p p <> `No -> reduce_op ri env p tys @@ -1032,8 +1060,6 @@ let reduce_cost ri env coe = | _ -> raise nohead - - (* -------------------------------------------------------------------- *) (* Perform one step of head reduction *) let reduce_head simplify ri env hyps f = @@ -1983,14 +2009,11 @@ let check_bindings exn tparams env s bd1 bd2 = let rec conv_oper env ob1 ob2 = match ob1, ob2 with | OP_Plain(e1,_), OP_Plain(e2,_) -> - Format.eprintf "[W]: ICI1@."; conv_expr env Fsubst.f_subst_id e1 e2 | OP_Plain({e_node = Eop(p,tys)},_), _ -> - Format.eprintf "[W]: ICI2@."; let ob1 = get_open_oper env p tys in conv_oper env ob1 ob2 | _, OP_Plain({e_node = Eop(p,tys)}, _) -> - Format.eprintf "[W]: ICI3@."; let ob2 = get_open_oper env p tys in conv_oper env ob1 ob2 | OP_Constr(p1,i1), OP_Constr(p2,i2) -> @@ -2001,7 +2024,8 @@ let rec conv_oper env ob1 ob2 = error_body (EcPath.p_equal p1 p2 && i11 = i21 && i12 = i22) | OP_Fix f1, OP_Fix f2 -> conv_opfix env f1 f2 - | OP_TC, OP_TC -> () + | OP_TC (p1, n1), OP_TC (p2, n2) -> + error_body (EcPath.p_equal p1 p2 && n1 = n2) | _, _ -> raise OpNotConv and conv_opfix env f1 f2 = diff --git a/src/ecReduction.mli b/src/ecReduction.mli index 659002c098..e7aff688d3 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -62,16 +62,17 @@ val can_eta : ident -> form * form list -> bool (* -------------------------------------------------------------------- *) type reduction_info = { - beta : bool; - delta_p : (path -> deltap); (* reduce operators *) - delta_h : (ident -> bool); (* reduce local definitions *) - zeta : bool; (* reduce let *) - iota : bool; (* reduce case *) - eta : bool; (* reduce eta-expansion *) - logic : rlogic_info; (* perform logical simplification *) - modpath : bool; (* reduce module path *) - user : bool; (* reduce user defined rules *) - cost : bool; (* reduce trivial cost statements *) + beta : bool; + delta_p : (path -> deltap); (* reduce operators *) + delta_h : (ident -> bool); (* reduce local definitions *) + delta_tc : bool; (* reduce tc-operators *) + zeta : bool; (* reduce let *) + iota : bool; (* reduce case *) + eta : bool; (* reduce eta-expansion *) + logic : rlogic_info; (* perform logical simplification *) + modpath : bool; (* reduce module path *) + user : bool; (* reduce user defined rules *) + cost : bool; (* reduce trivial cost statements *) } and deltap = [`Yes | `No | `Force] @@ -86,6 +87,7 @@ val nodelta : reduction_info val delta : reduction_info val reduce_logic : reduction_info -> env -> LDecl.hyps -> form -> form +val reduce_tc : env -> path -> ty list -> form option val h_red_opt : reduction_info -> LDecl.hyps -> form -> form option val h_red : reduction_info -> LDecl.hyps -> form -> form diff --git a/src/ecScope.ml b/src/ecScope.ml index 2b59ab7c73..bd18826384 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1614,14 +1614,11 @@ module Ty = struct "ambiguous operator (%s / %s)" (EcPath.tostring (fst (proj4_1 op1))) (EcPath.tostring (fst (proj4_1 op2))) - | [((p, _), _, _, _)] -> - let op = EcEnv.Op.by_path p env in - let opty = - Tvar.subst - (Tvar.init (List.map fst op.op_tparams) tvi) - op.op_ty - in - (p, opty) + | [((p, opparams), opty, subue, _)] -> + let subst = Tuni.offun (EcUnify.UniEnv.assubst subue) in + let opty = subst opty in + let opparams = List.map subst opparams in + ((p, opparams), opty) in Mstr.change @@ -1642,7 +1639,7 @@ module Ty = struct (fun x (_, ty) m -> match Mstr.find_opt x ops with | None -> m - | Some (loc, (p, opty)) -> + | Some (loc, ((p, opparams), opty)) -> if not (EcReduction.EqTest.for_type env ty opty) then begin let ppe = EcPrinting.PPEnv.ofenv env in hierror ~loc @@ -1650,7 +1647,7 @@ module Ty = struct \ - expected: %a@\n\ \ - got : %a" x (EcPrinting.pp_type ppe) ty (EcPrinting.pp_type ppe) opty - end; Mstr.add x p m) + end; Mstr.add x (p, opparams) m) reqs Mstr.empty (* ------------------------------------------------------------------ *) @@ -1714,18 +1711,23 @@ module Ty = struct let p_field = EcPath.fromqsymbol ([EcCoreLib.i_top; "Ring"; "Field" ], "field" ) (* ------------------------------------------------------------------ *) + let get_ring_field_op (name : string) (symbols : (path * ty list) Mstr.t) = + Option.map + (fun (p, tys) -> assert (List.is_empty tys); p) + (Mstr.find_opt name symbols) + let ring_of_symmap env ty kind symbols = { r_type = ty; - r_zero = oget (Mstr.find_opt "rzero" symbols); - r_one = oget (Mstr.find_opt "rone" symbols); - r_add = oget (Mstr.find_opt "add" symbols); - r_opp = (Mstr.find_opt "opp" symbols); - r_mul = oget (Mstr.find_opt "mul" symbols); - r_exp = (Mstr.find_opt "expr" symbols); - r_sub = (Mstr.find_opt "sub" symbols); + r_zero = oget (get_ring_field_op "rzero" symbols); + r_one = oget (get_ring_field_op "rone" symbols); + r_add = oget (get_ring_field_op "add" symbols); + r_opp = (get_ring_field_op "opp" symbols); + r_mul = oget (get_ring_field_op "mul" symbols); + r_exp = (get_ring_field_op "expr" symbols); + r_sub = (get_ring_field_op "sub" symbols); r_kind = kind; r_embed = - (match Mstr.find_opt "ofint" symbols with + (match get_ring_field_op "ofint" symbols with | None when EcReduction.EqTest.for_type env ty tint -> `Direct | None -> `Default | Some p -> `Embed p); } @@ -1772,8 +1774,8 @@ module Ty = struct (* ------------------------------------------------------------------ *) let field_of_symmap env ty symbols = { f_ring = ring_of_symmap env ty `Integer symbols; - f_inv = oget (Mstr.find_opt "inv" symbols); - f_div = Mstr.find_opt "div" symbols; } + f_inv = oget (get_ring_field_op "inv" symbols); + f_div = get_ring_field_op "div" symbols; } let addfield ~import (scope : scope) mode { pl_desc = tci; pl_loc = loc; } = let env = env scope in @@ -1884,9 +1886,10 @@ module Ty = struct let subst = List.fold_left (fun subst (opname, ty) -> - let oppath = Mstr.find (EcIdent.name opname) symbols in - let op = EcFol.f_op oppath [] (ty_subst tysubst ty) in - EcFol.Fsubst.f_bind_local subst opname op) + let oppath, optys = Mstr.find (EcIdent.name opname) symbols in + let op = + EcFol.f_op oppath (List.map (ty_subst tysubst) optys) (ty_subst tysubst ty) + in EcFol.Fsubst.f_bind_local subst opname op) (EcFol.Fsubst.f_subst_init ~sty:tysubst ()) tc.tc_ops in (* diff --git a/src/ecSection.ml b/src/ecSection.ml index 8781cd63da..14b0aa888f 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -434,7 +434,7 @@ let on_opdecl (cb : cb) (opdecl : operator) = | OB_oper Some b -> match b with | OP_Constr _ | OP_Record _ | OP_Proj _ -> assert false - | OP_TC -> assert false + | OP_TC _ -> assert false | OP_Plain (e, _) -> on_expr cb e | OP_Fix f -> let rec on_mpath_branches br = @@ -494,7 +494,9 @@ let on_instance cb ty tci = | `General (tci, syms) -> on_typeclass cb tci; - Option.iter (Mstr.iter (fun _ p -> cb (`Op p))) syms + Option.iter + (Mstr.iter (fun _ (p, tys) -> cb (`Op p); List.iter (on_ty cb) tys)) + syms (* -------------------------------------------------------------------- *) @@ -724,7 +726,7 @@ let op_body_fv body ty = let fv = ty_fv_and_tvar ty in match body with | OP_Plain (e, _) -> EcIdent.fv_union fv (fv_and_tvar_e e) - | OP_Constr _ | OP_Record _ | OP_Proj _ | OP_TC -> fv + | OP_Constr _ | OP_Record _ | OP_Proj _ | OP_TC _ -> fv | OP_Fix opfix -> let fv = List.fold_left (fun fv (_, ty) -> EcIdent.fv_union fv (ty_fv_and_tvar ty)) @@ -909,7 +911,7 @@ let generalize_opdecl to_gen prefix (name, operator) = let body = match body with | OP_Constr _ | OP_Record _ | OP_Proj _ -> assert false - | OP_TC -> assert false (* ??? *) + | OP_TC _ -> assert false (* FIXME:TC *) | OP_Plain (e,nosmt) -> OP_Plain (e_lam extra_a e, nosmt) | OP_Fix opfix -> diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 3ca34ff8dd..6271b0ec99 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -399,7 +399,7 @@ and subst_op_body (s : _subst) (bd : opbody) = opf_branches = subst_branches es opfix.opf_branches; opf_nosmt = opfix.opf_nosmt; } - | OP_TC -> OP_TC + | OP_TC (p, n) -> OP_TC (s.s_p p, n) and subst_branches es = function | OPB_Leaf (locals, e) -> @@ -507,7 +507,10 @@ let subst_instance (s : _subst) tci = | `General (tc, syms) -> let tc = subst_typeclass s tc in - let syms = Option.map (Mstr.map s.s_p) syms in + let syms = + Option.map + (Mstr.map (fun (p, tys) -> (s.s_p p, List.map s.s_ty tys))) + syms in `General (tc, syms) (* -------------------------------------------------------------------- *) diff --git a/src/ecTheory.ml b/src/ecTheory.ml index 92a0b7908e..65172668ed 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -54,7 +54,7 @@ and ctheory = { and tcinstance = [ | `Ring of ring | `Field of field - | `General of typeclass * (path Mstr.t) option + | `General of typeclass * ((path * ty list) Mstr.t) option ] and thmode = [ `Abstract | `Concrete ] diff --git a/src/ecTheory.mli b/src/ecTheory.mli index d114537dd1..d6c497a44c 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -51,7 +51,7 @@ and ctheory = { and tcinstance = [ | `Ring of ring | `Field of field - | `General of typeclass * (path Mstr.t) option + | `General of typeclass * ((path * ty list) Mstr.t) option ] and thmode = [ `Abstract | `Concrete ] diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 3275ac8524..d4efb3d2ac 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -134,6 +134,7 @@ let get_open_oper exn env p tys = | _ -> raise exn let rec oper_compatible exn env ob1 ob2 = + (* FIXME: duplicated code *) match ob1, ob2 with | OP_Plain(e1,_), OP_Plain(e2,_) -> expr_compatible exn env EcFol.Fsubst.f_subst_id e1 e2 @@ -151,7 +152,8 @@ let rec oper_compatible exn env ob1 ob2 = error_body exn (EcPath.p_equal p1 p2 && i11 = i21 && i12 = i22) | OP_Fix f1, OP_Fix f2 -> opfix_compatible exn env f1 f2 - | OP_TC, OP_TC -> () + | OP_TC (p1, n1), OP_TC (p2, n2) -> + error_body exn (EcPath.p_equal p1 p2 && n1 = n2) | _, _ -> raise exn and opfix_compatible exn env f1 f2 = @@ -898,7 +900,7 @@ and replay_instance | OB_oper (Some (OP_Record _)) | OB_oper (Some (OP_Proj _)) | OB_oper (Some (OP_Fix _)) - | OB_oper (Some (OP_TC )) -> + | OB_oper (Some (OP_TC _)) -> Some (EcPath.pappend npath q) | OB_oper (Some (OP_Plain (e, _))) -> match e.EcTypes.e_node with @@ -944,7 +946,11 @@ and replay_instance | `General (tc, syms) -> let tc = fortypeclass tc in - let syms = Option.map (Mstr.map forpath) syms in + let syms = + Option.map + (Mstr.map (fun (p, tys) -> + (forpath p, List.map (EcSubst.subst_ty subst) tys))) + syms in `General (tc, syms) in diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 07678a67a4..6eae8f00d0 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -375,7 +375,7 @@ let gen_select_op and by_tc ((p, _), _, _, _) = match oget (EcEnv.Op.by_path_opt p env) with - | { op_kind = OB_oper (Some OP_TC) } -> false + | { op_kind = OB_oper (Some (OP_TC _)) } -> false | _ -> true in @@ -1278,6 +1278,7 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = let rec_ = snd (oget (EcDecl.tydecl_as_record recty)) in let reccty = tconstr recp (List.map (tvar |- fst) recty.tyd_params) in let reccty, rectvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in + let rectvi = List.fst rectvi in (* FIXME:TC *) let fields = List.fold_left (fun map (((_, idx), _, _) as field) -> @@ -1418,7 +1419,8 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = let rec_ = snd (oget (EcDecl.tydecl_as_record recty)) in let reccty = tconstr recp (List.map (tvar |- fst) recty.tyd_params) in let reccty, rtvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in - let tysopn = Tvar.init (List.map fst recty.tyd_params) rtvi in + let rtvi = List.fst rtvi in (* FIXME:TC *) + let tysopn = Tvar.init (List.fst recty.tyd_params) rtvi in let fields = List.fold_left @@ -1560,7 +1562,6 @@ let trans_if_match ~loc env ue (gindty, gind) (c, b1, b2) = gind.tydt_ctors (*-------------------------------------------------------------------- *) - let var_or_proj fvar fproj pv ty = match pv with | `Var pv -> fvar pv ty diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 4b0369b968..76e1838990 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -316,7 +316,7 @@ module TypeClass = struct let acc = (tcdecl.tc_tparams, tginst.tc_args) :: acc in find_tc_in_parent acc prt) in - let for1 ((tgparams, tgty), tginst, opsyms) = + let for1 ((tgparams, tgty), tginst, (opsyms : (EcPath.path * ty list) Mstr.t option)) = let tgi_args, tgparams_prt = oget ~exn:Bailout (find_tc_in_parent [] tginst) in @@ -329,7 +329,7 @@ module TypeClass = struct let subst = Mid.of_list (List.map (snd_map fst) tvinfo) in - let subst = + let subst as subst0 = let tcsubst = List.fold_left (fun subst (tparams, args) -> @@ -359,11 +359,17 @@ module TypeClass = struct uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (ty, tgty)) with UnifyCore.UnificationFailure _ -> raise Bailout end; - assert (UnifyCore.UF.closed !uf); - let subst = UnifyCore.subst_of_uf !uf in let subst = Tuni.offun subst in + (* assert (UnifyCore.UF.closed !uf); *) + + let opsyms = opsyms |> Option.map ( + Mstr.map + (fun (p, tys) -> + (p, List.map (fun ty -> subst (Tvar.subst subst0 ty)) tys)) + ) in + let effects = List.flatten (List.map (fun (_, (ty, tcs)) -> @@ -382,7 +388,7 @@ end (* -------------------------------------------------------------------- *) type tcproblem = [ - `TcCtt of ty * typeclass * (EcPath.path Mstr.t) option ref + `TcCtt of ty * typeclass * ((EcPath.path * ty list) Mstr.t) option ref ] module UnifyExtraForTC : @@ -538,7 +544,13 @@ module UniEnv = struct ) Mid.empty tvi let subst_tv subst params = - List.map (fun (tv, _) -> subst (tvar tv)) params + List.map (fun (tv, tcs) -> + let tv = subst (tvar tv) in + let tcs = + List.map + (fun tc -> { tc with tc_args = List.map subst tc.tc_args }) + tcs + in (tv, tcs)) params let openty_r ue params tvi = let subst = Tvar.subst (opentvi ue params tvi) in @@ -649,27 +661,10 @@ let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig let subue = UniEnv.copy ue in try - begin try - match tvi with - | None -> - () - - | Some (TVIunamed lt) -> - List.iter2 - (fun ty (_, tc) -> hastcs_r env subue ty tc) - lt op.D.op_tparams - - | Some (TVInamed ls) -> - let tparams = List.map (fst_map EcIdent.name) op.D.op_tparams in - let tparams = Msym.of_list tparams in - List.iter (fun (x, ty) -> - hastcs_r env subue ty (oget (Msym.find_opt x tparams))) - ls - - with UnificationFailure _ -> raise E.Failure - end; - - let (tip, tvs) = UniEnv.openty_r subue op.D.op_tparams tvi in + let (tip, tvtcs) = UniEnv.openty_r subue op.D.op_tparams tvi in + + List.iter (fun (tv, tcs) -> hastcs_r env subue tv tcs) tvtcs; + let top = tip op.D.op_ty in let texpected = tfun_expected subue psig in @@ -687,7 +682,7 @@ let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig | _ -> None - in Some ((path, tvs), top, subue, bd) + in Some ((path, List.fst tvtcs), top, subue, bd) with E.Failure -> None diff --git a/src/ecUnify.mli b/src/ecUnify.mli index fcfa9bdd18..9ae5edec7a 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -27,8 +27,8 @@ module UniEnv : sig val getnamed : unienv -> symbol -> EcIdent.t val repr : unienv -> ty -> ty val opentvi : unienv -> ty_params -> tvi -> ty EcIdent.Mid.t - val openty : unienv -> ty_params -> tvi -> ty -> ty * ty list - val opentys : unienv -> ty_params -> tvi -> ty list -> ty list * ty list + val openty : unienv -> ty_params -> tvi -> ty -> ty * (ty * typeclass list) list + val opentys : unienv -> ty_params -> tvi -> ty list -> ty list * (ty * typeclass list) list val closed : unienv -> bool val close : unienv -> uidmap val assubst : unienv -> uidmap @@ -37,7 +37,7 @@ end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val hastc : EcEnv.env -> unienv -> ty -> typeclass -> (path Mstr.t) option option +val hastc : EcEnv.env -> unienv -> ty -> typeclass -> ((path * ty list) Mstr.t) option option val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty From bc83128fc05a7aead1d60d8fb3658bf7d3ae1aa5 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 12 May 2022 10:58:52 +0200 Subject: [PATCH 052/113] nits --- examples/typeclass.ec | 42 ++++++++++++++---------------------------- src/ecCallbyValue.ml | 5 ++++- src/ecPrinting.ml | 2 +- src/ecReduction.ml | 12 ++++++------ src/ecReduction.mli | 2 +- src/ecUnify.ml | 6 +++++- 6 files changed, 31 insertions(+), 38 deletions(-) diff --git a/examples/typeclass.ec b/examples/typeclass.ec index 9dea589e57..321858febb 100644 --- a/examples/typeclass.ec +++ b/examples/typeclass.ec @@ -1,36 +1,32 @@ (* ==================================================================== *) (* Typeclass examples *) +(* -------------------------------------------------------------------- *) +require import AllCore List. + (* -------------------------------------------------------------------- *) (* Set theory *) -type class ['a] foo = { - op bar : foo * 'a +type class ['a] artificial = { + op myop : artificial * 'a }. -op bari ['a] : int * 'a = (0, witness<:'a>). +op myopi ['a] : int * 'a = (0, witness<:'a>). -instance 'b foo with ['b] int - op bar = bari<:'b>. +instance 'b artificial with ['b] int + op myop = myopi<:'b>. -lemma L : bar<:bool, int> = (0, witness). +lemma reduce_tc : myop<:bool, int> = (0, witness). proof. class. - reflexivity. +qed. - - -(* - - - +(* -------------------------------------------------------------------- *) type class witness = { op witness : witness }. - - print witness. type class finite = { @@ -179,7 +175,7 @@ op big ['a, 'b <: monoid] (P : 'a -> bool) (F : 'a -> 'b) (r : 'a list) = (* Set theory *) lemma all_finiteP ['a <: finite] p : (all_finite p) <=> (forall (x : 'a), p x). -proof. by rewrite/all_finite allP; split => Hp x; rewrite Hp // enumP. qed. +proof. by rewrite/all_finite allP; split=> Hp x; rewrite Hp enumP. qed. lemma all_countableP ['a <: countable] p : (all_countable p) <=> (forall (x : 'a), p x). proof. @@ -247,20 +243,10 @@ proof. (*TODO: in the goal, the typeclass operator + should have been replaced with the + from CoreInt, but has not been.*) print mulrDl. move => x y z. - move: (Ring.IntID.mulrDl x y z). - move => HmulrDl. - have: false. - move: HmulrDl. - rewrite HmulrDl. - (* TODO: what? *) - admit. + class. + apply Ring.IntID.mulrDl. qed. - - - - - (* ==================================================================== *) (* Misc *) diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index 12540851fe..601ab540ce 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -326,7 +326,10 @@ and reduce_user_delta st f1 p tys args = let f = Op.reduce ~force:(mode = `Force) st.st_env p tys in cbv st Subst.subst_id f args else if st.st_ri.delta_tc then - match EcReduction.reduce_tc st.st_env p tys with + match EcReduction.reduce_tc + ~params:(LDecl.tohyps st.st_hyps).h_tvar + st.st_env p tys + with | None -> f2 | Some f -> cbv st Subst.subst_id f args else f2 diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index ba50e50ab8..33fddf27d5 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -3037,7 +3037,7 @@ module PPGoal = struct | FhoareS hs -> pp_hoareS ?prpo ppe fmt hs | FequivF ef -> pp_equivF ppe fmt ef | FequivS es -> pp_equivS ?prpo ppe fmt es - | _ -> Format.fprintf fmt "%a@\n%!" (pp_form ppe) concl + | _ -> Format.fprintf fmt "%a@\n%!" EcFol.pp_form concl end (* -------------------------------------------------------------------- *) diff --git a/src/ecReduction.ml b/src/ecReduction.ml index e6f643a424..25729a987d 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -686,13 +686,13 @@ let reduce_op ri env p tys = with NotReducible -> raise nohead else raise nohead -let reduce_tc env p tys = +let reduce_tc ?params env p tys = if not (EcEnv.Op.is_tc_op env p) then None else let tys = List.rev tys in let tcty, tys = List.hd tys, List.rev (List.tl tys) in let (tcp, opname) = EcDecl.operator_as_tc (EcEnv.Op.by_path p env) in - let ue = EcUnify.UniEnv.create None in + let ue = EcUnify.UniEnv.create params in let syms = oget (EcUnify.hastc env ue tcty { tc_name = tcp; tc_args = tys }) in match syms with None -> None | Some syms -> @@ -704,8 +704,8 @@ let reduce_tc env p tys = Some (EcFol.f_op optg opargs (Tvar.subst tysubst optg_decl.op_ty)) -let may_reduce_tc ri env p tys = - if ri.delta_tc then oget ~exn:nohead (reduce_tc env p tys) else raise nohead +let may_reduce_tc ri ?params env p tys = + if ri.delta_tc then oget ~exn:nohead (reduce_tc ?params env p tys) else raise nohead let is_record env f = match EcFol.destr_app f with @@ -1016,10 +1016,10 @@ let reduce_logic ri env hyps f p args = check_reduced hyps needsubterm f f' (* -------------------------------------------------------------------- *) -let reduce_delta ri env _hyps f = +let reduce_delta ri env hyps f = match f.f_node with | Fop (p, tys) when ri.delta_tc && EcEnv.Op.is_tc_op env p -> - may_reduce_tc ri env p tys + may_reduce_tc ri ~params:(LDecl.tohyps hyps).h_tvar env p tys | Fop (p, tys) when ri.delta_p p <> `No -> reduce_op ri env p tys diff --git a/src/ecReduction.mli b/src/ecReduction.mli index e7aff688d3..f6c1a50c80 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -87,7 +87,7 @@ val nodelta : reduction_info val delta : reduction_info val reduce_logic : reduction_info -> env -> LDecl.hyps -> form -> form -val reduce_tc : env -> path -> ty list -> form option +val reduce_tc : ?params:(ident * EcDecl.typeclass list) list -> env -> path -> ty list -> form option val h_red_opt : reduction_info -> LDecl.hyps -> form -> form option val h_red : reduction_info -> LDecl.hyps -> form -> form diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 76e1838990..8ad5a1d09b 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -663,7 +663,11 @@ let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig try let (tip, tvtcs) = UniEnv.openty_r subue op.D.op_tparams tvi in - List.iter (fun (tv, tcs) -> hastcs_r env subue tv tcs) tvtcs; + List.iter + (fun (tv, tcs) -> + try hastcs_r env subue tv tcs + with UnificationFailure _ -> raise E.Failure) + tvtcs; let top = tip op.D.op_ty in let texpected = tfun_expected subue psig in From 2aa276be0e8838bd52148b0536d1c9296a0e8d22 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Tue, 4 Oct 2022 16:38:17 +0200 Subject: [PATCH 053/113] Pre merge --- theories/algebra/Monoid.ec | 54 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 theories/algebra/Monoid.ec diff --git a/theories/algebra/Monoid.ec b/theories/algebra/Monoid.ec new file mode 100644 index 0000000000..f69122c423 --- /dev/null +++ b/theories/algebra/Monoid.ec @@ -0,0 +1,54 @@ +require import Int. + +(* -------------------------------------------------------------------- *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +(* -------------------------------------------------------------------- *) +lemma addm0 ['a <: addmonoid] : right_id idm (+)<:'a>. +proof. by move=> x; rewrite addmC add0m. qed. + +lemma addmCA ['a <: addmonoid] : left_commutative (+)<:'a>. +proof. by move=> x y z; rewrite !addmA (addmC x). qed. + +lemma addmAC ['a <: addmonoid] : right_commutative (+)<:'a>. +proof. by move=> x y z; rewrite -!addmA (addmC y). qed. + +lemma addmACA ['a <: addmonoid] : interchange (+)<:'a> (+)<:'a>. +proof. by move=> x y z t; rewrite -!addmA (addmCA y). qed. + +lemma iteropE ['a <: addmonoid] n x: iterop n (+)<:'a> x idm<:'a> = iter n ((+)<:'a> x) idm<:'a>. +proof. + elim/natcase n => [n le0_n|n ge0_n]. + + by rewrite ?(iter0, iterop0). + + by rewrite iterSr // addm0 iteropS. +qed. + +(* -------------------------------------------------------------------- *) +abstract theory AddMonoid. + type t. + + op idm : t. + op (+) : t -> t -> t. + + theory Axioms. + axiom nosmt addmA: associative (+). + axiom nosmt addmC: commutative (+). + axiom nosmt add0m: left_id idm (+). + end Axioms. + + instance addmonoid with t + op idm = idm + op (+) = (+). + + realize addmA by exact Axioms.addmA. + realize addmC by exact Axioms.addmC. + realize add0m by exact Axioms.add0m. + +end AddMonoid. From ab2599f60819d119abc0a6cdb043e5742260797d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20S=C3=A9r=C3=A9?= Date: Tue, 4 Oct 2022 17:56:46 +0200 Subject: [PATCH 054/113] Issue after merge in compilation, ppx_deriving added to nix --- default.nix | 2 ++ src/ecTypes.ml | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/default.nix b/default.nix index a4436d84f3..dc0bda83e5 100644 --- a/default.nix +++ b/default.nix @@ -30,6 +30,8 @@ let why3 = why3_local; in menhir menhirLib merlin + ppxlib + ppx_deriving yojson zarith ]); diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 95eb0eb565..f49ee9c091 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -265,7 +265,7 @@ let ty_subst_id = ts_mp = EcPath.sms_identity; ts_def = Mp.empty; ts_u = funnone ; - ts_v = funnone ; } + ts_v = Mid.empty ; } let is_ty_subst_id s = s.ts_p == identity From 207845459dc2909989baf00eb6ebf8615c4ba3ae Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 31 Aug 2023 11:06:09 +0200 Subject: [PATCH 055/113] leftovers --- theories/algebra/Monoid.ec => examples/monoid.ec | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename theories/algebra/Monoid.ec => examples/monoid.ec (100%) diff --git a/theories/algebra/Monoid.ec b/examples/monoid.ec similarity index 100% rename from theories/algebra/Monoid.ec rename to examples/monoid.ec From 33e61af0a1946788a7a6bd38c09e986b95d736c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Dupressoir?= Date: Fri, 12 Jan 2024 20:49:08 +0000 Subject: [PATCH 056/113] [WIP] typeclasses, finding issues --- theories/algebra/Monoid.ec | 35 + theories/algebra/Monoid.eca | 42 -- theories/algebra/Ring.ec | 1228 ++++++++++++++++++----------------- 3 files changed, 651 insertions(+), 654 deletions(-) create mode 100644 theories/algebra/Monoid.ec delete mode 100644 theories/algebra/Monoid.eca diff --git a/theories/algebra/Monoid.ec b/theories/algebra/Monoid.ec new file mode 100644 index 0000000000..f33a9da550 --- /dev/null +++ b/theories/algebra/Monoid.ec @@ -0,0 +1,35 @@ +require import Int. + +(* -------------------------------------------------------------------- *) +type class monoid = { + op idm : monoid + op (+) : monoid -> monoid -> monoid + + axiom addmA: associative (+) + axiom addmC: commutative (+) + axiom add0m: left_id idm (+) +}. + +(* -------------------------------------------------------------------- *) +section. +declare type m <: monoid. + +lemma addm0: right_id idm (+)<:m>. +proof. by move=> x; rewrite addmC add0m. qed. + +lemma addmCA: left_commutative (+)<:m>. +proof. by move=> x y z; rewrite !addmA (addmC x). qed. + +lemma addmAC: right_commutative (+)<:m>. +proof. by move=> x y z; rewrite -!addmA (addmC y). qed. + +lemma addmACA: interchange (+)<:m> (+). +proof. by move=> x y z t; rewrite -!addmA (addmCA y). qed. + +lemma iteropE n (x : m): iterop n (+) x idm = iter n ((+) x) idm. +proof. +elim/natcase n => [n le0_n|n ge0_n]. ++ by rewrite ?(iter0, iterop0). ++ by rewrite iterSr // addm0 iteropS. +qed. +end section. diff --git a/theories/algebra/Monoid.eca b/theories/algebra/Monoid.eca deleted file mode 100644 index 80176d5313..0000000000 --- a/theories/algebra/Monoid.eca +++ /dev/null @@ -1,42 +0,0 @@ -require import Int. - -(* -------------------------------------------------------------------- *) -type t. - -op idm : t. -op (+) : t -> t -> t. - -theory Axioms. - axiom nosmt addmA: associative Self.(+). - axiom nosmt addmC: commutative Self.(+). - axiom nosmt add0m: left_id idm Self.(+). -end Axioms. - -(* -------------------------------------------------------------------- *) -lemma addmA: associative Self.(+). -proof. by apply/Axioms.addmA. qed. - -lemma addmC: commutative Self.(+). -proof. by apply/Axioms.addmC. qed. - -lemma add0m: left_id idm Self.(+). -proof. by apply/Axioms.add0m. qed. - -lemma addm0: right_id idm Self.(+). -proof. by move=> x; rewrite addmC add0m. qed. - -lemma addmCA: left_commutative Self.(+). -proof. by move=> x y z; rewrite !addmA (addmC x). qed. - -lemma addmAC: right_commutative Self.(+). -proof. by move=> x y z; rewrite -!addmA (addmC y). qed. - -lemma addmACA: interchange Self.(+) Self.(+). -proof. by move=> x y z t; rewrite -!addmA (addmCA y). qed. - -lemma iteropE n x: iterop n Self.(+) x idm = iter n ((+) x) idm. -proof. - elim/natcase n => [n le0_n|n ge0_n]. - + by rewrite ?(iter0, iterop0). - + by rewrite iterSr // addm0 iteropS. -qed. diff --git a/theories/algebra/Ring.ec b/theories/algebra/Ring.ec index 749fcde9b6..789822d794 100644 --- a/theories/algebra/Ring.ec +++ b/theories/algebra/Ring.ec @@ -1,655 +1,648 @@ pragma +implicits. (* -------------------------------------------------------------------- *) -require import Core Int. -require (*--*) Monoid. +require import Core Int Monoid. (* -------------------------------------------------------------------- *) -abstract theory ZModule. - type t. +type class group <: monoid = { + op [ - ] : group -> group - op zeror : t. - op ( + ) : t -> t -> t. - op [ - ] : t -> t. + axiom addNr: left_inverse idm [-] (+)<:group> +}. - axiom nosmt addrA: associative (+). - axiom nosmt addrC: commutative (+). - axiom nosmt add0r: left_id zeror (+). - axiom nosmt addNr: left_inverse zeror [-] (+). +section. +declare type g <: group. - clone Monoid as AddMonoid with - type t <- t, - op idm <- zeror, - op (+) <- (+) - proof *. +abbrev zeror = idm<:g>. +abbrev ( - ) (x y : g) = x + -y. - realize Axioms.addmA by apply/addrA. - realize Axioms.addmC by apply/addrC. - realize Axioms.add0m by apply/add0r. +(* -------------------------------------------------------------------- *) +lemma nosmt addrA: associative (+)<:g>. +proof. by exact: addmA. qed. - clear [AddMonoid.Axioms.*]. +lemma nosmt addrC: commutative (+)<:g>. +proof. by exact: addmC. qed. - abbrev ( - ) (x y : t) = x + -y. +lemma nosmt add0r: left_id zeror (+)<:g>. +proof. by exact: add0m. qed. - lemma nosmt addr0: right_id zeror (+). - proof. by move=> x; rewrite addrC add0r. qed. +(* -------------------------------------------------------------------- *) +lemma nosmt addr0: right_id zeror (+)<:g>. +proof. by move=> x; rewrite addrC add0r. qed. - lemma nosmt addrN: right_inverse zeror [-] (+). - proof. by move=> x; rewrite addrC addNr. qed. +lemma nosmt addrN: right_inverse zeror [-] (+)<:g>. +proof. by move=> x; rewrite addrC addNr. qed. - lemma nosmt addrCA: left_commutative (+). - proof. by move=> x y z; rewrite !addrA (@addrC x y). qed. +lemma nosmt addrCA: left_commutative (+)<:g>. +proof. by move=> x y z; rewrite !addrA (@addrC x y). qed. - lemma nosmt addrAC: right_commutative (+). - proof. by move=> x y z; rewrite -!addrA (@addrC y z). qed. +lemma nosmt addrAC: right_commutative (+)<:g>. +proof. by move=> x y z; rewrite -!addrA (@addrC y z). qed. - lemma nosmt addrACA: interchange (+) (+). - proof. by move=> x y z t; rewrite -!addrA (addrCA y). qed. +lemma nosmt addrACA: interchange (+)<:g> (+)<:g>. +proof. by move=> x y z t; rewrite -!addrA (addrCA y). qed. - lemma nosmt subrr (x : t): x - x = zeror. - proof. by rewrite addrN. qed. +lemma nosmt subrr (x : g): x - x = zeror. +proof. by rewrite addrN. qed. - lemma nosmt addKr: left_loop [-] (+). - proof. by move=> x y; rewrite addrA addNr add0r. qed. +lemma nosmt addKr: left_loop [-] (+)<:g>. +proof. by move=> x y; rewrite addrA addNr add0r. qed. - lemma nosmt addNKr: rev_left_loop [-] (+). - proof. by move=> x y; rewrite addrA addrN add0r. qed. +lemma nosmt addNKr: rev_left_loop [-] (+)<:g>. +proof. by move=> x y; rewrite addrA addrN add0r. qed. - lemma nosmt addrK: right_loop [-] (+). - proof. by move=> x y; rewrite -addrA addrN addr0. qed. +lemma nosmt addrK: right_loop [-] (+)<:g>. +proof. by move=> x y; rewrite -addrA addrN addr0. qed. - lemma nosmt addrNK: rev_right_loop [-] (+). - proof. by move=> x y; rewrite -addrA addNr addr0. qed. +lemma nosmt addrNK: rev_right_loop [-] (+)<:g>. +proof. by move=> x y; rewrite -addrA addNr addr0. qed. - lemma nosmt subrK x y: (x - y) + y = x. - proof. by rewrite addrNK. qed. +lemma nosmt subrK (x y : g): (x - y) + y = x. +proof. by rewrite addrNK. qed. - lemma nosmt addrI: right_injective (+). - proof. by move=> x y z h; rewrite -(@addKr x z) -h addKr. qed. +lemma nosmt addrI: right_injective (+)<:g>. +proof. by move=> x y z h; rewrite -(@addKr x z) -h addKr. qed. - lemma nosmt addIr: left_injective (+). - proof. by move=> x y z h; rewrite -(@addrK x z) -h addrK. qed. +lemma nosmt addIr: left_injective (+)<:g>. +proof. by move=> x y z h; rewrite -(@addrK x z) -h addrK. qed. - lemma nosmt opprK: involutive [-]. - proof. by move=> x; apply (@addIr (-x)); rewrite addNr addrN. qed. +lemma nosmt opprK: involutive [-]<:g>. +proof. by move=> x; apply (@addIr (-x)); rewrite addNr addrN. qed. - lemma oppr_inj : injective [-]. - proof. by move=> x y eq; apply/(addIr (-x)); rewrite subrr eq subrr. qed. +lemma nosmt oppr_inj : injective [-]<:g>. +proof. by move=> x y eq; apply/(addIr (-x)); rewrite subrr eq subrr. qed. - lemma nosmt oppr0: -zeror = zeror. - proof. by rewrite -(@addr0 (-zeror)) addNr. qed. +lemma nosmt oppr0 : -zeror = zeror. +proof. by rewrite -(@addr0 (-zeror)) addNr. qed. - lemma oppr_eq0 x : (- x = zeror) <=> (x = zeror). - proof. by rewrite (inv_eq opprK) oppr0. qed. +lemma nosmt oppr_eq0 (x : g) : (- x = zeror) <=> (x = zeror). +proof. by rewrite (inv_eq opprK) oppr0. qed. - lemma nosmt subr0 (x : t): x - zeror = x. - proof. by rewrite oppr0 addr0. qed. +lemma nosmt subr0 (x : g): x - zeror = x. +proof. by rewrite oppr0 addr0. qed. - lemma nosmt sub0r (x : t): zeror - x = - x. - proof. by rewrite add0r. qed. +lemma nosmt sub0r (x : g): zeror - x = - x. +proof. by rewrite add0r. qed. - lemma nosmt opprD (x y : t): -(x + y) = -x + -y. - proof. by apply (@addrI (x + y)); rewrite addrA addrN addrAC addrK addrN. qed. +lemma nosmt opprD (x y : g): -(x + y) = -x + -y. +proof. by apply (@addrI (x + y)); rewrite addrA addrN addrAC addrK addrN. qed. - lemma nosmt opprB (x y : t): -(x - y) = y - x. - proof. by rewrite opprD opprK addrC. qed. +lemma nosmt opprB (x y : g): -(x - y) = y - x. +proof. by rewrite opprD opprK addrC. qed. - lemma nosmt subrACA: interchange (-) (+). - proof. by move=> x y z t; rewrite addrACA opprD. qed. +lemma nosmt subrACA: interchange (-) (+)<:g>. +proof. by move=> x y z t; rewrite addrACA opprD. qed. - lemma nosmt subr_eq (x y z : t): - (x - z = y) <=> (x = y + z). - proof. - move: (can2_eq (fun x, x - z) (fun x, x + z) _ _ x y) => //=. - by move=> {x} x /=; rewrite addrNK. - by move=> {x} x /=; rewrite addrK. - qed. +lemma nosmt subr_eq (x y z : g): + (x - z = y) <=> (x = y + z). +proof. +move: (can2_eq (fun x, x - z) (fun x, x + z) _ _ x y) => //=. ++ by move=> {x} x /=; rewrite addrNK. ++ by move=> {x} x /=; rewrite addrK. +qed. - lemma nosmt subr_eq0 (x y : t): (x - y = zeror) <=> (x = y). - proof. by rewrite subr_eq add0r. qed. +lemma nosmt subr_eq0 (x y : g): (x - y = zeror) <=> (x = y). +proof. by rewrite subr_eq add0r. qed. - lemma nosmt addr_eq0 (x y : t): (x + y = zeror) <=> (x = -y). - proof. by rewrite -(@subr_eq0 x) opprK. qed. +lemma nosmt addr_eq0 (x y : g): (x + y = zeror) <=> (x = -y). +proof. by rewrite -(@subr_eq0 x) opprK. qed. - lemma nosmt eqr_opp (x y : t): (- x = - y) <=> (x = y). - proof. by apply/(@can_eq _ _ opprK x y). qed. +lemma nosmt eqr_opp (x y : g): (- x = - y) <=> (x = y). +proof. by apply/(@can_eq _ _ opprK x y). qed. - lemma eqr_oppLR x y : (- x = y) <=> (x = - y). - proof. by apply/(@inv_eq _ opprK x y). qed. +lemma nosmt eqr_oppLR (x y : g) : (- x = y) <=> (x = - y). +proof. by apply/(@inv_eq _ opprK x y). qed. - lemma nosmt eqr_sub (x y z t : t) : (x - y = z - t) <=> (x + t = z + y). - proof. - rewrite -{1}(addrK t x) -{1}(addrK y z) -!addrA. - by rewrite (addrC (-t)) !addrA; split=> [/addIr /addIr|->//]. - qed. +lemma nosmt eqr_sub (x y z t : g) : (x - y = z - t) <=> (x + t = z + y). +proof. +rewrite -{1}(addrK t x) -{1}(addrK y z) -!addrA. +by rewrite (addrC (-t)) !addrA; split=> [/addIr /addIr|->//]. +qed. - lemma subr_add2r (z x y : t): (x + z) - (y + z) = x - y. - proof. by rewrite opprD addrACA addrN addr0. qed. +lemma nosmt subr_add2r (z x y : g): (x + z) - (y + z) = x - y. +proof. by rewrite opprD addrACA addrN addr0. qed. - op intmul (x : t) (n : int) = - (* (signz n) * (iterop `|n| ZModule.(+) x zeror) *) - if n < 0 - then -(iterop (-n) ZModule.(+) x zeror) - else (iterop n ZModule.(+) x zeror). +op intmul (x : g) (n : int) = + (* (signz n) * (iterop `|n| ZModule.(+) x zeror) *) + if n < 0 + then -(iterop (-n) (+)<:g> x zeror) + else (iterop n (+)<:g> x zeror). - lemma intmulpE z c : 0 <= c => - intmul z c = iterop c ZModule.(+) z zeror. - proof. by rewrite /intmul lezNgt => ->. qed. +lemma nosmt intmulpE (z : g) c : 0 <= c => + intmul z c = iterop c (+)<:g> z zeror. +proof. by rewrite /intmul lezNgt => ->. qed. - lemma mulr0z (x : t): intmul x 0 = zeror. - proof. by rewrite /intmul /= iterop0. qed. +lemma nosmt mulr0z (x : g): intmul x 0 = zeror. +proof. by rewrite /intmul /= iterop0. qed. - lemma mulr1z (x : t): intmul x 1 = x. - proof. by rewrite /intmul /= iterop1. qed. +lemma nosmt mulr1z (x : g): intmul x 1 = x. +proof. by rewrite /intmul /= iterop1. qed. - lemma mulr2z (x : t): intmul x 2 = x + x. - proof. by rewrite /intmul /= (@iteropS 1) // (@iterS 0) // iter0. qed. +lemma nosmt mulr2z (x : g): intmul x 2 = x + x. +proof. by rewrite /intmul /= (@iteropS 1) // (@iterS 0) // iter0. qed. - lemma mulrNz (x : t) (n : int): intmul x (-n) = -(intmul x n). - proof. - case: (n = 0)=> [->|nz_c]; first by rewrite oppz0 mulr0z oppr0. - rewrite /intmul oppz_lt0 oppzK ltz_def nz_c lezNgt /=. - by case: (n < 0); rewrite ?opprK. - qed. +lemma nosmt mulrNz (x : g) (n : int): intmul x (-n) = -(intmul x n). +proof. +case: (n = 0)=> [->|nz_c]; first by rewrite oppz0 mulr0z oppr0. +rewrite /intmul oppz_lt0 oppzK ltz_def nz_c lezNgt /=. +by case: (n < 0); rewrite ?opprK. +qed. - lemma mulrS (x : t) (n : int): 0 <= n => - intmul x (n+1) = x + intmul x n. - proof. - move=> ge0n; rewrite !intmulpE 1:addz_ge0 //. - by rewrite !AddMonoid.iteropE iterS. - qed. +lemma nosmt mulrS (x : g) (n : int): 0 <= n => + intmul x (n+1) = x + intmul x n. +proof. +move=> ge0n; rewrite !intmulpE 1:addz_ge0 //. +by rewrite !iteropE iterS. +qed. - lemma mulNrz x n : intmul (- x) n = - (intmul x n). - proof. - elim/intwlog: n => [n h| | n ge0_n ih]. - + by rewrite -(@oppzK n) !(@mulrNz _ (- n)) h. - + by rewrite !mulr0z oppr0. - + by rewrite !mulrS // ih opprD. - qed. +lemma nosmt mulNrz (x : g) n : intmul (- x) n = - (intmul x n). +proof. +elim/intwlog: n => [n h| | n ge0_n ih]. ++ by rewrite -(@oppzK n) !(@mulrNz _ (- n)) h. ++ by rewrite !mulr0z oppr0. ++ by rewrite !mulrS // ih opprD. +qed. - lemma mulNrNz x (n : int) : intmul (-x) (-n) = intmul x n. - proof. by rewrite mulNrz mulrNz opprK. qed. +lemma nosmt mulNrNz (x : g) (n : int) : intmul (-x) (-n) = intmul x n. +proof. by rewrite mulNrz mulrNz opprK. qed. - lemma mulrSz x n : intmul x (n + 1) = x + intmul x n. - proof. - case: (0 <= n) => [/mulrS ->//|]; rewrite -ltzNge => gt0_n. - case: (n = -1) => [->/=|]; 1: by rewrite mulrNz mulr1z mulr0z subrr. - move=> neq_n_N1; rewrite -!(@mulNrNz x). - rewrite (_ : -n = -(n+1) + 1) 1:/# mulrS 1:/#. - by rewrite addrA subrr add0r. - qed. +lemma nosmt mulrSz (x : g) n : intmul x (n + 1) = x + intmul x n. +proof. +case: (0 <= n) => [/mulrS ->//|]; rewrite -ltzNge => gt0_n. +case: (n = -1) => [->/=|]; 1: by rewrite mulrNz mulr1z mulr0z subrr. +move=> neq_n_N1; rewrite -!(@mulNrNz x). +rewrite (_ : -n = -(n+1) + 1) 1:/# mulrS 1:/#. +by rewrite addrA subrr add0r. +qed. - lemma mulrDz (x : t) (n m : int) : intmul x (n + m) = intmul x n + intmul x m. - proof. - wlog: n m / 0 <= m => [wlog|]. - + case: (0 <= m) => [/wlog|]; first by apply. - rewrite -ltzNge => lt0_m; rewrite (_ : n + m = -(-m - n)) 1:/#. - by rewrite mulrNz addzC wlog 1:/# !mulrNz -opprD opprK. - elim: m => /= [|m ge0_m ih]; first by rewrite mulr0z addr0. - by rewrite addzA !mulrSz ih addrCA. +lemma nosmt mulrDz (x : g) (n m : int) : intmul x (n + m) = intmul x n + intmul x m. +proof. +wlog: n m / 0 <= m => [wlog|]. ++ case: (0 <= m) => [/wlog|]; first by apply. + rewrite -ltzNge => lt0_m; rewrite (_ : n + m = -(-m - n)) 1:/#. + by rewrite mulrNz addzC wlog 1:/# !mulrNz -opprD opprK. +elim: m => /= [|m ge0_m ih]; first by rewrite mulr0z addr0. +by rewrite addzA !mulrSz ih addrCA. qed. -end ZModule. +end section. (* -------------------------------------------------------------------- *) -abstract theory ComRing. - clone include ZModule. - - op oner : t. - op ( * ) : t -> t -> t. - op invr : t -> t. - pred unit : t. - - abbrev ( / ) (x y : t) = x * (invr y). - - axiom nosmt oner_neq0 : oner <> zeror. - axiom nosmt mulrA : associative ( * ). - axiom nosmt mulrC : commutative ( * ). - axiom nosmt mul1r : left_id oner ( * ). - axiom nosmt mulrDl : left_distributive ( * ) (+). - axiom nosmt mulVr : left_inverse_in unit oner invr ( * ). - axiom nosmt unitP : forall (x y : t), y * x = oner => unit x. - axiom nosmt unitout : forall (x : t), !unit x => invr x = x. +type class comring <: group = { + op oner : comring + op ( * ) : comring -> comring -> comring + op invr : comring -> comring + op unit : comring -> bool - clone Monoid as MulMonoid with - type t <- t, - op idm <- oner, - op ( + ) <- ( * ) - proof *. + axiom oner_neq0 : oner <> zeror + axiom mulrA : associative ( * ) + axiom mulrC : commutative ( * ) + axiom mul1r : left_id oner ( * ) + axiom mulrDl : left_distributive ( * ) (+)<:comring> + axiom mulVr : left_inverse_in unit oner invr ( * ) + axiom unitP : forall (x y : comring), y * x = oner => unit x + axiom unitout : forall (x : comring), !unit x => invr x = x +}. - realize Axioms.addmA by apply/mulrA. - realize Axioms.addmC by apply/mulrC. - realize Axioms.add0m by apply/mul1r. +section. +declare type r <: comring. - clear [MulMonoid.Axioms.*]. +instance monoid with r + op idm = oner<:r> + op (+) = ( * )<:r>. +realize addmA by exact: mulrA. +realize addmC by exact: mulrC. +realize add0m by exact: mul1r. - lemma nosmt mulr1: right_id oner ( * ). - proof. by move=> x; rewrite mulrC mul1r. qed. +abbrev ( / ) (x y : r) = x * (invr y). - lemma nosmt mulrCA: left_commutative ( * ). - proof. by move=> x y z; rewrite !mulrA (@mulrC x y). qed. +lemma nosmt mulr1: right_id oner ( * )<:r>. +proof. by move=> x; rewrite mulrC mul1r. qed. - lemma nosmt mulrAC: right_commutative ( * ). - proof. by move=> x y z; rewrite -!mulrA (@mulrC y z). qed. +lemma nosmt mulrCA: left_commutative ( * )<:r>. +proof. by move=> x y z; rewrite !mulrA (@mulrC x y). qed. - lemma nosmt mulrACA: interchange ( * ) ( * ). - proof. by move=> x y z t; rewrite -!mulrA (mulrCA y). qed. +lemma nosmt mulrAC: right_commutative ( * )<:r>. +proof. by move=> x y z; rewrite -!mulrA (@mulrC y z). qed. - lemma nosmt mulrSl x y : (x + oner) * y = x * y + y. - proof. by rewrite mulrDl mul1r. qed. +lemma nosmt mulrACA: interchange ( * ) ( * )<:r>. +proof. by move=> x y z t; rewrite -!mulrA (mulrCA y). qed. - lemma nosmt mulrDr: right_distributive ( * ) (+). - proof. by move=> x y z; rewrite mulrC mulrDl !(@mulrC _ x). qed. +lemma nosmt mulrSl (x y : r) : (x + oner) * y = x * y + y. +proof. by rewrite mulrDl mul1r. qed. - lemma nosmt mul0r: left_zero zeror ( * ). - proof. by move=> x; apply: (@addIr (oner * x)); rewrite -mulrDl !add0r mul1r. qed. +lemma nosmt mulrDr: right_distributive ( * ) (+)<:r>. +proof. by move=> x y z; rewrite mulrC mulrDl !(@mulrC _ x). qed. - lemma nosmt mulr0: right_zero zeror ( * ). - proof. by move=> x; apply: (@addIr (x * oner)); rewrite -mulrDr !add0r mulr1. qed. +lemma nosmt mul0r: left_zero zeror ( * )<:r>. +proof. by move=> x; apply: (@addIr (oner * x)); rewrite -mulrDl !add0r mul1r. qed. - lemma nosmt mulrN (x y : t): x * (- y) = - (x * y). - proof. by apply: (@addrI (x * y)); rewrite -mulrDr !addrN mulr0. qed. +lemma nosmt mulr0: right_zero zeror ( * )<:r>. +proof. by move=> x; apply: (@addIr (x * oner)); rewrite -mulrDr !add0r mulr1. qed. - lemma nosmt mulNr (x y : t): (- x) * y = - (x * y). - proof. by apply: (@addrI (x * y)); rewrite -mulrDl !addrN mul0r. qed. +lemma nosmt mulrN (x y : r): x * (- y) = - (x * y). +proof. by apply: (@addrI (x * y)); rewrite -mulrDr !addrN mulr0. qed. - lemma nosmt mulrNN (x y : t): (- x) * (- y) = x * y. - proof. by rewrite mulrN mulNr opprK. qed. +lemma nosmt mulNr (x y : r): (- x) * y = - (x * y). +proof. by apply: (@addrI (x * y)); rewrite -mulrDl !addrN mul0r. qed. - lemma nosmt mulN1r (x : t): (-oner) * x = -x. - proof. by rewrite mulNr mul1r. qed. +lemma nosmt mulrNN (x y : r): (- x) * (- y) = x * y. +proof. by rewrite mulrN mulNr opprK. qed. - lemma nosmt mulrN1 x: x * -oner = -x. - proof. by rewrite mulrN mulr1. qed. +lemma nosmt mulN1r (x : r): (-oner) * x = -x. +proof. by rewrite mulNr mul1r. qed. - lemma nosmt mulrBl: left_distributive ( * ) (-). - proof. by move=> x y z; rewrite mulrDl !mulNr. qed. +lemma nosmt mulrN1 (x : r): x * -oner = -x. +proof. by rewrite mulrN mulr1. qed. - lemma nosmt mulrBr: right_distributive ( * ) (-). - proof. by move=> x y z; rewrite mulrDr !mulrN. qed. +lemma nosmt mulrBl: left_distributive ( * ) (-)<:r>. +proof. by move=> x y z; rewrite mulrDl !mulNr. qed. - lemma mulrnAl x y n : 0 <= n => (intmul x n) * y = intmul (x * y) n. - proof. - elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mul0r //. - by rewrite mulrDl ih. - qed. +lemma nosmt mulrBr: right_distributive ( * ) (-)<:r>. +proof. by move=> x y z; rewrite mulrDr !mulrN. qed. - lemma mulrnAr x y n : 0 <= n => x * (intmul y n) = intmul (x * y) n. - proof. - elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mulr0 //. - by rewrite mulrDr ih. - qed. +lemma nosmt mulrnAl (x y : r) n : 0 <= n => (intmul x n) * y = intmul (x * y) n. +proof. +elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mul0r //. +by rewrite mulrDl ih. +qed. - lemma mulrzAl x y z : (intmul x z) * y = intmul (x * y) z. - proof. - case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAl. - by rewrite -oppzK mulrNz mulNr mulrnAl -?mulrNz // oppz_ge0. - qed. +lemma nosmt mulrnAr (x y : r) n : 0 <= n => x * (intmul y n) = intmul (x * y) n. +proof. +elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mulr0 //. +by rewrite mulrDr ih. +qed. - lemma mulrzAr x y z : x * (intmul y z) = intmul (x * y) z. - proof. - case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAr. - by rewrite -oppzK mulrNz mulrN mulrnAr -?mulrNz // oppz_ge0. - qed. +lemma nosmt mulrzAl (x y : r) z : (intmul x z) * y = intmul (x * y) z. +proof. +case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAl. +by rewrite -oppzK mulrNz mulNr mulrnAl -?mulrNz // oppz_ge0. +qed. - lemma nosmt mulrV: right_inverse_in unit oner invr ( * ). - proof. by move=> x /mulVr; rewrite mulrC. qed. +lemma nosmt mulrzAr x (y : r) z : x * (intmul y z) = intmul (x * y) z. +proof. +case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAr. +by rewrite -oppzK mulrNz mulrN mulrnAr -?mulrNz // oppz_ge0. +qed. - lemma nosmt divrr (x : t): unit x => x / x = oner. - proof. by apply/mulrV. qed. +lemma nosmt mulrV: right_inverse_in unit oner invr ( * )<:r>. +proof. by move=> x /mulVr; rewrite mulrC. qed. - lemma nosmt invr_out (x : t): !unit x => invr x = x. - proof. by apply/unitout. qed. +lemma nosmt divrr (x : r): unit x => x / x = oner. +proof. by apply/mulrV. qed. - lemma nosmt unitrP (x : t): unit x <=> (exists y, y * x = oner). - proof. by split=> [/mulVr<- |]; [exists (invr x) | case=> y /unitP]. qed. +lemma nosmt invr_out (x : r): !unit x => invr x = x. +proof. by apply/unitout. qed. - lemma nosmt mulKr: left_loop_in unit invr ( * ). - proof. by move=> x un_x y; rewrite mulrA mulVr // mul1r. qed. +lemma nosmt unitrP (x : r): unit x <=> (exists y, y * x = oner). +proof. by split=> [/mulVr<- |]; [exists (invr x) | case=> y /unitP]. qed. - lemma nosmt mulrK: right_loop_in unit invr ( * ). - proof. by move=> y un_y x; rewrite -mulrA mulrV // mulr1. qed. +lemma nosmt mulKr: left_loop_in unit invr ( * )<:r>. +proof. by move=> x un_x y; rewrite mulrA mulVr // mul1r. qed. - lemma nosmt mulVKr: rev_left_loop_in unit invr ( * ). - proof. by move=> x un_x y; rewrite mulrA mulrV // mul1r. qed. +lemma nosmt mulrK: right_loop_in unit invr ( * )<:r>. +proof. by move=> y un_y x; rewrite -mulrA mulrV // mulr1. qed. - lemma nosmt mulrVK: rev_right_loop_in unit invr ( * ). - proof. by move=> y nz_y x; rewrite -mulrA mulVr // mulr1. qed. +lemma nosmt mulVKr: rev_left_loop_in unit invr ( * )<:r>. +proof. by move=> x un_x y; rewrite mulrA mulrV // mul1r. qed. - lemma nosmt mulrI: right_injective_in unit ( * ). - proof. by move=> x Ux; have /can_inj h := mulKr _ Ux. qed. +lemma nosmt mulrVK: rev_right_loop_in unit invr ( * )<:r>. +proof. by move=> y nz_y x; rewrite -mulrA mulVr // mulr1. qed. - lemma nosmt mulIr: left_injective_in unit ( * ). - proof. by move=> x /mulrI h y1 y2; rewrite !(@mulrC _ x) => /h. qed. +lemma nosmt mulrI: right_injective_in unit ( * )<:r>. +proof. by move=> x Ux; have /can_inj h := mulKr _ Ux. qed. - lemma nosmt unitrE (x : t): unit x <=> (x / x = oner). - proof. - split=> [Ux|xx1]; 1: by apply/divrr. - by apply/unitrP; exists (invr x); rewrite mulrC. - qed. +lemma nosmt mulIr: left_injective_in unit ( * )<:r>. +proof. by move=> x /mulrI h y1 y2; rewrite !(@mulrC _ x) => /h. qed. - lemma nosmt invrK: involutive invr. - proof. - move=> x; case: (unit x)=> Ux; 2: by rewrite !invr_out. - rewrite -(mulrK _ Ux (invr (invr x))) -mulrA. - rewrite (@mulrC x) mulKr //; apply/unitrP. - by exists x; rewrite mulrV. - qed. +lemma nosmt unitrE (x : r): unit x <=> (x / x = oner). +proof. +split=> [Ux|xx1]; 1: by apply/divrr. +by apply/unitrP; exists (invr x); rewrite mulrC. +qed. - lemma nosmt invr_inj: injective invr. - proof. by apply: (can_inj _ _ invrK). qed. +lemma nosmt invrK: involutive invr<:r>. +proof. +move=> x; case: (unit x)=> Ux; 2: by rewrite !invr_out. +rewrite -(mulrK _ Ux (invr (invr x))) -mulrA. +rewrite (@mulrC x) mulKr //; apply/unitrP. +by exists x; rewrite mulrV. +qed. - lemma nosmt unitrV x: unit (invr x) <=> unit x. - proof. by rewrite !unitrE invrK mulrC. qed. +lemma nosmt invr_inj: injective invr<:r>. +proof. by apply: (can_inj _ _ invrK). qed. - lemma nosmt unitr1: unit oner. - proof. by apply/unitrP; exists oner; rewrite mulr1. qed. +lemma nosmt unitrV (x : r): unit (invr x) <=> unit x. +proof. by rewrite !unitrE invrK mulrC. qed. - lemma nosmt invr1: invr oner = oner. - proof. by rewrite -{2}(mulVr _ unitr1) mulr1. qed. +lemma nosmt unitr1: unit oner<:r>. +proof. by apply/unitrP; exists oner; rewrite mulr1. qed. - lemma nosmt div1r x: oner / x = invr x. - proof. by rewrite mul1r. qed. +lemma nosmt invr1: invr oner = oner<:r>. +proof. by rewrite -{2}(mulVr _ unitr1) mulr1. qed. - lemma nosmt divr1 x: x / oner = x. - proof. by rewrite invr1 mulr1. qed. +lemma nosmt div1r x: oner / x = invr x. +proof. by rewrite mul1r. qed. - lemma nosmt unitr0: !unit zeror. - proof. by apply/negP=> /unitrP [y]; rewrite mulr0 eq_sym oner_neq0. qed. +lemma nosmt divr1 x: x / oner = x. +proof. by rewrite invr1 mulr1. qed. - lemma nosmt invr0: invr zeror = zeror. - proof. by rewrite invr_out ?unitr0. qed. +lemma nosmt unitr0: !unit zeror<:r>. +proof. by apply/negP=> /unitrP [y]; rewrite mulr0 eq_sym oner_neq0. qed. - lemma nosmt unitrN1: unit (-oner). - proof. by apply/unitrP; exists (-oner); rewrite mulrNN mulr1. qed. +lemma nosmt invr0: invr zeror = zeror<:r>. +proof. by rewrite invr_out ?unitr0. qed. - lemma nosmt invrN1: invr (-oner) = -oner. - proof. by rewrite -{2}(divrr unitrN1) mulN1r opprK. qed. +lemma nosmt unitrN1: unit (-oner<:r>). +proof. by apply/unitrP; exists (-oner); rewrite mulrNN mulr1. qed. - lemma nosmt unitrMl x y : unit y => (unit (x * y) <=> unit x). - proof. (* FIXME: wlog *) - move=> uy; case: (unit x)=> /=; last first. - apply/contra=> uxy; apply/unitrP; exists (y * invr (x * y)). - apply/(mulrI (invr y)); first by rewrite unitrV. - rewrite !mulrA mulVr // mul1r; apply/(mulIr y)=> //. - by rewrite -mulrA mulVr // mulr1 mulVr. - move=> ux; apply/unitrP; exists (invr y * invr x). - by rewrite -!mulrA mulKr // mulVr. - qed. +lemma nosmt invrN1: invr (-oner) = -oner<:r>. +proof. by rewrite -{2}(divrr unitrN1) mulN1r opprK. qed. - lemma nosmt unitrMr x y : unit x => (unit (x * y) <=> unit y). - proof. - move=> ux; split=> [uxy|uy]; last by rewrite unitrMl. - by rewrite -(mulKr _ ux y) unitrMl ?unitrV. - qed. +lemma nosmt unitrMl (x y : r) : unit y => (unit (x * y) <=> unit x). +proof. (* FIXME: wlog *) +move=> uy; case: (unit x)=> /=; last first. + apply/contra=> uxy; apply/unitrP; exists (y * invr (x * y)). + apply/(mulrI (invr y)); first by rewrite unitrV. + rewrite !mulrA mulVr // mul1r; apply/(mulIr y)=> //. + by rewrite -mulrA mulVr // mulr1 mulVr. +move=> ux; apply/unitrP; exists (invr y * invr x). +by rewrite -!mulrA mulKr // mulVr. +qed. - lemma nosmt unitrM x y : unit (x * y) <=> (unit x /\ unit y). - proof. - case: (unit x) => /=; first by apply: unitrMr. - apply: contra => /unitrP[z] zVE; apply/unitrP. - by exists (y * z); rewrite mulrAC (@mulrC y) (@mulrC _ z). - qed. +lemma nosmt unitrMr (x y : r): unit x => (unit (x * y) <=> unit y). +proof. +move=> ux; split=> [uxy|uy]; last by rewrite unitrMl. +by rewrite -(mulKr _ ux y) unitrMl ?unitrV. +qed. - lemma nosmt unitrN x : unit (-x) <=> unit x. - proof. by rewrite -mulN1r unitrMr // unitrN1. qed. +lemma nosmt unitrM (x y : r) : unit (x * y) <=> (unit x /\ unit y). +proof. +case: (unit x) => /=; first by apply: unitrMr. +apply: contra => /unitrP[z] zVE; apply/unitrP. +by exists (y * z); rewrite mulrAC (@mulrC y) (@mulrC _ z). +qed. - lemma nosmt invrM x y : unit x => unit y => invr (x * y) = invr y * invr x. - proof. - move=> Ux Uy; have Uxy: unit (x * y) by rewrite unitrMl. - by apply: (mulrI _ Uxy); rewrite mulrV ?mulrA ?mulrK ?mulrV. - qed. +lemma nosmt unitrN (x : r) : unit (-x) <=> unit x. +proof. by rewrite -mulN1r unitrMr // unitrN1. qed. - lemma nosmt invrN (x : t) : invr (- x) = - (invr x). - proof. - case: (unit x) => ux; last by rewrite !invr_out ?unitrN. - by rewrite -mulN1r invrM ?unitrN1 // invrN1 mulrN1. - qed. +lemma nosmt invrM (x y : r) : unit x => unit y => invr (x * y) = invr y * invr x. +proof. +move=> Ux Uy; have Uxy: unit (x * y) by rewrite unitrMl. +by apply: (mulrI _ Uxy); rewrite mulrV ?mulrA ?mulrK ?mulrV. +qed. - lemma nosmt invr_neq0 x : x <> zeror => invr x <> zeror. - proof. - move=> nx0; case: (unit x)=> Ux; last by rewrite invr_out ?Ux. - by apply/negP=> x'0; move: Ux; rewrite -unitrV x'0 unitr0. - qed. +lemma nosmt invrN (x : r) : invr (- x) = - (invr x). +proof. +case: (unit x) => ux; last by rewrite !invr_out ?unitrN. +by rewrite -mulN1r invrM ?unitrN1 // invrN1 mulrN1. +qed. - lemma nosmt invr_eq0 x : (invr x = zeror) <=> (x = zeror). - proof. by apply/iff_negb; split=> /invr_neq0; rewrite ?invrK. qed. +lemma nosmt invr_neq0 (x : r) : x <> zeror => invr x <> zeror. +proof. +move=> nx0; case: (unit x)=> Ux; last by rewrite invr_out ?Ux. +by apply/negP=> x'0; move: Ux; rewrite -unitrV x'0 unitr0. +qed. - lemma nosmt invr_eq1 x : (invr x = oner) <=> (x = oner). - proof. by rewrite (inv_eq invrK) invr1. qed. +lemma nosmt invr_eq0 (x : r) : (invr x = zeror) <=> (x = zeror). +proof. by apply/iff_negb; split=> /invr_neq0; rewrite ?invrK. qed. - op ofint n = intmul oner n. +lemma nosmt invr_eq1 (x : r) : (invr x = oner) <=> (x = oner). +proof. by rewrite (inv_eq invrK) invr1. qed. - lemma ofint0: ofint 0 = zeror. - proof. by apply/mulr0z. qed. +op ofint n = intmul oner<:r> n. - lemma ofint1: ofint 1 = oner. - proof. by apply/mulr1z. qed. +lemma nosmt ofint0: ofint 0 = zeror. +proof. by apply/mulr0z. qed. - lemma ofintS (i : int): 0 <= i => ofint (i+1) = oner + ofint i. - proof. by apply/mulrS. qed. +lemma nosmt ofint1: ofint 1 = oner. +proof. by apply/mulr1z. qed. - lemma ofintN (i : int): ofint (-i) = - (ofint i). - proof. by apply/mulrNz. qed. +lemma nosmt ofintS (i : int): 0 <= i => ofint (i+1) = oner + ofint i. +proof. by apply/mulrS. qed. - lemma mul1r0z x: x * ofint 0 = zeror. - proof. by rewrite ofint0 mulr0. qed. +lemma nosmt ofintN (i : int): ofint (-i) = - (ofint i). +proof. by apply/mulrNz. qed. - lemma mul1r1z x : x * ofint 1 = x. - proof. by rewrite ofint1 mulr1. qed. +lemma nosmt mul1r0z x: x * ofint 0 = zeror. +proof. by rewrite ofint0 mulr0. qed. - lemma mul1r2z x : x * ofint 2 = x + x. - proof. by rewrite /ofint mulr2z mulrDr mulr1. qed. +lemma nosmt mul1r1z x : x * ofint 1 = x. +proof. by rewrite ofint1 mulr1. qed. - lemma mulr_intl x z : (ofint z) * x = intmul x z. - proof. by rewrite mulrzAl mul1r. qed. +lemma nosmt mul1r2z x : x * ofint 2 = x + x. +proof. by rewrite /ofint mulr2z mulrDr mulr1. qed. - lemma mulr_intr x z : x * (ofint z) = intmul x z. - proof. by rewrite mulrzAr mulr1. qed. +lemma nosmt mulr_intl x z : (ofint z) * x = intmul x z. +proof. by rewrite mulrzAl mul1r. qed. - op exp (x : t) (n : int) = - if n < 0 - then invr (iterop (-n) ComRing.( * ) x oner) - else iterop n ComRing.( * ) x oner. +lemma nosmt mulr_intr x z : x * (ofint z) = intmul x z. +proof. by rewrite mulrzAr mulr1. qed. - lemma expr0 x: exp x 0 = oner. - proof. by rewrite /exp /= iterop0. qed. +op exp (x : r) (n : int) = + if n < 0 + then invr (iterop (-n) ( * ) x oner) + else iterop n ( * ) x oner. - lemma expr1 x: exp x 1 = x. - proof. by rewrite /exp /= iterop1. qed. +lemma nosmt expr0 x: exp x 0 = oner. +proof. by rewrite /exp /= iterop0. qed. - lemma exprS (x : t) i: 0 <= i => exp x (i+1) = x * (exp x i). - proof. - move=> ge0i; rewrite /exp !ltzNge ge0i addz_ge0 //=. - by rewrite !MulMonoid.iteropE iterS. - qed. +lemma nosmt expr1 x: exp x 1 = x. +proof. by rewrite /exp /= iterop1. qed. - lemma expr_pred (x : t) i : 0 < i => exp x i = x * (exp x (i - 1)). - proof. smt(exprS). qed. +lemma nosmt exprS (x : r) i: 0 <= i => exp x (i+1) = x * (exp x i). +proof. +move=> ge0i; rewrite /exp !ltzNge ge0i addz_ge0 //=. +(* we want to use the multiplicative monoid instance here *) +(* by rewrite !Monoid.iteropE iterS. *) admit. +qed. - lemma exprSr (x : t) i: 0 <= i => exp x (i+1) = (exp x i) * x. - proof. by move=> ge0_i; rewrite exprS // mulrC. qed. +lemma nosmt expr_pred (x : r) i : 0 < i => exp x i = x * (exp x (i - 1)). +proof. smt(exprS). qed. - lemma expr2 x: exp x 2 = x * x. - proof. by rewrite (@exprS _ 1) // expr1. qed. +lemma nosmt exprSr (x : r) i: 0 <= i => exp x (i+1) = (exp x i) * x. +proof. by move=> ge0_i; rewrite exprS // mulrC. qed. - lemma exprN (x : t) (i : int): exp x (-i) = invr (exp x i). - proof. - case: (i = 0) => [->|]; first by rewrite oppz0 expr0 invr1. - rewrite /exp oppz_lt0 ltzNge lez_eqVlt oppzK=> -> /=. - by case: (_ < _)%Int => //=; rewrite invrK. - qed. +lemma nosmt expr2 x: exp x 2 = x * x. +proof. by rewrite (@exprS _ 1) // expr1. qed. - lemma exprN1 (x : t) : exp x (-1) = invr x. - proof. by rewrite exprN expr1. qed. +lemma nosmt exprN (x : r) (i : int): exp x (-i) = invr (exp x i). +proof. +case: (i = 0) => [->|]; first by rewrite oppz0 expr0 invr1. +rewrite /exp oppz_lt0 ltzNge lez_eqVlt oppzK=> -> /=. +by case: (_ < _)%Int => //=; rewrite invrK. +qed. - lemma unitrX x m : unit x => unit (exp x m). - proof. - move=> invx; wlog: m / (0 <= m) => [wlog|]. - + (have [] : (0 <= m \/ 0 <= -m) by move=> /#); first by apply: wlog. - by move=> ?; rewrite -oppzK exprN unitrV &(wlog). - elim: m => [|m ge0_m ih]; first by rewrite expr0 unitr1. - by rewrite exprS // &(unitrMl). - qed. +lemma nosmt exprN1 (x : r) : exp x (-1) = invr x. +proof. by rewrite exprN expr1. qed. - lemma unitrX_neq0 x m : m <> 0 => unit (exp x m) => unit x. - proof. - wlog: m / (0 < m) => [wlog|]. - + case: (0 < m); [by apply: wlog | rewrite ltzNge /= => le0_m nz_m]. - by move=> h; (apply: (wlog (-m)); 1,2:smt()); rewrite exprN unitrV. - by move=> gt0_m _; rewrite (_ : m = m - 1 + 1) // exprS 1:/# unitrM. - qed. +lemma nosmt unitrX x m : unit x => unit (exp x m). +proof. +move=> invx; wlog: m / (0 <= m) => [wlog|]. ++ (have [] : (0 <= m \/ 0 <= -m) by move=> /#); first by apply: wlog. + by move=> ?; rewrite -oppzK exprN unitrV &(wlog). +elim: m => [|m ge0_m ih]; first by rewrite expr0 unitr1. +by rewrite exprS // &(unitrMl). +qed. - lemma exprV (x : t) (i : int): exp (invr x) i = exp x (-i). - proof. - wlog: i / (0 <= i) => [wlog|]; first by smt(exprN). - elim: i => /= [|i ge0_i ih]; first by rewrite !expr0. - case: (i = 0) => [->|] /=; first by rewrite exprN1 expr1. - move=> nz_i; rewrite exprS // ih !exprN. - case: (unit x) => [invx|invNx]. - + by rewrite -invrM ?unitrX // exprS // mulrC. - rewrite !invr_out //; last by rewrite exprS. - + by apply: contra invNx; apply: unitrX_neq0 => /#. - + by apply: contra invNx; apply: unitrX_neq0 => /#. - qed. +lemma nosmt unitrX_neq0 x m : m <> 0 => unit (exp x m) => unit x. +proof. +wlog: m / (0 < m) => [wlog|]. ++ case: (0 < m); [by apply: wlog | rewrite ltzNge /= => le0_m nz_m]. + by move=> h; (apply: (wlog (-m)); 1,2:smt()); rewrite exprN unitrV. +by move=> gt0_m _; rewrite (_ : m = m - 1 + 1) // exprS 1:/# unitrM. +qed. - lemma exprVn (x : t) (n : int) : 0 <= n => exp (invr x) n = invr (exp x n). - proof. - elim: n => [|n ge0_n ih]; first by rewrite !expr0 invr1. - case: (unit x) => ux. - - by rewrite exprSr -1:exprS // invrM ?unitrX // ih -invrM // unitrX. - - by rewrite !invr_out //; apply: contra ux; apply: unitrX_neq0 => /#. - qed. +lemma nosmt exprV (x : r) (i : int): exp (invr x) i = exp x (-i). +proof. +wlog: i / (0 <= i) => [wlog|]; first by smt(exprN). +elim: i => /= [|i ge0_i ih]; first by rewrite !expr0. +case: (i = 0) => [->|] /=; first by rewrite exprN1 expr1. +move=> nz_i; rewrite exprS // ih !exprN. +case: (unit x) => [invx|invNx]. ++ by rewrite -invrM ?unitrX // exprS // mulrC. +rewrite !invr_out //; last by rewrite exprS. ++ by apply: contra invNx; apply: unitrX_neq0 => /#. ++ by apply: contra invNx; apply: unitrX_neq0 => /#. +qed. - lemma exprMn (x y : t) (n : int) : 0 <= n => exp (x * y) n = exp x n * exp y n. - proof. - elim: n => [|n ge0_n ih]; first by rewrite !expr0 mulr1. - by rewrite !exprS // mulrACA ih. - qed. +lemma nosmt exprVn (x : r) (n : int) : 0 <= n => exp (invr x) n = invr (exp x n). +proof. +elim: n => [|n ge0_n ih]; first by rewrite !expr0 invr1. +case: (unit x) => ux. +- by rewrite exprSr -1:exprS // invrM ?unitrX // ih -invrM // unitrX. +- by rewrite !invr_out //; apply: contra ux; apply: unitrX_neq0 => /#. +qed. - lemma exprD_nneg x (m n : int) : 0 <= m => 0 <= n => - exp x (m + n) = exp x m * exp x n. - proof. - move=> ge0_m ge0_n; elim: m ge0_m => [|m ge0_m ih]. - by rewrite expr0 mul1r. - by rewrite addzAC !exprS ?addz_ge0 // ih mulrA. - qed. +lemma nosmt exprMn (x y : r) (n : int) : 0 <= n => exp (x * y) n = exp x n * exp y n. +proof. +elim: n => [|n ge0_n ih]; first by rewrite !expr0 mulr1. +by rewrite !exprS // mulrACA ih. +qed. - lemma exprD x (m n : int) : unit x => exp x (m + n) = exp x m * exp x n. - proof. - wlog: m n x / (0 <= m + n) => [wlog invx|]. - + case: (0 <= m + n); [by move=> ?; apply: wlog | rewrite lezNgt /=]. - move=> lt0_mDn; rewrite -(@oppzK (m + n)) -exprV. - rewrite -{2}(@oppzK m) -{2}(@oppzK n) -!(@exprV _ (- _)%Int). - by rewrite -wlog 1:/# ?unitrV //#. - move=> ge0_mDn invx; wlog: m n ge0_mDn / (m <= n) => [wlog|le_mn]. - + by case: (m <= n); [apply: wlog | rewrite mulrC addzC /#]. - (have ge0_n: 0 <= n by move=> /#); elim: n ge0_n m le_mn ge0_mDn. - + by move=> n _ _ /=; rewrite expr0 mulr1. - move=> n ge0_n ih m le_m_Sn ge0_mDSn; move: ge0_mDSn. - rewrite lez_eqVlt => -[?|]; first have->: n+1 = -m by move=> /#. - + by rewrite subzz exprN expr0 divrr // unitrX. - move=> gt0_mDSn; move: le_m_Sn; rewrite lez_eqVlt. - case=> [->>|lt_m_Sn]; first by rewrite exprD_nneg //#. - by rewrite addzA exprS 1:/# ih 1,2:/# exprS // mulrCA. - qed. +lemma nosmt exprD_nneg x (m n : int) : 0 <= m => 0 <= n => + exp x (m + n) = exp x m * exp x n. +proof. + move=> ge0_m ge0_n; elim: m ge0_m => [|m ge0_m ih]. + by rewrite expr0 mul1r. + by rewrite addzAC !exprS ?addz_ge0 // ih mulrA. +qed. - lemma exprM x (m n : int) : - exp x (m * n) = exp (exp x m) n. - proof. - wlog : n / 0 <= n. - + move=> h; case: (0 <= n) => hn; 1: by apply h. - by rewrite -{1}(@oppzK n) (_: m * - -n = -(m * -n)) 1:/# - exprN h 1:/# exprN invrK. - wlog : m / 0 <= m. - + move=> h; case: (0 <= m) => hm hn; 1: by apply h. - rewrite -{1}(@oppzK m) (_: (- -m) * n = - (-m) * n) 1:/#. - by rewrite exprN h 1:/# // exprN exprV exprN invrK. - elim/natind: n => [|n hn ih hm _]; 1: smt (expr0). - by rewrite mulzDr exprS //= mulrC exprD_nneg 1:/# 1:// ih. - qed. +lemma nosmt exprD x (m n : int) : unit x => exp x (m + n) = exp x m * exp x n. +proof. +wlog: m n x / (0 <= m + n) => [wlog invx|]. ++ case: (0 <= m + n); [by move=> ?; apply: wlog | rewrite lezNgt /=]. + move=> lt0_mDn; rewrite -(@oppzK (m + n)) -exprV. + rewrite -{2}(@oppzK m) -{2}(@oppzK n) -!(@exprV _ (- _)%Int). + by rewrite -wlog 1:/# ?unitrV //#. +move=> ge0_mDn invx; wlog: m n ge0_mDn / (m <= n) => [wlog|le_mn]. ++ by case: (m <= n); [apply: wlog | rewrite mulrC addzC /#]. +(have ge0_n: 0 <= n by move=> /#); elim: n ge0_n m le_mn ge0_mDn. ++ by move=> n _ _ /=; rewrite expr0 mulr1. +move=> n ge0_n ih m le_m_Sn ge0_mDSn; move: ge0_mDSn. +rewrite lez_eqVlt => -[?|]; first have->: n+1 = -m by move=> /#. ++ by rewrite subzz exprN expr0 divrr // unitrX. +move=> gt0_mDSn; move: le_m_Sn; rewrite lez_eqVlt. +case=> [->>|lt_m_Sn]; first by rewrite exprD_nneg //#. +by rewrite addzA exprS 1:/# ih 1,2:/# exprS // mulrCA. +qed. - lemma expr0n n : 0 <= n => exp zeror n = if n = 0 then oner else zeror. - proof. - elim: n => [|n ge0_n _]; first by rewrite expr0. - by rewrite exprS // mul0r addz1_neq0. - qed. +lemma nosmt exprM x (m n : int) : + exp x (m * n) = exp (exp x m) n. +proof. +wlog : n / 0 <= n. ++ move=> h; case: (0 <= n) => hn; 1: by apply h. + by rewrite -{1}(@oppzK n) (_: m * - -n = -(m * -n)) 1:/# + exprN h 1:/# exprN invrK. +wlog : m / 0 <= m. ++ move=> h; case: (0 <= m) => hm hn; 1: by apply h. + rewrite -{1}(@oppzK m) (_: (- -m) * n = - (-m) * n) 1:/#. + by rewrite exprN h 1:/# // exprN exprV exprN invrK. +elim/natind: n => [|n hn ih hm _]; 1: smt (expr0). +by rewrite mulzDr exprS //= mulrC exprD_nneg 1:/# 1:// ih. +qed. - lemma expr0z z : exp zeror z = if z = 0 then oner else zeror. - proof. - case: (0 <= z) => [/expr0n // | /ltzNge lt0_z]. - rewrite -{1}(@oppzK z) exprN; have ->/=: z <> 0 by smt(). - rewrite invr_eq0 expr0n ?oppz_ge0 1:ltzW //. - by have ->/=: -z <> 0 by smt(). - qed. +lemma nosmt expr0n n : 0 <= n => exp zeror n = if n = 0 then oner else zeror. +proof. +elim: n => [|n ge0_n _]; first by rewrite expr0. +by rewrite exprS // mul0r addz1_neq0. +qed. - lemma expr1z z : exp oner z = oner. - proof. - elim/intwlog: z. - + by move=> n h; rewrite -(@oppzK n) exprN h invr1. - + by rewrite expr0. - + by move=> n ge0_n ih; rewrite exprS // mul1r ih. - qed. +lemma nosmt expr0z z : exp zeror z = if z = 0 then oner else zeror. +proof. +case: (0 <= z) => [/expr0n // | /ltzNge lt0_z]. +rewrite -{1}(@oppzK z) exprN; have ->/=: z <> 0 by smt(). +by rewrite invr_eq0 expr0n ?oppz_ge0 1:ltzW. +qed. - lemma sqrrD x y : - exp (x + y) 2 = exp x 2 + intmul (x * y) 2 + exp y 2. - proof. - by rewrite !expr2 mulrDl !mulrDr mulr2z !addrA (@mulrC y x). - qed. +lemma nosmt expr1z z : exp oner z = oner. +proof. +elim/intwlog: z. ++ by move=> n h; rewrite -(@oppzK n) exprN h invr1. ++ by rewrite expr0. ++ by move=> n ge0_n ih; rewrite exprS // mul1r ih. +qed. - lemma sqrrN x : exp (-x) 2 = exp x 2. - proof. by rewrite !expr2 mulrNN. qed. +lemma nosmt sqrrD (x y : r) : + exp (x + y) 2 = exp x 2 + intmul (x * y) 2 + exp y 2. +proof. +by rewrite !expr2 mulrDl !mulrDr mulr2z !addrA (@mulrC y x). +qed. - lemma sqrrB x y : - exp (x - y) 2 = exp x 2 - intmul (x * y) 2 + exp y 2. - proof. by rewrite sqrrD sqrrN mulrN mulNrz. qed. +lemma nosmt sqrrN x : exp (-x) 2 = exp x 2. +proof. by rewrite !expr2 mulrNN. qed. - lemma signr_odd n : 0 <= n => exp (-oner) (b2i (odd n)) = exp (-oner) n. - proof. - elim: n => [|n ge0_nih]; first by rewrite odd0 expr0 expr0. - rewrite !(iterS, oddS) // exprS // -/(odd _) => <-. - by case: (odd _); rewrite /b2i /= !(expr0, expr1) mulN1r ?opprK. - qed. +lemma nosmt sqrrB x y : + exp (x - y) 2 = exp x 2 - intmul (x * y) 2 + exp y 2. +proof. by rewrite sqrrD sqrrN mulrN mulNrz. qed. - lemma subr_sqr_1 x : exp x 2 - oner = (x - oner) * (x + oner). - proof. - rewrite mulrBl mulrDr !(mulr1, mul1r) expr2 -addrA. - by congr; rewrite opprD addrA addrN add0r. - qed. +lemma nosmt signr_odd n : 0 <= n => exp (-oner) (b2i (odd n)) = exp (-oner) n. +proof. +elim: n => [|n ge0_nih]; first by rewrite odd0 expr0 expr0. +rewrite !(iterS, oddS) // exprS // -/(odd _) => <-. +by case: (odd _); rewrite /b2i /= !(expr0, expr1) mulN1r ?opprK. +qed. - op lreg (x : t) = injective (fun y => x * y). +lemma nosmt subr_sqr_1 x : exp x 2 - oner = (x - oner) * (x + oner). +proof. +rewrite mulrBl mulrDr !(mulr1, mul1r) expr2 -addrA. +by congr; rewrite opprD addrA addrN add0r. +qed. - lemma mulrI_eq0 x y : lreg x => (x * y = zeror) <=> (y = zeror). - proof. by move=> reg_x; rewrite -{1}(mulr0 x) (inj_eq reg_x). qed. +op lreg (x : r) = injective (fun y => x * y). - lemma lreg_neq0 x : lreg x => x <> zeror. - proof. - apply/contraL=> ->; apply/negP => /(_ zeror oner). - by rewrite (@eq_sym _ oner) oner_neq0 /= !mul0r. - qed. +lemma nosmt mulrI_eq0 x y : lreg x => (x * y = zeror) <=> (y = zeror). +proof. by move=> reg_x; rewrite -{1}(mulr0 x) (inj_eq reg_x). qed. - lemma mulrI0_lreg x : (forall y, x * y = zeror => y = zeror) => lreg x. - proof. - by move=> reg_x y z eq; rewrite -subr_eq0 &(reg_x) mulrBr eq subrr. - qed. +lemma nosmt lreg_neq0 x : lreg x => x <> zeror. +proof. +apply/contraL=> ->; apply/negP => /(_ zeror oner). +by rewrite (@eq_sym _ oner) oner_neq0 /= !mul0r. +qed. - lemma lregN x : lreg x => lreg (-x). - proof. by move=> reg_x y z; rewrite !mulNr => /oppr_inj /reg_x. qed. +lemma nosmt mulrI0_lreg x : (forall y, x * y = zeror => y = zeror) => lreg x. +proof. +by move=> reg_x y z eq; rewrite -subr_eq0 &(reg_x) mulrBr eq subrr. +qed. - lemma lreg1 : lreg oner. - proof. by move=> x y; rewrite !mul1r. qed. +lemma nosmt lregN x : lreg x => lreg (-x). +proof. by move=> reg_x y z; rewrite !mulNr => /oppr_inj /reg_x. qed. +lemma nosmt lreg1 : lreg oner. +proof. by move=> x y; rewrite !mul1r. qed. - lemma lregM x y : lreg x => lreg y => lreg (x * y). - proof. by move=> reg_x reg_y z t; rewrite -!mulrA => /reg_x /reg_y. qed. +lemma nosmt lregM x y : lreg x => lreg y => lreg (x * y). +proof. by move=> reg_x reg_y z t; rewrite -!mulrA => /reg_x /reg_y. qed. - lemma lregXn x n : 0 <= n => lreg x => lreg (exp x n). - proof. - move=> + reg_x; elim: n => [|n ge0_n ih]. - - by rewrite expr0 &(lreg1). - - by rewrite exprS // &(lregM). - qed. -end ComRing. +lemma nosmt lregXn x n : 0 <= n => lreg x => lreg (exp x n). +proof. +move=> + reg_x; elim: n => [|n ge0_n ih]. +- by rewrite expr0 &(lreg1). +- by rewrite exprS // &(lregM). +qed. +end section. +(* (* -------------------------------------------------------------------- *) abstract theory ComRingDflInv. clone include ComRing with @@ -672,138 +665,124 @@ abstract theory ComRingDflInv. by move=> x; rewrite /unit_ negb_exists => /choiceb_dfl /(_ x). qed. end ComRingDflInv. +*) (* -------------------------------------------------------------------- *) -abstract theory BoolRing. - clone include ComRing. - - axiom mulrr : forall (x : t), x * x = x. +type class boolring <: comring = { + axiom mulrr : forall (x : boolring), x * x = x +}. - lemma nosmt addrr (x : t): x + x = zeror. - proof. - apply (@addrI (x + x)); rewrite addr0 -{1 2 3 4}mulrr. - by rewrite -mulrDr -mulrDl mulrr. - qed. -end BoolRing. +lemma nosmt addrr ['a <: boolring] (x : 'a): x + x = zeror. +proof. +apply (@addrI (x + x)); rewrite addr0 -{1 2 3 4}mulrr. +by rewrite -mulrDr -mulrDl mulrr. +qed. (* -------------------------------------------------------------------- *) -abstract theory IDomain. - clone include ComRing. - +type class idomain <: comring = { axiom mulf_eq0: - forall (x y : t), x * y = zeror <=> x = zeror \/ y = zeror. + forall (x y : idomain), x * y = zeror <=> x = zeror \/ y = zeror +}. - lemma mulf_neq0 (x y : t): x <> zeror => y <> zeror => x * y <> zeror. - proof. by move=> nz_x nz_y; apply/negP; rewrite mulf_eq0 /#. qed. +section. +declare type r <: idomain. - lemma expf_eq0 x n : (exp x n = zeror) <=> (n <> 0 /\ x = zeror). - proof. - elim/intwlog: n => [n| |n ge0_n ih]. - + by rewrite exprN invr_eq0 /#. - + by rewrite expr0 oner_neq0. - by rewrite exprS // mulf_eq0 ih addz1_neq0 ?andKb. - qed. +lemma nosmt mulf_neq0 (x y : r): x <> zeror => y <> zeror => x * y <> zeror. +proof. by move=> nz_x nz_y; apply/negP; rewrite mulf_eq0 /#. qed. - lemma mulfI (x : t): x <> zeror => injective (( * ) x). - proof. - move=> ne0_x y y'; rewrite -(opprK (x * y')) -mulrN -addr_eq0. - by rewrite -mulrDr mulf_eq0 ne0_x /= addr_eq0 opprK. - qed. +lemma nosmt expf_eq0 (x : r) n : (exp x n = zeror) <=> (n <> 0 /\ x = zeror). +proof. +elim/intwlog: n => [n| |n ge0_n ih]. ++ by rewrite exprN invr_eq0 /#. ++ by rewrite expr0 oner_neq0. +by rewrite exprS // mulf_eq0 ih addz1_neq0 ?andKb. +qed. - lemma mulIf x: x <> zeror => injective (fun y => y * x). - proof. by move=> nz_x y z; rewrite -!(@mulrC x); exact: mulfI. qed. +lemma nosmt mulfI (x : r): x <> zeror => injective (( * ) x). +proof. +move=> ne0_x y y'; rewrite -(opprK (x * y')) -mulrN -addr_eq0. +by rewrite -mulrDr mulf_eq0 ne0_x /= addr_eq0 opprK. +qed. - lemma sqrf_eq1 x : (exp x 2 = oner) <=> (x = oner \/ x = -oner). - proof. by rewrite -subr_eq0 subr_sqr_1 mulf_eq0 subr_eq0 addr_eq0. qed. +lemma nosmt mulIf (x : r): x <> zeror => injective (fun y => y * x). +proof. by move=> nz_x y z; rewrite -!(@mulrC x); exact: mulfI. qed. - lemma lregP x : lreg x <=> x <> zeror. - proof. by split=> [/lreg_neq0//|/mulfI]. qed. +lemma nosmt sqrf_eq1 (x : r): (exp x 2 = oner) <=> (x = oner \/ x = -oner). +proof. by rewrite -subr_eq0 subr_sqr_1 mulf_eq0 subr_eq0 addr_eq0. qed. - lemma eqr_div (x1 y1 x2 y2 : t) : unit y1 => unit y2 => - (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). - proof. - move=> Nut1 Nut2; rewrite -{1}(@mulrK y2 _ x1) //. - rewrite -{1}(@mulrK y1 _ x2) // -!mulrA (@mulrC (invr y1)) !mulrA. - split=> [|->] //; - (have nz_Vy1: unit (invr y1) by rewrite unitrV); - (have nz_Vy2: unit (invr y2) by rewrite unitrV). - by move/(mulIr _ nz_Vy1)/(mulIr _ nz_Vy2). - qed. +lemma nosmt lregP (x : r): lreg x <=> x <> zeror. +proof. by split=> [/lreg_neq0//|/mulfI]. qed. -end IDomain. +lemma nosmt eqr_div (x1 y1 x2 y2 : r) : unit y1 => unit y2 => + (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). +proof. +move=> Nut1 Nut2; rewrite -{1}(@mulrK y2 _ x1) //. +rewrite -{1}(@mulrK y1 _ x2) // -!mulrA (@mulrC (invr y1)) !mulrA. +split=> [|->] //; + (have nz_Vy1: unit (invr y1) by rewrite unitrV); + (have nz_Vy2: unit (invr y2) by rewrite unitrV). +by move/(mulIr _ nz_Vy1)/(mulIr _ nz_Vy2). +qed. +end section. (* -------------------------------------------------------------------- *) -abstract theory Field. - clone include IDomain with pred unit (x : t) <- x <> zeror. - - lemma mulfV (x : t): x <> zeror => x * (invr x) = oner. - proof. by apply/mulrV. qed. - - lemma mulVf (x : t): x <> zeror => (invr x) * x = oner. - proof. by apply/mulVr. qed. - - lemma nosmt divff (x : t): x <> zeror => x / x = oner. - proof. by apply/divrr. qed. - - lemma nosmt invfM (x y : t) : invr (x * y) = invr x * invr y. - proof. - case: (x = zeror) => [->|nz_x]; first by rewrite !(mul0r, invr0). - case: (y = zeror) => [->|nz_y]; first by rewrite !(mulr0, invr0). - by rewrite invrM // mulrC. - qed. - - lemma invf_div x y : invr (x / y) = y / x. - proof. by rewrite invfM invrK mulrC. qed. - - lemma eqf_div (x1 y1 x2 y2 : t) : y1 <> zeror => y2 <> zeror => - (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). - proof. by apply: eqr_div. qed. - - lemma expfM x y n : exp (x * y) n = exp x n * exp y n. - proof. - elim/intwlog: n => [n h | | n ge0_n ih]. - + by rewrite -(@oppzK n) !(@exprN _ (-n)) h invfM. - + by rewrite !expr0 mulr1. - + by rewrite !exprS // mulrCA -!mulrA -ih mulrCA. - qed. -end Field. - -(* --------------------------------------------------------------------- *) -abstract theory Additive. - type t1, t2. - - clone import Self.ZModule as ZM1 with type t <- t1. - clone import Self.ZModule as ZM2 with type t <- t2. - - pred additive (f : t1 -> t2) = - forall (x y : t1), f (x - y) = f x - f y. - - op f : { t1 -> t2 | additive f } as f_is_additive. - - lemma raddf0: f ZM1.zeror = ZM2.zeror. - proof. by rewrite -ZM1.subr0 f_is_additive ZM2.subrr. qed. - - lemma raddfB (x y : t1): f (x - y) = f x - f y. - proof. by apply/f_is_additive. qed. - - lemma raddfN (x : t1): f (- x) = - (f x). - proof. by rewrite -ZM1.sub0r raddfB raddf0 ZM2.sub0r. qed. - - lemma raddfD (x y : t1): f (x + y) = f x + f y. - proof. by rewrite -{1}(@ZM1.opprK y) raddfB raddfN ZM2.opprK. qed. -end Additive. +(* +(* TODO: Disjointness of type class operator names? *) +type class ffield <: group = { + op onef : ffield + op ( * ) : ffield -> ffield -> ffield + op invf : ffield -> ffield + + axiom onef_neq0 : onef <> zeror + axiom mulfA : associative ( * ) + axiom mulfC : commutative ( * ) + axiom mul1f : left_id onef ( * ) + axiom mulfDl : left_distributive ( * ) (+)<:ffield> + axiom mulVf : left_inverse_in (predC (pred1 zeror)) onef invf ( * ) + axiom unitP : forall (x y : ffield), y * x = onef => x <> zeror + axiom unitout : invr zeror = zeror +}. +*) + +(* TODO: Probably not the right way *) +type class ffield <: comring = { + axiom unit_neq0: forall (x : ffield), unit x <=> x <> zeror +}. + +section. +declare type f <: ffield. + +lemma nosmt mulfV (x : f): x <> zeror => x * (invr x) = oner. +proof. by move=> /unit_neq0/mulrV. qed. + +lemma nosmt mulVf (x : f): x <> zeror => (invr x) * x = oner. +proof. by move=> /unit_neq0/mulVr. qed. + +lemma nosmt divff (x : f): x <> zeror => x / x = oner. +proof. by move=> /unit_neq0/divrr. qed. + +lemma nosmt invfM (x y : f) : invr (x * y) = invr x * invr y. +proof. +case: (x = zeror) => [->|nz_x]; first by rewrite !(mul0r, invr0). +case: (y = zeror) => [->|nz_y]; first by rewrite !(mulr0, invr0). +by rewrite invrM ?unit_neq0 // mulrC. +qed. -(* --------------------------------------------------------------------- *) -abstract theory Multiplicative. - type t1, t2. +lemma nosmt invf_div (x y : f) : invr (x / y) = y / x. +proof. by rewrite invfM invrK mulrC. qed. - clone import Self.ComRing as ZM1 with type t <- t1. - clone import Self.ComRing as ZM2 with type t <- t2. +lemma nosmt eqf_div (x1 y1 x2 y2 : f) : y1 <> zeror => y2 <> zeror => + (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). +proof. by rewrite -!unit_neq0; exact: eqr_div<:f>. qed. - pred multiplicative (f : t1 -> t2) = - f ZM1.oner = ZM2.oner - /\ forall (x y : t1), f (x * y) = f x * f y. -end Multiplicative. +lemma nosmt expfM (x y : f) n : exp (x * y) n = exp x n * exp y n. +proof. +elim/intwlog: n => [n h | | n ge0_n ih]. ++ by rewrite -(@oppzK n) !(@exprN _ (-n)) h invfM. ++ by rewrite !expr0 mulr1. ++ by rewrite !exprS // mulrCA -!mulrA -ih mulrCA. +qed. +end section. (* --------------------------------------------------------------------- *) (* Rewrite database for algebra tactic *) @@ -812,6 +791,30 @@ hint rewrite rw_algebra : . hint rewrite inj_algebra : . (* -------------------------------------------------------------------- *) +(* TODO: Instantiation of type classes with inheritance is broken *) +(* TODO: Instantiation of type class operators with literals is broken *) +op zeroz = 0. +op addz (x y : int) = x + y. +op negz (x : int) = -x. + + +instance monoid with int + op idm = zeroz + op (+) = addz. +realize addmA by exact: addzA. +realize addmC by exact: addzC. +realize add0m by exact: add0z. + +(* TODO: This is just broken *) +instance group with int + (* op idm = zeroz *) + op [-] = negz. +realize addNr. +(* TODO: Note that the zero remains undefined *) +rewrite /left_inverse /negz /idm. +(* by exact: addNz. *) admit. + +(* theory IntID. clone include IDomain with type t <- int, @@ -851,3 +854,4 @@ rewrite lez_eqVlt; case: (n = 0) => [->// _|+ h]. + by case: h => [<-//|] /poddX ->. qed. end IntID. +*) From 5f6d5798ff1fb78b0b7f0dfcc33fdc5981780499 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 3 May 2024 17:17:19 +0200 Subject: [PATCH 057/113] [subst]: fix name capture --- src/ecCoreSubst.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index 7ad76d3ae6..e12ad5a7cc 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -197,6 +197,7 @@ let refresh (s : f_subst) (x : ident) : ident = let add_elocal (s : f_subst) ((x, t) as xt : ebinding) : f_subst * ebinding = let x' = refresh s x in let t' = ty_subst s t in + let s = f_rem_local s x in if x == x' && t == t' then (s, xt) else (bind_elocal s x (e_local x' t'), (x', t')) @@ -363,6 +364,7 @@ module Fsubst = struct let add_local (s : f_subst) ((x, t) as xt : ebinding) : f_subst * ebinding = let x' = refresh s x in let t' = ty_subst s t in + let s = f_rem_local s x in if x == x' && t == t' then (s, xt) else (f_bind_rename s x x' t', (x', t')) From 89aaa445efdfa9a19aba95d8e91461f4b6b2c7e2 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sat, 18 May 2024 00:37:31 +0200 Subject: [PATCH 058/113] TC Refactoring. Add TC instance witness in operators / types. All stdlib / examples compile (with the exception of TC examples) TC mechanism is currently disconnected. --- src/ecAst.ml | 136 ++++++-- src/ecAst.mli | 22 +- src/ecCallbyValue.ml | 12 +- src/ecCoreEqTest.ml | 26 +- src/ecCoreFol.ml | 157 ++++------ src/ecCoreFol.mli | 3 +- src/ecCoreGoal.ml | 2 +- src/ecCoreGoal.mli | 6 +- src/ecCoreSubst.ml | 291 +++++++++++------- src/ecCoreSubst.mli | 38 +-- src/ecDecl.ml | 43 +-- src/ecDecl.mli | 15 +- src/ecEnv.ml | 201 ++++++------ src/ecEnv.mli | 36 ++- src/ecFol.ml | 3 +- src/ecHiGoal.ml | 17 +- src/ecHiInductive.ml | 6 +- src/ecHiPredicates.ml | 5 +- src/ecInductive.ml | 18 +- src/ecLowGoal.ml | 20 +- src/ecLowGoal.mli | 4 +- src/ecMatching.mli | 2 +- src/ecPV.ml | 16 +- src/ecPrinting.ml | 74 +++-- src/ecProcSem.ml | 2 +- src/ecProofTerm.ml | 46 +-- src/ecProofTerm.mli | 17 +- src/ecProofTyping.ml | 2 +- src/ecReduction.ml | 88 ++++-- src/ecReduction.mli | 2 +- src/ecScope.ml | 212 ++++++------- src/ecSection.ml | 90 +++--- src/ecSmt.ml | 4 +- src/ecSubst.ml | 475 ++++++++++++++++------------ src/ecSubst.mli | 28 +- src/ecTheory.ml | 13 +- src/ecTheory.mli | 13 +- src/ecTheoryReplay.ml | 62 ++-- src/ecTypes.ml | 192 ++++++------ src/ecTypes.mli | 34 +- src/ecTyping.ml | 112 +++---- src/ecTyping.mli | 4 +- src/ecUnify.ml | 684 +++++++++++++++++------------------------ src/ecUnify.mli | 41 ++- src/ecUserMessages.ml | 2 +- src/ecUtils.ml | 11 + src/ecUtils.mli | 1 + src/phl/ecPhlCond.ml | 12 +- src/phl/ecPhlEqobs.ml | 2 +- src/phl/ecPhlInline.ml | 2 +- src/phl/ecPhlRCond.ml | 6 +- 51 files changed, 1768 insertions(+), 1542 deletions(-) diff --git a/src/ecAst.ml b/src/ecAst.ml index 49ddd597e0..e209e25732 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -61,9 +61,27 @@ and ty_node = | Tunivar of EcUid.uid | Tvar of EcIdent.t | Ttuple of ty list - | Tconstr of EcPath.path * ty list + | Tconstr of EcPath.path * etyarg list | Tfun of ty * ty +(* -------------------------------------------------------------------- *) +and etyarg = ty * tcwitness list + +and tcwitness = + | TCIConcrete of { + path: EcPath.path; + etyargs: (ty * tcwitness list) list; + } + + | TCIAbstract of { + support: [ + | `Var of EcIdent.t + | `Univar of EcUid.uid + | `Abs of EcPath.path + ]; + offset: int; + } + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; @@ -100,10 +118,8 @@ and expr_node = | Ematch of expr * expr list * ty (* match _ with _ *) | Eproj of expr * int (* projection of a tuple *) -and etyarg = ty * tcwitness list and ebinding = EcIdent.t * ty and ebindings = ebinding list -and tcwitness = (ty * tcwitness list) list * EcPath.path (* -------------------------------------------------------------------- *) and lvalue = @@ -365,10 +381,15 @@ let lp_fv = function Sid.empty ids (* -------------------------------------------------------------------- *) -let rec tcw_fv ((ws, _) : tcwitness) = - List.fold_left - (fun fv (ty, tcws) -> fv_union fv (fv_union ty.ty_fv (tcws_fv tcws))) - Mid.empty ws +let rec tcw_fv (tcw : tcwitness) = + match tcw with + | TCIConcrete { etyargs } -> + List.fold_left + (fun fv (ty, tcws) -> fv_union fv (fv_union ty.ty_fv (tcws_fv tcws))) + Mid.empty etyargs + + | TCIAbstract _ -> + Mid.empty (* FIXME:TC *) and tcws_fv (tcws : tcwitness list) = List.fold_left @@ -384,18 +405,53 @@ let etyargs_fv (tyargs : etyarg list) = Mid.empty tyargs (* -------------------------------------------------------------------- *) -let rec tcw_equal ((tcw1, p1) : tcwitness) ((tcw2, p2) : tcwitness) = - EcPath.p_equal p1 p2 && List.all2 etyarg_equal tcw1 tcw2 +let rec tcw_equal (tcw1 : tcwitness) (tcw2 : tcwitness) = + match tcw1, tcw2 with + | TCIConcrete tcw1, TCIConcrete tcw2 -> + EcPath.p_equal tcw1.path tcw2.path + && List.all2 etyarg_equal tcw1.etyargs tcw2.etyargs + + | TCIAbstract { support = support1; offset = o1; } + , TCIAbstract { support = support2; offset = o2; } + -> + let tyvar_eq () = + match support1, support2 with + | `Var x1, `Var x2 -> + EcIdent.id_equal x1 x2 + | `Univar u1, `Univar u2 -> + uid_equal u1 u2 + | `Abs p1, `Abs p2 -> + EcPath.p_equal p1 p2 + | _, _ -> false + + in o1 = o2 && tyvar_eq () + + | _, _ -> + false and etyarg_equal ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = ty_equal ty1 ty2 && List.all2 tcw_equal tcws1 tcws2 (* -------------------------------------------------------------------- *) -let rec tcw_hash ((tcw, p) : tcwitness) = - Why3.Hashcons.combine_list etyarg_hash (p_hash p) tcw - -and etyarg_hash ((ty, tcws) : etyarg) = - Why3.Hashcons.combine_list tcw_hash (ty_hash ty) tcws +let rec tcw_hash (tcw : tcwitness) = + match tcw with + | TCIConcrete tcw -> + Why3.Hashcons.combine_list + etyarg_hash + (p_hash tcw.path) + tcw.etyargs + + | TCIAbstract { support = `Var tyvar; offset } -> + Why3.Hashcons.combine (EcIdent.id_hash tyvar) offset + + | TCIAbstract { support = `Univar uni; offset } -> + Why3.Hashcons.combine (Hashtbl.hash uni) offset + + | TCIAbstract { support = `Abs p; offset } -> + Why3.Hashcons.combine (EcPath.p_hash p) offset + + and etyarg_hash ((ty, tcws) : etyarg) = + Why3.Hashcons.combine_list tcw_hash (ty_hash ty) tcws (* -------------------------------------------------------------------- *) let e_equal = ((==) : expr -> expr -> bool) @@ -448,7 +504,6 @@ let s_equal = ((==) : stmt -> stmt -> bool) let s_hash = fun s -> s.s_tag let s_fv = fun s -> s.s_fv - (*-------------------------------------------------------------------- *) let qt_equal : quantif -> quantif -> bool = (==) let qt_hash : quantif -> int = Hashtbl.hash @@ -836,7 +891,7 @@ module Hsty = Why3.Hashcons.Make (struct List.all2 ty_equal lt1 lt2 | Tconstr (p1, lt1), Tconstr (p2, lt2) -> - EcPath.p_equal p1 p2 && List.all2 ty_equal lt1 lt2 + EcPath.p_equal p1 p2 && List.all2 etyarg_equal lt1 lt2 | Tfun (d1, c1), Tfun (d2, c2)-> ty_equal d1 d2 && ty_equal c1 c2 @@ -849,7 +904,7 @@ module Hsty = Why3.Hashcons.Make (struct | Tunivar u -> u | Tvar id -> EcIdent.tag id | Ttuple tl -> Why3.Hashcons.combine_list ty_hash 0 tl - | Tconstr (p, tl) -> Why3.Hashcons.combine_list ty_hash p.p_tag tl + | Tconstr (p, tl) -> Why3.Hashcons.combine_list etyarg_hash p.p_tag tl | Tfun (t1, t2) -> Why3.Hashcons.combine (ty_hash t1) (ty_hash t2) let fv ty = @@ -861,7 +916,7 @@ module Hsty = Why3.Hashcons.Make (struct | Tunivar _ -> Mid.empty | Tvar _ -> Mid.empty (* FIXME: section *) | Ttuple tys -> union (fun a -> a.ty_fv) tys - | Tconstr (_, tys) -> union (fun a -> a.ty_fv) tys + | Tconstr (_, tys) -> union etyarg_fv tys | Tfun (t1, t2) -> union (fun a -> a.ty_fv) [t1; t2] let tag n ty = { ty with ty_tag = n; ty_fv = fv ty.ty_node; } @@ -982,7 +1037,27 @@ module Hexpr = Why3.Hashcons.Make (struct end) (* -------------------------------------------------------------------- *) -let mk_expr e ty = +let normalize_enode (node : expr_node) : expr_node = + match node with + | Equant (_, [], body) -> + body.e_node + + | Equant (q1, bds1, { e_node = Equant (q2, bds2, body) }) + when q1 = q2 + -> Equant (q1, bds1 @ bds2, body) + + | Eapp (hd, []) -> + hd.e_node + + | Eapp ({ e_node = Eapp (hd, args1) }, args2) -> + Eapp (hd, args1 @ args2) + + | _ -> + node + +(* -------------------------------------------------------------------- *) +let mk_expr (e : expr_node) (ty : ty) = + let e = normalize_enode e in Hexpr.hashcons { e_node = e; e_tag = -1; e_fv = Mid.empty; e_ty = ty } (* -------------------------------------------------------------------- *) @@ -1184,7 +1259,28 @@ module Hsform = Why3.Hashcons.Make (struct { f with f_tag = n; f_fv = fv; } end) -let mk_form node ty = +(* -------------------------------------------------------------------- *) +let normalize_fnode (node : f_node) : f_node = + match node with + | Fquant (_, [], body) -> + body.f_node + + | Fquant (q1, bds1, { f_node = Fquant (q2, bds2, body) }) + when q1 = q2 + -> Fquant (q1, bds1 @ bds2, body) + + | Fapp (hd, []) -> + hd.f_node + + | Fapp ({ f_node = Fapp (hd, args1)}, args2) -> + Fapp (hd, args1 @ args2) + + | _ -> + node + +(* -------------------------------------------------------------------- *) +let mk_form (node : f_node) (ty : ty) = + let node = normalize_fnode (node) in let aout = Hsform.hashcons { f_node = node; diff --git a/src/ecAst.mli b/src/ecAst.mli index 950493ff0d..aea1579329 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -49,9 +49,27 @@ and ty_node = | Tunivar of EcUid.uid | Tvar of EcIdent.t | Ttuple of ty list - | Tconstr of EcPath.path * ty list + | Tconstr of EcPath.path * etyarg list | Tfun of ty * ty +(* -------------------------------------------------------------------- *) +and etyarg = ty * tcwitness list + +and tcwitness = + | TCIConcrete of { + path: EcPath.path; + etyargs: (ty * tcwitness list) list; + } + + | TCIAbstract of { + support: [ + | `Var of EcIdent.t + | `Univar of EcUid.uid + | `Abs of EcPath.path + ]; + offset: int; + } + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; @@ -88,10 +106,8 @@ and expr_node = | Ematch of expr * expr list * ty (* match _ with _ *) | Eproj of expr * int (* projection of a tuple *) -and etyarg = ty * tcwitness list and ebinding = EcIdent.t * ty and ebindings = ebinding list -and tcwitness = (ty * tcwitness list) list * EcPath.path (* -------------------------------------------------------------------- *) and lvalue = diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index 51d33a0162..172fdfe479 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -295,9 +295,10 @@ and app_red st f1 args = let body = EcFol.form_of_expr EcFol.mhr body in let body = - Tvar.f_subst ~freshen:true - (List.map fst op.EcDecl.op_tparams) - (List.fst tys) (* FIXME:TC *) body in + Tvar.f_subst + ~freshen:true + (List.combine (List.fst op.EcDecl.op_tparams) tys) + body in cbv st subst body (Args.create ty eargs) with E.NoCtor -> @@ -324,10 +325,7 @@ and reduce_user_delta st f1 p tys args = cbv st Subst.subst_id f args | _ -> if st.st_ri.delta_tc then - match EcReduction.reduce_tc - ~params:(LDecl.tohyps st.st_hyps).h_tvar - st.st_env p (List.fst tys) (* FIXME: TC *) - with + match EcReduction.reduce_tc st.st_env p tys with | None -> f2 | Some f -> cbv st Subst.subst_id f args else f2 diff --git a/src/ecCoreEqTest.ml b/src/ecCoreEqTest.ml index 4cd0b3b364..04f5939642 100644 --- a/src/ecCoreEqTest.ml +++ b/src/ecCoreEqTest.ml @@ -37,7 +37,7 @@ and for_type_r env t1 t2 = | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> if List.length lt1 = List.length lt2 - && List.all2 (for_type env) lt1 lt2 + && List.all2 (for_etyarg env) lt1 lt2 then true else if Ty.defined p1 env @@ -53,16 +53,34 @@ and for_type_r env t1 t2 = | _, _ -> false (* -------------------------------------------------------------------- *) -let rec for_etyarg env ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = +and for_etyarg env ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = for_type env ty1 ty2 && for_tcws env tcws1 tcws2 and for_etyargs env (tyargs1 : etyarg list) (tyargs2 : etyarg list) = List.length tyargs1 = List.length tyargs2 && List.for_all2 (for_etyarg env) tyargs1 tyargs2 -and for_tcw env ((tyargs1, p1) : tcwitness) ((tyargs2, p2) : tcwitness) = - EcPath.p_equal p1 p2 && for_etyargs env tyargs1 tyargs2 +and for_tcw env (tcw1 : tcwitness) (tcw2 : tcwitness) = + match tcw1, tcw2 with + | TCIConcrete tcw1, TCIConcrete tcw2 -> + EcPath.p_equal tcw1.path tcw2.path + && for_etyargs env tcw1.etyargs tcw2.etyargs + | TCIAbstract { support = `Var v1; offset = o1 }, + TCIAbstract { support = `Var v2; offset = o2 } -> + EcIdent.id_equal v1 v2 && o1 = o2 + + | TCIAbstract { support = `Univar v1; offset = o1 }, + TCIAbstract { support = `Univar v2; offset = o2 } -> + EcUid.uid_equal v1 v2 && o1 = o2 + + | TCIAbstract { support = `Abs p1; offset = o1 }, + TCIAbstract { support = `Abs p2; offset = o2 } -> + EcPath.p_equal p1 p2 && o1 = o2 + + | _, _ -> + false + and for_tcws env (tcws1 : tcwitness list) (tcws2 : tcwitness list) = List.length tcws1 = List.length tcws2 && List.for_all2 (for_tcw env) tcws1 tcws2 diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index d6792c5ee1..2aa34d00c5 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -156,15 +156,7 @@ let f_op x tyargs ty = f_op_tc x (List.map (fun ty -> (ty, [])) tyargs) ty let f_app f args ty = - let f, args' = - match f.f_node with - | Fapp (f, args') -> (f, args') - | _ -> (f, []) - in let args' = args' @ args in - - if List.is_empty args' then begin - (*if ty_equal ty f.f_ty then f else mk_form f.f_node ty *) f - end else mk_form (Fapp (f, args')) ty + mk_form (Fapp (f, args)) ty (* -------------------------------------------------------------------- *) let f_local x ty = mk_form (Flocal x) ty @@ -189,18 +181,18 @@ let f_tuple args = | [x] -> x | _ -> mk_form (Ftuple args) (ttuple (List.map f_ty args)) +(* -------------------------------------------------------------------- *) let f_quant q b f = - if List.is_empty b then f else - let (q, b, f) = - match f.f_node with - | Fquant(q',b',f') when q = q' -> (q, b@b', f') - | _ -> q, b , f in - let ty = - if q = Llambda - then toarrow (List.map (fun (_,gty) -> gty_as_ty gty) b) f.f_ty - else tbool in - - mk_form (Fquant (q, b, f)) ty + let ty = + match q with + | Llambda -> + let dom = + List.map (fun (_, gty) -> gty_as_ty gty) b + in toarrow dom f.f_ty + + | _ -> tbool in + + mk_form (Fquant (q, b, f)) ty let f_proj f i ty = mk_form (Fproj(f, i)) ty let f_if f1 f2 f3 = mk_form (Fif (f1, f2, f3)) f2.f_ty @@ -391,115 +383,88 @@ let f_some ({ f_ty = ty } as f : form) : form = f_app op [f] (toption ty) (* -------------------------------------------------------------------- *) -let f_map gt g fp = +let f_map (g : form -> form) (fp : form) : form = match fp.f_node with - | Fquant(q, b, f) -> - let map_gty ((x, gty) as b1) = - let gty' = - match gty with - | GTty ty -> - let ty' = gt ty in if ty == ty' then gty else GTty ty' - | _ -> gty - in - if gty == gty' then b1 else (x, gty') - in + | Fint _ -> fp + | Fglob _ -> fp + | Flocal _ -> fp + | Fpvar _ -> fp + | Fop _ -> fp - let b' = List.Smart.map map_gty b in - let f' = g f in - - f_quant q b' f' - - | Fint _ -> fp - | Fglob _ -> fp + | Fquant(q, b, f) -> + f_quant q b (g f) | Fif (f1, f2, f3) -> - f_if (g f1) (g f2) (g f3) + f_if (g f1) (g f2) (g f3) | Fmatch (b, fs, ty) -> - f_match (g b) (List.map g fs) (gt ty) + f_match (g b) (List.map g fs) ty | Flet (lp, f1, f2) -> - f_let lp (g f1) (g f2) - - | Flocal id -> - let ty' = gt fp.f_ty in - f_local id ty' - - | Fpvar (id, s) -> - let ty' = gt fp.f_ty in - f_pvar id ty' s - - | Fop (p, tyargs) -> - let tyargs' = List.Smart.map (etyarg_map gt) tyargs in - let ty' = gt fp.f_ty in - f_op_tc p tyargs' ty' + f_let lp (g f1) (g f2) - | Fapp (f, fs) -> - let f' = g f in - let fs' = List.Smart.map g fs in - let ty' = gt fp.f_ty in - f_app f' fs' ty' + | Fapp (hd, args) -> + let hd = g hd in + let args = List.Smart.map g args in + f_app hd args fp.f_ty | Ftuple fs -> - let fs' = List.Smart.map g fs in - f_tuple fs' + f_tuple (List.Smart.map g fs) | Fproj (f, i) -> - let f' = g f in - let ty' = gt fp.f_ty in - f_proj f' i ty' + f_proj (g f) i fp.f_ty | FhoareF hf -> - let pr' = g hf.hf_pr in - let po' = g hf.hf_po in - f_hoareF_r { hf with hf_pr = pr'; hf_po = po'; } + let pr' = g hf.hf_pr in + let po' = g hf.hf_po in + f_hoareF_r { hf with hf_pr = pr'; hf_po = po'; } | FhoareS hs -> - let pr' = g hs.hs_pr in - let po' = g hs.hs_po in - f_hoareS_r { hs with hs_pr = pr'; hs_po = po'; } + let pr' = g hs.hs_pr in + let po' = g hs.hs_po in + f_hoareS_r { hs with hs_pr = pr'; hs_po = po'; } | FeHoareF hf -> - let pr' = g hf.ehf_pr in - let po' = g hf.ehf_po in - f_eHoareF_r { hf with ehf_pr = pr'; ehf_po = po' } + let pr' = g hf.ehf_pr in + let po' = g hf.ehf_po in + f_eHoareF_r { hf with ehf_pr = pr'; ehf_po = po' } | FeHoareS hs -> - let pr' = g hs.ehs_pr in - let po' = g hs.ehs_po in - f_eHoareS_r { hs with ehs_pr = pr'; ehs_po = po'; } + let pr' = g hs.ehs_pr in + let po' = g hs.ehs_po in + f_eHoareS_r { hs with ehs_pr = pr'; ehs_po = po'; } | FbdHoareF bhf -> - let pr' = g bhf.bhf_pr in - let po' = g bhf.bhf_po in - let bd' = g bhf.bhf_bd in - f_bdHoareF_r { bhf with bhf_pr = pr'; bhf_po = po'; bhf_bd = bd'; } + let pr' = g bhf.bhf_pr in + let po' = g bhf.bhf_po in + let bd' = g bhf.bhf_bd in + f_bdHoareF_r { bhf with bhf_pr = pr'; bhf_po = po'; bhf_bd = bd'; } | FbdHoareS bhs -> - let pr' = g bhs.bhs_pr in - let po' = g bhs.bhs_po in - let bd' = g bhs.bhs_bd in - f_bdHoareS_r { bhs with bhs_pr = pr'; bhs_po = po'; bhs_bd = bd'; } + let pr' = g bhs.bhs_pr in + let po' = g bhs.bhs_po in + let bd' = g bhs.bhs_bd in + f_bdHoareS_r { bhs with bhs_pr = pr'; bhs_po = po'; bhs_bd = bd'; } | FequivF ef -> - let pr' = g ef.ef_pr in - let po' = g ef.ef_po in - f_equivF_r { ef with ef_pr = pr'; ef_po = po'; } + let pr' = g ef.ef_pr in + let po' = g ef.ef_po in + f_equivF_r { ef with ef_pr = pr'; ef_po = po'; } | FequivS es -> - let pr' = g es.es_pr in - let po' = g es.es_po in - f_equivS_r { es with es_pr = pr'; es_po = po'; } + let pr' = g es.es_pr in + let po' = g es.es_po in + f_equivS_r { es with es_pr = pr'; es_po = po'; } | FeagerF eg -> - let pr' = g eg.eg_pr in - let po' = g eg.eg_po in - f_eagerF_r { eg with eg_pr = pr'; eg_po = po'; } + let pr' = g eg.eg_pr in + let po' = g eg.eg_po in + f_eagerF_r { eg with eg_pr = pr'; eg_po = po'; } | Fpr pr -> - let args' = g pr.pr_args in - let ev' = g pr.pr_event in - f_pr_r { pr with pr_args = args'; pr_event = ev'; } + let args' = g pr.pr_args in + let ev' = g pr.pr_event in + f_pr_r { pr with pr_args = args'; pr_event = ev'; } (* -------------------------------------------------------------------- *) let f_iter g f = diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 9c24c0c3d5..ad489db1b9 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -75,8 +75,9 @@ val f_node : form -> f_node (* -------------------------------------------------------------------- *) (* not recursive *) -val f_map : (EcTypes.ty -> EcTypes.ty) -> (form -> form) -> form -> form +val f_map : (form -> form) -> form -> form val f_iter : (form -> unit) -> form -> unit + val form_exists: (form -> bool) -> form -> bool val form_forall: (form -> bool) -> form -> bool diff --git a/src/ecCoreGoal.ml b/src/ecCoreGoal.ml index 94d386c1e9..dc4849947f 100644 --- a/src/ecCoreGoal.ml +++ b/src/ecCoreGoal.ml @@ -51,7 +51,7 @@ and pt_head = | PTCut of EcFol.form | PTHandle of handle | PTLocal of EcIdent.t -| PTGlobal of EcPath.path * (ty list) +| PTGlobal of EcPath.path * etyarg list | PTTerm of proofterm and pt_arg = diff --git a/src/ecCoreGoal.mli b/src/ecCoreGoal.mli index eb3f1aa157..38e19dacb3 100644 --- a/src/ecCoreGoal.mli +++ b/src/ecCoreGoal.mli @@ -53,7 +53,7 @@ and pt_head = | PTCut of EcFol.form | PTHandle of handle | PTLocal of EcIdent.t -| PTGlobal of EcPath.path * (ty list) +| PTGlobal of EcPath.path * etyarg list | PTTerm of proofterm and pt_arg = @@ -80,12 +80,12 @@ val pamemory : EcMemory.memory -> pt_arg val pamodule : EcPath.mpath * EcModules.module_sig -> pt_arg (* -------------------------------------------------------------------- *) -val paglobal : ?args:pt_arg list -> tys:ty list -> EcPath.path -> pt_arg +val paglobal : ?args:pt_arg list -> tys:etyarg list -> EcPath.path -> pt_arg val palocal : ?args:pt_arg list -> EcIdent.t -> pt_arg val pahandle : ?args:pt_arg list -> handle -> pt_arg (* -------------------------------------------------------------------- *) -val ptglobal : ?args:pt_arg list -> tys:ty list -> EcPath.path -> proofterm +val ptglobal : ?args:pt_arg list -> tys:etyarg list -> EcPath.path -> proofterm val ptlocal : ?args:pt_arg list -> EcIdent.t -> proofterm val pthandle : ?args:pt_arg list -> handle -> proofterm val ptcut : ?args:pt_arg list -> EcFol.form -> proofterm diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index f9cd34eb53..badd2beec9 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -14,17 +14,11 @@ type mod_extra = { mex_glob : memory -> form; } -type sc_instanciate = { - sc_memtype : memtype; - sc_mempred : mem_pr Mid.t; - sc_expr : expr Mid.t; -} - (* -------------------------------------------------------------------- *) type f_subst = { fs_freshen : bool; (* true means freshen locals *) - fs_u : ty Muid.t; - fs_v : ty Mid.t; + fs_u : etyarg Muid.t; + fs_v : etyarg Mid.t; fs_mod : EcPath.mpath Mid.t; fs_modex : mod_extra Mid.t; fs_loc : form Mid.t; @@ -49,7 +43,7 @@ let mex_fv (mp : mpath) (ex : mod_extra) : uid Mid.t = (* -------------------------------------------------------------------- *) let fv_Mid (type a) - (fv : a -> uid Mid.t) (m : a Mid.t) (s : uid Mid.t) : uid Mid.t + (fv : a -> int Mid.t) (m : a Mid.t) (s : int Mid.t) : int Mid.t = Mid.fold (fun _ t s -> fv_union s (fv t)) m s @@ -60,9 +54,10 @@ let f_subst_init ?(tv=Mid.empty) ?(esloc=Mid.empty) () = + let fv = Mid.empty in - let fv = Muid.fold (fun _ t s -> fv_union s (ty_fv t)) tu fv in - let fv = fv_Mid ty_fv tv fv in + let fv = Muid.fold (fun _ t s -> fv_union s (etyarg_fv t)) tu fv in + let fv = fv_Mid etyarg_fv tv fv in let fv = fv_Mid e_fv esloc fv in { @@ -168,19 +163,70 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = Mid.find_opt m s.fs_modex |> Option.map (fun ex -> ex.mex_tglob) |> Option.value ~default:ty + | Tunivar id -> Muid.find_opt id s.fs_u - |> Option.map (ty_subst s) + |> Option.map (fun (ty, _) -> ty_subst s ty) |> Option.value ~default:ty + | Tvar id -> - Mid.find_def ty id s.fs_v - | _ -> - ty_map (ty_subst s) ty + Mid.find_opt id s.fs_v + |> Option.map fst + |> Option.value ~default:ty + + | Tfun (ty1, ty2) -> + let ty1 = ty_subst s ty1 in + let ty2 = ty_subst s ty2 in + tfun ty1 ty2 + + | Ttuple tys -> + let tys = List.Smart.map (ty_subst s) tys in + ttuple tys + + | Tconstr (p, etyargs) -> + let etyargs = List.Smart.map (etyarg_subst s) etyargs in + tconstr_tc p etyargs + +(* -------------------------------------------------------------------- *) +and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = + match tcw with + | TCIConcrete ({ etyargs = etyargs0 } as rtcw) -> + let etyargs = List.Smart.map (etyarg_subst s) etyargs0 in + if etyargs ==(*phy*) etyargs0 then + tcw + else TCIConcrete { rtcw with etyargs } + + | TCIAbstract { support = `Var tyvar; offset } -> + Mid.find_opt tyvar s.fs_v + |> Option.map (fun (_, tcws) -> List.nth tcws offset) + |> Option.value ~default:tcw + + | TCIAbstract { support = `Univar uni; offset } -> + Muid.find_opt uni s.fs_u + |> Option.map (fun (_, tcws) -> List.nth tcws offset) + |> Option.value ~default:tcw + + | TCIAbstract { support = `Abs _ } -> + tcw + +(* -------------------------------------------------------------------- *) +and etyarg_subst (s : f_subst) ((ty, tcws) as tyarg : etyarg) : etyarg = + let ty' = ty_subst s ty in + let tcws' = List.Smart.map (tcw_subst s) tcws in + SmartPair.mk tyarg ty' tcws' (* -------------------------------------------------------------------- *) let ty_subst (s : f_subst) : ty -> ty = if is_ty_subst_id s then identity else ty_subst s +(* -------------------------------------------------------------------- *) +let etyarg_subst (s : f_subst) : etyarg -> etyarg = + if is_ty_subst_id s then identity else etyarg_subst s + +(* -------------------------------------------------------------------- *) +let tcw_subst (s : f_subst) : tcwitness -> tcwitness = + if is_ty_subst_id s then identity else tcw_subst s + (* -------------------------------------------------------------------- *) let is_e_subst_id (s : f_subst) = not s.fs_freshen @@ -241,48 +287,59 @@ let elp_subst (s : f_subst) (lp : lpattern) : f_subst * lpattern = in (s, LRecord (p, xs')) -(* -------------------------------------------------------------------- *) -let rec tcw_subst (s : f_subst) ((tcws, p) as tcw : tcwitness) : tcwitness = - let tcws' = List.Smart.map (etyarg_subst s) tcws in - SmartPair.mk tcw tcws' p - -and etyarg_subst (s : f_subst) ((ty, tcws) as tyarg : etyarg) : etyarg = - let ty' = ty_subst s ty in - let tcws' = List.Smart.map (tcw_subst s) tcws in - SmartPair.mk tyarg ty' tcws' - (* -------------------------------------------------------------------- *) let rec e_subst (s : f_subst) (e : expr) : expr = + let mk (node : expr_node) = + let ty = ty_subst s e.e_ty in + mk_expr node ty in + match e.e_node with + | Eint _ -> + e + | Elocal id -> begin match Mid.find_opt id s.fs_eloc with | Some e' -> e' - | None -> e_local id (ty_subst s e.e_ty) + | None -> mk (Elocal id) end | Evar pv -> - let pv' = pv_subst s pv in - let ty' = ty_subst s e.e_ty in - e_var pv' ty' + mk (Evar (pv_subst s pv)) - | Eop (p, tys) -> - (* FIXME:TC *) - let tys' = List.Smart.map (etyarg_subst s) tys in - let ty' = ty_subst s e.e_ty in - e_op_tc p tys' ty' + | Eop (p, etyargs) -> + mk (Eop (p, List.Smart.map (etyarg_subst s) etyargs)) | Elet (lp, e1, e2) -> let e1' = e_subst s e1 in let s, lp' = elp_subst s lp in let e2' = e_subst s e2 in - e_let lp' e1' e2' + mk (Elet (lp', e1', e2')) - | Equant (q, b, e1) -> + | Equant (q, b, bd) -> let s, b' = add_elocals s b in - let e1' = e_subst s e1 in - e_quantif q b' e1' - - | _ -> e_map (ty_subst s) (e_subst s) e + let bd' = e_subst s bd in + mk (Equant (q, b', bd')) + + | Eapp (e, es) -> + let e = e_subst s e in + let es = List.Smart.map (e_subst s) es in + mk (Eapp (e, es)) + + | Etuple es -> + let es = List.Smart.map (e_subst s) es in + mk (Etuple es) + + | Eif (c, e1, e2) -> + mk (Eif (e_subst s c, e_subst s e1, e_subst s e2)) + + | Ematch (e, bs, ty) -> + let e = e_subst s e in + let bs = List.Smart.map (e_subst s) bs in + let ty = ty_subst s ty in + mk (Ematch (e, bs, ty)) + + | Eproj (e, (i : int)) -> + mk (Eproj (e_subst s e, i)) (* -------------------------------------------------------------------- *) let e_subst (s : f_subst) : expr -> expr= @@ -422,37 +479,46 @@ module Fsubst = struct (* ------------------------------------------------------------------ *) let rec f_subst ~(tx : tx) (s : f_subst) (fp : form) : form = + let f_subst = f_subst ~tx in + let [@warning "-26"] add_binding = add_binding ~tx in + let add_bindings = add_bindings ~tx in + + let mk (node : f_node) : form = + let ty = ty_subst s fp.f_ty in + mk_form node ty in + tx ~before:fp ~after:(match fp.f_node with - | Fquant (q, b, f) -> - let s, b' = add_bindings ~tx s b in - let f' = f_subst ~tx s f in - f_quant q b' f' + | Fint _ -> + fp + + | Fquant (q, b, bd) -> + let s, b = add_bindings s b in + let bd = f_subst s bd in + mk (Fquant (q, b, bd)) | Flet (lp, f1, f2) -> - let f1' = f_subst ~tx s f1 in - let s, lp' = lp_subst s lp in - let f2' = f_subst ~tx s f2 in - f_let lp' f1' f2' - - | Flocal id -> begin - match Mid.find_opt id s.fs_loc with - | Some f -> - f - | None -> - let ty' = ty_subst s fp.f_ty in - f_local id ty' - end + let f1 = f_subst s f1 in + let s, lp = lp_subst s lp in + let f2 = f_subst s f2 in + mk (Flet (lp, f1, f2)) - | Fop (p, tys) -> - let ty' = ty_subst s fp.f_ty in - let tys' = List.Smart.map (etyarg_subst s) tys in - f_op_tc p tys' ty' + | Flocal id -> + Mid.find_opt id s.fs_loc + |> ofdfl (fun () -> mk (Flocal id)) + + | Fop (p, etyargs) -> + let etyargs = List.Smart.map (etyarg_subst s) etyargs in + mk (Fop (p, etyargs)) + + | Fapp (f, fs) -> + let f = f_subst s f in + let fs = List.Smart.map (f_subst s) fs in + mk (Fapp (f, fs)) | Fpvar (pv, m) -> - let pv' = pv_subst s pv in - let m' = m_subst s m in - let ty' = ty_subst s fp.f_ty in - f_pvar pv' ty' m' + let pv = pv_subst s pv in + let m = m_subst s m in + mk (Fpvar (pv, m)) | Fglob (mid, m) -> let m' = m_subst s m in @@ -461,48 +527,68 @@ module Fsubst = struct | Some _ -> (Mid.find mid s.fs_modex).mex_glob m' end + | Ftuple fs -> + let fs = List.Smart.map (f_subst s) fs in + mk (Ftuple fs) + + | Fproj (f, (i : int)) -> + let f = f_subst s f in + mk (Fproj (f, i)) + + | Fif (c, f1, f2) -> + let c = f_subst s c in + let f1 = f_subst s f1 in + let f2 = f_subst s f2 in + mk (Fif (c, f1, f2)) + + | Fmatch (f, bs, ty) -> + let f = f_subst s f in + let bs = List.Smart.map (f_subst s) bs in + let ty = ty_subst s ty in + mk (Fmatch (f, bs, ty)) + | FhoareF hf -> let hf_f = x_subst s hf.hf_f in let s = f_rem_mem s mhr in - let hf_pr = f_subst ~tx s hf.hf_pr in - let hf_po = f_subst ~tx s hf.hf_po in + let hf_pr = f_subst s hf.hf_pr in + let hf_po = f_subst s hf.hf_po in f_hoareF hf_pr hf_f hf_po | FhoareS hs -> let hs_s = s_subst s hs.hs_s in let s, hs_m = add_me_binding s hs.hs_m in - let hs_pr = f_subst ~tx s hs.hs_pr in - let hs_po = f_subst ~tx s hs.hs_po in + let hs_pr = f_subst s hs.hs_pr in + let hs_po = f_subst s hs.hs_po in f_hoareS hs_m hs_pr hs_s hs_po | FeHoareF hf -> let hf_f = x_subst s hf.ehf_f in let s = f_rem_mem s mhr in - let hf_pr = f_subst ~tx s hf.ehf_pr in - let hf_po = f_subst ~tx s hf.ehf_po in + let hf_pr = f_subst s hf.ehf_pr in + let hf_po = f_subst s hf.ehf_po in f_eHoareF hf_pr hf_f hf_po | FeHoareS hs -> let hs_s = s_subst s hs.ehs_s in let s, hs_m = add_me_binding s hs.ehs_m in - let hs_pr = f_subst ~tx s hs.ehs_pr in - let hs_po = f_subst ~tx s hs.ehs_po in + let hs_pr = f_subst s hs.ehs_pr in + let hs_po = f_subst s hs.ehs_po in f_eHoareS hs_m hs_pr hs_s hs_po | FbdHoareF hf -> let hf_f = x_subst s hf.bhf_f in let s = f_rem_mem s mhr in - let hf_pr = f_subst ~tx s hf.bhf_pr in - let hf_po = f_subst ~tx s hf.bhf_po in - let hf_bd = f_subst ~tx s hf.bhf_bd in + let hf_pr = f_subst s hf.bhf_pr in + let hf_po = f_subst s hf.bhf_po in + let hf_bd = f_subst s hf.bhf_bd in f_bdHoareF hf_pr hf_f hf_po hf.bhf_cmp hf_bd | FbdHoareS hs -> let hs_s = s_subst s hs.bhs_s in let s, hs_m = add_me_binding s hs.bhs_m in - let hs_pr = f_subst ~tx s hs.bhs_pr in - let hs_po = f_subst ~tx s hs.bhs_po in - let hs_bd = f_subst ~tx s hs.bhs_bd in + let hs_pr = f_subst s hs.bhs_pr in + let hs_po = f_subst s hs.bhs_po in + let hs_bd = f_subst s hs.bhs_bd in f_bdHoareS hs_m hs_pr hs_s hs_po hs.bhs_cmp hs_bd | FequivF ef -> @@ -510,8 +596,8 @@ module Fsubst = struct let ef_fr = x_subst s ef.ef_fr in let s = f_rem_mem s mleft in let s = f_rem_mem s mright in - let ef_pr = f_subst ~tx s ef.ef_pr in - let ef_po = f_subst ~tx s ef.ef_po in + let ef_pr = f_subst s ef.ef_pr in + let ef_po = f_subst s ef.ef_po in f_equivF ef_pr ef_fl ef_fr ef_po | FequivS es -> @@ -519,8 +605,8 @@ module Fsubst = struct let es_sr = s_subst s es.es_sr in let s, es_ml = add_me_binding s es.es_ml in let s, es_mr = add_me_binding s es.es_mr in - let es_pr = f_subst ~tx s es.es_pr in - let es_po = f_subst ~tx s es.es_po in + let es_pr = f_subst s es.es_pr in + let es_po = f_subst s es.es_po in f_equivS es_ml es_mr es_pr es_sl es_sr es_po | FeagerF eg -> @@ -530,21 +616,18 @@ module Fsubst = struct let eg_sr = s_subst s eg.eg_sr in let s = f_rem_mem s mleft in let s = f_rem_mem s mright in - let eg_pr = f_subst ~tx s eg.eg_pr in - let eg_po = f_subst ~tx s eg.eg_po in + let eg_pr = f_subst s eg.eg_pr in + let eg_po = f_subst s eg.eg_po in f_eagerF eg_pr eg_sl eg_fl eg_fr eg_sr eg_po | Fpr pr -> let pr_mem = m_subst s pr.pr_mem in let pr_fun = x_subst s pr.pr_fun in - let pr_args = f_subst ~tx s pr.pr_args in + let pr_args = f_subst s pr.pr_args in let s = f_rem_mem s mhr in - let pr_event = f_subst ~tx s pr.pr_event in - - f_pr pr_mem pr_fun pr_args pr_event + let pr_event = f_subst s pr.pr_event in - | _ -> - f_map (ty_subst s) (f_subst ~tx s) fp) + f_pr pr_mem pr_fun pr_args pr_event) (* ------------------------------------------------------------------ *) and oi_subst (s : f_subst) (oi : PreOI.t) : PreOI.t = @@ -672,22 +755,22 @@ module Fsubst = struct fun f -> if Mid.mem m1 f.f_fv then f_subst s f else f (* ------------------------------------------------------------------ *) - let init_subst_tvar ~(freshen : bool) (s : ty Mid.t) : f_subst = + let init_subst_tvar ~(freshen : bool) (s : etyarg Mid.t) : f_subst = f_subst_init ~freshen ~tv:s () - let f_subst_tvar ~(freshen : bool) (s : ty Mid.t) : form -> form = + let f_subst_tvar ~(freshen : bool) (s : etyarg Mid.t) : form -> form = f_subst (init_subst_tvar ~freshen s) end (* -------------------------------------------------------------------- *) module Tuni = struct - let subst (uidmap : ty Muid.t) : f_subst = + let subst (uidmap : etyarg Muid.t) : f_subst = f_subst_init ~tu:uidmap () - let subst1 ((id, t) : uid * ty) : f_subst = + let subst1 ((id, t) : uid * etyarg) : f_subst = subst (Muid.singleton id t) - let subst_dom (uidmap : ty Muid.t) (dom : dom) : dom = + let subst_dom (uidmap : etyarg Muid.t) (dom : dom) : dom = List.map (ty_subst (subst uidmap)) dom let occurs (u : uid) : ty -> bool = @@ -716,16 +799,18 @@ end (* -------------------------------------------------------------------- *) module Tvar = struct - let subst (s : ty Mid.t) (ty : ty) : ty = + let subst (s : etyarg Mid.t) (ty : ty) : ty = ty_subst { f_subst_id with fs_v = s } ty - let subst1 ((id, t) : ebinding) (ty : ty) : ty = + let subst1 ((id, t) : ident * etyarg) (ty : ty) : ty = subst (Mid.singleton id t) ty - let init (lv : ident list) (lt : ty list) : ty Mid.t = - assert (List.length lv = List.length lt); - List.fold_left2 (fun s v t -> Mid.add v t s) Mid.empty lv lt + let init (init : (ident * etyarg) list) : etyarg Mid.t = + Mid.of_list init + + let subst_etyarg (s : etyarg Mid.t) (ety : etyarg) : etyarg = + etyarg_subst { f_subst_id with fs_v = s } ety - let f_subst ~(freshen : bool) (lv : ident list) (lt : ty list) : form -> form = - Fsubst.f_subst_tvar ~freshen (init lv lt) + let f_subst ~(freshen : bool) (bds : (ident * etyarg) list) : form -> form = + Fsubst.f_subst_tvar ~freshen (init bds) end diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index 1c12e0acbb..9905a45fce 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -7,13 +7,6 @@ open EcTypes open EcCoreModules open EcCoreFol -(* -------------------------------------------------------------------- *) -type sc_instanciate = { - sc_memtype : memtype; - sc_mempred : mem_pr Mid.t; - sc_expr : expr Mid.t; -} - (* -------------------------------------------------------------------- *) type f_subst @@ -26,8 +19,8 @@ type 'a subst_binder = f_subst -> 'a -> f_subst * 'a (* -------------------------------------------------------------------- *) val f_subst_init : ?freshen:bool - -> ?tu:ty Muid.t - -> ?tv:ty Mid.t + -> ?tu:etyarg Muid.t + -> ?tv:etyarg Mid.t -> ?esloc:expr Mid.t -> unit -> f_subst @@ -35,19 +28,21 @@ val f_subst_init : (* -------------------------------------------------------------------- *) module Tuni : sig val univars : ty -> Suid.t - val subst1 : (uid * ty) -> f_subst - val subst : ty Muid.t -> f_subst - val subst_dom : ty Muid.t -> dom -> dom + val subst1 : (uid * etyarg) -> f_subst + val subst : etyarg Muid.t -> f_subst + val subst_dom : etyarg Muid.t -> dom -> dom val occurs : uid -> ty -> bool val fv : ty -> Suid.t end (* -------------------------------------------------------------------- *) module Tvar : sig - val init : EcIdent.t list -> ty list -> ty Mid.t - val subst1 : (EcIdent.t * ty) -> ty -> ty - val subst : ty Mid.t -> ty -> ty - val f_subst : freshen:bool -> EcIdent.t list -> ty list -> form -> form + val init : (EcIdent.t * etyarg) list -> etyarg Mid.t + val subst1 : (EcIdent.t * etyarg) -> ty -> ty + val subst : etyarg Mid.t -> ty -> ty + val subst_etyarg : etyarg Mid.t -> etyarg -> etyarg + + val f_subst : freshen:bool -> (EcIdent.t * etyarg) list -> form -> form end (* -------------------------------------------------------------------- *) @@ -55,7 +50,6 @@ val add_elocal : (EcIdent.t * ty) subst_binder val add_elocals : (EcIdent.t * ty) list subst_binder val bind_elocal : f_subst -> EcIdent.t -> expr -> f_subst - (* -------------------------------------------------------------------- *) val ty_subst : ty substitute val etyarg_subst : etyarg substitute @@ -69,8 +63,8 @@ module Fsubst : sig val f_subst_init : ?freshen:bool - -> ?tu:ty Muid.t - -> ?tv:ty Mid.t + -> ?tu:etyarg Muid.t + -> ?tv:etyarg Mid.t -> ?esloc:expr Mid.t -> unit -> f_subst @@ -86,11 +80,7 @@ module Fsubst : sig val f_subst_local : EcIdent.t -> form -> form -> form val f_subst_mem : EcIdent.t -> EcIdent.t -> form -> form - - val f_subst_tvar : - freshen:bool -> - EcTypes.ty EcIdent.Mid.t -> - form -> form + val f_subst_tvar : freshen:bool -> etyarg Mid.t -> form -> form val add_binding : binding subst_binder val add_bindings : bindings subst_binder diff --git a/src/ecDecl.ml b/src/ecDecl.ml index f715cc78b3..d1a32da4e7 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -12,7 +12,7 @@ module CS = EcCoreSubst (* -------------------------------------------------------------------- *) type typeclass = { tc_name : EcPath.path; - tc_args : ty list; + tc_args : etyarg list; } type ty_param = EcIdent.t * typeclass list @@ -70,8 +70,16 @@ let abs_tydecl ?(resolve = true) ?(tc = []) ?(params = `Int 0) lc = tyd_loca = lc; } (* -------------------------------------------------------------------- *) -let ty_instanciate (params : ty_params) (args : ty list) (ty : ty) = - let subst = CS.Tvar.init (List.map fst params) args in +let etyargs_of_tparams (tps : ty_params) : etyarg list = + List.map (fun (a, tcs) -> + let ety = + List.mapi (fun offset _ -> TCIAbstract { support = `Var a; offset }) tcs + in (tvar a, ety) + ) tps + +(* -------------------------------------------------------------------- *) +let ty_instanciate (params : ty_params) (args : etyarg list) (ty : ty) = + let subst = CS.Tvar.init (List.combine (List.map fst params) args) in CS.Tvar.subst subst ty (* -------------------------------------------------------------------- *) @@ -262,35 +270,6 @@ let operator_as_tc (op : operator) = | OB_oper (Some OP_TC (tcpath, name)) -> (tcpath, name) | _ -> assert false -(* -------------------------------------------------------------------- *) -let axiomatized_op ?(nargs = 0) ?(nosmt = false) path (tparams, axbd) lc = - let axbd, axpm = - let bdpm = List.map fst tparams in - let axpm = List.map EcIdent.fresh bdpm in - (CS.Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) axbd, - List.combine axpm (List.map snd tparams)) - in - - let args, axbd = - match axbd.f_node with - | Fquant (Llambda, bds, axbd) -> - let bds, flam = List.split_at nargs bds in - (bds, f_lambda flam axbd) - | _ -> [], axbd - in - - let opargs = List.map (fun (x, ty) -> f_local x (gty_as_ty ty)) args in - let tyargs = List.map (EcTypes.tvar |- fst) axpm in - let op = f_op path tyargs (toarrow (List.map f_ty opargs) axbd.EcAst.f_ty) in - let op = f_app op opargs axbd.f_ty in - let axspec = f_forall args (f_eq op axbd) in - - { ax_tparams = axpm; - ax_spec = axspec; - ax_kind = `Axiom (Ssym.empty, false); - ax_loca = lc; - ax_visibility = if nosmt then `NoSmt else `Visible; } - (* -------------------------------------------------------------------- *) type tc_decl = { tc_tparams : ty_params; diff --git a/src/ecDecl.mli b/src/ecDecl.mli index c85c738d56..9ceec317c5 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -8,7 +8,7 @@ open EcCoreFol (* -------------------------------------------------------------------- *) type typeclass = { tc_name : EcPath.path; - tc_args : ty list; + tc_args : etyarg list; } type ty_param = EcIdent.t * typeclass list @@ -42,7 +42,9 @@ val tydecl_as_record : tydecl -> (form * (EcSymbols.symbol * EcTypes.ty) list) val abs_tydecl : ?resolve:bool -> ?tc:typeclass list -> ?params:ty_pctor -> locality -> tydecl -val ty_instanciate : ty_params -> ty list -> ty -> ty +val etyargs_of_tparams : ty_params -> etyarg list + +val ty_instanciate : ty_params -> etyarg list -> ty -> ty (* -------------------------------------------------------------------- *) type locals = EcIdent.t list @@ -151,15 +153,6 @@ and ax_visibility = [`Visible | `NoSmt | `Hidden] val is_axiom : axiom_kind -> bool val is_lemma : axiom_kind -> bool -(* -------------------------------------------------------------------- *) -val axiomatized_op : - ?nargs: int - -> ?nosmt:bool - -> EcPath.path - -> (ty_params * form) - -> locality - -> axiom - (* -------------------------------------------------------------------- *) type tc_decl = { tc_tparams : ty_params; diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 28bd11b1cc..7c5b13173b 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -89,6 +89,7 @@ type mc = { mc_axioms : (ipath * EcDecl.axiom) MMsym.t; mc_theories : (ipath * ctheory) MMsym.t; mc_typeclasses: (ipath * tc_decl) MMsym.t; + mc_tcinstances: (ipath * tcinstance) MMsym.t; mc_rwbase : (ipath * path) MMsym.t; mc_components : ipath MMsym.t; } @@ -175,8 +176,7 @@ type preenv = { env_memories : EcMemory.memtype Mmem.t; env_actmem : EcMemory.memory option; env_abs_st : EcModules.abs_uses Mid.t; - env_tci : ((ty_params * ty) * tcinstance) list; - env_tc : tc_decl list; + env_tci : (path option * tcinstance) list; env_rwbase : Sp.t Mip.t; env_atbase : (path list Mint.t) Msym.t; env_redbase : mredinfo; @@ -258,6 +258,7 @@ let empty_mc params = { mc_variables = MMsym.empty; mc_functions = MMsym.empty; mc_typeclasses= MMsym.empty; + mc_tcinstances= MMsym.empty; mc_rwbase = MMsym.empty; mc_components = MMsym.empty; } @@ -289,7 +290,6 @@ let empty gstate = env_actmem = None; env_abs_st = Mid.empty; env_tci = []; - env_tc = []; env_rwbase = Mip.empty; env_atbase = Msym.empty; env_redbase = Mrd.empty; @@ -486,12 +486,13 @@ module MC = struct | IPIdent _ -> assert false | IPPath p -> p - let _downpath_for_tydecl = _downpath_for_th - let _downpath_for_modsig = _downpath_for_th - let _downpath_for_operator = _downpath_for_th - let _downpath_for_axiom = _downpath_for_th - let _downpath_for_typeclass = _downpath_for_th - let _downpath_for_rwbase = _downpath_for_th + let _downpath_for_tydecl = _downpath_for_th + let _downpath_for_modsig = _downpath_for_th + let _downpath_for_operator = _downpath_for_th + let _downpath_for_axiom = _downpath_for_th + let _downpath_for_typeclass = _downpath_for_th + let _downpath_for_tcinstance = _downpath_for_th + let _downpath_for_rwbase = _downpath_for_th (* ------------------------------------------------------------------ *) let _params_of_path p env = @@ -883,7 +884,7 @@ module MC = struct let on1 (opid, optype) = let opname = EcIdent.name opid in let optype = EcSubst.subst_ty tsubst optype in - let tcargs = List.map (fun (a, _) -> tvar a) tc.tc_tparams in + let tcargs = etyargs_of_tparams tc.tc_tparams in let opargs = (self, [{tc_name = mypath; tc_args = tcargs;}]) in let opargs = tc.tc_tparams @ [opargs] in let opdecl = OP_TC (mypath, opname) in @@ -905,7 +906,7 @@ module MC = struct let axioms = List.map (fun (x, ax) -> - let tcargs = List.map (fun (a, _) -> tvar a) tc.tc_tparams in + let tcargs = etyargs_of_tparams tc.tc_tparams in let axargs = (self, [{tc_name = mypath; tc_args = tcargs}]) in let axargs = tc.tc_tparams @ [axargs] in let ax = EcSubst.subst_form fsubst ax in @@ -933,6 +934,20 @@ module MC = struct let import_typeclass p ax env = import (_up_typeclass true) (IPPath p) ax env + (* -------------------------------------------------------------------- *) + let lookup_tcinstance qnx env = + match lookup (fun mc -> mc.mc_tcinstances) qnx env with + | None -> lookup_error (`QSymbol qnx) + | Some (p, (args, obj)) -> (_downpath_for_tcinstance env p args, obj) + + let _up_tcinstance candup mc x obj= + if not candup && MMsym.last x mc.mc_tcinstances <> None then + raise (DuplicatedBinding x); + { mc with mc_tcinstances = MMsym.add x obj mc.mc_tcinstances } + + let import_tcinstance p tci env = + import (_up_tcinstance true) (IPPath p) tci env + (* -------------------------------------------------------------------- *) let lookup_rwbase qnx env = match lookup (fun mc -> mc.mc_rwbase) qnx env with @@ -1088,11 +1103,17 @@ module MC = struct | Th_typeclass (x, tc) -> (add2mc _up_typeclass x tc mc, None) + | Th_instance (x, tci) -> + let mc = + x |> Option.fold + ~none:mc + ~some:(fun x -> add2mc _up_tcinstance x tci mc) + in (mc, None) + | Th_baserw (x, _) -> (add2mc _up_rwbase x (expath x) mc, None) - | Th_export _ | Th_addrw _ | Th_instance _ - | Th_auto _ | Th_reduction _ -> + | Th_export _ | Th_addrw _ | Th_auto _ | Th_reduction _ -> (mc, None) in @@ -1171,6 +1192,9 @@ module MC = struct and bind_typeclass x tc env = bind _up_typeclass x tc env + and bind_tcinstance x tci env = + bind _up_tcinstance x tci env + and bind_rwbase x p env = bind _up_rwbase x p env end @@ -1340,43 +1364,77 @@ module TypeClass = struct | Some obj -> obj let add (p : EcPath.path) (env : env) = - let obj = by_path p env in - MC.import_typeclass p obj env + MC.import_typeclass p (by_path p env) env - let rebind name tc env = - let env = MC.bind_typeclass name tc env in - { env with env_tc = tc :: env.env_tc } + let rebind (name : symbol) (tc : t) (env : env) = + MC.bind_typeclass name tc env - let bind ?(import = import0) name tc env = + let bind ?(import = import0) (name : symbol) (tc : t) (env : env) = let env = if import.im_immediate then rebind name tc env else env in { env with env_item = mkitem import (Th_typeclass (name, tc)) :: env.env_item } - let lookup qname (env : env) = + let lookup (qname : qsymbol) (env : env) = MC.lookup_typeclass qname env - let lookup_opt name env = + let lookup_opt (name : qsymbol) (env : env) = try_lf (fun () -> lookup name env) - let lookup_path name env = + let lookup_path (name : qsymbol) (env : env) = fst (lookup name env) +end + +(* ------------------------------------------------------------------ *) +module TcInstance = struct + type t = tcinstance + + let by_path_opt (p : EcPath.path) (env : env) = + omap + check_not_suspended + (MC.by_path (fun mc -> mc.mc_tcinstances) (IPPath p) env) + + let by_path (p : EcPath.path) (env : env) = + match by_path_opt p env with + | None -> lookup_error (`Path p) + | Some obj -> obj - let get_typeclasses (env : env) = - env.env_tc + let add (p : EcPath.path) (env : env) = + MC.import_tcinstance p (by_path p env) env - let bind_instance (ty : ty_params * ty) (cr : tcinstance) tci = - (ty, cr) :: tci + let bind_instance (path : path option) (tci : t) (env : _) = + (path, tci) :: env - let add_instance ?(import = import0) ty cr lc env = + let rebind (name : symbol option) (tci : t) (env : env) = let env = - if import.im_immediate then - { env with env_tci = bind_instance ty cr env.env_tci } - else env in + name |> Option.fold ~none:env ~some:(fun name -> + MC.bind_tcinstance name tci env) + in + let path = + Option.map + (fun name -> EcPath.pqname (root env) name) + name + in { env with env_tci = bind_instance path tci env.env_tci } + + let bind ?(import = import0) (name : symbol option) (tci : t) (env : env) = + let env = + if import.im_immediate then rebind name tci env else env in { env with - env_tci = bind_instance ty cr env.env_tci; - env_item = mkitem import (Th_instance (ty, cr, lc)) :: env.env_item; } + env_item = mkitem import (Th_instance (name, tci)) :: env.env_item } + + let lookup qname (env : env) = + MC.lookup_tcinstance qname env + + let lookup_opt (name : qsymbol) (env : env) = + try_lf (fun () -> lookup name env) + + let lookup_path (name : qsymbol) (env : env) = + fst (lookup name env) + + let get_instances (env : env) = + env.env_tci - let get_instances env = env.env_tci + let get_all (env : env) : (path option * t) list = + env.env_tci end (* -------------------------------------------------------------------- *) @@ -2632,7 +2690,7 @@ module Ty = struct let add (p : EcPath.path) (env : env) = let obj = by_path p env in - MC.import_tydecl p obj env + MC.import_tydecl p obj env let lookup qname (env : env) = MC.lookup_tydecl qname env @@ -2648,11 +2706,11 @@ module Ty = struct | Some { tyd_type = `Concrete _ } -> true | _ -> false - let unfold (name : EcPath.path) (args : EcTypes.ty list) (env : env) = + let unfold (name : EcPath.path) (args : etyarg list) (env : env) = match by_path_opt name env with | Some ({ tyd_type = `Concrete body } as tyd) -> Tvar.subst - (Tvar.init (List.map fst tyd.tyd_params) args) + (Tvar.init (List.combine (List.fst tyd.tyd_params) args)) body | _ -> raise (LookupFailure (`Path name)) @@ -2661,13 +2719,11 @@ module Ty = struct | Tconstr (p, tys) when defined p env -> hnorm (unfold p tys env) env | _ -> ty - let rec ty_hnorm (ty : ty) (env : env) = match ty.ty_node with | Tconstr (p, tys) when defined p env -> ty_hnorm (unfold p tys env) env | _ -> ty - let rec decompose_fun (ty : ty) (env : env) : dom * ty = match (hnorm ty env).ty_node with | Tfun (ty1, ty2) -> @@ -2705,32 +2761,14 @@ module Ty = struct | Tconstr (p, tys) -> Some (p, oget (by_path_opt p env), tys) | _ -> None - let rebind name ty env = - let env = MC.bind_tydecl name ty env in - - match ty.tyd_type with - | `Abstract tcs -> - (* FIXME: TC: refresh? *) - let myty = - let myp = EcPath.pqname (root env) name in - let myty = EcTypes.tconstr myp (List.map (tvar |- fst) ty.tyd_params) in - (ty.tyd_params, myty) in - let env_tci = - List.fold - (fun inst (tc : typeclass) -> - TypeClass.bind_instance myty (`General (tc, None)) inst) (* FIXME: TC *) - env.env_tci tcs - in - { env with env_tci } - - | _ -> env + let rebind (name : symbol) (tyd : t) (env : env) = + MC.bind_tydecl name tyd env let bind ?(import = import0) name ty env = let env = if import.im_immediate then rebind name ty env else env in { env with env_item = mkitem import (Th_type (name, ty)) :: env.env_item } - let iter ?name f (env : env) = gen_iter (fun mc -> mc.mc_tydecls) MC.lookup_tydecls ?name f env @@ -2829,10 +2867,10 @@ module Op = struct else false let reduce ?mode ?nargs env p tys = - let op, f = core_reduce ?mode ?nargs env p in + let op, form = core_reduce ?mode ?nargs env p in Tvar.f_subst ~freshen:true - (List.map fst op.op_tparams) - (List.fst tys) (* FIXME:TC *) f + (List.combine (List.fst op.op_tparams) tys) + form let is_projection env p = try EcDecl.is_proj (by_path p env) @@ -2930,7 +2968,7 @@ module Ax = struct let instanciate p tys env = match by_path_opt p env with | Some ({ ax_spec = f } as ax) -> - Tvar.f_subst ~freshen:true (List.map fst ax.ax_tparams) tys f + Tvar.f_subst ~freshen:true (List.combine (List.map fst ax.ax_tparams) tys) f | _ -> raise (LookupFailure (`Path p)) let iter ?name f (env : env) = @@ -2940,22 +2978,6 @@ module Ax = struct gen_all (fun mc -> mc.mc_axioms) MC.lookup_axioms ?check ?name env end -(* -------------------------------------------------------------------- *) -module Algebra = struct - let bind_ring ty cr env = - assert (Mid.is_empty ty.ty_fv); - { env with env_tci = - TypeClass.bind_instance ([], ty) (`Ring cr) env.env_tci } - - let bind_field ty cr env = - assert (Mid.is_empty ty.ty_fv); - { env with env_tci = - TypeClass.bind_instance ([], ty) (`Field cr) env.env_tci } - - let add_ring ty cr lc env = TypeClass.add_instance ([], ty) (`Ring cr) lc env - let add_field ty cr lc env = TypeClass.add_instance ([], ty) (`Field cr) lc env -end - (* -------------------------------------------------------------------- *) module Theory = struct type t = ctheory @@ -3006,27 +3028,12 @@ module Theory = struct let xpath x = EcPath.pqname path x in match item.ti_item with - | Th_instance (ty, k, _) -> - TypeClass.bind_instance ty k inst + | Th_instance (name, tci) -> + TcInstance.bind_instance (Option.map xpath name) tci inst | Th_theory (x, cth) when cth.cth_mode = `Concrete -> bind_instance_th (xpath x) inst cth.cth_items - | Th_type (x, tyd) -> begin - match tyd.tyd_type with - | `Abstract tcs -> (* FIXME:TC this code is a duplicate *) - let myty = - let typ = List.map (fst_map EcIdent.fresh) tyd.tyd_params in - (typ, EcTypes.tconstr (xpath x) (List.map (tvar |- fst) typ)) - in - List.fold - (fun inst tc -> - TypeClass.bind_instance myty (`General (tc, None)) inst) - inst tcs - - | _ -> inst - end - | _ -> inst (* ------------------------------------------------------------------ *) @@ -3120,13 +3127,12 @@ module Theory = struct | _, `Concrete -> let thname = EcPath.pqname (root env) name in let env_tci = bind_instance_th thname env.env_tci items in - let env_tc = bind_tc_th thname env.env_tc items in let env_rwbase = bind_br_th thname env.env_rwbase items in let env_atbase = bind_at_th thname env.env_atbase items in let env_ntbase = bind_nt_th thname env.env_ntbase items in let env_redbase = bind_rd_th thname env.env_redbase items in let env = - { env with env_tci; env_tc; env_rwbase; env_atbase; env_ntbase; env_redbase; } + { env with env_tci; env_rwbase; env_atbase; env_ntbase; env_redbase; } in add_restr_th thname env items @@ -3308,7 +3314,6 @@ module Theory = struct | `Concrete -> { env with env_tci = bind_instance_th thpath env.env_tci cth.cth_items; - env_tc = bind_tc_th thpath env.env_tc cth.cth_items; env_rwbase = bind_br_th thpath env.env_rwbase cth.cth_items; env_atbase = bind_at_th thpath env.env_atbase cth.cth_items; env_ntbase = bind_nt_th thpath env.env_ntbase cth.cth_items; diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 2f6f981814..4afa9c44a6 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -165,7 +165,7 @@ module Ax : sig val iter : ?name:qsymbol -> (path -> t -> unit) -> env -> unit val all : ?check:(path -> t -> bool) -> ?name:qsymbol -> env -> (path * t) list - val instanciate : path -> EcTypes.ty list -> env -> form + val instanciate : path -> etyarg list -> env -> form end (* -------------------------------------------------------------------- *) @@ -337,16 +337,15 @@ module Ty : sig val bind : ?import:import -> symbol -> t -> env -> env val defined : path -> env -> bool - val unfold : path -> EcTypes.ty list -> env -> EcTypes.ty - val hnorm : EcTypes.ty -> env -> EcTypes.ty - val decompose_fun : EcTypes.ty -> env -> EcTypes.dom * EcTypes.ty + val unfold : path -> etyarg list -> env -> ty + val hnorm : ty -> env -> ty + val decompose_fun : ty -> env -> EcTypes.dom * ty val get_top_decl : - EcTypes.ty -> env -> (path * EcDecl.tydecl * EcTypes.ty list) option - + EcTypes.ty -> env -> (path * EcDecl.tydecl * etyarg list) option val scheme_of_ty : - [`Ind | `Case] -> EcTypes.ty -> env -> (path * EcTypes.ty list) option + [`Ind | `Case] -> EcTypes.ty -> env -> (path * etyarg list) option val signature : env -> ty -> ty list * ty @@ -356,12 +355,6 @@ end val ty_hnorm : ty -> env -> ty -(* -------------------------------------------------------------------- *) -module Algebra : sig - val add_ring : ty -> EcDecl.ring -> is_local -> env -> env - val add_field : ty -> EcDecl.field -> is_local -> env -> env -end - (* -------------------------------------------------------------------- *) module TypeClass : sig type t = tc_decl @@ -374,11 +367,22 @@ module TypeClass : sig val lookup : qsymbol -> env -> path * t val lookup_opt : qsymbol -> env -> (path * t) option val lookup_path : qsymbol -> env -> path +end + +(* -------------------------------------------------------------------- *) +module TcInstance : sig + type t = tcinstance - val get_typeclasses : env -> t list + val add : path -> env -> env + val bind : ?import:import -> symbol option -> t -> env -> env + + val by_path : path -> env -> t + val by_path_opt : path -> env -> t option + val lookup : qsymbol -> env -> path * t + val lookup_opt : qsymbol -> env -> (path * t) option + val lookup_path : qsymbol -> env -> path - val add_instance : ?import:import -> (ty_params * ty) -> tcinstance -> is_local -> env -> env - val get_instances : env -> ((ty_params * ty) * tcinstance) list + val get_all : env -> (path option * t) list end (* -------------------------------------------------------------------- *) diff --git a/src/ecFol.ml b/src/ecFol.ml index 5b2d7e8efe..614ab2a329 100644 --- a/src/ecFol.ml +++ b/src/ecFol.ml @@ -179,8 +179,7 @@ let f_mu_x f1 f2 = let proj_distr_ty env ty = match (EcEnv.Ty.hnorm ty env).ty_node with - | Tconstr(_,lty) when List.length lty = 1 -> - List.hd lty + | Tconstr(_, [lty, []]) -> lty | _ -> assert false let f_mu env f1 f2 = diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index db3ed7c0e0..0316d8b904 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -676,8 +676,12 @@ let process_delta ~und_delta ?target (s, o, p) tc = match sform_of_form fp with | SFop ((_, tvi), []) -> begin (* FIXME: TC HOOK *) - let body = Tvar.f_subst ~freshen:true (List.map fst tparams) (List.fst tvi) body in - let body = f_app body args topfp.f_ty in + let body = + Tvar.f_subst + ~freshen:true + (List.combine (List.map fst tparams) tvi) + body in + let body = f_app body args topfp.f_ty in try EcReduction.h_red EcReduction.beta_red hyps body with EcEnv.NotReducible -> body end @@ -699,8 +703,13 @@ let process_delta ~und_delta ?target (s, o, p) tc = | `RtoL -> let fp = (* FIXME: TC HOOK *) - let body = Tvar.f_subst ~freshen:true (List.map fst tparams) (List.fst tvi) body in - let fp = f_app body args p.f_ty in + let body = + Tvar.f_subst + ~freshen:true + (List.combine (List.map fst tparams) tvi) + body + in + let fp = f_app body args p.f_ty in try EcReduction.h_red EcReduction.beta_red hyps fp with EcEnv.NotReducible -> fp in diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 464bf31b4f..73cbe0f8bf 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -137,7 +137,7 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = match tdecl.tyd_type with | `Abstract _ -> - List.exists isempty (targs) + List.exists isempty (List.fst targs) (* FIXME:TC *) | `Concrete ty -> isempty_1 [tyinst () ty] @@ -315,8 +315,8 @@ let trans_matchfix EcUnify.UniEnv.restore ~src:subue ~dst:ue; let ctorty = - let tvi = Some (EcUnify.TVIunamed tvi) in - fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in + let tvi = Some (EcUnify.tvi_unamed tvi) in + fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in let pty = EcUnify.UniEnv.fresh ue in (try EcUnify.unify env ue (toarrow ctorty pty) opty diff --git a/src/ecHiPredicates.ml b/src/ecHiPredicates.ml index 7b28167af5..14a4b1ff80 100644 --- a/src/ecHiPredicates.ml +++ b/src/ecHiPredicates.ml @@ -20,7 +20,7 @@ exception TransPredError of EcLocation.t * EcEnv.env * tperror let tperror loc env e = raise (TransPredError (loc, env, e)) (* -------------------------------------------------------------------- *) -let close_pr_body (uni : ty EcUid.Muid.t) (body : prbody) = +let close_pr_body (uni : etyarg EcUid.Muid.t) (body : prbody) = let fsubst = EcFol.Fsubst.f_subst_init ~tu:uni () in let tsubst = ty_subst fsubst in @@ -77,10 +77,9 @@ let trans_preddecl_r (env : EcEnv.env) (pr : ppredicate located) = if not (EcUnify.UniEnv.closed ue) then tperror loc env TPE_TyNotClosed; - let uidmap = EcUnify.UniEnv.assubst ue in + let uidmap = EcUnify.UniEnv.assubst ue in let tparams = EcUnify.UniEnv.tparams ue in let body = body |> omap (close_pr_body uidmap) in - let dom = Tuni.subst_dom uidmap dom in EcDecl.mk_pred ~opaque:false tparams dom body pr.pp_locality diff --git a/src/ecInductive.ml b/src/ecInductive.ml index 9f135e7a52..9ef2625736 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -38,15 +38,15 @@ let datatype_proj_path (p : EP.path) (x : symbol) = (* -------------------------------------------------------------------- *) let indsc_of_record (rc : record) = - let targs = List.map (tvar |- fst) rc.rc_tparams in - let recty = tconstr rc.rc_path targs in + let targs = etyargs_of_tparams rc.rc_tparams in + let recty = tconstr_tc rc.rc_path targs in let recx = fresh_id_of_ty recty in let recfm = FL.f_local recx recty in let predty = tfun recty tbool in let predx = EcIdent.create "P" in let pred = FL.f_local predx predty in let ctor = record_ctor_path rc.rc_path in - let ctor = FL.f_op ctor targs (toarrow (List.map snd rc.rc_fields) recty) in + let ctor = FL.f_op_tc ctor targs (toarrow (List.map snd rc.rc_fields) recty) in let prem = let ids = List.map (fun (_, fty) -> (fresh_id_of_ty fty, fty)) rc.rc_fields in let vars = List.map (fun (x, xty) -> FL.f_local x xty) ids in @@ -104,7 +104,9 @@ let indsc_of_datatype ?normty (mode : indmode) (dt : datatype) = end | Tconstr (p', ts) -> - if List.exists (occurs p) ts then raise NonPositive; + (* FIXME:TC *) + if List.exists (EcTypes.etyarg_sub_exists (occurs p)) ts then + raise NonPositive; if not (EcPath.p_equal p p') then None else Some (FL.f_app pred [fac] tbool) @@ -115,11 +117,11 @@ let indsc_of_datatype ?normty (mode : indmode) (dt : datatype) = |> omap (FL.f_forall [x, GTty ty1]) and schemec mode (targs, p) pred (ctor, tys) = - let indty = tconstr p (List.map tvar targs) in + let indty = tconstr_tc p targs in let xs = List.map (fun xty -> (fresh_id_of_ty xty, xty)) tys in let cargs = List.map (fun (x, xty) -> FL.f_local x xty) xs in let ctor = EcPath.pqoname (EcPath.prefix tpath) ctor in - let ctor = FL.f_op ctor (List.map tvar targs) (toarrow tys indty) in + let ctor = FL.f_op_tc ctor targs (toarrow tys indty) in let form = FL.f_app pred [FL.f_app ctor cargs indty] tbool in let form = match mode with @@ -139,7 +141,7 @@ let indsc_of_datatype ?normty (mode : indmode) (dt : datatype) = form and scheme mode (targs, p) ctors = - let indty = tconstr p (List.map tvar targs) in + let indty = tconstr_tc p targs in let indx = fresh_id_of_ty indty in let indfm = FL.f_local indx indty in let predty = tfun indty tbool in @@ -157,7 +159,7 @@ let indsc_of_datatype ?normty (mode : indmode) (dt : datatype) = | Tconstr (p', _) when EcPath.p_equal p p' -> true | _ -> EcTypes.ty_sub_exists (occurs p) t - in scheme mode (List.map fst dt.dt_tparams, tpath) dt.dt_ctors + in scheme mode (etyargs_of_tparams dt.dt_tparams, tpath) dt.dt_ctors (* -------------------------------------------------------------------- *) let datatype_projectors (tpath, tparams, { tydt_ctors = ctors }) = diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 989daa7875..b6c2a96466 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -674,9 +674,14 @@ let t_apply_hyp (x : EcIdent.t) ?args ?sk tc = let t_hyp (x : EcIdent.t) tc = t_apply_hyp x ~args:[] ~sk:0 tc +(* -------------------------------------------------------------------- *) +let t_apply_s_tc (p : path) (etys : etyarg list) ?args ?sk tc = + tt_apply_s p etys ?args ?sk (FApi.tcenv_of_tcenv1 tc) + (* -------------------------------------------------------------------- *) let t_apply_s (p : path) (tys : ty list) ?args ?sk tc = - tt_apply_s p tys ?args ?sk (FApi.tcenv_of_tcenv1 tc) + let etys = List.map (fun ty -> (ty, [])) tys in + tt_apply_s p etys ?args ?sk (FApi.tcenv_of_tcenv1 tc) (* -------------------------------------------------------------------- *) let t_apply_hd (hd : handle) ?args ?sk tc = @@ -1434,8 +1439,7 @@ let t_elim_prind_r ?reduce ?accept (_mode : [`Case | `Ind]) tc = | _ -> raise InvalidGoalShape in - (* FIXME:TC *) - t_apply_s p (List.fst tv) ~args:(args @ [f2]) ~sk tc + t_apply_s_tc p tv ~args:(args @ [f2]) ~sk tc | _ -> raise TTC.NoMatch @@ -1515,8 +1519,7 @@ let t_split_prind ?reduce (tc : tcenv1) = | None -> raise InvalidGoalShape | Some (x, sk) -> let p = EcInductive.prind_introsc_path p x in - (* FIXME:TC *) - t_apply_s p (List.fst tv) ~args ~sk tc + t_apply_s_tc p tv ~args ~sk tc in t_lazy_match ?reduce t_split_r tc @@ -1536,12 +1539,10 @@ let t_or_intro_prind ?reduce (side : side) (tc : tcenv1) = match EcInductive.prind_is_iso_ors pri with | Some ((x, sk), _) when side = `Left -> let p = EcInductive.prind_introsc_path p x in - (* FIXME:TC *) - t_apply_s p (List.fst tv) ~args ~sk tc + t_apply_s_tc p tv ~args ~sk tc | Some (_, (x, sk)) when side = `Right -> let p = EcInductive.prind_introsc_path p x in - (* FIXME:TC *) - t_apply_s p (List.fst tv) ~args ~sk tc + t_apply_s_tc p tv ~args ~sk tc | _ -> raise InvalidGoalShape in t_lazy_match ?reduce t_split_r tc @@ -2162,7 +2163,6 @@ let t_progress ?options ?ti (tt : FApi.backward) (tc : tcenv1) = in entry tc (* -------------------------------------------------------------------- *) - let pp_tc tc = let pr = proofenv_of_proof (proof_of_tcenv tc) in let cl = List.map (FApi.get_pregoal_by_id^~ pr) (FApi.tc_opened tc) in diff --git a/src/ecLowGoal.mli b/src/ecLowGoal.mli index 45577ee723..c980b630f8 100644 --- a/src/ecLowGoal.mli +++ b/src/ecLowGoal.mli @@ -97,6 +97,8 @@ val t_apply : proofterm -> FApi.backward * skip before applying [p]. *) val t_apply_s : path -> ty list -> ?args:(form list) -> ?sk:int -> FApi.backward +val t_apply_s_tc : path -> etyarg list -> ?args:(form list) -> ?sk:int -> FApi.backward + (* Apply a proof term of the form [h f1...fp _ ... _] constructed from * the local hypothesis and formulas given to the function. The [int] * argument gives the number of premises to skip before applying @@ -173,7 +175,7 @@ val t_elim_iso_or : ?reduce:lazyred -> tcenv1 -> int list * tcenv (* Elimination using an custom elimination principle. *) val t_elimT_form : proofterm -> ?sk:int -> form -> FApi.backward -val t_elimT_form_global : path -> ?typ:(ty list) -> ?sk:int -> form -> FApi.backward +val t_elimT_form_global : path -> ?typ:(etyarg list) -> ?sk:int -> form -> FApi.backward (* Eliminiation using an elimation principle of an induction type *) val t_elimT_ind : ?reduce:lazyred -> [ `Case | `Ind ] -> FApi.backward diff --git a/src/ecMatching.mli b/src/ecMatching.mli index 40a4213f83..ca198edfd1 100644 --- a/src/ecMatching.mli +++ b/src/ecMatching.mli @@ -151,7 +151,7 @@ val f_match : -> unienv * mevmap -> form -> form - -> unienv * (ty Muid.t) * mevmap + -> unienv * (etyarg Muid.t) * mevmap (* -------------------------------------------------------------------- *) type ptnpos = private [`Select of int | `Sub of ptnpos] Mint.t diff --git a/src/ecPV.ml b/src/ecPV.ml index 6a7c0c6737..f0acf429ae 100644 --- a/src/ecPV.ml +++ b/src/ecPV.ml @@ -107,7 +107,7 @@ module Mpv = struct let rec esubst env (s : esubst) e = match e.e_node with | Evar pv -> (try find env pv s with Not_found -> e) - | _ -> EcTypes.e_map (fun ty -> ty) (esubst env s) e + | _ -> EcTypes.e_map (esubst env s) e let rec isubst env (s : esubst) (i : instr) = let esubst = esubst env s in @@ -173,30 +173,30 @@ module PVM = struct | FequivF _ -> check_binding EcFol.mleft s; check_binding EcFol.mright s; - EcFol.f_map (fun ty -> ty) aux f + EcFol.f_map aux f | FequivS es -> check_binding (fst es.es_ml) s; check_binding (fst es.es_mr) s; - EcFol.f_map (fun ty -> ty) aux f + EcFol.f_map aux f | FhoareF _ | FbdHoareF _ -> check_binding EcFol.mhr s; - EcFol.f_map (fun ty -> ty) aux f + EcFol.f_map aux f | FhoareS hs -> check_binding (fst hs.hs_m) s; - EcFol.f_map (fun ty -> ty) aux f + EcFol.f_map aux f | FbdHoareS hs -> check_binding (fst hs.bhs_m) s; - EcFol.f_map (fun ty -> ty) aux f + EcFol.f_map aux f | Fpr pr -> check_binding pr.pr_mem s; - EcFol.f_map (fun ty -> ty) aux f + EcFol.f_map aux f | Fquant(q,b,f1) -> let f1 = if has_mod b then subst (Mod.add_mod_binding b env) s f1 else aux f1 in f_quant q b f1 - | _ -> EcFol.f_map (fun ty -> ty) aux f) + | _ -> EcFol.f_map aux f) let subst1 env pv m f = let s = add env pv m f empty in diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 66664237c3..4fc6a62a1a 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -184,7 +184,7 @@ module PPEnv = struct in p_shorten exists p - let op_symb (ppe : t) p info = + let op_symb (ppe : t) (p : P.path) (info : ([`Expr | `Form] * etyarg list * dom) option) = let specs = [1, EcPath.pqoname (EcPath.prefix EcCoreLib.CI_Bool.p_eq) "<>"] in let check_for_local sm = @@ -198,13 +198,13 @@ module PPEnv = struct check_for_local sm; EcEnv.Op.lookup_path sm ppe.ppe_env - | Some (mode, typ, dom) -> + | Some (mode, ety, dom) -> let filter = match mode with | `Expr -> fun _ op -> not (EcDecl.is_pred op) | `Form -> fun _ _ -> true in - let tvi = Some (EcUnify.TVIunamed typ) in + let tvi = Some (EcUnify.tvi_unamed ety) in fun sm -> check_for_local sm; @@ -525,7 +525,7 @@ let pp_modtype1 (ppe : PPEnv.t) fmt mty = (* -------------------------------------------------------------------- *) let pp_local (ppe : PPEnv.t) fmt x = - Format.fprintf fmt "%s" (PPEnv.local_symb ppe x) + Format.fprintf fmt "%s" (EcIdent.tostring x) (* (PPEnv.local_symb ppe x) *) (* -------------------------------------------------------------------- *) let pp_local ?fv (ppe : PPEnv.t) fmt x = @@ -701,7 +701,7 @@ let rec pp_type_r ppe outer fmt ty = (pp_paren (pp_list ",@ " subpp)) xs (pp_tyname ppe) name in - maybe_paren_nosc outer t_prio_name pp fmt (name, tyargs) + maybe_paren_nosc outer t_prio_name pp fmt (name, List.fst tyargs) end | Tfun (t1, t2) -> @@ -915,7 +915,11 @@ let pp_opname fmt (nm, op) = in EcSymbols.pp_qsymbol fmt (nm, op) -let pp_opname_with_tvi ppe fmt (nm, op, tvi) = +let pp_opname_with_tvi + (ppe : PPEnv.t) + (fmt : Format.formatter) + ((nm, op, tvi) : symbol list * symbol * etyarg list option) += match tvi with | None -> pp_opname fmt (nm, op) @@ -923,7 +927,7 @@ let pp_opname_with_tvi ppe fmt (nm, op, tvi) = | Some tvi -> Format.fprintf fmt "%a<:%a>" pp_opname (nm, op) - (pp_list ",@ " (pp_type ppe)) tvi + (pp_list ",@ " (pp_type ppe)) (List.fst tvi) (* -------------------------------------------------------------------- *) let pp_opapp @@ -940,7 +944,7 @@ let pp_opapp (fmt : Format.formatter) ((pred : [`Expr | `Form]), (op : EcPath.path), - (tvi : EcTypes.ty list), + (tvi : EcTypes.etyarg list), (es : 'a list)) = let (nm, opname) = @@ -1253,7 +1257,6 @@ let pp_chained_orderings (ppe : PPEnv.t) t_ty pp_sub outer fmt (f, fs) = (fun fmt -> ignore (List.fold_left (fun fe (op, tvi, f) -> - let tvi = List.fst tvi (* FIXME:TC *) in let (nm, opname) = PPEnv.op_symb ppe op (Some (`Form, tvi, [t_ty fe; t_ty f])) in @@ -1381,7 +1384,7 @@ let lower_left (ppe : PPEnv.t) (t_ty : form -> EcTypes.ty) (f : form) else l_l f2 onm e_bin_prio_rop4 | Fapp ({f_node = Fop (op, tys)}, [f1; f2]) -> (let (inm, opname) = - PPEnv.op_symb ppe op (Some (`Form, List.fst tys, List.map t_ty [f1; f2])) in (* FIXME: TC *) + PPEnv.op_symb ppe op (Some (`Form, tys, List.map t_ty [f1; f2])) in (* FIXME: TC *) if inm <> [] && inm <> onm then None else match priority_of_binop opname with @@ -1614,11 +1617,11 @@ and try_pp_notations (ppe : PPEnv.t) outer fmt f = let ev = MEV.of_idents (List.map fst nt.ont_args) `Form in let ue = EcUnify.UniEnv.create None in let ov = EcUnify.UniEnv.opentvi ue tv None in - let ti = Tvar.subst ov in + let ti = Tvar.subst ov.subst in let hy = EcEnv.LDecl.init ppe.PPEnv.ppe_env [] in let mr = odfl mhr (EcEnv.Memory.get_active ppe.PPEnv.ppe_env) in let bd = form_of_expr mr nt.ont_body in - let bd = Fsubst.f_subst_tvar ~freshen:true ov bd in + let bd = Fsubst.f_subst_tvar ~freshen:true ov.subst bd in try let (ue, ev) = @@ -1657,8 +1660,6 @@ and try_pp_notations (ppe : PPEnv.t) outer fmt f = and pp_form_core_r (ppe : PPEnv.t) outer fmt f = let pp_opapp ppe outer fmt (op, tys, es) = - let tys = List.fst tys in (* FIXME:TC *) - let rec dt_sub f = match destr_app f with | ({ f_node = Fop (p, tvi) }, args) -> Some (p, tvi, args) @@ -1855,7 +1856,7 @@ and pp_form_core_r (ppe : PPEnv.t) outer fmt f = (string_of_hcmp hs.bhs_cmp) (pp_form_r ppef (fst outer, (max_op_prec,`NonAssoc))) hs.bhs_bd - | Fpr pr-> + | Fpr pr -> let me = EcEnv.Fun.prF_memenv EcFol.mhr pr.pr_fun ppe.PPEnv.ppe_env in let ppep = PPEnv.create_and_push_mem ppe ~active:true me in @@ -1872,16 +1873,19 @@ and pp_form_core_r (ppe : PPEnv.t) outer fmt f = (pp_form ppep) pr.pr_event and pp_form_r (ppe : PPEnv.t) outer fmt f = - let printers = - [try_pp_notations; - try_pp_form_eqveq; - try_pp_chained_orderings; - try_pp_lossless] - in + let doit fmt = + let printers = + [try_pp_notations; + try_pp_form_eqveq; + try_pp_chained_orderings; + try_pp_lossless] + in + + match List.ofind (fun pp -> pp ppe outer fmt f) printers with + | Some _ -> () + | None -> pp_form_core_r ppe outer fmt f - match List.ofind (fun pp -> pp ppe outer fmt f) printers with - | Some _ -> () - | None -> pp_form_core_r ppe outer fmt f + in Format.fprintf fmt "(%t : %a)" doit (pp_type ppe) f.f_ty and pp_form ppe fmt f = pp_form_r ppe ([], (min_op_prec, `NonAssoc)) fmt f @@ -2127,12 +2131,12 @@ let pp_typeclass (ppe : PPEnv.t) fmt tc = | [ty] -> Format.fprintf fmt "%a %a" - (pp_type ppe) ty + (pp_type ppe) (fst ty) (pp_tyname ppe) tc.tc_name | tys -> Format.fprintf fmt "(%a) %a" - (pp_list ",@ " (pp_type ppe)) tys + (pp_list ",@ " (pp_type ppe)) (List.fst tys) (pp_tyname ppe) tc.tc_name (* -------------------------------------------------------------------- *) @@ -3225,7 +3229,7 @@ let rec pp_instr_r (ppe : PPEnv.t) fmt i = let pp_branch fmt ((vars, s), (cname, _)) = let ptn = EcTypes.toarrow (List.snd vars) e.e_ty in - let ptn = f_op (EcPath.pqoname (EcPath.prefix p) cname) typ ptn in + let ptn = f_op_tc (EcPath.pqoname (EcPath.prefix p) cname) typ ptn in let ptn = f_app ptn (List.map (fun (x, ty) -> f_local x ty) vars) e.e_ty in Format.fprintf fmt "| %a => @[%a@]@ " @@ -3373,10 +3377,10 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = | EcTheory.Th_typeclass _ -> Format.fprintf fmt "typeclass ." - | EcTheory.Th_instance ((typ, ty), tc, lc) -> begin - let ppe = PPEnv.add_locals ppe (List.map fst typ) in (* FIXME *) + | EcTheory.Th_instance (_, tci) -> begin + let ppe = PPEnv.add_locals ppe (List.fst tci.tci_params) in - match tc with + match tci.tci_instance with | (`Ring _ | `Field _) as tc -> begin let (name, ops) = let rec ops_of_ring cr = @@ -3412,10 +3416,10 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = in Format.fprintf fmt "%ainstance %s with [%a] %a@\n@[ %a@]" - pp_locality lc + pp_locality tci.tci_local name - (pp_paren (pp_list ",@ " (pp_tyvar ppe))) (List.map fst typ) - (pp_type ppe) ty + (pp_paren (pp_list ",@ " (pp_tyvar ppe))) (List.fst tci.tci_params) + (pp_type ppe) tci.tci_type (pp_list "@\n" (fun fmt (name, op) -> Format.fprintf fmt "op %s = %s" @@ -3425,7 +3429,9 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = | `General (tc, _) -> Format.fprintf fmt "%ainstance %a with %a." - pp_locality lc (pp_type ppe) ty (pp_typeclass ppe) tc + pp_locality tci.tci_local + (pp_type ppe) tci.tci_type + (pp_typeclass ppe) tc end | EcTheory.Th_baserw (name, _lc) -> diff --git a/src/ecProcSem.ml b/src/ecProcSem.ml index 808ea8674d..97f0b8a657 100644 --- a/src/ecProcSem.ml +++ b/src/ecProcSem.ml @@ -416,7 +416,7 @@ and translate_e (env : senv) (e : expr) = raise SemNotSupported | _ -> - e_map (fun x -> x) (translate_e env) e + e_map (translate_e env) e (* -------------------------------------------------------------------- *) and translate_lv (env : senv) (lv : lvalue) : lpattern = diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index d912710d2f..4a2d2373da 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -119,8 +119,8 @@ let concretize_e_form_gen (CPTEnv subst) ids f = f_forall ids f (* -------------------------------------------------------------------- *) -let concretize_e_form cptenv f = - concretize_e_form_gen cptenv [] f +let concretize_e_form (CPTEnv subst) f = + Fsubst.f_subst subst f (* -------------------------------------------------------------------- *) let rec concretize_e_arg ((CPTEnv subst) as cptenv) arg = @@ -136,7 +136,7 @@ and concretize_e_head ((CPTEnv subst) as cptenv) head = | PTCut f -> PTCut (Fsubst.f_subst subst f) | PTHandle h -> PTHandle h | PTLocal x -> PTLocal x - | PTGlobal (p, tys) -> PTGlobal (p, List.map (ty_subst subst) tys) + | PTGlobal (p, tys) -> PTGlobal (p, List.map (etyarg_subst subst) tys) | PTTerm pt -> PTTerm (concretize_e_pt cptenv pt) and concretize_e_pt ((CPTEnv subst) as cptenv) pt = @@ -190,23 +190,31 @@ let pt_of_hyp_r ptenv x = ptev_ax = ax; } (* -------------------------------------------------------------------- *) -let pt_of_global pf hyps p tys = +let pt_of_global_tc pf hyps p etyargs = let ptenv = ptenv_of_penv hyps pf in - let ax = EcEnv.Ax.instanciate p tys (LDecl.toenv hyps) in + let ax = EcEnv.Ax.instanciate p etyargs (LDecl.toenv hyps) in { ptev_env = ptenv; - ptev_pt = ptglobal ~tys p; + ptev_pt = ptglobal ~tys:etyargs p; ptev_ax = ax; } (* -------------------------------------------------------------------- *) -let pt_of_global_r ptenv p tys = +let pt_of_global pf hyps p tys = + pt_of_global_tc pf hyps p (List.map (fun ty -> (ty, [])) tys) + +(* -------------------------------------------------------------------- *) +let pt_of_global_tc_r ptenv p etyargs = let env = LDecl.toenv ptenv.pte_hy in - let ax = EcEnv.Ax.instanciate p tys env in + let ax = EcEnv.Ax.instanciate p etyargs env in { ptev_env = ptenv; - ptev_pt = ptglobal ~tys p; + ptev_pt = ptglobal ~tys:etyargs p; ptev_ax = ax; } +(* -------------------------------------------------------------------- *) +let pt_of_global_r ptenv p tys = + pt_of_global_tc_r ptenv p (List.map (fun ty -> (ty, [])) tys) + (* -------------------------------------------------------------------- *) let pt_of_handle_r ptenv hd = let g = FApi.get_pregoal_by_id hd ptenv.pte_pe in @@ -221,13 +229,11 @@ let pt_of_uglobal_r ptenv p = let ax = oget (EcEnv.Ax.by_path_opt p env) in let typ, ax = (ax.EcDecl.ax_tparams, ax.EcDecl.ax_spec) in - (* FIXME: TC HOOK *) let fs = EcUnify.UniEnv.opentvi ptenv.pte_ue typ None in - let ax = Fsubst.f_subst_tvar ~freshen:true fs ax in - let typ = List.map (fun (a, _) -> EcIdent.Mid.find a fs) typ in + let ax = Fsubst.f_subst_tvar ~freshen:true fs.subst ax in { ptev_env = ptenv; - ptev_pt = ptglobal ~tys:typ p; + ptev_pt = ptglobal ~tys:fs.args p; ptev_ax = ax; } (* -------------------------------------------------------------------- *) @@ -263,7 +269,7 @@ let pattern_form ?name hyps ~ptn subject = (fun aux f -> if EcReduction.is_alpha_eq hyps f ptn then fx - else f_map (fun ty -> ty) aux f) + else f_map aux f) subject in (x, body) @@ -511,12 +517,10 @@ let process_named_pterm pe (tvi, fp) = PT.pf_check_tvi pe.pte_pe typ tvi; - (* FIXME: TC HOOK *) let fs = EcUnify.UniEnv.opentvi pe.pte_ue typ tvi in - let ax = Fsubst.f_subst_tvar ~freshen:false fs ax in - let typ = List.map (fun (a, _) -> EcIdent.Mid.find a fs) typ in + let ax = Fsubst.f_subst_tvar ~freshen:false fs.subst ax in - (p, (typ, ax)) + (p, (fs.args, ax)) (* ------------------------------------------------------------------ *) let process_pterm_cut ~prcut pe pt = @@ -904,7 +908,7 @@ let tc1_process_full_closed_pterm (tc : tcenv1) (ff : ppterm) = (* -------------------------------------------------------------------- *) type prept = [ | `Hy of EcIdent.t - | `G of EcPath.path * ty list + | `G of EcPath.path * etyarg list | `UG of EcPath.path | `HD of handle | `App of prept * prept_arg list @@ -924,8 +928,8 @@ let pt_of_prept tc (pt : prept) = let rec build_pt = function | `Hy id -> pt_of_hyp_r ptenv id - | `G (p, tys) -> pt_of_global_r ptenv p tys - | `UG p -> pt_of_global_r ptenv p [] + | `G (p, tys) -> pt_of_global_tc_r ptenv p tys + | `UG p -> pt_of_global_tc_r ptenv p [] | `HD hd -> pt_of_handle_r ptenv hd | `App (pt, args) -> List.fold_left app_pt_ev (build_pt pt) args diff --git a/src/ecProofTerm.mli b/src/ecProofTerm.mli index 55ec0f6c84..55b2f5ff31 100644 --- a/src/ecProofTerm.mli +++ b/src/ecProofTerm.mli @@ -150,12 +150,13 @@ val ptenv : proofenv -> LDecl.hyps -> (EcUnify.unienv * mevmap) -> pt_env val copy : pt_env -> pt_env (* Proof-terms construction from components *) -val pt_of_hyp : proofenv -> LDecl.hyps -> EcIdent.t -> pt_ev -val pt_of_global_r : pt_env -> EcPath.path -> ty list -> pt_ev -val pt_of_global : proofenv -> LDecl.hyps -> EcPath.path -> ty list -> pt_ev -val pt_of_uglobal_r : pt_env -> EcPath.path -> pt_ev -val pt_of_uglobal : proofenv -> LDecl.hyps -> EcPath.path -> pt_ev - +val pt_of_hyp : proofenv -> LDecl.hyps -> EcIdent.t -> pt_ev +val pt_of_global_tc_r : pt_env -> EcPath.path -> etyarg list -> pt_ev +val pt_of_global_tc : proofenv -> LDecl.hyps -> EcPath.path -> etyarg list -> pt_ev +val pt_of_global_r : pt_env -> EcPath.path -> ty list -> pt_ev +val pt_of_global : proofenv -> LDecl.hyps -> EcPath.path -> ty list -> pt_ev +val pt_of_uglobal_r : pt_env -> EcPath.path -> pt_ev +val pt_of_uglobal : proofenv -> LDecl.hyps -> EcPath.path -> pt_ev (* -------------------------------------------------------------------- *) val ffpattern_of_genpattern : LDecl.hyps -> genpattern -> ppterm option @@ -163,7 +164,7 @@ val ffpattern_of_genpattern : LDecl.hyps -> genpattern -> ppterm option (* -------------------------------------------------------------------- *) type prept = [ | `Hy of EcIdent.t - | `G of EcPath.path * ty list + | `G of EcPath.path * etyarg list | `UG of EcPath.path | `HD of handle | `App of prept * prept_arg list @@ -184,7 +185,7 @@ module Prept : sig val (@) : prept -> prept_arg list -> prept val hyp : EcIdent.t -> prept - val glob : EcPath.path -> ty list -> prept + val glob : EcPath.path -> etyarg list -> prept val uglob : EcPath.path -> prept val hdl : handle -> prept diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 2fe5cf066c..59ad43c11f 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -175,7 +175,7 @@ let tc1_process_Xhl_formula_xreal tc pf = (* ------------------------------------------------------------------ *) (* FIXME: factor out to typing module *) -(* FIXME: TC HOOK - check parameter constraints *) +(* FIXME:TC HOOK - check parameter constraints *) (* ------------------------------------------------------------------ *) let pf_check_tvi (pe : proofenv) typ tvi = match tvi with diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 1be347e21b..b7496a5da8 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -665,27 +665,46 @@ let reduce_op ri env nargs p tys = Op.reduce ~mode ~nargs env p tys with NotReducible -> raise nohead -let reduce_tc ?params env p tys = +let reduce_tc (env : EcEnv.env) (p : path) (tys : etyarg list) = if not (EcEnv.Op.is_tc_op env p) then None else - let tys = List.rev tys in - let tcty, tys = List.hd tys, List.rev (List.tl tys) in - let (tcp, opname) = EcDecl.operator_as_tc (EcEnv.Op.by_path p env) in - let ue = EcUnify.UniEnv.create params in - let syms = oget (EcUnify.hastc env ue tcty { tc_name = tcp; tc_args = tys }) in + (* Last type application if the TC parameter. We extract the type-class * + * information from the witness. *) + let _, (_, tcw) = List.betail tys in + let tcw = as_seq1 tcw in - match syms with None -> None | Some syms -> + match tcw with + | TCIAbstract _ -> + None + + | TCIConcrete { path = tcipath; etyargs = tciargs; } -> + let tci = oget (EcEnv.TcInstance.by_path_opt tcipath env) in - let optg, opargs = EcMaps.Mstr.find opname syms in - let opargs = List.map (ty_subst (Tuni.subst (EcUnify.UniEnv.assubst ue))) opargs in - let optg_decl = EcEnv.Op.by_path optg env in - let tysubst = Tvar.init (List.fst optg_decl.op_tparams) opargs in + match tci.tci_instance with + | `General (_, Some syms) -> + let subst = + List.fold_left + (fun subst (a, ety) -> + let ety = EcSubst.subst_etyarg subst ety in + EcSubst.add_tyvar subst a ety) + EcSubst.empty + (List.combine (List.fst tci.tci_params) tciargs) + in - Some (EcFol.f_op optg opargs (Tvar.subst tysubst optg_decl.op_ty)) + let (_, opname) = EcDecl.operator_as_tc (EcEnv.Op.by_path p env) in + let optg, opargs = EcMaps.Mstr.find opname syms in + let opargs = List.map (EcSubst.subst_etyarg subst) opargs in + let optg_decl = EcEnv.Op.by_path optg env in + let tysubst = Tvar.init (List.combine (List.fst optg_decl.op_tparams) opargs) in + + Some (EcFol.f_op_tc optg opargs (Tvar.subst tysubst optg_decl.op_ty)) + + | _ -> + None -let may_reduce_tc ri ?params env p tys = +let may_reduce_tc (ri : reduction_info) (env : EcEnv.env) (p : path) (tys : etyarg list) = if ri.delta_tc then - oget ~exn:nohead (reduce_tc ?params env p tys) + oget ~exn:nohead (reduce_tc env p tys) else raise nohead @@ -730,8 +749,8 @@ let reduce_user_gen simplify ri env hyps f = oget ~exn:needsubterm (List.Exceptionless.find_map (fun rule -> try - let ue = EcUnify.UniEnv.create None in - let tvi = EcUnify.UniEnv.opentvi ue rule.R.rl_tyd None in + let ue = EcUnify.UniEnv.create None in + let tvi = EcUnify.UniEnv.opentvi ue rule.R.rl_tyd None in let check_alpha_eq f f' = if not (is_alpha_eq hyps f f') then raise NotReducible @@ -749,8 +768,7 @@ let reduce_user_gen simplify ri env hyps f = | ({ f_node = Fop (p, tys) }, args), R.Rule (`Op (p', tys'), args') when EcPath.p_equal p p' && List.length args = List.length args' -> - let tys' = List.map (Tvar.subst tvi) tys' in - + let tys' = List.map (Tvar.subst tvi.subst) tys' in let tys = List.fst tys in (* FIXME:TC *) begin @@ -783,7 +801,7 @@ let reduce_user_gen simplify ri env hyps f = let subst = ts in let subst = Mid.fold (fun x f s -> Fsubst.f_bind_local s x f) !pv subst in - Fsubst.f_subst subst (Fsubst.f_subst_tvar ~freshen:true tvi f) + Fsubst.f_subst subst (Fsubst.f_subst_tvar ~freshen:true tvi.subst f) in List.iter (fun cond -> @@ -875,10 +893,10 @@ let reduce_logic ri env hyps f p args = check_reduced hyps needsubterm f f' (* -------------------------------------------------------------------- *) -let reduce_delta ri env hyps f = +let reduce_delta ri env f = match f.f_node with | Fop (p, tys) when ri.delta_tc && EcEnv.Op.is_tc_op env p -> - may_reduce_tc ri ~params:(LDecl.tohyps hyps).h_tvar env p (List.fst tys) (* FIXME: TC *) + may_reduce_tc ri env p tys | Fop (p, tys) when ri.delta_p p <> `No -> reduce_op ri env 0 p tys @@ -1026,8 +1044,9 @@ let reduce_head simplify ri env hyps f = (* FIXME subst-refact can we do both subst in once *) let body = Tvar.f_subst ~freshen:true - (List.map fst op.EcDecl.op_tparams) - (List.fst tys) (* FIXME:TC *) body in + (List.combine + (List.map fst op.EcDecl.op_tparams) + tys) body in f_app (Fsubst.f_subst subst body) eargs f.f_ty @@ -1044,14 +1063,14 @@ let reduce_head simplify ri env hyps f = when ri.eta && can_eta x (fn, args) -> f_app fn (List.take (List.length args - 1) args) f.f_ty - | Fop _ -> reduce_delta ri env hyps f + | Fop _ -> reduce_delta ri env f | Fapp({ f_node = Fop(p,_); }, args) -> begin try reduce_logic ri env hyps f p args with NotRed kind1 -> try reduce_user_gen simplify ri env hyps f with NotRed kind2 -> - if kind1 = NoHead && kind2 = NoHead then reduce_delta ri env hyps f + if kind1 = NoHead && kind2 = NoHead then reduce_delta ri env f else raise needsubterm end @@ -1144,7 +1163,7 @@ and reduce_head_top_force ri env onhead f = | f -> if onhead then reduce_head_top ri env ~onhead f else f | exception (NotRed _) -> - try reduce_delta ri.ri env ri.hyps f + try reduce_delta ri.ri env f with NotRed _ -> RedTbl.set_norm ri.redtbl f; raise nohead end @@ -1206,36 +1225,36 @@ let rec simplify ri env f = match f.f_node with | FhoareF hf when ri.ri.modpath -> let hf_f = EcEnv.NormMp.norm_xfun env hf.hf_f in - f_map (fun ty -> ty) (simplify ri env) (f_hoareF_r { hf with hf_f }) + f_map (simplify ri env) (f_hoareF_r { hf with hf_f }) | FeHoareF hf when ri.ri.modpath -> let ehf_f = EcEnv.NormMp.norm_xfun env hf.ehf_f in - f_map (fun ty -> ty) (simplify ri env) (f_eHoareF_r { hf with ehf_f }) + f_map (simplify ri env) (f_eHoareF_r { hf with ehf_f }) | FbdHoareF hf when ri.ri.modpath -> let bhf_f = EcEnv.NormMp.norm_xfun env hf.bhf_f in - f_map (fun ty -> ty) (simplify ri env) (f_bdHoareF_r { hf with bhf_f }) + f_map (simplify ri env) (f_bdHoareF_r { hf with bhf_f }) | FequivF ef when ri.ri.modpath -> let ef_fl = EcEnv.NormMp.norm_xfun env ef.ef_fl in let ef_fr = EcEnv.NormMp.norm_xfun env ef.ef_fr in - f_map (fun ty -> ty) (simplify ri env) (f_equivF_r { ef with ef_fl; ef_fr; }) + f_map (simplify ri env) (f_equivF_r { ef with ef_fl; ef_fr; }) | FeagerF eg when ri.ri.modpath -> let eg_fl = EcEnv.NormMp.norm_xfun env eg.eg_fl in let eg_fr = EcEnv.NormMp.norm_xfun env eg.eg_fr in - f_map (fun ty -> ty) (simplify ri env) (f_eagerF_r { eg with eg_fl ; eg_fr; }) + f_map (simplify ri env) (f_eagerF_r { eg with eg_fl ; eg_fr; }) | Fpr pr when ri.ri.modpath -> let pr_fun = EcEnv.NormMp.norm_xfun env pr.pr_fun in - f_map (fun ty -> ty) (simplify ri env) (f_pr_r { pr with pr_fun }) + f_map (simplify ri env) (f_pr_r { pr with pr_fun }) | Fquant (q, bd, f) -> let env = Mod.add_mod_binding bd env in f_quant q bd (simplify ri env f) | _ -> - f_map (fun ty -> ty) (simplify ri env) f + f_map (simplify ri env) f let simplify ri hyps f = let ri, env = init_redinfo ri hyps in @@ -1329,6 +1348,9 @@ let zpop ri side f hd = let rec conv ri env f1 f2 stk = if f_equal f1 f2 then conv_next ri env f1 stk else match f1.f_node, f2.f_node with + | Flocal x, Flocal y when EcIdent.id_equal x y -> + true + | Fquant (q1, bd1, f1'), Fquant(q2,bd2,f2') -> if q1 <> q2 then force_head_sub ri env f1 f2 stk else diff --git a/src/ecReduction.mli b/src/ecReduction.mli index bb5405b70f..e7d76ef046 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -86,7 +86,7 @@ val nodelta : reduction_info val delta : reduction_info val reduce_logic : reduction_info -> env -> LDecl.hyps -> form -> form -val reduce_tc : ?params:(ident * EcDecl.typeclass list) list -> env -> path -> ty list -> form option +val reduce_tc : env -> path -> etyarg list -> form option val h_red_opt : reduction_info -> LDecl.hyps -> form -> form option val h_red : reduction_info -> LDecl.hyps -> form -> form diff --git a/src/ecScope.ml b/src/ecScope.ml index 8d0b9329b4..3eaa315647 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1085,6 +1085,33 @@ module Op = struct let item = EcTheory.mkitem import (EcTheory.Th_operator (x, op)) in { scope with sc_env = EcSection.add_item item scope.sc_env; } + (* -------------------------------------------------------------------- *) + let axiomatized_op ?(nargs = 0) ?(nosmt = false) path (tparams, axbd) lc = + let axpm, axbd = + let subst, axpm = EcSubst.fresh_tparams EcSubst.empty tparams in + (axpm, EcSubst.subst_form subst axbd) + in + + let args, axbd = + match axbd.f_node with + | Fquant (Llambda, bds, axbd) -> + let bds, flam = List.split_at nargs bds in + (bds, f_lambda flam axbd) + | _ -> [], axbd + in + + let opargs = List.map (fun (x, ty) -> f_local x (gty_as_ty ty)) args in + let opty = toarrow (List.map f_ty opargs) axbd.EcAst.f_ty in + let op = f_op_tc path (etyargs_of_tparams axpm) opty in + let op = f_app op opargs axbd.f_ty in + let axspec = f_forall args (f_eq op axbd) in + + { ax_tparams = axpm; + ax_spec = axspec; + ax_kind = `Axiom (Ssym.empty, false); + ax_loca = lc; + ax_visibility = if nosmt then `NoSmt else `Visible; } + let add (scope : scope) (op : poperator located) = assert (scope.sc_pr_uc = None); let op = op.pl_desc and loc = op.pl_loc in @@ -1193,7 +1220,7 @@ module Op = struct let axop = let nosmt = op.po_nosmt in let nargs = List.sum (List.map (List.length |- fst) args) in - EcDecl.axiomatized_op ~nargs ~nosmt path (tyop.op_tparams, bd) lc in + axiomatized_op ~nargs ~nosmt path (tyop.op_tparams, bd) lc in let tyop = { tyop with op_opaque = true; } in let scope = bind scope (unloc op.po_name, tyop) in Ax.bind scope (unloc ax, axop) @@ -1220,11 +1247,10 @@ module Op = struct ax in - let ax, axpm = - let bdpm = List.map fst tparams in - let axpm = List.map EcIdent.fresh bdpm in - (Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) ax, - List.combine axpm (List.map snd tparams)) in + let axpm, ax = + let subst, tparams = EcSubst.fresh_tparams EcSubst.empty tparams in + (tparams, EcSubst.subst_form subst ax) in + let ax = { ax_tparams = axpm; ax_spec = ax; @@ -1241,11 +1267,11 @@ module Op = struct hierror ~loc "multiple names are only allowed for non-refined abstract operators"; let addnew scope name = - let nparams = List.map (fst_map EcIdent.fresh) tparams in - let subst = Tvar.init - (List.map fst tparams) - (List.map (tvar |- fst) nparams) in - let rop = EcDecl.mk_op ~opaque:false nparams (Tvar.subst subst ty) None lc in + let subst, nparams = + EcSubst.fresh_tparams EcSubst.empty tparams in + let rop = + EcDecl.mk_op ~opaque:false + nparams (EcSubst.subst_ty subst ty) None lc in bind scope (unloc name, rop) in List.fold_left addnew scope op.po_aliases @@ -1260,10 +1286,18 @@ module Op = struct if not (EcAlgTactic.is_module_loaded (env scope)) then hierror "for tag %s, load Distr first" tag; - let oppath = EcPath.pqname (path scope) (unloc op.po_name) in - let nparams = List.map (EcIdent.fresh |- fst) tyop.op_tparams in (* FIXME: TC *) - let subst = Tvar.init (List.fst tyop.op_tparams) (List.map tvar nparams) in - let ty = Tvar.subst subst tyop.op_ty in + let subst, nparams = + EcSubst.fresh_tparams EcSubst.empty tyop.op_tparams in + let oppath = EcPath.pqname (path scope) (unloc op.po_name) in + let optyargs = + let mktcw (a : EcIdent.t) (i : int) = + TCIAbstract { support = `Var a; offset = i; } + in + List.map + (fun (a, tcs) -> (tvar a, List.mapi (fun i _ -> mktcw a i) tcs)) + nparams + in + let ty = EcSubst.subst_ty subst tyop.op_ty in let aty, rty = EcTypes.tyfun_flat ty in let dty = @@ -1273,13 +1307,13 @@ module Op = struct in let bds = List.combine (List.map EcTypes.fresh_id_of_ty aty) aty in - let ax = EcFol.f_op oppath (List.map tvar nparams) ty in + let ax = EcFol.f_op_tc oppath optyargs ty in let ax = EcFol.f_app ax (List.map (curry f_local) bds) rty in let ax = EcFol.f_app (EcFol.f_op pred [dty] (tfun rty tbool)) [ax] tbool in let ax = EcFol.f_forall (List.map (snd_map gtty) bds) ax in let ax = - { ax_tparams = List.map (fun ty -> (ty, [])) nparams; + { ax_tparams = nparams; ax_spec = ax; ax_kind = `Axiom (Ssym.empty, false); ax_loca = lc; @@ -1610,11 +1644,6 @@ module Ty = struct let ue = TT.transtyvars env (loc, Some args) in let tcs = List.map (TT.transtc env ue) tcs in let tp = EcUnify.UniEnv.tparams ue in - - begin match tp, tcs with - | [(x, [])], [{ tc_args = [ty] }] -> - Format.eprintf "[W]%s %s@." (EcIdent.tostring x) (EcTypes.dump_ty ty) - | _ -> () end; tp, `Abstract tcs | PTYD_Alias bd -> @@ -1714,6 +1743,7 @@ module Ty = struct hierror ~loc:x.pl_loc "invalid operator name: `%s'" (unloc x); let tvi = List.map (TT.transty tp_tydecl env ue) tvi in + let tvi = List.map (fun ty -> (Some ty, None)) tvi in let selected = EcUnify.select_op ~filter:(fun _ -> EcDecl.is_oper) (Some (EcUnify.TVIunamed tvi)) env (unloc op) ue [] @@ -1721,16 +1751,15 @@ module Ty = struct let op = match selected with | [] -> hierror ~loc:op.pl_loc "unknown operator" - | op1::op2::_ -> + | op1 :: op2 :: _ -> hierror ~loc:op.pl_loc "ambiguous operator (%s / %s)" (EcPath.tostring (fst (proj4_1 op1))) (EcPath.tostring (fst (proj4_1 op2))) | [((p, opparams), opty, subue, _)] -> let subst = Tuni.subst (EcUnify.UniEnv.assubst subue) in - let subst = ty_subst subst in - let opty = subst opty in - let opparams = List.map subst opparams in + let opty = ty_subst subst opty in + let opparams = List.map (etyarg_subst subst) opparams in ((p, opparams), opty) in @@ -1816,15 +1845,7 @@ module Ty = struct interactive (* ------------------------------------------------------------------ *) - (* FIXME section: those path does not exists ... - futhermode Ring.ZModule is an abstract theory *) - let p_zmod = EcPath.fromqsymbol ([EcCoreLib.i_top; "Ring"; "ZModule"], "zmodule") - let p_ring = EcPath.fromqsymbol ([EcCoreLib.i_top; "Ring"; "ComRing"], "ring" ) - let p_idomain = EcPath.fromqsymbol ([EcCoreLib.i_top; "Ring"; "IDomain"], "idomain") - let p_field = EcPath.fromqsymbol ([EcCoreLib.i_top; "Ring"; "Field" ], "field" ) - - (* ------------------------------------------------------------------ *) - let get_ring_field_op (name : string) (symbols : (path * ty list) Mstr.t) = + let get_ring_field_op (name : string) (symbols : (path * etyarg list) Mstr.t) = Option.map (fun (p, tys) -> assert (List.is_empty tys); p) (Mstr.find_opt name symbols) @@ -1868,22 +1889,18 @@ module Ty = struct let lc = (tci.pti_loca :> locality) in let inter = check_tci_axioms scope mode tci.pti_axs axioms lc in - let add env p = - let item = { tc_name = p; tc_args = []; } in - let item = EcTheory.Th_instance (ty, `General (item, None), tci.pti_loca) in - let item = EcTheory.mkitem import item in - EcSection.add_item item env in + let instance = EcTheory. + { tci_params = fst ty + ; tci_type = snd ty + ; tci_instance = `Ring cr + ; tci_local = (tci.pti_loca :> locality) } in - let scope = - { scope with sc_env = - List.fold_left add - (let item = - EcTheory.Th_instance (([], snd ty), `Ring cr, tci.pti_loca) in - let item = EcTheory.mkitem import item in - EcSection.add_item item scope.sc_env) - [p_zmod; p_ring; p_idomain] } + let scope = + let item = EcTheory.Th_instance (None, instance) in + let item = EcTheory.mkitem import item in + { scope with sc_env = EcSection.add_item item scope.sc_env } in - in Ax.add_defer scope inter + Ax.add_defer scope inter (* ------------------------------------------------------------------ *) let field_of_symmap env ty symbols = @@ -1915,28 +1932,24 @@ module Ty = struct let lc = (tci.pti_loca :> locality) in let inter = check_tci_axioms scope mode tci.pti_axs axioms lc; in - let add env p = - let item = { tc_name = p; tc_args = [] } in - let item = EcTheory.Th_instance(ty, `General (item, None), tci.pti_loca) in - let item = EcTheory.mkitem import item in - EcSection.add_item item env in - - let scope = - { scope with - sc_env = - List.fold_left add - (let item = - EcTheory.Th_instance (([], snd ty), `Field cr, tci.pti_loca) in - let item = EcTheory.mkitem import item in - EcSection.add_item item scope.sc_env) - [p_zmod; p_ring; p_idomain; p_field] } + let instance = EcTheory. + { tci_params = fst ty + ; tci_type = snd ty + ; tci_instance = `Field cr + ; tci_local = (tci.pti_loca :> locality) } in - in Ax.add_defer scope inter + let scope = + let item = EcTheory.Th_instance (None, instance) in + let item = EcTheory.mkitem import item in + { scope with sc_env = EcSection.add_item item scope.sc_env } in + + Ax.add_defer scope inter (* ------------------------------------------------------------------ *) - let symbols_of_tc (_env : EcEnv.env) ty (tcp, tc) = - let subst = EcSubst.empty in - let subst = EcSubst.add_tydef subst tcp.tc_name ([], snd ty) in + let symbols_of_tc (_env : EcEnv.env) ((tparams, ty) : ty_params * ty) (tcp, tc) = + let subst, tparams = EcSubst.fresh_tparams EcSubst.empty tparams in + let ty = EcSubst.subst_ty subst ty in + let subst = EcSubst.add_tydef subst tcp.tc_name (List.fst tparams, ty) in let subst = List.fold_left (fun subst (a, ty) -> EcSubst.add_tyvar subst a ty) @@ -1947,8 +1960,6 @@ module Ty = struct tc.tc_ops (* ------------------------------------------------------------------ *) - (*TODOTC: we have to consider the operators of the parent typeclass instance, and also the types. - How can I find this instance?*) let add_generic_instance ~import (scope : scope) mode { pl_desc = tci; pl_loc = loc; } = @@ -1968,21 +1979,7 @@ module Ty = struct let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in -(* - let prti = - Option.map - (fun prt -> - let ue = EcUnify.UniEnv.create (Some typarams) in - if not (EcUnify.hastc (env scope) ue (snd ty) prt) then - hierror "type must be an instance of `%s'" (EcPath.tostring tcp.tc_name); - let oprti = EcEnv.TypeClass.get_instance (env scope) prt in - match oprti with - | Some prti -> prti - | _ -> hierror "instance of `%s' was said to be in the env, but was not found" (EcPath.tostring tcp.tc_name) ) - tc.tc_prt in -*) - - let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in (* FIXME: TC *) + let tcsyms = symbols_of_tc (env scope) ty (tcp, tc) in let tcsyms = Mstr.of_list tcsyms in let symbols = check_tci_operators (env scope) ty tci.pti_ops tcsyms in @@ -1993,41 +1990,18 @@ module Ty = struct (fun subst (a, ty) -> EcSubst.add_tyvar subst a ty) subst (List.combine (List.fst tc.tc_tparams) tcp.tc_args) in -(* - let vsubst = - ofold - (fun tcp_prt vs -> - let tc_prt = EcEnv.TypeClass.by_path tcp_prt.tc_name (env scope) in - List.combine (List.fst tc_prt.tc_tparams) tcp_prt.tc_args @ vs) - vsubst tc.tc_prt in -*) - let subst = List.fold_left (fun subst (opname, ty) -> let oppath, optys = Mstr.find (EcIdent.name opname) symbols in let op = - EcFol.f_op + EcFol.f_op_tc oppath - (List.map (EcSubst.subst_ty subst) optys) + (List.map (EcSubst.subst_etyarg subst) optys) (EcSubst.subst_ty subst ty) in EcSubst.add_flocal subst opname op) subst tc.tc_ops in -(* - let subst = - ofold - (fun tcp_prt s -> - let tc_prt = EcEnv.TypeClass.by_path tcp_prt.tc_name (env scope) in - List.fold_left - (fun subst (opname, ty) -> - let oppath = Mstr.find (EcIdent.name opname) symbols in - let op = EcFol.f_op oppath [] (ty_subst tysubst ty) in - EcFol.Fsubst.f_bind_local subst opname op) - s tc_prt.tc_ops) - subst tc.tc_prt in -*) - let axioms = List.map (fun (name, ax) -> @@ -2037,12 +2011,16 @@ module Ty = struct let lc = (tci.pti_loca :> locality) in let inter = check_tci_axioms scope mode tci.pti_axs axioms lc in - let add env = - let item = EcTheory.Th_instance (ty, `General (tcp, Some symbols), tci.pti_loca) in - let item = EcTheory.mkitem import item in - EcSection.add_item item env in + let instance = EcTheory. + { tci_params = fst ty + ; tci_type = snd ty + ; tci_instance = `General (tcp, Some symbols) + ; tci_local = lc } in - let scope = { scope with sc_env = add scope.sc_env } in + let scope = + let item = EcTheory.Th_instance (None, instance) in (* FIXME *) + let item = EcTheory.mkitem import item in + { scope with sc_env = EcSection.add_item item scope.sc_env } in Ax.add_defer scope inter @@ -2427,8 +2405,8 @@ module Search = struct let ps = ref Mid.empty in let ue = EcUnify.UniEnv.create None in let tip = EcUnify.UniEnv.opentvi ue decl.op_tparams None in - let tip = f_subst_init ~tv:tip () in - let es = e_subst tip in + let tip = f_subst_init ~tv:tip.subst () in + let es = e_subst tip in let xs = List.map (snd_map (ty_subst tip)) nt.ont_args in let bd = EcFol.form_of_expr EcFol.mhr (es nt.ont_body) in let fp = EcFol.f_lambda (List.map (snd_map EcFol.gtty) xs) bd in diff --git a/src/ecSection.ml b/src/ecSection.ml index dd7d5f8cd8..aaa327f8af 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -53,7 +53,7 @@ let pp_cbarg env fmt (who : cbarg) = | `Typeclass p -> Format.fprintf fmt "typeclass %a" (EcPrinting.pp_tyname ppe) p | `Instance tci -> - match tci with + match tci.tci_instance with | `Ring _ -> Format.fprintf fmt "ring instance" | `Field _ -> Format.fprintf fmt "field instance" | `General _ -> Format.fprintf fmt "instance" @@ -107,9 +107,25 @@ let rec on_ty (cb : cb) (ty : ty) = | Tvar _ -> () | Tglob _ -> () | Ttuple tys -> List.iter (on_ty cb) tys - | Tconstr (p, tys) -> cb (`Type p); List.iter (on_ty cb) tys + | Tconstr (p, tys) -> cb (`Type p); List.iter (on_etyarg cb) tys | Tfun (ty1, ty2) -> List.iter (on_ty cb) [ty1; ty2] +and on_etyarg cb ((ty, tcw) : etyarg) = + on_ty cb ty; + List.iter (on_tcwitness cb) tcw + +and on_tcwitness cb (tcw : tcwitness) = + match tcw with + | TCIConcrete { path; etyargs } -> + List.iter (on_etyarg cb) etyargs; + cb (`Type path) (* FIXME:TC *) + + | TCIAbstract { support = `Abs path } -> + cb (`Type path) + + | TCIAbstract { support = `Var _ | `Univar _ } -> + () + let on_pv (cb : cb) (pv : prog_var)= match pv with | PVglob xp -> on_xp cb xp @@ -127,14 +143,6 @@ let on_binding (cb : cb) ((_, ty) : (EcIdent.t * ty)) = let on_bindings (cb : cb) (bds : (EcIdent.t * ty) list) = List.iter (on_binding cb) bds -let rec on_etyarg cb ((ty, tcw) : etyarg) = - on_ty cb ty; - List.iter (on_tcwitness cb) tcw - -and on_tcwitness cb ((args, p) : tcwitness) = - List.iter (on_etyarg cb) args; - cb (`Type p) (* FIXME:TC *) - let rec on_expr (cb : cb) (e : expr) = let cbrec = on_expr cb in @@ -367,7 +375,7 @@ and on_oi (cb : cb) (oi : OI.t) = (* -------------------------------------------------------------------- *) let on_typeclass cb tc = cb (`Typeclass tc.tc_name); - List.iter (on_ty cb) tc.tc_args + List.iter (on_etyarg cb) tc.tc_args let on_typeclasses cb tcs = List.iter (on_typeclass cb) tcs @@ -464,18 +472,18 @@ let on_field cb f = let on_p p = cb (`Op p) in on_p f.f_inv; oiter on_p f.f_div -let on_instance cb ty tci = - on_typarams cb (fst ty); - on_ty cb (snd ty); +let on_instance cb tci = + on_typarams cb tci.tci_params; + on_ty cb tci.tci_type; (* FIXME section: ring/field use type class that do not exists *) - match tci with + match tci.tci_instance with | `Ring r -> on_ring cb r | `Field f -> on_field cb f | `General (tci, syms) -> on_typeclass cb tci; Option.iter - (Mstr.iter (fun _ (p, tys) -> cb (`Op p); List.iter (on_ty cb) tys)) + (Mstr.iter (fun _ (p, tys) -> cb (`Op p); List.iter (on_etyarg cb) tys)) syms (* -------------------------------------------------------------------- *) @@ -1003,11 +1011,11 @@ let generalize_export to_gen (p,lc) = if lc = `Local || to_clear to_gen (`Th p) then to_gen, None else to_gen, Some (Th_export (p,lc)) -let generalize_instance to_gen (ty,tci, lc) = - if lc = `Local then to_gen, None - (* FIXME: be sure that we have no dep to declare or local, +let generalize_instance to_gen (x, tci) = + if tci.tci_local = `Local then to_gen, None + (* FIXME:TC be sure that we have no dep to declare or local, or fix this code *) - else to_gen, Some (Th_instance (ty,tci,lc)) + else to_gen, Some (Th_instance (x, tci)) let generalize_baserw to_gen prefix (s,lc) = if lc = `Local then @@ -1041,7 +1049,7 @@ let rec generalize_th_item to_gen prefix th_item = | Th_module me -> generalize_module to_gen me | Th_theory cth -> generalize_ctheory to_gen prefix cth | Th_export (p,lc) -> generalize_export to_gen (p,lc) - | Th_instance (ty,i,lc) -> generalize_instance to_gen (ty,i,lc) + | Th_instance (x,tci)-> generalize_instance to_gen (x,tci) | Th_typeclass _ -> assert false | Th_baserw (s,lc) -> generalize_baserw to_gen prefix (s,lc) | Th_addrw (p,ps,lc) -> generalize_addrw to_gen (p, ps, lc) @@ -1133,7 +1141,7 @@ let rec set_local_item item = | Th_typeclass (s,tc) -> Th_typeclass (s, { tc with tc_loca = set_local tc.tc_loca }) | Th_theory (s, th) -> Th_theory (s, set_local_th th) | Th_export (p,lc) -> Th_export (p, set_local lc) - | Th_instance (ty,ti,lc) -> Th_instance (ty,ti, set_local lc) + | Th_instance (x,tci) -> Th_instance (x, { tci with tci_local = set_local tci.tci_local }) | Th_baserw (s,lc) -> Th_baserw (s, set_local lc) | Th_addrw (p,ps,lc) -> Th_addrw (p, ps, set_local lc) | Th_reduction r -> Th_reduction r @@ -1390,18 +1398,18 @@ let check_tcdecl scenv prefix name tc = else on_tcdecl (cb scenv from cd_glob) tc -let check_instance scenv ty tci lc = - let from = (lc :> locality), `Instance tci in - if lc = `Local then check_section scenv from +let check_instance scenv tci = + let from = (tci.tci_local, `Instance tci) in + if tci.tci_local = `Local then check_section scenv from else if scenv.sc_insec then - match tci with + match tci.tci_instance with | `Ring _ | `Field _ -> - on_instance (cb scenv from cd_glob) ty tci + on_instance (cb scenv from cd_glob) tci | `General _ -> let cd = { cd_glob with d_ty = [`Declare; `Global]; } in - on_instance (cb scenv from cd) ty tci + on_instance (cb scenv from cd) tci (* -----------------------------------------------------------*) type checked_ctheory = ctheory @@ -1433,19 +1441,19 @@ let add_item_ (item : theory_item) (scenv:scenv) = let env = scenv.sc_env in let env = match item.ti_item with - | Th_type (s,tyd) -> EcEnv.Ty.bind s tyd env - | Th_operator (s,op) -> EcEnv.Op.bind s op env - | Th_axiom (s, ax) -> EcEnv.Ax.bind s ax env - | Th_modtype (s, ms) -> EcEnv.ModTy.bind s ms env - | Th_module me -> EcEnv.Mod.bind me.tme_expr.me_name me env - | Th_typeclass(s,tc) -> EcEnv.TypeClass.bind s tc env - | Th_theory (s, cth) -> EcEnv.Theory.bind s cth env - | Th_export (p, lc) -> EcEnv.Theory.export p lc env - | Th_instance (tys,i,lc) -> EcEnv.TypeClass.add_instance tys i lc env - | Th_baserw (s,lc) -> EcEnv.BaseRw.add s lc env - | Th_addrw (p,ps,lc) -> EcEnv.BaseRw.addto p ps lc env + | Th_type (s,tyd) -> EcEnv.Ty.bind s tyd env + | Th_operator (s,op) -> EcEnv.Op.bind s op env + | Th_axiom (s, ax) -> EcEnv.Ax.bind s ax env + | Th_modtype (s, ms) -> EcEnv.ModTy.bind s ms env + | Th_module me -> EcEnv.Mod.bind me.tme_expr.me_name me env + | Th_typeclass (s,tc) -> EcEnv.TypeClass.bind s tc env + | Th_theory (s, cth) -> EcEnv.Theory.bind s cth env + | Th_export (p, lc) -> EcEnv.Theory.export p lc env + | Th_instance (x, tci) -> EcEnv.TcInstance.bind x tci env + | Th_baserw (s,lc) -> EcEnv.BaseRw.add s lc env + | Th_addrw (p, ps, lc) -> EcEnv.BaseRw.addto p ps lc env | Th_auto (level, base, ps, lc) -> EcEnv.Auto.add ~level ?base ps lc env - | Th_reduction r -> EcEnv.Reduction.add r env + | Th_reduction r -> EcEnv.Reduction.add r env in { scenv with sc_env = env; @@ -1483,7 +1491,7 @@ let check_item scenv item = | Th_module me -> check_module scenv prefix me | Th_typeclass (s,tc) -> check_tcdecl scenv prefix s tc | Th_export (_, lc) -> assert (lc = `Global || scenv.sc_insec); - | Th_instance (ty,tci,lc) -> check_instance scenv ty tci lc + | Th_instance(_, tci) -> check_instance scenv tci | Th_baserw (_,lc) -> if (lc = `Local && not scenv.sc_insec) then hierror "local base rewrite can only be declared inside section"; diff --git a/src/ecSmt.ml b/src/ecSmt.ml index 5ebc9f33f7..a21fb4f6bb 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -376,7 +376,7 @@ let rec trans_ty ((genv, lenv) as env) ty = | Tconstr (p, tys) -> let id = trans_pty genv p in - WTy.ty_app id (trans_tys env tys) + WTy.ty_app id (trans_tys env (List.fst tys)) (* FIXME:TC *) | Tfun (t1, t2) -> WTy.ty_func (trans_ty env t1) (trans_ty env t2) @@ -765,7 +765,7 @@ and trans_branch (genv, lenv) (p, _dty, tvs) (f, (cname, argsty)) = in let lenv, ws = trans_lvars genv lenv xs in - let wcty = trans_ty (genv, lenv) (tconstr p tvs) in + let wcty = trans_ty (genv, lenv) (tconstr_tc p tvs) in let ws = List.map WTerm.pat_var ws in let ws = WTerm.pat_app csymb ws wcty in let wf = trans_app (genv, lenv) f [] in diff --git a/src/ecSubst.ml b/src/ecSubst.ml index ae765c9184..9a27df1067 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -27,7 +27,7 @@ exception InconsistentSubst type subst = { sb_module : EcPath.mpath Mid.t; sb_path : EcPath.path Mp.t; - sb_tyvar : ty Mid.t; + sb_tyvar : etyarg Mid.t; sb_elocal : expr Mid.t; sb_flocal : EcCoreFol.form Mid.t; sb_fmem : EcIdent.t Mid.t; @@ -125,17 +125,17 @@ let has_def (s : subst) (p : EcPath.path) = Mp.mem p s.sb_def (* -------------------------------------------------------------------- *) -let add_tyvar (s : subst) (x : EcIdent.t) (ty : ty) = +let add_tyvar (s : subst) (x : EcIdent.t) (ety : etyarg) = (* FIXME: check name clash *) let merger = function - | None -> Some ty + | None -> Some ety | Some _ -> raise (SubstNameClash (`Ident x)) in { s with sb_tyvar = Mid.change merger x s.sb_tyvar } (* -------------------------------------------------------------------- *) -let add_tyvars (s : subst) (xs : EcIdent.t list) (tys : ty list) = - List.fold_left2 add_tyvar s xs tys +let add_tyvars (s : subst) (xs : (EcIdent.t * etyarg) list) = + List.fold_left (fun s (x, ety) -> add_tyvar s x ety) s xs (* -------------------------------------------------------------------- *) let rec subst_ty (s : subst) (ty : ty) = @@ -144,23 +144,25 @@ let rec subst_ty (s : subst) (ty : ty) = tglob (EcPath.mget_ident (subst_mpath s (EcPath.mident mp))) | Tunivar _ -> - ty (* FIXME *) + ty | Tvar a -> - Mid.find_def ty a s.sb_tyvar + Mid.find_opt a s.sb_tyvar + |> Option.map fst + |> Option.value ~default:ty | Ttuple tys -> ttuple (subst_tys s tys) - | Tconstr (p, tys) -> begin - let tys = subst_tys s tys in + | Tconstr (p, etys) -> begin + let etys = subst_etyargs s etys in match Mp.find_opt p s.sb_tydef with | None -> - tconstr (subst_path s p) tys + tconstr_tc (subst_path s p) etys | Some (args, body) -> - let s = List.fold_left2 add_tyvar empty args tys in + let s = List.fold_left2 add_tyvar empty args etys in subst_ty s body end @@ -171,6 +173,43 @@ let rec subst_ty (s : subst) (ty : ty) = and subst_tys (s : subst) (tys : ty list) = List.map (subst_ty s) tys +(* -------------------------------------------------------------------- *) +and subst_etyarg (s : subst) ((ty, tcws) : etyarg) : etyarg = + (subst_ty s ty, subst_tcws s tcws) + +(* -------------------------------------------------------------------- *) +and subst_etyargs (s : subst) (tyargs : etyarg list) : etyarg list = + List.map (subst_etyarg s) tyargs + +(* -------------------------------------------------------------------- *) +and subst_tcw (s : subst) (tcw : tcwitness) = + match tcw with + | TCIConcrete { etyargs; path } -> + let path = subst_path s path in + let etyargs = subst_etyargs s etyargs in + TCIConcrete { etyargs; path } + + | TCIAbstract { support = `Var a; offset } -> + Mid.find_opt a s.sb_tyvar + |> Option.map snd + |> Option.map (fun tcs -> List.nth tcs offset) + |> Option.value ~default:tcw + + | TCIAbstract { support = `Univar _ } -> + tcw + + | TCIAbstract ({ support = `Abs p } as tcw) -> + match Mp.find_opt p s.sb_tydef with + | None -> + TCIAbstract { tcw with support = `Abs (subst_path s p) } + + | Some _ -> + assert false (* FIXME:TC *) + +(* -------------------------------------------------------------------- *) +and subst_tcws (s : subst) (tcws : tcwitness list) : tcwitness list = + List.map (subst_tcw s) tcws + (* -------------------------------------------------------------------- *) let add_module (s : subst) (x : EcIdent.t) (m : EcPath.mpath) = let merger = function @@ -255,9 +294,9 @@ let add_path (s : subst) ~src ~dst = assert (Mp.find_opt src s.sb_path = None); { s with sb_path = Mp.add src dst s.sb_path } -let add_tydef (s : subst) p (ids, ty) = +let add_tydef (s : subst) p (typ, ty) = assert (Mp.find_opt p s.sb_tydef = None); - { s with sb_tydef = Mp.add p (ids, ty) s.sb_tydef } + { s with sb_tydef = Mp.add p (typ, ty) s.sb_tydef } let add_opdef (s : subst) p (ids, f) = assert (Mp.find_opt p s.sb_def = None); @@ -304,51 +343,80 @@ let subst_expr_lpattern (s : subst) (lp : lpattern) = (* -------------------------------------------------------------------- *) let rec subst_expr (s : subst) (e : expr) = + let mk (node : expr_node) = + let ty = subst_ty s e.e_ty in + mk_expr node ty in + match e.e_node with + | Eint _ -> + mk e.e_node + | Elocal id -> begin match Mid.find id s.sb_elocal with | aout -> aout - | exception Not_found -> e_local id (subst_ty s e.e_ty) + | exception Not_found -> mk (Elocal id) end | Evar pv -> - e_var (subst_progvar s pv) (subst_ty s e.e_ty) + mk (Evar (subst_progvar s pv)) | Eapp ({ e_node = Eop (p, tyargs) }, args) when has_opdef s p -> - let tyargs = subst_etyargs s tyargs in - let ty = subst_ty s e.e_ty in - let body = oget (get_opdef s p) in - let args = List.map (subst_expr s) args in - subst_eop ty tyargs args body + let tyargs = subst_etyargs s tyargs in + let ty = subst_ty s e.e_ty in + let body = oget (get_opdef s p) in + let args = List.map (subst_expr s) args in + subst_eop ty tyargs args body + + | Eapp (hd, args) -> + let hd = subst_expr s hd in + let args = List.map (subst_expr s) args in + mk (Eapp (hd, args)) | Eop (p, tyargs) when has_opdef s p -> - let tys = subst_etyargs s tyargs in - let ty = subst_ty s e.e_ty in - let body = oget (get_opdef s p) in - subst_eop ty tys [] body + let tys = subst_etyargs s tyargs in + let ty = subst_ty s e.e_ty in + let body = oget (get_opdef s p) in + subst_eop ty tys [] body | Eop (p, tyargs) -> - let p = subst_path s p in - let tyargs = subst_etyargs s tyargs in - let ty = subst_ty s e.e_ty in - e_op_tc p tyargs ty + let p = subst_path s p in + let tyargs = subst_etyargs s tyargs in + mk (Eop (p, tyargs)) + + | Eif (c, e1, e2) -> + let c = subst_expr s c in + let e1 = subst_expr s e1 in + let e2 = subst_expr s e2 in + mk (Eif (c, e1, e2)) + + | Ematch (c, bs, ty) -> + let c = subst_expr s c in + let bs = List.map (subst_expr s) bs in + let ty = subst_ty s ty in + mk (Ematch (c, bs, ty)) + + | Eproj (sube, (i : int)) -> + let sube = subst_expr s sube in + mk (Eproj (sube, i)) + + | Etuple es -> + let es = List.map (subst_expr s) es in + mk (Etuple es) | Elet (lp, e1, e2) -> - let e1 = subst_expr s e1 in - let s, lp = subst_expr_lpattern s lp in - let e2 = subst_expr s e2 in - e_let lp e1 e2 - - | Equant (q, b, e1) -> - let s, b = fresh_elocals s b in - let e1 = subst_expr s e1 in - e_quantif q b e1 + let e1 = subst_expr s e1 in + let s, lp = subst_expr_lpattern s lp in + let e2 = subst_expr s e2 in + mk (Elet (lp, e1, e2)) - | _ -> e_map (subst_ty s) (subst_expr s) e + | Equant (q, b, bd) -> + let s, b = fresh_elocals s b in + let bd = subst_expr s bd in + mk (Equant (q, b, bd)) (* -------------------------------------------------------------------- *) and subst_eop ety tys args (tyids, e) = - let s = add_tyvars empty tyids (List.fst tys) in (* FIXME: TC *) + let s = add_tyvars empty (List.combine tyids tys) in let (s, args, e) = match e.e_node with @@ -362,28 +430,6 @@ and subst_eop ety tys args (tyids, e) = e_app (subst_expr s e) args ety -(* -------------------------------------------------------------------- *) -and subst_etyarg (s : subst) ((ty, tcws) : etyarg) : etyarg = - (subst_ty s ty, List.map (subst_tcw s) tcws) - -(* -------------------------------------------------------------------- *) -and subst_etyargs (s : subst) (tyargs : etyarg list) : etyarg list = - List.map (subst_etyarg s) tyargs - -(* -------------------------------------------------------------------- *) -and subst_tcw (s : subst) ((tcw, p) : tcwitness) = - let tcw = - List.map - (fun (ty, tcws) -> (subst_ty s ty, subst_tcws s tcws)) - tcw in - let p = subst_path s p in - - (tcw, p) - -(* -------------------------------------------------------------------- *) -and subst_tcws (s : subst) (tcws : tcwitness list) : tcwitness list = - List.map (subst_tcw s) tcws - (* -------------------------------------------------------------------- *) let subst_lv (s : subst) (lv : lvalue) = let for1 (pv, ty) = (subst_progvar s pv, subst_ty s ty) in @@ -484,166 +530,187 @@ let subst_form_lpattern (s : subst) (lp : lpattern) = (* -------------------------------------------------------------------- *) let rec subst_form (s : subst) (f : form) = + let mk (node : f_node) = + let ty = subst_ty s f.f_ty in + mk_form node ty in + match f.f_node with - | Fquant (q, b, f1) -> - let s, b = fresh_glocals s b in - let e1 = subst_form s f1 in - f_quant q b e1 + | Fint _ -> + mk (f.f_node) + + | Fquant (q, b, bd) -> + let s, b = fresh_glocals s b in + let bd = subst_form s bd in + mk (Fquant (q, b, bd)) | Fmatch (f, bs, ty) -> - let f = subst_form s f in - let bs = List.map (subst_form s) bs in - let ty = subst_ty s ty in - f_match f bs ty + let f = subst_form s f in + let bs = List.map (subst_form s) bs in + let ty = subst_ty s ty in + mk (Fmatch (f, bs, ty)) | Flet (lp, f, body) -> - let f = subst_form s f in - let s, lp = subst_form_lpattern s lp in - let body = subst_form s body in - f_let lp f body + let f = subst_form s f in + let s, lp = subst_form_lpattern s lp in + let body = subst_form s body in + mk (Flet (lp, f, body)) | Flocal x -> begin - match Mid.find x s.sb_flocal with - | aout -> aout - | exception Not_found -> f_local x (subst_ty s f.f_ty) - end + match Mid.find x s.sb_flocal with + | aout -> aout + | exception Not_found -> mk (Flocal x) + end | Fpvar (pv, m) -> - let pv = subst_progvar s pv in - let ty = subst_ty s f.f_ty in - let m = subst_mem s m in - f_pvar pv ty m + let pv = subst_progvar s pv in + let m = subst_mem s m in + mk (Fpvar (pv, m)) | Fglob (mp, m) -> - let mp = EcPath.mget_ident (subst_mpath s (EcPath.mident mp)) in - let m = subst_mem s m in - f_glob mp m + let mp = EcPath.mget_ident (subst_mpath s (EcPath.mident mp)) in + let m = subst_mem s m in + mk (Fglob (mp, m)) | Fapp ({ f_node = Fop (p, tyargs) }, args) when has_def s p -> - let tys = subst_etyargs s tyargs in - let ty = subst_ty s f.f_ty in - let body = oget (get_def s p) in - let args = List.map (subst_form s) args in - subst_fop ty tys args body + let tys = subst_etyargs s tyargs in + let ty = subst_ty s f.f_ty in + let body = oget (get_def s p) in + let args = List.map (subst_form s) args in + subst_fop ty tys args body + + | Fapp (hd, args) -> + let hd = subst_form s hd in + let args = List.map (subst_form s) args in + mk (Fapp (hd, args)) | Fop (p, tyargs) when has_def s p -> - let tyargs = subst_etyargs s tyargs in - let ty = subst_ty s f.f_ty in - let body = oget (get_def s p) in - subst_fop ty tyargs [] body + let tyargs = subst_etyargs s tyargs in + let ty = subst_ty s f.f_ty in + let body = oget (get_def s p) in + subst_fop ty tyargs [] body | Fop (p, tyargs) -> - let p = subst_path s p in - let tyargs = subst_etyargs s tyargs in - let ty = subst_ty s f.f_ty in - f_op_tc p tyargs ty + let p = subst_path s p in + let tyargs = subst_etyargs s tyargs in + mk (Fop (p, tyargs)) + + | Fif (c, f1, f2) -> + let c = subst_form s c in + let f1 = subst_form s f1 in + let f2 = subst_form s f2 in + mk (Fif (c, f1, f2)) + + | Ftuple fs -> + let fs = List.map (subst_form s) fs in + mk (Ftuple fs) + + | Fproj (subf, (i : int)) -> + let subf = subst_form s subf in + mk (Fproj (subf, i)) | FhoareF { hf_pr; hf_f; hf_po } -> - let hf_pr, hf_po = - let s = add_memory s mhr mhr in - let hf_pr = subst_form s hf_pr in - let hf_po = subst_form s hf_po in - (hf_pr, hf_po) in - let hf_f = subst_xpath s hf_f in - f_hoareF hf_pr hf_f hf_po + let hf_pr, hf_po = + let s = add_memory s mhr mhr in + let hf_pr = subst_form s hf_pr in + let hf_po = subst_form s hf_po in + (hf_pr, hf_po) in + let hf_f = subst_xpath s hf_f in + f_hoareF hf_pr hf_f hf_po | FhoareS { hs_m; hs_pr; hs_s; hs_po } -> - let hs_m, (hs_pr, hs_po) = - let s, hs_m = subst_memtype s hs_m in - let hs_pr = subst_form s hs_pr in - let hs_po = subst_form s hs_po in - hs_m, (hs_pr, hs_po) in - let hs_s = subst_stmt s hs_s in - f_hoareS hs_m hs_pr hs_s hs_po + let hs_m, (hs_pr, hs_po) = + let s, hs_m = subst_memtype s hs_m in + let hs_pr = subst_form s hs_pr in + let hs_po = subst_form s hs_po in + hs_m, (hs_pr, hs_po) in + let hs_s = subst_stmt s hs_s in + f_hoareS hs_m hs_pr hs_s hs_po | FbdHoareF { bhf_pr; bhf_f; bhf_po; bhf_cmp; bhf_bd } -> - let bhf_pr, bhf_po = - let s = add_memory s mhr mhr in - let bhf_pr = subst_form s bhf_pr in - let bhf_po = subst_form s bhf_po in - (bhf_pr, bhf_po) in - let bhf_f = subst_xpath s bhf_f in - let bhf_bd = subst_form s bhf_bd in - f_bdHoareF bhf_pr bhf_f bhf_po bhf_cmp bhf_bd + let bhf_pr, bhf_po = + let s = add_memory s mhr mhr in + let bhf_pr = subst_form s bhf_pr in + let bhf_po = subst_form s bhf_po in + (bhf_pr, bhf_po) in + let bhf_f = subst_xpath s bhf_f in + let bhf_bd = subst_form s bhf_bd in + f_bdHoareF bhf_pr bhf_f bhf_po bhf_cmp bhf_bd | FbdHoareS { bhs_m; bhs_pr; bhs_s; bhs_po; bhs_cmp; bhs_bd } -> - let bhs_m, (bhs_pr, bhs_po, bhs_bd) = - let s, bhs_m = subst_memtype s bhs_m in - let bhs_pr = subst_form s bhs_pr in - let bhs_po = subst_form s bhs_po in - let bhs_bd = subst_form s bhs_bd in - bhs_m, (bhs_pr, bhs_po, bhs_bd) in - let bhs_s = subst_stmt s bhs_s in - f_bdHoareS bhs_m bhs_pr bhs_s bhs_po bhs_cmp bhs_bd + let bhs_m, (bhs_pr, bhs_po, bhs_bd) = + let s, bhs_m = subst_memtype s bhs_m in + let bhs_pr = subst_form s bhs_pr in + let bhs_po = subst_form s bhs_po in + let bhs_bd = subst_form s bhs_bd in + bhs_m, (bhs_pr, bhs_po, bhs_bd) in + let bhs_s = subst_stmt s bhs_s in + f_bdHoareS bhs_m bhs_pr bhs_s bhs_po bhs_cmp bhs_bd | FeHoareF { ehf_pr; ehf_f; ehf_po } -> - let ehf_pr, ehf_po = - let s = add_memory s mhr mhr in - let ehf_pr = subst_form s ehf_pr in - let ehf_po = subst_form s ehf_po in - (ehf_pr, ehf_po) in - let ehf_f = subst_xpath s ehf_f in - f_eHoareF ehf_pr ehf_f ehf_po + let ehf_pr, ehf_po = + let s = add_memory s mhr mhr in + let ehf_pr = subst_form s ehf_pr in + let ehf_po = subst_form s ehf_po in + (ehf_pr, ehf_po) in + let ehf_f = subst_xpath s ehf_f in + f_eHoareF ehf_pr ehf_f ehf_po | FeHoareS { ehs_m; ehs_pr; ehs_s; ehs_po } -> - let ehs_m, (ehs_pr, ehs_po) = - let s, ehs_m = subst_memtype s ehs_m in - let ehs_pr = subst_form s ehs_pr in - let ehs_po = subst_form s ehs_po in - ehs_m, (ehs_pr, ehs_po) in - let ehs_s = subst_stmt s ehs_s in - f_eHoareS ehs_m ehs_pr ehs_s ehs_po + let ehs_m, (ehs_pr, ehs_po) = + let s, ehs_m = subst_memtype s ehs_m in + let ehs_pr = subst_form s ehs_pr in + let ehs_po = subst_form s ehs_po in + ehs_m, (ehs_pr, ehs_po) in + let ehs_s = subst_stmt s ehs_s in + f_eHoareS ehs_m ehs_pr ehs_s ehs_po | FequivF { ef_pr; ef_fl; ef_fr; ef_po } -> - let ef_pr, ef_po = - let s = add_memory s mleft mleft in - let s = add_memory s mright mright in - let ef_pr = subst_form s ef_pr in - let ef_po = subst_form s ef_po in - (ef_pr, ef_po) in - let ef_fl = subst_xpath s ef_fl in - let ef_fr = subst_xpath s ef_fr in - f_equivF ef_pr ef_fl ef_fr ef_po + let ef_pr, ef_po = + let s = add_memory s mleft mleft in + let s = add_memory s mright mright in + let ef_pr = subst_form s ef_pr in + let ef_po = subst_form s ef_po in + (ef_pr, ef_po) in + let ef_fl = subst_xpath s ef_fl in + let ef_fr = subst_xpath s ef_fr in + f_equivF ef_pr ef_fl ef_fr ef_po | FequivS { es_ml; es_mr; es_pr; es_sl; es_sr; es_po } -> - let (es_ml, es_mr), (es_pr, es_po) = - let s, es_ml = subst_memtype s es_ml in - let s, es_mr = subst_memtype s es_mr in - let es_pr = subst_form s es_pr in - let es_po = subst_form s es_po in - (es_ml, es_mr), (es_pr, es_po) in - let es_sl = subst_stmt s es_sl in - let es_sr = subst_stmt s es_sr in - f_equivS es_ml es_mr es_pr es_sl es_sr es_po + let (es_ml, es_mr), (es_pr, es_po) = + let s, es_ml = subst_memtype s es_ml in + let s, es_mr = subst_memtype s es_mr in + let es_pr = subst_form s es_pr in + let es_po = subst_form s es_po in + (es_ml, es_mr), (es_pr, es_po) in + let es_sl = subst_stmt s es_sl in + let es_sr = subst_stmt s es_sr in + f_equivS es_ml es_mr es_pr es_sl es_sr es_po | FeagerF { eg_pr; eg_sl; eg_fl; eg_fr; eg_sr; eg_po } -> - let eg_pr, eg_po = - let s = add_memory s mleft mleft in - let s = add_memory s mright mright in - let eg_pr = subst_form s eg_pr in - let eg_po = subst_form s eg_po in - (eg_pr, eg_po) in - let eg_sl = subst_stmt s eg_sl in - let eg_sr = subst_stmt s eg_sr in - let eg_fl = subst_xpath s eg_fl in - let eg_fr = subst_xpath s eg_fr in - f_eagerF eg_pr eg_sl eg_fl eg_fr eg_sr eg_po + let eg_pr, eg_po = + let s = add_memory s mleft mleft in + let s = add_memory s mright mright in + let eg_pr = subst_form s eg_pr in + let eg_po = subst_form s eg_po in + (eg_pr, eg_po) in + let eg_sl = subst_stmt s eg_sl in + let eg_sr = subst_stmt s eg_sr in + let eg_fl = subst_xpath s eg_fl in + let eg_fr = subst_xpath s eg_fr in + f_eagerF eg_pr eg_sl eg_fl eg_fr eg_sr eg_po | Fpr { pr_mem; pr_fun; pr_args; pr_event } -> - let pr_mem = subst_mem s pr_mem in - let pr_fun = subst_xpath s pr_fun in - let pr_args = subst_form s pr_args in - let pr_event = - let s = add_memory s mhr mhr in - subst_form s pr_event in - f_pr pr_mem pr_fun pr_args pr_event - - | Fif _ | Fint _ | Ftuple _ | Fproj _ | Fapp _ -> - f_map (subst_ty s) (subst_form s) f + let pr_mem = subst_mem s pr_mem in + let pr_fun = subst_xpath s pr_fun in + let pr_args = subst_form s pr_args in + let pr_event = + let s = add_memory s mhr mhr in + subst_form s pr_event in + f_pr pr_mem pr_fun pr_args pr_event (* -------------------------------------------------------------------- *) and subst_fop fty tys args (tyids, f) = - let s = add_tyvars empty tyids (List.fst tys) in (* FIXME: TC *) + let s = add_tyvars empty (List.combine tyids tys) in let (s, args, f) = match f.f_node with @@ -847,13 +914,17 @@ let subst_top_module (s : subst) (m : top_module_expr) = (* -------------------------------------------------------------------- *) let subst_typeclass (s : subst) (tc : typeclass) = { tc_name = subst_path s tc.tc_name; - tc_args = List.map (subst_ty s) tc.tc_args; } + tc_args = subst_etyargs s tc.tc_args; } (* -------------------------------------------------------------------- *) let fresh_tparam (s : subst) ((x, tcs) : ty_param) = let newx = EcIdent.fresh x in let tcs = List.map (subst_typeclass s) tcs in - let s = add_tyvar s x (tvar newx) in + let tcw = + let mk (offset : int) = + TCIAbstract { support = `Var newx; offset; } + in List.mapi (fun i _ -> mk i) tcs in + let s = add_tyvar s x (tvar newx, tcw) in (s, (newx, tcs)) (* -------------------------------------------------------------------- *) @@ -1030,7 +1101,15 @@ let subst_field (s : subst) cr = f_div = omap (subst_path s) cr.f_div; } (* -------------------------------------------------------------------- *) -let subst_instance (s : subst) tci = +let subst_tc (s : subst) tc = + let s, tc_tparams = fresh_tparams s tc.tc_tparams in + let tc_prt = omap (subst_typeclass s) tc.tc_prt in + let tc_ops = List.map (snd_map (subst_ty s)) tc.tc_ops in + let tc_axs = List.map (snd_map (subst_form s)) tc.tc_axs in + { tc_tparams; tc_prt; tc_ops; tc_axs; tc_loca = tc.tc_loca } + +(* -------------------------------------------------------------------- *) +let subst_tcibody (s : subst) (tci : tcibody) = match tci with | `Ring cr -> `Ring (subst_ring s cr) | `Field cr -> `Field (subst_field s cr) @@ -1039,17 +1118,19 @@ let subst_instance (s : subst) tci = let tc = subst_typeclass s tc in let syms = Option.map - (Mstr.map (fun (p, tys) -> (subst_path s p, List.map (subst_ty s) tys))) + (Mstr.map (fun (p, tys) -> (subst_path s p, subst_etyargs s tys))) syms in `General (tc, syms) + (* -------------------------------------------------------------------- *) -let subst_tc (s : subst) tc = - let s, tc_tparams = fresh_tparams s tc.tc_tparams in - let tc_prt = omap (subst_typeclass s) tc.tc_prt in - let tc_ops = List.map (snd_map (subst_ty s)) tc.tc_ops in - let tc_axs = List.map (snd_map (subst_form s)) tc.tc_axs in - { tc_tparams; tc_prt; tc_ops; tc_axs; tc_loca = tc.tc_loca } +let subst_tcinstance (s : subst) (tci : tcinstance) = + let s, tci_params = fresh_tparams s tci.tci_params in + let tci_type = subst_ty s tci.tci_type in + let tci_instance = subst_tcibody s tci.tci_instance in + let tci_local = tci.tci_local in + + { tci_params; tci_type; tci_instance; tci_local; } (* -------------------------------------------------------------------- *) (* SUBSTITUTION OVER THEORIES *) @@ -1076,8 +1157,8 @@ let rec subst_theory_item_r (s : subst) (item : theory_item_r) = | Th_export (p, lc) -> Th_export (subst_path s p, lc) - | Th_instance (ty, tci, lc) -> - Th_instance (subst_genty s ty, subst_instance s tci, lc) + | Th_instance (x, tci) -> + Th_instance (x, subst_tcinstance s tci) | Th_typeclass (x, tc) -> Th_typeclass (x, subst_tc s tc) @@ -1117,16 +1198,16 @@ and subst_theory_source (s : subst) (ths : thsource) = { ths_base = subst_path s ths.ths_base; } (* -------------------------------------------------------------------- *) -let init_tparams (params : (EcIdent.t * ty) list) : subst = - List.fold_left (fun s (x, ty) -> add_tyvar s x ty) empty params +let init_tparams (params : (EcIdent.t * etyarg) list) : subst = + add_tyvars empty params (* -------------------------------------------------------------------- *) -let open_oper op tys = +let open_oper (op : operator) (tys : etyarg list) : ty * operator_kind = let s = List.combine (List.fst op.op_tparams) tys in let s = init_tparams s in (subst_ty s op.op_ty, subst_op_kind s op.op_kind) -let open_tydecl tyd tys = +let open_tydecl (tyd : tydecl) (tys : etyarg list) : EcDecl.ty_body = let s = List.combine (List.fst tyd.tyd_params) tys in let s = init_tparams s in subst_tydecl_body s tyd.tyd_type diff --git a/src/ecSubst.mli b/src/ecSubst.mli index 8a74b4ff77..7222a2922b 100644 --- a/src/ecSubst.mli +++ b/src/ecSubst.mli @@ -25,7 +25,7 @@ val is_empty : subst -> bool val add_module : subst -> EcIdent.t -> mpath -> subst val add_path : subst -> src:path -> dst:path -> subst val add_tydef : subst -> path -> (EcIdent.t list * ty) -> subst -val add_tyvar : subst -> EcIdent.t -> ty -> subst +val add_tyvar : subst -> EcIdent.t -> etyarg -> subst val add_opdef : subst -> path -> (EcIdent.t list * expr) -> subst val add_pddef : subst -> path -> (EcIdent.t list * form) -> subst val add_moddef : subst -> src:path -> dst:path -> subst @@ -63,19 +63,21 @@ val subst_modsig_body : subst -> module_sig_body -> module_sig_body val subst_mod_restr : subst -> mod_restr -> mod_restr (* -------------------------------------------------------------------- *) -val subst_gty : subst -> gty -> gty -val subst_genty : subst -> (ty_params * ty) -> (ty_params * ty) -val subst_ty : subst -> ty -> ty -val subst_form : subst -> form -> form -val subst_expr : subst -> expr -> expr -val subst_stmt : subst -> stmt -> stmt - val subst_progvar : subst -> prog_var -> prog_var -val subst_mem : subst -> EcIdent.t -> EcIdent.t -val subst_flocal : subst -> form -> form +val subst_mem : subst -> EcIdent.t -> EcIdent.t +val subst_flocal : subst -> form -> form +val subst_gty : subst -> gty -> gty +val subst_genty : subst -> (ty_params * ty) -> (ty_params * ty) +val subst_ty : subst -> ty -> ty +val subst_etyarg : subst -> etyarg -> etyarg +val subst_tcw : subst -> tcwitness -> tcwitness +val subst_form : subst -> form -> form +val subst_expr : subst -> expr -> expr +val subst_stmt : subst -> stmt -> stmt -val subst_etyarg : subst -> etyarg -> etyarg +(* -------------------------------------------------------------------- *) +val open_oper : operator -> etyarg list -> ty * operator_kind +val open_tydecl : tydecl -> etyarg list -> ty_body (* -------------------------------------------------------------------- *) -val open_oper : operator -> ty list -> ty * operator_kind -val open_tydecl : tydecl -> ty list -> ty_body +val fresh_tparams : subst -> ty_params -> subst * ty_params diff --git a/src/ecTheory.ml b/src/ecTheory.ml index e042bc2b49..1e30910129 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -33,7 +33,7 @@ and theory_item_r = | Th_module of top_module_expr | Th_theory of (symbol * ctheory) | Th_export of EcPath.path * is_local - | Th_instance of (ty_params * EcTypes.ty) * tcinstance * is_local + | Th_instance of (symbol option * tcinstance) | Th_typeclass of (symbol * tc_decl) | Th_baserw of symbol * is_local | Th_addrw of EcPath.path * EcPath.path list * is_local @@ -51,10 +51,17 @@ and ctheory = { cth_source : thsource option; } -and tcinstance = [ +and tcinstance = { + tci_params : ty_params; + tci_type : ty; + tci_instance : tcibody; + tci_local : locality; +} + +and tcibody = [ | `Ring of ring | `Field of field - | `General of typeclass * ((path * ty list) Mstr.t) option + | `General of typeclass * ((path * etyarg list) Mstr.t) option ] and thmode = [ `Abstract | `Concrete ] diff --git a/src/ecTheory.mli b/src/ecTheory.mli index 7e7a8547cf..5cb708ebeb 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -28,7 +28,7 @@ and theory_item_r = | Th_module of top_module_expr | Th_theory of (symbol * ctheory) | Th_export of EcPath.path * is_local - | Th_instance of (ty_params * EcTypes.ty) * tcinstance * is_local + | Th_instance of (symbol option * tcinstance) | Th_typeclass of (symbol * tc_decl) | Th_baserw of symbol * is_local | Th_addrw of EcPath.path * EcPath.path list * is_local @@ -47,10 +47,17 @@ and ctheory = { cth_source : thsource option; } -and tcinstance = [ +and tcinstance = { + tci_params : ty_params; + tci_type : ty; + tci_instance : tcibody; + tci_local : locality; +} + +and tcibody = [ | `Ring of ring | `Field of field - | `General of typeclass * ((path * ty list) Mstr.t) option + | `General of typeclass * ((path * etyarg list) Mstr.t) option ] and thmode = [ `Abstract | `Concrete ] diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 83a00f6e54..6ec2c74134 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -51,14 +51,17 @@ let keep_of_mode (mode : clmode) = (* -------------------------------------------------------------------- *) exception Incompatible of incompatible -let tparams_compatible rtyvars ntyvars = +(* FIXME:TC *) +let tparams_compatible (rtyvars : ty_params) (ntyvars : ty_params) = let rlen = List.length rtyvars and nlen = List.length ntyvars in if rlen <> nlen then - raise (Incompatible (NotSameNumberOfTyParam(rlen,nlen))) + raise (Incompatible (NotSameNumberOfTyParam (rlen, nlen))) let ty_compatible env ue (rtyvars, rty) (ntyvars, nty) = tparams_compatible rtyvars ntyvars; - let subst = CS.Tvar.init rtyvars (List.map tvar ntyvars) in + let subst = + let etyargs = etyargs_of_tparams ntyvars in + CS.Tvar.init (List.combine (List.fst rtyvars) etyargs) in let rty = CS.Tvar.subst subst rty in try EcUnify.unify env ue rty nty with EcUnify.UnificationFailure _ -> @@ -110,7 +113,7 @@ let rec tybody_compatible exn hyps ty_body1 ty_body2 = let tydecl_compatible env tyd1 tyd2 = let params = tyd1.tyd_params in tparams_compatible params tyd2.tyd_params; - let tparams = List.map (fun (id,_) -> tvar id) params in + let tparams = etyargs_of_tparams params in let ty_body1 = tyd1.tyd_type in let ty_body2 = EcSubst.open_tydecl tyd2 tparams in let exn = Incompatible (TyBody(*tyd1,tyd2*)) in @@ -140,10 +143,10 @@ let rec oper_compatible exn env ob1 ob2 = let ri = { EcReduction.full_red with delta_p = fun _-> `Force; } in error_body exn (EcReduction.is_conv ~ri:ri (EcEnv.LDecl.init env []) f1 f2) | OP_Plain({f_node = Fop(p,tys)},_), _ -> - let ob1 = get_open_oper exn env p (List.fst tys) in (* FIXME: TC *) + let ob1 = get_open_oper exn env p tys in oper_compatible exn env ob1 ob2 | _, OP_Plain({f_node = Fop(p,tys)}, _) -> - let ob2 = get_open_oper exn env p (List.fst tys) in (* FIXME: TC *) + let ob2 = get_open_oper exn env p tys in oper_compatible exn env ob1 ob2 | OP_Constr(p1,i1), OP_Constr(p2,i2) -> error_body exn (EcPath.p_equal p1 p2 && i1 = i2) @@ -199,10 +202,10 @@ let rec pred_compatible exn env pb1 pb2 = match pb1, pb2 with | PR_Plain f1, PR_Plain f2 -> error_body exn (EcReduction.is_conv (EcEnv.LDecl.init env []) f1 f2) | PR_Plain {f_node = Fop(p,tys)}, _ -> - let pb1 = get_open_pred exn env p (List.fst tys) in (* FIXME: TC *) + let pb1 = get_open_pred exn env p tys in pred_compatible exn env pb1 pb2 | _, PR_Plain {f_node = Fop(p,tys)} -> - let pb2 = get_open_pred exn env p (List.fst tys) in (* FIXME: TC *) + let pb2 = get_open_pred exn env p tys in pred_compatible exn env pb1 pb2 | PR_Ind pr1, PR_Ind pr2 -> ind_compatible exn env pr1 pr2 @@ -231,7 +234,7 @@ let operator_compatible env oper1 oper2 = let params = oper1.op_tparams in tparams_compatible oper1.op_tparams oper2.op_tparams; let oty1, okind1 = oper1.op_ty, oper1.op_kind in - let tparams = List.map (fun (id,_) -> tvar id) params in + let tparams = etyargs_of_tparams params in let oty2, okind2 = EcSubst.open_oper oper2 tparams in if not (EcReduction.EqTest.for_type env oty1 oty2) then raise (Incompatible (DifferentType(oty1, oty2))); @@ -374,17 +377,17 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | `Datatype { tydt_ctors = octors }, Tconstr (np, _) -> begin match (EcEnv.Ty.by_path np env).tyd_type with | `Datatype { tydt_ctors = _ } -> - let newtparams = List.fst newtyd.tyd_params in - let newtparams_ty = List.map tvar newtparams in - let newdtype = tconstr np newtparams_ty in - let tysubst = CS.Tvar.init (List.fst otyd.tyd_params) newtparams_ty in + let newtparams = etyargs_of_tparams newtyd.tyd_params in + let newdtype = tconstr_tc np newtparams in + let tysubst = + CS.Tvar.init (List.combine (List.fst otyd.tyd_params) newtparams) in List.fold_left (fun subst (name, tyargs) -> let np = EcPath.pqoname (EcPath.prefix np) name in let newtyargs = List.map (CS.Tvar.subst tysubst) tyargs in EcSubst.add_opdef subst (xpath ove name) - (newtparams, e_op np newtparams_ty (toarrow newtyargs newdtype))) + (List.fst newtyd.tyd_params, e_op_tc np newtparams (toarrow newtyargs newdtype))) subst octors | _ -> subst end @@ -457,8 +460,8 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = in begin try ty_compatible env ue - (List.map fst reftyvars, refty) - (List.map fst (EcUnify.UniEnv.tparams ue), ty) + (reftyvars, refty) + (EcUnify.UniEnv.tparams ue, ty) with Incompatible err -> clone_error env (CE_OpIncompatible ((snd ove.ovre_prefix, x), err)) end; @@ -571,8 +574,8 @@ and replay_prd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopr) = begin try ty_compatible env ue - (List.map fst reftyvars, refty) - (List.map fst (EcUnify.UniEnv.tparams ue), body.f_ty) + (reftyvars, refty) + (EcUnify.UniEnv.tparams ue, body.f_ty) with Incompatible err -> clone_error env (CE_OpIncompatible ((snd ove.ovre_prefix, x), err)) @@ -885,7 +888,7 @@ and replay_typeclass (* -------------------------------------------------------------------- *) and replay_instance - (ove : _ ovrenv) (subst, ops, proofs, scope) (import, (typ, ty), tc, lc) + (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, tci) = let opath = ove.ovre_opath in let npath = ove.ovre_npath in @@ -924,13 +927,14 @@ and replay_instance let forpath p = odfl p (forpath p) in let fortypeclass (tc : typeclass) = - (* FIXME: TC *) { tc_name = forpath tc.tc_name; - tc_args = List.map (EcSubst.subst_ty subst) tc.tc_args; } in + tc_args = List.map (EcSubst.subst_etyarg subst) tc.tc_args; } in try - let (typ, ty) = EcSubst.subst_genty subst (typ, ty) in - let tc = + let subst, tci_params = EcSubst.fresh_tparams subst tci.tci_params in + let tci_type = EcSubst.subst_ty subst tci.tci_type in + + let tci_instance : tcibody = let rec doring cr = { r_type = EcSubst.subst_ty subst cr.r_type; r_zero = forpath cr.r_zero; @@ -953,7 +957,7 @@ and replay_instance f_inv = forpath cr.f_inv; f_div = cr.f_div |> omap forpath; } in - match tc with + match tci.tci_instance with | `Ring cr -> `Ring (doring cr) | `Field cr -> `Field (dofield cr) @@ -962,13 +966,15 @@ and replay_instance let syms = Option.map (Mstr.map (fun (p, tys) -> - (forpath p, List.map (EcSubst.subst_ty subst) tys))) + (forpath p, List.map (EcSubst.subst_etyarg subst) tys))) syms in `General (tc, syms) in + let tci = { tci with tci_params; tci_type; tci_instance; } in + let scope = - ove.ovre_hooks.hadd_item scope import (Th_instance ((typ, ty), tc, lc)) + ove.ovre_hooks.hadd_item scope import (Th_instance (x, tci)) in (subst, ops, proofs, scope) with E.InvInstPath -> @@ -1016,8 +1022,8 @@ and replay1 (ove : _ ovrenv) (subst, ops, proofs, scope) item = | Th_typeclass (x, tc) -> replay_typeclass ove (subst, ops, proofs, scope) (item.ti_import, x, tc) - | Th_instance ((typ, ty), tc, lc) -> - replay_instance ove (subst, ops, proofs, scope) (item.ti_import, (typ, ty), tc, lc) + | Th_instance (x, tci) -> + replay_instance ove (subst, ops, proofs, scope) (item.ti_import, x, tci) | Th_theory (ox, cth) -> begin let thmode = cth.cth_mode in diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 417e2a07b3..ba5195a1f4 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -52,17 +52,18 @@ let rec dump_ty ty = | Tconstr (p, tys) -> Printf.sprintf "%s[%s]" (EcPath.tostring p) - (String.concat ", " (List.map dump_ty tys)) + (String.concat ", " (List.map dump_ty (List.fst tys))) | Tfun (t1, t2) -> Printf.sprintf "(%s) -> (%s)" (dump_ty t1) (dump_ty t2) (* -------------------------------------------------------------------- *) -let tuni uid = mk_ty (Tunivar uid) -let tvar id = mk_ty (Tvar id) -let tconstr p lt = mk_ty (Tconstr (p, lt)) -let tfun t1 t2 = mk_ty (Tfun (t1, t2)) -let tglob m = mk_ty (Tglob m) +let tuni uid = mk_ty (Tunivar uid) +let tvar id = mk_ty (Tvar id) +let tconstr p lt = mk_ty (Tconstr (p, List.map (fun ty -> (ty, [])) lt)) +let tconstr_tc p lt = mk_ty (Tconstr (p, lt)) +let tfun t1 t2 = mk_ty (Tfun (t1, t2)) +let tglob m = mk_ty (Tglob m) (* -------------------------------------------------------------------- *) let tunit = tconstr EcCoreLib.CI_Unit .p_unit [] @@ -103,7 +104,7 @@ let rec tyfun_flat (ty : ty) = (* -------------------------------------------------------------------- *) let as_tdistr (ty : ty) = match ty.ty_node with - | Tconstr (p, [sty]) + | Tconstr (p, [sty, []]) when EcPath.p_equal p EcCoreLib.CI_Distr.p_distr -> Some sty @@ -112,7 +113,7 @@ let as_tdistr (ty : ty) = let is_tdistr (ty : ty) = as_tdistr ty <> None (* -------------------------------------------------------------------- *) -let ty_map f t = +let rec ty_map (f : ty -> ty) (t : ty) : ty = match t.ty_node with | Tglob _ | Tunivar _ | Tvar _ -> t @@ -120,39 +121,85 @@ let ty_map f t = ttuple (List.Smart.map f lty) | Tconstr (p, lty) -> - let lty = List.Smart.map f lty in - tconstr p lty + let lty = List.Smart.map (etyarg_map f) lty in + tconstr_tc p lty | Tfun (t1, t2) -> tfun (f t1) (f t2) -let ty_fold f s ty = - match ty.ty_node with - | Tglob _ | Tunivar _ | Tvar _ -> s - | Ttuple lty -> List.fold_left f s lty - | Tconstr(_, lty) -> List.fold_left f s lty - | Tfun(t1,t2) -> f (f s t1) t2 +and etyarg_map (f : ty -> ty) ((ty, tcw) : etyarg) : etyarg = + let ty = f ty in + let tcw = List.Smart.map (tcw_map f) tcw in + (ty, tcw) -let ty_sub_exists f t = - match t.ty_node with - | Tglob _ | Tunivar _ | Tvar _ -> false - | Ttuple lty -> List.exists f lty - | Tconstr (_, lty) -> List.exists f lty - | Tfun (t1, t2) -> f t1 || f t2 +and tcw_map (f : ty -> ty) (tcw : tcwitness) : tcwitness = + match tcw with + | TCIConcrete { path; etyargs; } -> + let etyargs = List.Smart.map (etyarg_map f) etyargs in + TCIConcrete { path; etyargs; } -let ty_iter f t = - match t.ty_node with - | Tglob _ | Tunivar _ | Tvar _ -> () - | Ttuple lty -> List.iter f lty - | Tconstr (_, lty) -> List.iter f lty - | Tfun (t1,t2) -> f t1; f t2 + | TCIAbstract _ -> + tcw +(* -------------------------------------------------------------------- *) +let rec ty_fold (f : 'a -> ty -> 'a) (v : 'a) (ty : ty) : 'a = + match ty.ty_node with + | Tglob _ | Tunivar _ | Tvar _ -> v + | Ttuple lty -> List.fold_left f v lty + | Tconstr (_, lty) -> List.fold_left (etyarg_fold f) v lty + | Tfun (t1, t2) -> f (f v t1) t2 + +and etyarg_fold (f : 'a -> ty -> 'a) (v : 'a) (ety : etyarg) : 'a = + let (ty, tcw) = ety in + List.fold_left (tcw_fold f) (f v ty) tcw + +and tcw_fold (f : 'a -> ty -> 'a) (v : 'a) (tcw : tcwitness) : 'a = + match tcw with + | TCIConcrete { etyargs } -> + List.fold_left (etyarg_fold f) v etyargs + + | TCIAbstract _ -> + v + +(* -------------------------------------------------------------------- *) +let ty_iter (f : ty -> unit) (ty : ty) : unit = + ty_fold (fun () -> f) () ty + +let etyarg_iter (f : ty -> unit) (ety : etyarg) : unit = + etyarg_fold (fun () -> f) () ety + +let tcw_iter (f : ty -> unit) (tcw : tcwitness) : unit = + tcw_fold (fun () -> f) () tcw + +(* -------------------------------------------------------------------- *) +let ty_sub_exists (f : ty -> bool) (ty : ty) = + let exception Exists in + try + ty_iter (fun ty -> if f ty then raise Exists) ty; + false + with Exists -> true + +let etyarg_sub_exists (f : ty -> bool) (ety : etyarg) = + let exception Exists in + try + etyarg_iter (fun ty -> if f ty then raise Exists) ety; + false + with Exists -> true + +let tcw_sub_exists (f : ty -> bool) (tcw : tcwitness) = + let exception Exists in + try + tcw_iter (fun ty -> if f ty then raise Exists) tcw; + false + with Exists -> true + +(* -------------------------------------------------------------------- *) exception FoundUnivar -let rec ty_check_uni t = - match t.ty_node with +let rec ty_check_uni (ty : ty) : unit = + match ty.ty_node with | Tunivar _ -> raise FoundUnivar - | _ -> ty_iter ty_check_uni t + | _ -> ty_iter ty_check_uni ty (* -------------------------------------------------------------------- *) let symbol_of_ty (ty : ty) = @@ -197,7 +244,6 @@ let ovar_of_var { v_name = n; v_type = t } = { ov_name = Some n; ov_type = t } module Tvar = struct - let rec fv_rec fv t = match t.ty_node with | Tvar id -> Sid.add id fv @@ -223,9 +269,17 @@ and tcws_tvar_fv (tcws : tcwitness list) = (fun fv tcw -> Sid.union fv (tcw_tvar_fv tcw)) Sid.empty tcws -and tcw_tvar_fv ((etyargs, _) : tcwitness) : Sid.t = - etyargs_tvar_fv etyargs +and tcw_tvar_fv (tcw : tcwitness) : Sid.t = + match tcw with + | TCIConcrete { etyargs } -> + etyargs_tvar_fv etyargs + + | TCIAbstract { support = `Var tyvar } -> + Sid.singleton tyvar + | TCIAbstract { support = (`Univar _ | `Abs _) } -> + Sid.empty + (* -------------------------------------------------------------------- *) type pvar_kind = EcAst.pvar_kind @@ -392,13 +446,6 @@ let e_proj_simpl e i ty = | _ -> e_proj e i ty let e_quantif q b e = - if List.is_empty b then e else - - let b, e = - match e.e_node with - | Equant (q', b', e) when eqt_equal q q' -> (b@b', e) - | _ -> b, e in - let ty = match q with | `ELambda -> toarrow (List.map snd b) e.e_ty @@ -411,11 +458,7 @@ let e_exists b e = e_quantif `EExists b e let e_lam b e = e_quantif `ELambda b e let e_app x args ty = - if args = [] then x - else - match x.e_node with - | Eapp(x', args') -> mk_expr (Eapp (x', (args'@args))) ty - | _ -> mk_expr (Eapp (x, args)) ty + mk_expr (Eapp (x, args)) ty let e_app_op ?(tyargs=[]) op args ty = e_app (e_op op tyargs (toarrow (List.map e_ty args) ty)) args ty @@ -471,63 +514,33 @@ let e_oget (e : expr) (ty : ty) : expr = e_app op [e] ty (* -------------------------------------------------------------------- *) -let rec tcw_map fty ((w, p) as wp : tcwitness) : tcwitness= - let for1 ((ty, ws) as arg) = - SmartPair.mk arg (fty ty) (List.Smart.map (tcw_map fty) ws) - in SmartPair.mk wp (List.map for1 w) p - -let etyarg_map fty ((ty, tcw) as arg : etyarg) : etyarg = - SmartPair.mk arg (fty ty) (List.Smart.map (tcw_map fty) tcw) - -(* -------------------------------------------------------------------- *) -let e_map fty fe e = +let e_map (fe : expr -> expr) (e : expr) : expr = match e.e_node with - | Eint _ | Elocal _ | Evar _ -> e - - | Eop (p, tyargs) -> - let tyargs' = List.Smart.map (etyarg_map fty) tyargs in - let ty' = fty e.e_ty in - e_op_tc p tyargs' ty' + | Eint _ -> e + | Elocal _ -> e + | Evar _ -> e + | Eop _ -> e | Eapp (e1, args) -> - let e1' = fe e1 in - let args' = List.Smart.map fe args in - let ty' = fty e.e_ty in - e_app e1' args' ty' + e_app (fe e1) (List.Smart.map fe args) e.e_ty | Elet (lp, e1, e2) -> - let e1' = fe e1 in - let e2' = fe e2 in - e_let lp e1' e2' + e_let lp (fe e1) (fe e2) | Etuple le -> - let le' = List.Smart.map fe le in - e_tuple le' + e_tuple (List.Smart.map fe le) | Eproj (e1, i) -> - let e' = fe e1 in - let ty = fty e.e_ty in - e_proj e' i ty + e_proj (fe e1) i e.e_ty | Eif (e1, e2, e3) -> - let e1' = fe e1 in - let e2' = fe e2 in - let e3' = fe e3 in - e_if e1' e2' e3' + e_if (fe e1) (fe e2) (fe e3) - | Ematch (b, es, ty) -> - let ty' = fty ty in - let b' = fe b in - let es' = List.Smart.map fe es in - e_match b' es' ty' + | Ematch (e, bs, ty) -> + e_match (fe e) (List.Smart.map fe bs) ty | Equant (q, b, bd) -> - let dop (x, ty as xty) = - let ty' = fty ty in - if ty == ty' then xty else (x, ty') in - let b' = List.Smart.map dop b in - let bd' = fe bd in - e_quantif q b' bd' + e_quantif q b (fe bd) let e_fold (fe : 'a -> expr -> 'a) (state : 'a) (e : expr) = match e.e_node with @@ -597,3 +610,4 @@ let split_args e = match e.e_node with | Eapp (e, args) -> (e, args) | _ -> (e, []) + \ No newline at end of file diff --git a/src/ecTypes.mli b/src/ecTypes.mli index e30fa64990..1c3def08f0 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -1,4 +1,6 @@ (* -------------------------------------------------------------------- *) + +open EcAst open EcBigInt open EcMaps open EcSymbols @@ -27,13 +29,14 @@ val dump_ty : ty -> string val ty_equal : ty -> ty -> bool val ty_hash : ty -> int -val tuni : EcUid.uid -> ty -val tvar : EcIdent.t -> ty -val ttuple : ty list -> ty -val tconstr : EcPath.path -> ty list -> ty -val tfun : ty -> ty -> ty -val tglob : EcIdent.t -> ty -val tpred : ty -> ty +val tuni : EcUid.uid -> ty +val tvar : EcIdent.t -> ty +val ttuple : ty list -> ty +val tconstr : EcPath.path -> ty list -> ty +val tconstr_tc : EcPath.path -> EcAst.etyarg list -> ty +val tfun : ty -> ty -> ty +val tglob : EcIdent.t -> ty +val tpred : ty -> ty val ty_fv_and_tvar : ty -> int Mid.t @@ -65,18 +68,29 @@ val ty_check_uni : ty -> unit (* -------------------------------------------------------------------- *) module Tvar : sig - val fv : ty -> Sid.t + val fv : ty -> Sid.t end (* -------------------------------------------------------------------- *) (* [map f t] applies [f] on strict subterms of [t] (not recursive) *) val ty_map : (ty -> ty) -> ty -> ty +val etyarg_map : (ty -> ty) -> etyarg -> etyarg +val tcw_map : (ty -> ty) -> tcwitness -> tcwitness (* [sub_exists f t] true if one of the strict-subterm of [t] valid [f] *) val ty_sub_exists : (ty -> bool) -> ty -> bool +val etyarg_sub_exists : (ty -> bool) -> etyarg -> bool +val tcw_sub_exists : (ty -> bool) -> tcwitness -> bool +(* -------------------------------------------------------------------- *) val ty_fold : ('a -> ty -> 'a) -> 'a -> ty -> 'a +val etyarg_fold : ('a -> ty -> 'a) -> 'a -> etyarg -> 'a +val tcw_fold : ('a -> ty -> 'a) -> 'a -> tcwitness -> 'a + +(* -------------------------------------------------------------------- *) val ty_iter : (ty -> unit) -> ty -> unit +val etyarg_iter : (ty -> unit) -> etyarg -> unit +val tcw_iter : (ty -> unit) -> tcwitness -> unit (* -------------------------------------------------------------------- *) val symbol_of_ty : ty -> string @@ -164,7 +178,6 @@ val etyarg_fv : etyarg -> int Mid.t val etyargs_fv : etyarg list -> int Mid.t val etyarg_hash : etyarg -> int val etyarg_equal : etyarg -> etyarg -> bool -val etyarg_map : (ty -> ty) -> etyarg -> etyarg (* -------------------------------------------------------------------- *) type tcwitness = EcAst.tcwitness @@ -230,8 +243,7 @@ val split_args : expr -> expr * expr list (* -------------------------------------------------------------------- *) val e_map : - (ty -> ty ) (* 1-subtype op. *) - -> (expr -> expr) (* 1-subexpr op. *) + (expr -> expr) (* 1-subexpr op. *) -> expr -> expr diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 6f2aa6469e..9c24bfbf1c 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -25,7 +25,7 @@ let wp = (ref (None : wp option)) (* -------------------------------------------------------------------- *) type opmatch = [ - | `Op of EcPath.path * EcTypes.ty list + | `Op of EcPath.path * EcTypes.etyarg list | `Lc of EcIdent.t | `Var of EcTypes.prog_var | `Proj of EcTypes.prog_var * EcMemory.proj_arg @@ -200,7 +200,7 @@ let unify_or_fail (env : EcEnv.env) ue loc ~expct:ty1 ty2 = let tyinst = ty_subst (Tuni.subst uidmap) in tyerror loc env (TypeMismatch ((tyinst ty1, tyinst ty2), (tyinst t1, tyinst t2))) - | `TcCtt _ -> + | `TcCtt _ | `TcTw _ -> (* FIXME: proper error message *) tyerror loc env TypeClassMismatch (* -------------------------------------------------------------------- *) @@ -325,7 +325,7 @@ module OpSelect = struct type opsel = [ | `Pv of EcMemory.memory option * pvsel - | `Op of (EcPath.path * ty list) + | `Op of (EcPath.path * etyarg list) | `Lc of EcIdent.ident | `Nt of EcUnify.sbody ] @@ -352,7 +352,7 @@ let gen_select_op let fpv me (pv, ty, ue) = (`Pv (me, pv), ty, ue, (pv :> opmatch)) - and fop (op, ty, ue, bd) = + and fop ((op : path * etyarg list), ty, ue, bd) = match bd with | None -> (`Op op, ty, ue, (`Op op :> opmatch)) | Some bd -> (`Nt bd, ty, ue, (`Op op :> opmatch)) @@ -952,7 +952,7 @@ let trans_msymbol env msymb = (m,mt) (* -------------------------------------------------------------------- *) -let rec transty (tp : typolicy) (env : EcEnv.env) ue ty = +let rec transty (tp : typolicy) (env : EcEnv.env) (ue : EcUnify.unienv) (ty : pty) : ty = match ty.pl_desc with | PTunivar -> if tp.tp_uni @@ -1018,20 +1018,20 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = tyerror (loc tc_name) env (UnknownTypeClass (unloc tc_name)) | Some (p, decl) -> - let args = List.map (transty tp_tydecl env ue) args in - if List.length decl.tc_tparams <> List.length args then begin - tyerror (loc tc_name) env - (TCArgsCountMismatch (unloc tc_name, decl.tc_tparams, args)); - end; - - (* FIXME: TC *) - List.iter2 - (fun (_, tcs) ty -> - List.iter (fun tc -> - if Option.is_none (EcUnify.hastc env ue ty tc) then - tyerror (loc tc_name) env (CannotInferTC (ty, tc))) tcs) - decl.tc_tparams args; - { tc_name = p; tc_args = args; } + let args = List.map (transty tp_tydecl env ue) args in + + if List.length decl.tc_tparams <> List.length args then begin + tyerror (loc tc_name) env + (TCArgsCountMismatch (unloc tc_name, decl.tc_tparams, args)); + end; + + let tvi = EcUnify.UniEnv.opentvi ue decl.tc_tparams None in + + List.iter2 + (fun (ty, _) aty -> EcUnify.unify env ue ty aty) + tvi.args args; + + { tc_name = p; tc_args = tvi.args; } (* -------------------------------------------------------------------- *) let transtyvars (env : EcEnv.env) (loc, (tparams : ptyparams option)) = @@ -1099,8 +1099,8 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = let recty = oget (EcEnv.Ty.by_path_opt recp env) in let rec_ = snd (oget (EcDecl.tydecl_as_record recty)) in let reccty = tconstr recp (List.map (tvar |- fst) recty.tyd_params) in - let reccty, rectvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in - let rectvi = List.fst rectvi in (* FIXME:TC *) + let reccty, recopnd = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in + let fields = List.fold_left (fun map (((_, idx), _, _) as field) -> @@ -1120,8 +1120,9 @@ let transpattern1 env ue (p : EcParsetree.plpattern) = let pty = EcUnify.UniEnv.fresh ue in let fty = snd (List.nth rec_ i) in let fty, _ = - EcUnify.UniEnv.openty ue recty.tyd_params - (Some (EcUnify.TVIunamed rectvi)) fty + EcUnify.UniEnv.openty + ue recty.tyd_params + (Some (EcUnify.tvi_unamed recopnd.args)) fty in (try EcUnify.unify env ue pty fty with EcUnify.UnificationFailure _ -> assert false); @@ -1154,7 +1155,9 @@ let transpattern env ue (p : EcParsetree.plpattern) = let transtvi env ue tvi = match tvi.pl_desc with | TVIunamed lt -> - EcUnify.TVIunamed (List.map (transty tp_relax env ue) lt) + let tys = List.map (transty tp_relax env ue) lt in + let tvi = List.map (fun ty -> (Some ty, None)) tys in + EcUnify.TVIunamed tvi | TVInamed lst -> let add locals (s, t) = @@ -1163,8 +1166,9 @@ let transtvi env ue tvi = (s, transty tp_relax env ue t) :: locals in - let lst = List.fold_left add [] lst in - EcUnify.TVInamed (List.rev_map (fun (s,t) -> unloc s, t) lst) + let tvi = List.fold_left add [] lst in + let tvi = List.map (snd_map (fun ty -> (Some ty, None))) tvi in + EcUnify.TVInamed (List.rev_map (fun (s, t) -> unloc s, t) tvi) let rec destr_tfun env ue tf = match tf.ty_node with @@ -1239,10 +1243,8 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = let recty = oget (EcEnv.Ty.by_path_opt recp env) in let rec_ = snd (oget (EcDecl.tydecl_as_record recty)) in - let reccty = tconstr recp (List.map (tvar |- fst) recty.tyd_params) in - let reccty, rtvi = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in - let rtvi = List.fst rtvi in (* FIXME:TC *) - let tysopn = Tvar.init (List.fst recty.tyd_params) rtvi in + let reccty = tconstr_tc recp (EcDecl.etyargs_of_tparams recty.tyd_params) in + let reccty, ropnd = EcUnify.UniEnv.openty ue recty.tyd_params None reccty in let fields = List.fold_left @@ -1271,7 +1273,7 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = | None -> match dflrec with | None -> tyerror loc env (MissingRecField name) - | Some _ -> `Dfl (Tvar.subst tysopn rty, name) + | Some _ -> `Dfl (Tvar.subst ropnd.subst rty, name) in List.mapi (fun i (name, rty) -> get_field i name rty) rec_ in @@ -1287,7 +1289,7 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = | `Dfl (rty, name) -> let nm = oget (EcPath.prefix recp) in - (proj (nm, name, (rtvi, reccty), rty, oget dflrec), rty) + (proj (nm, name, (ropnd.args, reccty), rty, oget dflrec), rty) in List.map for1 fields @@ -1298,7 +1300,7 @@ let trans_record env ue (subtt, proj) (loc, b, fields) = (EcPath.prefix recp) (Printf.sprintf "mk_%s" (EcPath.basename recp)) in - (ctor, fields, (rtvi, reccty)) + (ctor, fields, (ropnd.args, reccty)) (* -------------------------------------------------------------------- *) let trans_branch ~loc env ue gindty ((pb, body) : ppattern * _) = @@ -1337,8 +1339,8 @@ let trans_branch ~loc env ue gindty ((pb, body) : ppattern * _) = EcUnify.UniEnv.restore ~src:subue ~dst:ue; let ctorty = - let tvi = Some (EcUnify.TVIunamed tvi) in - fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in + let tvi = Some (EcUnify.tvi_unamed tvi) in + fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in let pty = EcUnify.UniEnv.fresh ue in (try EcUnify.unify env ue (toarrow ctorty pty) opty @@ -1428,7 +1430,7 @@ let expr_of_opselect (e_lam elam body, args) | (`Op _ | `Lc _ | `Pv _) as sel -> let op = match sel with - | `Op (p, tys) -> e_op p tys ty + | `Op (p, tys) -> e_op_tc p tys ty | `Lc id -> e_local id ty | `Pv (_me, pv) -> var_or_proj e_var e_proj pv ty @@ -1585,10 +1587,10 @@ let transexp (env : EcEnv.env) mode ue e = let (ctor, fields, (rtvi, reccty)) = let proj (recp, name, (rtvi, reccty), pty, arg) = let proj = EcPath.pqname recp name in - let proj = e_op proj rtvi (tfun reccty pty) in + let proj = e_op_tc proj rtvi (tfun reccty pty) in e_app proj [arg] pty in trans_record env ue (transexp env, proj) (loc, b, fields) in - let ctor = e_op ctor rtvi (toarrow (List.map snd fields) reccty) in + let ctor = e_op_tc ctor rtvi (toarrow (List.map snd fields) reccty) in let ctor = e_app ctor (List.map fst fields) reccty in ctor, reccty @@ -1606,7 +1608,7 @@ let transexp (env : EcEnv.env) mode ue e = let rty = EcUnify.UniEnv.fresh ue in (try EcUnify.unify env ue (tfun ety rty) pty with EcUnify.UnificationFailure _ -> assert false); - (e_app (e_op op tvi pty) [sube] rty, rty) + (e_app (e_op_tc op tvi pty) [sube] rty, rty) end | PEproji (sube, i) -> begin @@ -1830,7 +1832,7 @@ let form_of_opselect in (f_lambda flam (Fsubst.f_subst subst body), args) | (`Op _ | `Lc _ | `Pv _) as sel -> let op = match sel with - | `Op (p, tys) -> f_op p tys ty + | `Op (p, tys) -> f_op_tc p tys ty | `Lc id -> f_local id ty | `Pv (me, pv) -> var_or_proj (fun x ty -> f_pvar x ty (oget me)) f_proj pv ty @@ -1847,7 +1849,7 @@ let form_of_opselect * - e is the index to update * - ty is the type of the value [x] *) -type lvmap = (path * ty list) * prog_var * expr * ty +type lvmap = (path * etyarg list) * prog_var * expr * ty type lVAl = | Lval of lvalue @@ -1857,7 +1859,7 @@ let i_asgn_lv (_loc : EcLocation.t) (_env : EcEnv.env) lv e = match lv with | Lval lv -> i_asgn (lv, e) | LvMap ((op,tys), x, ei, ty) -> - let op = e_op op tys (toarrow [ty; ei.e_ty; e.e_ty] ty) in + let op = e_op_tc op tys (toarrow [ty; ei.e_ty; e.e_ty] ty) in i_asgn (LvVar (x,ty), e_app op [e_var x ty; ei; e] ty) let i_rnd_lv loc env lv e = @@ -3288,12 +3290,12 @@ and trans_form_or_pattern env ?mv ?ps ue pf tt = let (ctor, fields, (rtvi, reccty)) = let proj (recp, name, (rtvi, reccty), pty, arg) = let proj = EcPath.pqname recp name in - let proj = f_op proj rtvi (tfun reccty pty) in + let proj = f_op_tc proj rtvi (tfun reccty pty) in f_app proj [arg] pty in trans_record env ue ((fun f -> let f = transf env f in (f, f.f_ty)), proj) (f.pl_loc, b, fields) in - let ctor = f_op ctor rtvi (toarrow (List.map snd fields) reccty) in + let ctor = f_op_tc ctor rtvi (toarrow (List.map snd fields) reccty) in f_app ctor (List.map fst fields) reccty | PFproj (subf, x) -> begin @@ -3311,7 +3313,7 @@ and trans_form_or_pattern env ?mv ?ps ue pf tt = let rty = EcUnify.UniEnv.fresh ue in (try EcUnify.unify env ue (tfun subf.f_ty rty) pty with EcUnify.UnificationFailure _ -> assert false); - f_app (f_op op tvi pty) [subf] rty + f_app (f_op_tc op tvi pty) [subf] rty end | PFproji (psubf, i) -> begin @@ -3445,15 +3447,21 @@ and trans_pattern env ps ue pf = (* -------------------------------------------------------------------- *) let get_instances (tvi, bty) env = - let inst = List.pmap - (function - | (_, (`Ring _ | `Field _)) as x -> Some x - | _ -> None) - (EcEnv.TypeClass.get_instances env) in + let inst = + let filter ((_, tci) : path option * EcTheory.tcinstance) = + match tci with + | EcTheory.{ + tci_params = []; + tci_instance = (`Ring _ | `Field _) as bd + } -> Some (tci.tci_type, bd) + + | _ -> None + + in List.pmap filter (EcEnv.TcInstance.get_all env) in - List.pmap (fun ((typ, gty), cr) -> + List.pmap (fun (gty, cr) -> let ue = EcUnify.UniEnv.create (Some tvi) in - let (gty, _typ) = EcUnify.UniEnv.openty ue typ None gty in + let (gty, _) = EcUnify.UniEnv.openty ue [] None gty in try EcUnify.unify env ue bty gty; let ts = Tuni.subst (UE.close ue) in diff --git a/src/ecTyping.mli b/src/ecTyping.mli index bc23950176..1be2dc148c 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -16,7 +16,7 @@ val wp : wp option ref (* -------------------------------------------------------------------- *) type opmatch = [ - | `Op of EcPath.path * EcTypes.ty list + | `Op of EcPath.path * EcTypes.etyarg list | `Lc of EcIdent.t | `Var of EcTypes.prog_var | `Proj of EcTypes.prog_var * EcMemory.proj_arg @@ -25,7 +25,7 @@ type opmatch = [ type 'a mismatch_sets = [`Eq of 'a * 'a | `Sub of 'a ] -type 'a suboreq = [`Eq of 'a | `Sub of 'a ] +type 'a suboreq = [`Eq of 'a | `Sub of 'a ] type mismatch_funsig = | MF_targs of ty * ty (* expected, got *) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 06f5f3f44d..adcbfa6f0d 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -11,47 +11,20 @@ open EcDecl module Sp = EcPath.Sp -(* -------------------------------------------------------------------- *) -exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * typeclass] -exception UninstanciateUni - (* ==================================================================== *) -module type UFRaw = sig - type uf - type data - - val set : uid -> data * ty option -> uf -> uf -end +type problem = [ + | `TyUni of ty * ty + | `TcTw of tcwitness * tcwitness + | `TcCtt of EcUid.uid * ty * typeclass +] (* ==================================================================== *) -module type UnifyExtra = sig - type state - type problem +exception UnificationFailure of problem - exception Failure - - module State : sig - val default : state - val union : state * ty option -> state * ty option -> state * problem list - end - - module Problem : sig - val solve : - (module EcUFind.S - with type t = 'uf - and type item = uid - and type data = state * ty option) - -> 'uf ref -> EcEnv.env -> state Mid.t -> problem -> problem list - end -end +exception UninstanciateUni (* ==================================================================== *) -module UnifyGen(X : UnifyExtra) = struct - (* ------------------------------------------------------------------ *) - type pb = [ `TyUni of (ty * ty) | `Other of X.problem ] - - exception UnificationFailure of pb - +module Unify = struct module UFArgs = struct module I = struct type t = uid @@ -61,20 +34,19 @@ module UnifyGen(X : UnifyExtra) = struct end module D = struct - type data = X.state * ty option - type effects = pb list + type data = ty option + type effects = problem list let default : data = - (X.State.default, None) + None - let isvoid ((_, x) : data) = - (x = None) + let isvoid (x : data) = + Option.is_none x let noeffects : effects = [] - let union ((_, ty1) as d1 : data) ((_, ty2) as d2 : data) : data * effects = - let pb, cts_pb = X.State.union d1 d2 in - let ty, cts_ty = + let union (ty1 : data) (ty2 : data) : data * effects = + let ty, cts = match ty1, ty2 with | None, None -> (None, []) @@ -84,11 +56,9 @@ module UnifyGen(X : UnifyExtra) = struct | None, Some ty | Some ty, None -> Some ty, [] in - let cts = - (List.map (fun x -> `Other x) cts_pb) - @ (List.map (fun x -> `TyUni x) cts_ty) in + let cts = List.map (fun x -> `TyUni x) cts in - (pb, ty), (cts :> effects) + ty, (cts :> effects) end end @@ -96,22 +66,85 @@ module UnifyGen(X : UnifyExtra) = struct module UF = EcUFind.Make(UFArgs.I)(UFArgs.D) (* ------------------------------------------------------------------ *) - let fresh ?(extra = X.State.default) ?ty uf = + type ucore = { + uf : UF.t; + tvtc : typeclass list Mid.t; + tcenv : tcenv; + } + + and tcenv = { + (* Map from UID to TC problems. The UID set collects all the * + * unification variables the TC problem depends on. Only * + * fully instantiated problems trigger a type-class resolution. * + * The UID is the univar from which the TC problem originates. *) + problems : (Suid.t * typeclass list) Muid.t; + + (* Map from univars to TC problems that depend on them. This * + * map is kept in sync with the UID set that appears in the * + * bindings of [problems] *) + byunivar : Suid.t Muid.t; + + (* Map from problems UID to type-class instance witness *) + resolution : tcwitness list Muid.t + } + + (* ------------------------------------------------------------------ *) + let initial_ucore ?(tvtc = Mid.empty) () : ucore = + let tcenv = + { problems = Muid.empty + ; byunivar = Muid.empty + ; resolution = Muid.empty } + in { uf = UF.initial; tvtc; tcenv; } + + (* ------------------------------------------------------------------ *) + let fresh + ?(tcs : (typeclass * tcwitness option) list option) + ?(ty : ty option) + ({ uf; tcenv } as uc : ucore) + = let uid = EcUid.unique () in + let uf = match ty with | Some { ty_node = Tunivar id } -> - let uf = UF.set uid (extra, None) uf in - fst (UF.union uid id uf) - | None | Some _ -> UF.set uid (extra, ty) uf + let uf = UF.set uid None uf in + let ty, effects = UF.union uid id uf in + assert (List.is_empty effects); + ty + | (None | Some _) as ty -> UF.set uid ty uf in - (uf, tuni uid) + + let ty = Option.value ~default:(tuni uid) (UF.data uid uf) in + + let tcs, tws = List.split (Option.value ~default:[] tcs) in + + let tws = tws |> List.mapi (fun i tcw -> + match tcw with + | None -> + TCIAbstract { support = `Univar uid; offset = i } + | Some tcw -> + tcw + ) in + + let tcenv = + let deps = Tuni.univars ty in + let problems = Muid.add uid (deps, tcs) tcenv.problems in + let byunivar = Suid.fold (fun duni byunivar -> + Muid.change (fun pbs -> + Some (Suid.add uid (Option.value ~default:Suid.empty pbs)) + ) duni byunivar + ) deps tcenv.byunivar in + let resolution = Muid.add uid tws tcenv.resolution in + { problems; byunivar; resolution; } + in + + ({ uc with uf; tcenv; }, (tuni uid, tws)) (* ------------------------------------------------------------------ *) - let unify_core (env : EcEnv.env) (tvtc : X.state Mid.t) (uf : UF.t) pb = + let unify_core (env : EcEnv.env) (uc : ucore) (pb : problem) : ucore = let failure () = raise (UnificationFailure pb) in - let uf = ref uf in + let uf = ref uc.uf in let pb = let x = Queue.create () in Queue.push pb x; x in let ocheck i t = @@ -122,16 +155,16 @@ module UnifyGen(X : UnifyExtra) = struct match t.ty_node with | Tunivar i' -> begin let i' = UF.find i' !uf in - match i' with - | _ when i = i' -> true - | _ when Hint.mem map i' -> false - | _ -> - match snd (UF.data i' !uf) with - | None -> Hint.add map i' (); false - | Some t -> - match doit t with - | true -> true - | false -> Hint.add map i' (); false + match i' with + | _ when i = i' -> true + | _ when Hint.mem map i' -> false + | _ -> + match UF.data i' !uf with + | None -> Hint.add map i' (); false + | Some t -> + match doit t with + | true -> true + | false -> Hint.add map i' (); false end | _ -> EcTypes.ty_sub_exists doit t @@ -141,24 +174,23 @@ module UnifyGen(X : UnifyExtra) = struct let setvar i t = let (ti, effects) = - UFArgs.D.union (UF.data i !uf) (X.State.default, Some t) + UFArgs.D.union (UF.data i !uf) (Some t) in - if odfl false (snd ti |> omap (ocheck i)) then failure (); + if odfl false (ti |> omap (ocheck i)) then failure (); List.iter (Queue.push^~ pb) effects; uf := UF.set i ti !uf and getvar t = match t.ty_node with - | Tunivar i -> snd_map (odfl t) (UF.data i !uf) - | _ -> (X.State.default, t) - + | Tunivar i -> odfl t (UF.data i !uf) + | _ -> t in let doit () = while not (Queue.is_empty pb) do match Queue.pop pb with | `TyUni (t1, t2) -> begin - let (t1, t2) = (snd (getvar t1), snd (getvar t2)) in + let (t1, t2) = (getvar t1, getvar t2) in match ty_equal t1 t2 with | true -> () @@ -182,8 +214,17 @@ module UnifyGen(X : UnifyExtra) = struct Queue.push (`TyUni (t2, t2')) pb | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> - if List.length lt1 <> List.length lt2 then failure (); - List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) lt1 lt2 + if List.length lt1 <> List.length lt2 then failure (); + + let ty1, tws1 = List.split lt1 in + let ty2, tws2 = List.split lt2 in + + List.iter2 (fun t1 t2 -> Queue.push (`TyUni (t1, t2)) pb) ty1 ty2; + + List.iter2 (fun tw1 tw2 -> + if List.length tw1 <> List.length tw2 then failure (); + List.iter2 (fun w1 w2 -> Queue.push (`TcTw (w1, w2)) pb) tw1 tw2 + ) tws1 tws2 | Tconstr (p, lt), _ when EcEnv.Ty.defined p env -> Queue.push (`TyUni (EcEnv.Ty.unfold p lt env, t2)) pb @@ -195,33 +236,29 @@ module UnifyGen(X : UnifyExtra) = struct end end - | `Other pb1 -> - try - List.iter - (fun x -> Queue.push (`Other x) pb) - (X.Problem.solve (module UF) uf env tvtc pb1) - with X.Failure -> failure () + | _ -> + () (* FIXME:TC *) done in - doit (); !uf + doit (); { uc with uf = !uf } (* -------------------------------------------------------------------- *) - let close (uf : UF.t) = + let close (uc : ucore) = let map = Hint.create 0 in let rec doit t = match t.ty_node with | Tunivar i -> begin - match Hint.find_opt map i with - | Some t -> t - | None -> begin - let t = - match snd (UF.data i uf) with - | None -> tuni (UF.find i uf) - | Some t -> doit t - in - Hint.add map i t; t - end + match Hint.find_opt map i with + | Some t -> t + | None -> begin + let t = + match UF.data i uc.uf with + | None -> tuni (UF.find i uc.uf) + | Some t -> doit t + in + Hint.add map i t; t + end end | _ -> ty_map doit t @@ -229,248 +266,38 @@ module UnifyGen(X : UnifyExtra) = struct fun t -> doit t (* ------------------------------------------------------------------ *) - let subst_of_uf (uf : UF.t) = - let close = close uf in + let subst_of_uf (uc : ucore) = + let close = close uc in List.fold_left (fun m uid -> match close (tuni uid) with | { ty_node = Tunivar uid' } when uid_equal uid uid' -> m - | t -> Muid.add uid t m - ) - Muid.empty (UF.domain uf) -end - -(* -------------------------------------------------------------------- *) -module UnifyExtraEmpty : - UnifyExtra with type state = unit - and type problem = unit = -struct - type state = unit - type problem = unit - type uparam = state * ty option - - exception Failure - - module State = struct - let default : state = - () - - let union (_ : uparam) (_ : uparam) : state * problem list = - ((), []) - end - - module Problem = struct - let solve (type uf) (module _) - (_ : uf ref) (_ : EcEnv.env) (_ : state Mid.t) (() : problem) - = - [] - end + | t -> Muid.add uid (t, []) m (* FIXME:TC *) + ) Muid.empty (UF.domain uc.uf) end -(* -------------------------------------------------------------------- *) -module UnifyCore = UnifyGen(UnifyExtraEmpty) - -(* -------------------------------------------------------------------- *) -module TypeClass = struct - let hastc - (env : EcEnv.env) (tvtc : (typeclass list) Mid.t) - (ty : ty) (tc : typeclass) - = - - let instances = EcEnv.TypeClass.get_instances env in - - let instances = - List.filter_map - (function (x, `General (y, syms)) -> Some (x, y, syms) | _ -> None) - instances in - - let instances = - (* FIXME:TC *) - let ring = EcPath.fromqsymbol ([EcCoreLib.i_top], "Ring" ) in - let field = EcPath.fromqsymbol ([EcCoreLib.i_top], "Field") in - - List.filter - (fun (_, tc, _) -> - List.for_all - (fun p -> not (EcPath.isprefix p tc.tc_name)) - [ring; field]) - instances in - - let instances = - let tvinst = - List.map - (fun (tv, tcs) -> - List.map (fun tc -> (([], tvar tv), tc, None)) tcs) - (Mid.bindings tvtc) - in List.flatten tvinst @ instances in - - let exception Bailout in - - let rec find_tc_in_parent acc tginst = - if EcPath.p_equal tc.tc_name tginst.tc_name then - Some (tginst.tc_args, List.rev acc) - else - let tcdecl = EcEnv.TypeClass.by_path tginst.tc_name env in - tcdecl.tc_prt |> obind (fun prt -> - let acc = (tcdecl.tc_tparams, tginst.tc_args) :: acc in - find_tc_in_parent acc prt) in - - let for1 ((tgparams, tgty), tginst, (opsyms : (EcPath.path * ty list) Mstr.t option)) = - let tgi_args, tgparams_prt = - oget ~exn:Bailout (find_tc_in_parent [] tginst) in - - let uf, tvinfo = - List.fold_left_map - (fun uf (tv, tcs) -> - let uf, tvty = UnifyCore.fresh uf in uf, (tv, (tvty, tcs))) - UnifyCore.UF.initial tgparams in - - let subst = - Mid.of_list (List.map (snd_map fst) tvinfo) in - - let subst as subst0 = - let tcsubst = - List.fold_left - (fun subst (tparams, args) -> - let args = List.map (Tvar.subst subst) args in - let subst = List.combine (List.fst tparams) args in - Mid.of_list subst) - subst tgparams_prt in - - Mid.fold - (fun x ty subst -> Mid.add x ty subst) - tcsubst subst in - - let uf, tgi_args = ref uf, List.map (Tvar.subst subst) tgi_args in - - List.iter2 - (fun pty tgty -> - let tgty = Tvar.subst subst tgty in - try - uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (pty, tgty)) - with UnifyCore.UnificationFailure _ -> - raise Bailout) - tc.tc_args tgi_args; - - let tgty = Tvar.subst subst tgty in - - begin try - uf := UnifyCore.unify_core env Mid.empty !uf (`TyUni (ty, tgty)) - with UnifyCore.UnificationFailure _ -> raise Bailout end; - - let subst = UnifyCore.subst_of_uf !uf in - let subst = ty_subst (Tuni.subst subst) in - - (* assert (UnifyCore.UF.closed !uf); *) - - let opsyms = opsyms |> Option.map ( - Mstr.map - (fun (p, tys) -> - (p, List.map (fun ty -> subst (Tvar.subst subst0 ty)) tys)) - ) in - - let effects = - List.flatten (List.map - (fun (_, (ty, tcs)) -> - List.map (fun tc -> (subst ty, tc)) tcs) - tvinfo) - - in (effects, opsyms) - - in - - let for1 pb = - try Some (for1 pb) with Bailout -> None in - - List.find_map_opt for1 instances -end - -(* -------------------------------------------------------------------- *) -type tcproblem = [ - `TcCtt of ty * typeclass * ((EcPath.path * ty list) Mstr.t) option ref -] - -module UnifyExtraForTC : - UnifyExtra with type state = typeclass list - and type problem = tcproblem = -struct - type state = typeclass list - type problem = tcproblem - type uparam = state * ty option - - exception Failure - - module State = struct - let default : state = - [] - - let union (d1 : uparam) (d2 : uparam) = - match d1, d2 with - | (tc1, None), (tc2, None) -> - (tc1 @ tc2), [] - - | (tc1, Some _), (tc2, Some _) -> - (tc1 @ tc2), [] - - | (tc1, None ), (tc2, Some ty) - | (tc2, Some ty), (tc1, None ) -> - (tc1 @ tc2), List.map (fun tc -> `TcCtt (ty, tc, ref None)) tc1 - end - - module Problem = struct - let solve (type uf) - (module UF : EcUFind.S - with type t = uf - and type item = uid - and type data = uparam) - (uf : uf ref) - (env : EcEnv.env) - (tvtc : state Mid.t) - (pb : problem) - : problem list - = - let `TcCtt (ty, tc, tcrec) = pb in - - let tytc, ty = - match ty.ty_node with - | Tunivar i -> snd_map (odfl ty) (UF.data i !uf) - | _ -> (State.default, ty) in - - match ty.ty_node with - | Tunivar i -> - uf := UF.set i (tc :: tytc, None) !uf; - [] - - | _ -> begin - match TypeClass.hastc env tvtc ty tc with - | None -> - raise Failure - | Some (effects, opsyms) -> - tcrec := opsyms; - List.map (fun (ty, tc) -> `TcCtt (ty, tc, ref None)) effects - end - end -end - -(* -------------------------------------------------------------------- *) -module Unify = UnifyGen(UnifyExtraForTC) - (* -------------------------------------------------------------------- *) type unienv_r = { - ue_uf : Unify.UF.t; + ue_uc : Unify.ucore; ue_named : EcIdent.t Mstr.t; - ue_tvtc : typeclass list Mid.t; ue_decl : EcIdent.t list; ue_closed : bool; } type unienv = unienv_r ref +type petyarg = ty option * tcwitness option list option + type tvar_inst = -| TVIunamed of ty list -| TVInamed of (EcSymbols.symbol * ty) list +| TVIunamed of petyarg list +| TVInamed of (EcSymbols.symbol * petyarg) list type tvi = tvar_inst option -type uidmap = uid -> ty option + +let tvi_unamed (ety : etyarg list) : tvar_inst = + TVIunamed (List.map + (fun (ty, tcw) -> Some ty, Some (List.map Option.some tcw)) + ety + ) module UniEnv = struct let copy (ue : unienv) : unienv = @@ -479,7 +306,7 @@ module UniEnv = struct let restore ~(dst:unienv) ~(src:unienv) = dst := !src - let getnamed ue x = + let getnamed (ue : unienv) (x : symbol) = match Mstr.find_opt x (!ue).ue_named with | Some a -> a | None -> begin @@ -491,143 +318,191 @@ module UniEnv = struct }; id end - let create (vd : (EcIdent.t * typeclass list) list option) = - let ue = { - ue_uf = Unify.UF.initial; - ue_named = Mstr.empty; - ue_tvtc = Mid.empty; - ue_decl = []; - ue_closed = false; - } in - + let create (vd : (EcIdent.t * typeclass list) list option) : unienv = let ue = match vd with - | None -> ue + | None -> + { ue_uc = Unify.initial_ucore () + ; ue_named = Mstr.empty + ; ue_decl = [] + ; ue_closed = false + } + | Some vd -> let vdmap = List.map (fun (x, _) -> (EcIdent.name x, x)) vd in - { ue with - ue_named = Mstr.of_list vdmap; - ue_tvtc = Mid.of_list vd; - ue_decl = List.rev_map fst vd; - ue_closed = true; } - in - ref ue - - let fresh ?tcs ?ty ue = - let (uf, uid) = Unify.fresh ?extra:tcs ?ty (!ue).ue_uf in - ue := { !ue with ue_uf = uf }; uid + let tvtc = Mid.of_list vd in + { ue_uc = Unify.initial_ucore ~tvtc () + ; ue_named = Mstr.of_list vdmap + ; ue_decl = List.rev_map fst vd + ; ue_closed = true; + } + in ref ue + + let xfresh + ?(tcs : (typeclass * tcwitness option) list option) + ?(ty : ty option) + (ue : unienv) + = + let (uc, tytw) = Unify.fresh ?tcs ?ty (!ue).ue_uc in + ue := { !ue with ue_uc = uc }; tytw + + let fresh ?(ty : ty option) (ue : unienv) = + let (uc, (ty, tw)) = Unify.fresh ?ty (!ue).ue_uc in + assert (List.is_empty tw); + ue := { !ue with ue_uc = uc }; ty + + type opened = { + subst : etyarg Mid.t; + params : (ty * typeclass list) list; + args : etyarg list; + } + + let subst_tv (subst : etyarg Mid.t) (params : ty_params) = + List.map (fun (tv, tcs) -> + let tv = Tvar.subst subst (tvar tv) in + let tcs = + List.map + (fun tc -> + let tc_args = + List.map (Tvar.subst_etyarg subst) tc.tc_args + in { tc with tc_args }) + tcs + in (tv, tcs)) params - let opentvi ue (params : ty_params) tvi = + let opentvi (ue : unienv) (params : ty_params) (tvi : tvi) : opened = let tvi = match tvi with | None -> - List.map (fun (v, tc) -> (v, (None, tc))) params + List.map (fun (v, tcs) -> + (v, (None, List.map (fun x -> (x, None)) tcs)) + ) params | Some (TVIunamed lt) -> - List.map2 (fun (v, tc) ty -> (v, (Some ty, tc))) params lt + let combine (v, tc) (ty, tcw) = + let tctcw = + match tcw with + | None -> + List.map (fun tc -> (tc, None)) tc + | Some tcw -> + List.combine tc tcw + in (v, (ty, tctcw)) in + + List.map2 combine params lt | Some (TVInamed lt) -> List.map (fun (v, tc) -> - let ty = List.assoc_opt (EcIdent.name v) lt in - (v, (ty, tc)) - ) params in + let ty, tcw = + List.assoc_opt (EcIdent.name v) lt + |> Option.value ~default:(None, None) in + + let tcw = + match tcw with + | None -> + List.map (fun _ -> None) tc + | Some tcw -> + tcw in + + (v, (ty, List.map2 (fun x y -> (x, y)) tc tcw)) + ) params + in - List.fold_left (fun s (v, (ty, tcs)) -> + let subst = + List.fold_left (fun s (v, (ty, tcws)) -> let tcs = - let for1 tc = - { tc_name = tc.tc_name; - tc_args = List.map (Tvar.subst s) tc.tc_args } in - List.map for1 tcs in - Mid.add v (fresh ?ty:ty ~tcs ue) s - ) Mid.empty tvi - - let subst_tv subst params = - List.map (fun (tv, tcs) -> - let tv = subst (tvar tv) in - let tcs = - List.map - (fun tc -> { tc with tc_args = List.map subst tc.tc_args }) - tcs - in (tv, tcs)) params + let for1 (tc, tcw) = + let tc = + { tc_name = tc.tc_name; + tc_args = List.map (Tvar.subst_etyarg s) tc.tc_args } in + (tc, tcw) + in List.map for1 tcws + in Mid.add v (xfresh ?ty ~tcs ue) s + ) Mid.empty tvi in - let openty_r ue params tvi = - let subst = f_subst_init ~tv:(opentvi ue params tvi) () in - (subst, subst_tv (ty_subst subst) params) + let args = List.map (fun (x, _) -> oget (Mid.find_opt x subst)) params in + let params = subst_tv subst params in - let opentys ue params tvi tys = - let (subst, tvs) = openty_r ue params tvi in - (List.map (ty_subst subst) tys, tvs) + { subst; args; params; } - let openty ue params tvi ty = - let (subst, tvs) = openty_r ue params tvi in - (ty_subst subst ty, tvs) + let opentys (ue : unienv) (params : ty_params) (tvi : tvi) (tys : ty list) = + let opened = opentvi ue params tvi in + let tys = List.map (Tvar.subst opened.subst) tys in + tys, opened + + let openty (ue : unienv) (params : ty_params) (tvi : tvi) (ty : ty) = + let opened = opentvi ue params tvi in + Tvar.subst opened.subst ty, opened let repr (ue : unienv) (t : ty) : ty = match t.ty_node with - | Tunivar id -> odfl t (snd (Unify.UF.data id (!ue).ue_uf)) + | Tunivar id -> odfl t (Unify.UF.data id (!ue).ue_uc.uf) | _ -> t let closed (ue : unienv) = - Unify.UF.closed (!ue).ue_uf + Unify.UF.closed (!ue).ue_uc.uf (* FIXME:TC *) let close (ue : unienv) = if not (closed ue) then raise UninstanciateUni; - (Unify.subst_of_uf (!ue).ue_uf) + (Unify.subst_of_uf (!ue).ue_uc) - let assubst ue = Unify.subst_of_uf (!ue).ue_uf + let assubst (ue : unienv) = + Unify.subst_of_uf (!ue).ue_uc - let tparams ue = - let fortv x = odfl [] (Mid.find_opt x (!ue).ue_tvtc) in + let tparams (ue : unienv) = + let fortv x = odfl [] (Mid.find_opt x (!ue).ue_uc.tvtc) in List.map (fun x -> (x, fortv x)) (List.rev (!ue).ue_decl) end (* -------------------------------------------------------------------- *) -let unify_core env ue pb = - let uf = - try - Unify.unify_core env (!ue).ue_tvtc (!ue).ue_uf pb - with Unify.UnificationFailure pb -> begin - match pb with - | `TyUni (ty1, ty2) -> - raise (UnificationFailure (`TyUni (ty1, ty2))) - | `Other (`TcCtt (ty, tc, _)) -> - raise (UnificationFailure (`TcCtt (ty, tc))) - end - in ue := { !ue with ue_uf = uf; } +let unify_core (env : EcEnv.env) (ue : unienv) (pb : problem) = + let uc = Unify.unify_core env (!ue).ue_uc pb in + ue := { !ue with ue_uc = uc; } (* -------------------------------------------------------------------- *) -let unify env ue t1 t2 = +let unify (env : EcEnv.env) (ue : unienv) (t1 : ty) (t2 : ty) = unify_core env ue (`TyUni (t1, t2)) -let xhastc_r env ue ty tc = - let instance = ref None in - unify_core env ue (`Other (`TcCtt (ty, tc, instance))); - !instance +let xhastc_r (env : EcEnv.env) (ue : unienv) (ty : ty) (tc : typeclass) = + let uid = EcUid.unique () in + unify_core env ue (`TcCtt (uid, ty, tc)); + assert false -let hastc_r env ue ty tc = +let hastc_r (env : EcEnv.env) (ue : unienv) (ty : ty) (tc : typeclass) = ignore (xhastc_r env ue ty tc : _ option) -let xhastcs_r env ue ty tcs = +let xhastcs_r (env : EcEnv.env) (ue : unienv) (ty : ty) (tcs : typeclass list) = List.map (hastc_r env ue ty) tcs -let hastcs_r env ue ty tcs = +let hastcs_r (env : EcEnv.env) (ue : unienv) (ty : ty) (tcs : typeclass list) = List.iter (hastc_r env ue ty) tcs (* -------------------------------------------------------------------- *) -let hastc env ue ty tc = +let hastc (env : EcEnv.env) (ue : unienv) (ty : ty) (tc : typeclass) = try Some (xhastc_r env ue ty tc) with UnificationFailure _ -> None (* -------------------------------------------------------------------- *) -let tfun_expected ue psig = - let tres = UniEnv.fresh ue in - EcTypes.toarrow psig tres +let tfun_expected (ue : unienv) (psig : ty list) = + EcTypes.toarrow psig (UniEnv.fresh ue) (* -------------------------------------------------------------------- *) type sbody = ((EcIdent.t * ty) list * expr) Lazy.t (* -------------------------------------------------------------------- *) -let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig = +type select_filter_t = EcPath.path -> operator -> bool + +type select_t = + ((EcPath.path * etyarg list) * ty * unienv * sbody option) list + +let select_op + ?(hidden : bool = false) + ?(filter : select_filter_t = fun _ _ -> true) + (tvi : tvi) + (env : EcEnv.env) + (name : qsymbol) + (ue : unienv) + (psig : dom) + : select_t += ignore hidden; (* FIXME *) let module D = EcDecl in @@ -659,7 +534,9 @@ let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig let subue = UniEnv.copy ue in try - let (tip, tvtcs) = UniEnv.openty_r subue op.D.op_tparams tvi in + let UniEnv.{ subst = tip; params = tvtcs } = + UniEnv.opentvi subue op.D.op_tparams tvi in + let tip = f_subst_init ~tv:tip () in List.iter (fun (tv, tcs) -> @@ -667,7 +544,7 @@ let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig with UnificationFailure _ -> raise E.Failure) tvtcs; - let top = ty_subst tip op.D.op_ty in + let top = EcCoreSubst.ty_subst tip op.D.op_ty in let texpected = tfun_expected subue psig in (try unify env subue top texpected @@ -684,8 +561,11 @@ let select_op ?(hidden = false) ?(filter = fun _ _ -> true) tvi env name ue psig in Some (Lazy.from_fun substnt) | _ -> None + in + + let args = List.map (fun ty -> (ty, [])) (List.fst tvtcs) in - in Some ((path, List.fst tvtcs), top, subue, bd) + Some ((path, args), top, subue, bd) (* FIXME:TC *) with E.Failure -> None diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 022bf3526d..6ad19e0ada 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -1,37 +1,54 @@ (* -------------------------------------------------------------------- *) open EcUid +open EcIdent open EcPath open EcSymbols open EcMaps open EcTypes open EcDecl -(* -------------------------------------------------------------------- *) -exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * typeclass] +(* ==================================================================== *) +type problem = [ + | `TyUni of ty * ty + | `TcTw of tcwitness * tcwitness + | `TcCtt of EcUid.uid * ty * typeclass +] + +exception UnificationFailure of problem exception UninstanciateUni type unienv +type petyarg = ty option * tcwitness option list option + type tvar_inst = -| TVIunamed of ty list -| TVInamed of (EcSymbols.symbol * ty) list +| TVIunamed of petyarg list +| TVInamed of (EcSymbols.symbol * petyarg) list type tvi = tvar_inst option -type uidmap = uid -> ty option + +val tvi_unamed : etyarg list -> tvar_inst module UniEnv : sig + type opened = { + subst : etyarg Mid.t; + params : (ty * typeclass list) list; + args : etyarg list; + } + val create : (EcIdent.t * typeclass list) list option -> unienv val copy : unienv -> unienv (* constant time *) val restore : dst:unienv -> src:unienv -> unit (* constant time *) - val fresh : ?tcs:typeclass list -> ?ty:ty -> unienv -> ty + val xfresh : ?tcs:(EcDecl.typeclass * EcTypes.tcwitness option) list -> ?ty:ty -> unienv -> etyarg + val fresh : ?ty:ty -> unienv -> ty val getnamed : unienv -> symbol -> EcIdent.t val repr : unienv -> ty -> ty - val opentvi : unienv -> ty_params -> tvi -> ty EcIdent.Mid.t - val openty : unienv -> ty_params -> tvi -> ty -> ty * (ty * typeclass list) list - val opentys : unienv -> ty_params -> tvi -> ty list -> ty list * (ty * typeclass list) list + val opentvi : unienv -> ty_params -> tvi -> opened + val openty : unienv -> ty_params -> tvi -> ty -> ty * opened + val opentys : unienv -> ty_params -> tvi -> ty list -> ty list * opened val closed : unienv -> bool - val close : unienv -> ty Muid.t - val assubst : unienv -> ty Muid.t + val close : unienv -> etyarg Muid.t + val assubst : unienv -> etyarg Muid.t val tparams : unienv -> ty_params end @@ -51,4 +68,4 @@ val select_op : -> qsymbol -> unienv -> dom - -> ((EcPath.path * ty list) * ty * unienv * sbody option) list + -> ((EcPath.path * etyarg list) * ty * unienv * sbody option) list diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 77cf7ccdfa..a8f2d0d5f4 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -366,7 +366,7 @@ end = struct let pp_op fmt ((op, inst), subue) = let uidmap = EcUnify.UniEnv.assubst subue in - let inst = Tuni.subst_dom uidmap inst in + let inst = Tuni.subst_dom uidmap (List.fst inst) in begin match inst with | [] -> diff --git a/src/ecUtils.ml b/src/ecUtils.ml index 8df2c9554f..4ffd1804a7 100644 --- a/src/ecUtils.ml +++ b/src/ecUtils.ml @@ -472,6 +472,17 @@ module List = struct | None -> failwith "List.last" | Some x -> x + let betail = + let rec aux (acc : 'a list) (s : 'a list) = + match s, acc with + | [], [] -> + failwith "List.betail" + | [], v :: vs-> + List.rev vs, v + | x :: xs, _ -> + aux (x :: acc) xs + in fun s -> aux [] s + let mbfilter (p : 'a -> bool) (s : 'a list) = match s with [] | [_] -> s | _ -> List.filter p s diff --git a/src/ecUtils.mli b/src/ecUtils.mli index 0dcac68887..df63ee8d65 100644 --- a/src/ecUtils.mli +++ b/src/ecUtils.mli @@ -279,6 +279,7 @@ module List : sig val min : ?cmp:('a -> 'a -> int) -> 'a list -> 'a val max : ?cmp:('a -> 'a -> int) -> 'a list -> 'a + val betail : 'a list -> 'a list * 'a val nth_opt : 'a list -> int -> 'a option val mbfilter : ('a -> bool) -> 'a list -> 'a list val fusion : ('a -> 'a -> 'a) -> 'a list -> 'a list -> 'a list diff --git a/src/phl/ecPhlCond.ml b/src/phl/ecPhlCond.ml index abf5e4ddc2..b83903f552 100644 --- a/src/phl/ecPhlCond.ml +++ b/src/phl/ecPhlCond.ml @@ -226,8 +226,8 @@ let t_equiv_match_same_constr tc = let bhl = List.map (fst_map EcIdent.fresh) cl in let bhr = List.map (fst_map EcIdent.fresh) cr in let cop = EcPath.pqoname (EcPath.prefix pl) c in - let copl = f_op cop tyl (toarrow (List.snd cl) fl.f_ty) in - let copr = f_op cop tyr (toarrow (List.snd cr) fr.f_ty) in + let copl = f_op_tc cop tyl (toarrow (List.snd cl) fl.f_ty) in + let copr = f_op_tc cop tyr (toarrow (List.snd cr) fr.f_ty) in let lhs = f_eq fl (f_app copl (List.map (curry f_local) bhl) fl.f_ty) in let lhs = f_exists (List.map (snd_map gtty) bhl) lhs in @@ -242,8 +242,8 @@ let t_equiv_match_same_constr tc = let sb, bhl = add_elocals sb cl in let sb, bhr = add_elocals sb cr in let cop = EcPath.pqoname (EcPath.prefix pl) c in - let copl = f_op cop tyl (toarrow (List.snd cl) fl.f_ty) in - let copr = f_op cop tyr (toarrow (List.snd cr) fr.f_ty) in + let copl = f_op_tc cop tyl (toarrow (List.snd cl) fl.f_ty) in + let copr = f_op_tc cop tyr (toarrow (List.snd cr) fr.f_ty) in let pre = f_ands_simpl [ f_eq fl (f_app copl (List.map (curry f_local) bhl) fl.f_ty); f_eq fr (f_app copr (List.map (curry f_local) bhr) fr.f_ty) ] @@ -305,8 +305,8 @@ let t_equiv_match_eq tc = sb cl cr in let cop = EcPath.pqoname (EcPath.prefix pl) c in - let copl = f_op cop tyl (toarrow (List.snd cl) fl.f_ty) in - let copr = f_op cop tyr (toarrow (List.snd cr) fr.f_ty) in + let copl = f_op_tc cop tyl (toarrow (List.snd cl) fl.f_ty) in + let copr = f_op_tc cop tyr (toarrow (List.snd cr) fr.f_ty) in let pre = f_ands_simpl [ f_eq fl (f_app copl (List.map (curry f_local) bh) fl.f_ty); f_eq fr (f_app copr (List.map (curry f_local) bh) fr.f_ty) ] diff --git a/src/phl/ecPhlEqobs.ml b/src/phl/ecPhlEqobs.ml index 6c7e1c72d2..3a72b58f29 100644 --- a/src/phl/ecPhlEqobs.ml +++ b/src/phl/ecPhlEqobs.ml @@ -232,7 +232,7 @@ and i_eqobs_in il ir sim local (eqo:Mpv2.t) = let typr, _, tyinstr = oget (EcEnv.Ty.get_top_decl el.e_ty env) in let test = EcPath.p_equal typl typr && - List.for_all2 (EcReduction.EqTest.for_type env) tyinstl tyinstr in + List.for_all2 (EcReduction.EqTest.for_etyarg env) tyinstl tyinstr in if not test then raise EqObsInError; let rsim = ref sim in let doit eqs1 (argsl,sl) (argsr, sr) = diff --git a/src/phl/ecPhlInline.ml b/src/phl/ecPhlInline.ml index 0004785f2c..63d98eead0 100644 --- a/src/phl/ecPhlInline.ml +++ b/src/phl/ecPhlInline.ml @@ -32,7 +32,7 @@ module LowSubst = struct let rec esubst m e = match e.e_node with | Evar pv -> e_var (pvsubst m pv) e.e_ty - | _ -> EcTypes.e_map (fun ty -> ty) (esubst m) e + | _ -> EcTypes.e_map (esubst m) e let lvsubst m lv = match lv with diff --git a/src/phl/ecPhlRCond.ml b/src/phl/ecPhlRCond.ml index 4a328ee18f..eabf2c4623 100644 --- a/src/phl/ecPhlRCond.ml +++ b/src/phl/ecPhlRCond.ml @@ -157,7 +157,7 @@ module LowMatch = struct in (x, xty)) cvars in let vars = List.map (curry f_local) names in let cty = toarrow (List.snd names) f.f_ty in - let po = f_op cname (List.snd tyinst) cty in + let po = f_op_tc cname (List.snd tyinst) cty in let po = f_app po vars f.f_ty in f_exists (List.map (snd_map gtty) names) (f_eq f po) in @@ -186,7 +186,7 @@ module LowMatch = struct let epr, asgn = if frame then begin let vars = List.map (fun (pv, ty) -> f_pvar pv ty (fst me)) pvs in - let epr = f_op cname (List.snd tyinst) f.f_ty in + let epr = f_op_tc cname (List.snd tyinst) f.f_ty in let epr = f_app epr vars f.f_ty in Some (f_eq f epr), [] end else begin @@ -195,7 +195,7 @@ module LowMatch = struct (* FIXME: factorize out *) let rty = ttuple (List.snd cvars) in let proj = EcInductive.datatype_proj_path typ (EcPath.basename cname) in - let proj = e_op proj (List.snd tyinst) (tfun e.e_ty (toption rty)) in + let proj = e_op_tc proj (List.snd tyinst) (tfun e.e_ty (toption rty)) in let proj = e_app proj [e] (toption rty) in let proj = e_oget proj rty in i_asgn (lv, proj)) in From 9f80bc06afd9ea727a81f4f580db7493939ddc87 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sat, 18 May 2024 20:23:06 +0200 Subject: [PATCH 059/113] ml-kem: jobs=1 --- .github/workflows/external.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/external.json b/.github/workflows/external.json index 25af395304..dc8b62b3fc 100644 --- a/.github/workflows/external.json +++ b/.github/workflows/external.json @@ -27,7 +27,7 @@ , "subdir" : "." , "config" : "config/tests.config" , "scenario" : "mlkem" - , "options" : "-pragmas Proofs:weak" + , "options" : "-pragmas Proofs:weak -jobs 1" } , From 8bf7a6ce2caa503fbd0ed99dfec81c050d647745 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 3 Dec 2024 09:29:44 +0100 Subject: [PATCH 060/113] nits --- src/ecTyping.ml | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 556e9da9a0..9095b9cbc5 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -390,23 +390,6 @@ let gen_select_op |> Option.to_list else [] in -<<<<<<< HEAD - | None -> - let ops () : (OpSelect.opsel * ty * EcUnify.unienv * opmatch) list = - let ops = EcUnify.select_op ~filter:ue_filter tvi env name ue psig in - let ops = opsc |> ofold (fun opsc -> List.mbfilter (by_scope opsc)) ops in - let ops = match List.mbfilter by_current ops with [] -> ops | ops -> ops in - let ops = match List.mbfilter by_tc ops with [] -> ops | ops -> ops in - (List.map fop ops) - - and pvs () : (OpSelect.opsel * ty * EcUnify.unienv * opmatch) list = - let me, pvs = - match EcEnv.Memory.get_active env, actonly with - | None, true -> (None, []) - | me , _ -> ( me, select_pv env me name ue tvi psig) - in List.map (fpv me) pvs - in -======= let ops () : OpSelect.gopsel list = let ops = EcUnify.select_op ~filter:ue_filter tvi env name ue psig in let ops = opsc |> ofold (fun opsc -> List.mbfilter (by_scope opsc)) ops in @@ -421,7 +404,6 @@ let gen_select_op | me , _ -> ( me, select_pv env me name ue tvi psig) in List.map (fpv me) pvs in ->>>>>>> origin/main let select (filters : (unit -> OpSelect.gopsel list) list) : OpSelect.gopsel list = List.find_map_opt From 6eddaa50050ef21f698f01d3e342f83a9b06f55f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 7 Jan 2025 10:35:48 +0100 Subject: [PATCH 061/113] create TC univar --- src/ecAst.ml | 21 ++++++++++------- src/ecAst.mli | 3 ++- src/ecCoreEqTest.ml | 7 +++--- src/ecCoreSubst.ml | 52 +++++++++++++++++++++++++++---------------- src/ecCoreSubst.mli | 15 ++++++++----- src/ecHiNotations.ml | 4 ++-- src/ecHiPredicates.ml | 5 ++--- src/ecMatching.mli | 3 +-- src/ecPrinting.ml | 35 ++++++++++++++++++++++++++--- src/ecReduction.ml | 3 +++ src/ecSection.ml | 5 ++++- src/ecSubst.ml | 6 ++--- src/ecTypes.ml | 10 +++++++-- src/ecUnify.ml | 40 +++++++++------------------------ src/ecUnify.mli | 9 ++------ 15 files changed, 129 insertions(+), 89 deletions(-) diff --git a/src/ecAst.ml b/src/ecAst.ml index 54a2f7804e..f88d0e0c2f 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -57,9 +57,11 @@ and ty_node = | Tfun of ty * ty (* -------------------------------------------------------------------- *) -and etyarg = ty * tcwitness list +and etyarg = ty * tcwitness list and tcwitness = + | TCIUni of EcUid.uid + | TCIConcrete of { path: EcPath.path; etyargs: (ty * tcwitness list) list; @@ -68,12 +70,11 @@ and tcwitness = | TCIAbstract of { support: [ | `Var of EcIdent.t - | `Univar of EcUid.uid | `Abs of EcPath.path ]; offset: int; } - + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; @@ -374,6 +375,9 @@ let lp_fv = function (* -------------------------------------------------------------------- *) let rec tcw_fv (tcw : tcwitness) = match tcw with + | TCIUni _ -> + Mid.empty + | TCIConcrete { etyargs } -> List.fold_left (fun fv (ty, tcws) -> fv_union fv (fv_union ty.ty_fv (tcws_fv tcws))) @@ -398,6 +402,9 @@ let etyargs_fv (tyargs : etyarg list) = (* -------------------------------------------------------------------- *) let rec tcw_equal (tcw1 : tcwitness) (tcw2 : tcwitness) = match tcw1, tcw2 with + | TCIUni uid1, TCIUni uid2 -> + uid_equal uid1 uid2 + | TCIConcrete tcw1, TCIConcrete tcw2 -> EcPath.p_equal tcw1.path tcw2.path && List.all2 etyarg_equal tcw1.etyargs tcw2.etyargs @@ -409,8 +416,6 @@ let rec tcw_equal (tcw1 : tcwitness) (tcw2 : tcwitness) = match support1, support2 with | `Var x1, `Var x2 -> EcIdent.id_equal x1 x2 - | `Univar u1, `Univar u2 -> - uid_equal u1 u2 | `Abs p1, `Abs p2 -> EcPath.p_equal p1 p2 | _, _ -> false @@ -426,6 +431,9 @@ and etyarg_equal ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = (* -------------------------------------------------------------------- *) let rec tcw_hash (tcw : tcwitness) = match tcw with + | TCIUni uid -> + Hashtbl.hash uid + | TCIConcrete tcw -> Why3.Hashcons.combine_list etyarg_hash @@ -435,9 +443,6 @@ let rec tcw_hash (tcw : tcwitness) = | TCIAbstract { support = `Var tyvar; offset } -> Why3.Hashcons.combine (EcIdent.id_hash tyvar) offset - | TCIAbstract { support = `Univar uni; offset } -> - Why3.Hashcons.combine (Hashtbl.hash uni) offset - | TCIAbstract { support = `Abs p; offset } -> Why3.Hashcons.combine (EcPath.p_hash p) offset diff --git a/src/ecAst.mli b/src/ecAst.mli index 016687c992..50614765c5 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -56,6 +56,8 @@ and ty_node = and etyarg = ty * tcwitness list and tcwitness = + | TCIUni of EcUid.uid + | TCIConcrete of { path: EcPath.path; etyargs: (ty * tcwitness list) list; @@ -64,7 +66,6 @@ and tcwitness = | TCIAbstract of { support: [ | `Var of EcIdent.t - | `Univar of EcUid.uid | `Abs of EcPath.path ]; offset: int; diff --git a/src/ecCoreEqTest.ml b/src/ecCoreEqTest.ml index 04f5939642..f9e1a4f35b 100644 --- a/src/ecCoreEqTest.ml +++ b/src/ecCoreEqTest.ml @@ -62,6 +62,9 @@ and for_etyargs env (tyargs1 : etyarg list) (tyargs2 : etyarg list) = and for_tcw env (tcw1 : tcwitness) (tcw2 : tcwitness) = match tcw1, tcw2 with + | TCIUni uid1, TCIUni uid2 -> + EcUid.uid_equal uid1 uid2 + | TCIConcrete tcw1, TCIConcrete tcw2 -> EcPath.p_equal tcw1.path tcw2.path && for_etyargs env tcw1.etyargs tcw2.etyargs @@ -70,10 +73,6 @@ and for_tcw env (tcw1 : tcwitness) (tcw2 : tcwitness) = TCIAbstract { support = `Var v2; offset = o2 } -> EcIdent.id_equal v1 v2 && o1 = o2 - | TCIAbstract { support = `Univar v1; offset = o1 }, - TCIAbstract { support = `Univar v2; offset = o2 } -> - EcUid.uid_equal v1 v2 && o1 = o2 - | TCIAbstract { support = `Abs p1; offset = o1 }, TCIAbstract { support = `Abs p2; offset = o2 } -> EcPath.p_equal p1 p2 && o1 = o2 diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index 6a1261bd6e..d320ad38f2 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -17,7 +17,8 @@ type mod_extra = { (* -------------------------------------------------------------------- *) type f_subst = { fs_freshen : bool; (* true means freshen locals *) - fs_u : etyarg Muid.t; + fs_u : ty Muid.t; + fs_utc : tcwitness Muid.t; fs_v : etyarg Mid.t; fs_mod : EcPath.mpath Mid.t; fs_modex : mod_extra Mid.t; @@ -47,22 +48,36 @@ let fv_Mid (type a) = Mid.fold (fun _ t s -> fv_union s (fv t)) m s +(* -------------------------------------------------------------------- *) +type unisubst = { + uvars : ty Muid.t; + utcvars : tcwitness Muid.t; +} + +(* -------------------------------------------------------------------- *) +let unisubst0 : unisubst = { + uvars = Muid.empty; utcvars = Muid.empty; +} + (* -------------------------------------------------------------------- *) let f_subst_init - ?(freshen=false) - ?(tu=Muid.empty) - ?(tv=Mid.empty) - ?(esloc=Mid.empty) - () = + ?(freshen = false) + ?(tu = unisubst0) + ?(tv = Mid.empty) + ?(esloc = Mid.empty) + () += let fv = Mid.empty in - let fv = Muid.fold (fun _ t s -> fv_union s (etyarg_fv t)) tu fv in + let fv = Muid.fold (fun _ t s -> fv_union s (ty_fv t)) tu.uvars fv in + let fv = Muid.fold (fun _ t s -> fv_union s (tcw_fv t)) tu.utcvars fv in let fv = fv_Mid etyarg_fv tv fv in let fv = fv_Mid e_fv esloc fv in { fs_freshen = freshen; - fs_u = tu; + fs_u = tu.uvars; + fs_utc = tu.utcvars; fs_v = tv; fs_mod = Mid.empty; fs_modex = Mid.empty; @@ -166,7 +181,7 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = | Tunivar id -> Muid.find_opt id s.fs_u - |> Option.map (fun (ty, _) -> ty_subst s ty) + |> Option.map (ty_subst s) |> Option.value ~default:ty | Tvar id -> @@ -190,7 +205,11 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = (* -------------------------------------------------------------------- *) and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = match tcw with - | TCIConcrete ({ etyargs = etyargs0 } as rtcw) -> + | TCIUni uid -> + Muid.find_opt uid s.fs_utc + |> Option.value ~default:tcw + +| TCIConcrete ({ etyargs = etyargs0 } as rtcw) -> let etyargs = List.Smart.map (etyarg_subst s) etyargs0 in if etyargs ==(*phy*) etyargs0 then tcw @@ -201,11 +220,6 @@ and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = |> Option.map (fun (_, tcws) -> List.nth tcws offset) |> Option.value ~default:tcw - | TCIAbstract { support = `Univar uni; offset } -> - Muid.find_opt uni s.fs_u - |> Option.map (fun (_, tcws) -> List.nth tcws offset) - |> Option.value ~default:tcw - | TCIAbstract { support = `Abs _ } -> tcw @@ -768,13 +782,13 @@ end (* -------------------------------------------------------------------- *) module Tuni = struct - let subst (uidmap : etyarg Muid.t) : f_subst = + let subst (uidmap : unisubst) : f_subst = f_subst_init ~tu:uidmap () - let subst1 ((id, t) : uid * etyarg) : f_subst = - subst (Muid.singleton id t) + let subst1 ((id, t) : uid * ty) : f_subst = + subst { unisubst0 with uvars = Muid.singleton id t } - let subst_dom (uidmap : etyarg Muid.t) (dom : dom) : dom = + let subst_dom (uidmap : unisubst) (dom : dom) : dom = List.map (ty_subst (subst uidmap)) dom let occurs (u : uid) : ty -> bool = diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index e1760c7830..9ac3be0b47 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -16,10 +16,15 @@ type tx = before:form -> after:form -> form type 'a tx_substitute = ?tx:tx -> 'a substitute type 'a subst_binder = f_subst -> 'a -> f_subst * 'a +(* -------------------------------------------------------------------- *) +type unisubst = { + uvars : ty Muid.t; utcvars : tcwitness Muid.t; +} + (* -------------------------------------------------------------------- *) val f_subst_init : ?freshen:bool - -> ?tu:etyarg Muid.t + -> ?tu:unisubst -> ?tv:etyarg Mid.t -> ?esloc:expr Mid.t -> unit @@ -28,9 +33,9 @@ val f_subst_init : (* -------------------------------------------------------------------- *) module Tuni : sig val univars : ty -> Suid.t - val subst1 : (uid * etyarg) -> f_subst - val subst : etyarg Muid.t -> f_subst - val subst_dom : etyarg Muid.t -> dom -> dom + val subst1 : (uid * ty) -> f_subst + val subst : unisubst -> f_subst + val subst_dom : unisubst -> dom -> dom val occurs : uid -> ty -> bool val fv : ty -> Suid.t end @@ -63,7 +68,7 @@ module Fsubst : sig val f_subst_init : ?freshen:bool - -> ?tu:etyarg Muid.t + -> ?tu:unisubst -> ?tv:etyarg Mid.t -> ?esloc:expr Mid.t -> unit -> f_subst diff --git a/src/ecHiNotations.ml b/src/ecHiNotations.ml index ea8959d97c..1ea8f0f173 100644 --- a/src/ecHiNotations.ml +++ b/src/ecHiNotations.ml @@ -83,8 +83,8 @@ let trans_abbrev_r (env : env) (at : pabbrev located) = if not (EcUnify.UniEnv.closed ue) then nterror gloc env NTE_TyNotClosed; - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in - let es = e_subst ts in + let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let es = e_subst ts in let body = es body in let codom = ty_subst ts codom in let xs = List.map (snd_map (ty_subst ts)) xs in diff --git a/src/ecHiPredicates.ml b/src/ecHiPredicates.ml index bef3d19e32..5b0432b855 100644 --- a/src/ecHiPredicates.ml +++ b/src/ecHiPredicates.ml @@ -2,7 +2,6 @@ open EcUtils open EcSymbols open EcLocation -open EcTypes open EcCoreSubst open EcParsetree open EcDecl @@ -20,8 +19,8 @@ exception TransPredError of EcLocation.t * EcEnv.env * tperror let tperror loc env e = raise (TransPredError (loc, env, e)) (* -------------------------------------------------------------------- *) -let close_pr_body (uni : etyarg EcUid.Muid.t) (body : prbody) = - let fsubst = EcFol.Fsubst.f_subst_init ~tu:uni () in +let close_pr_body (uidmap : unisubst) (body : prbody) = + let fsubst = EcFol.Fsubst.f_subst_init ~tu:uidmap () in let tsubst = ty_subst fsubst in match body with diff --git a/src/ecMatching.mli b/src/ecMatching.mli index 538c47b3f8..d1f822f3d7 100644 --- a/src/ecMatching.mli +++ b/src/ecMatching.mli @@ -1,6 +1,5 @@ (* -------------------------------------------------------------------- *) open EcMaps -open EcUid open EcIdent open EcTypes open EcModules @@ -196,7 +195,7 @@ val f_match : -> unienv * mevmap -> form -> form - -> unienv * (etyarg Muid.t) * mevmap + -> unienv * unisubst * mevmap (* -------------------------------------------------------------------- *) type ptnpos = private [`Select of int | `Sub of ptnpos] Mint.t diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 4d8c36a1d3..23234a701b 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -561,7 +561,7 @@ let pp_modtype1 (ppe : PPEnv.t) fmt mty = (* -------------------------------------------------------------------- *) let pp_local (ppe : PPEnv.t) fmt x = - Format.fprintf fmt "%s" (EcIdent.tostring x) (* (PPEnv.local_symb ppe x) *) + Format.fprintf fmt "%s" (PPEnv.local_symb ppe x) (* -------------------------------------------------------------------- *) let pp_local ?fv (ppe : PPEnv.t) fmt x = @@ -947,6 +947,36 @@ let pp_opname fmt (nm, op) = in EcSymbols.pp_qsymbol fmt (nm, op) +(* -------------------------------------------------------------------- *) +let rec pp_etyarg (ppe : PPEnv.t) (fmt : Format.formatter) ((ty, tcws) : etyarg) = + Format.fprintf fmt "%a[%a]" (pp_type ppe) ty (pp_tcws ppe) tcws + +(* -------------------------------------------------------------------- *) +and pp_etyargs (ppe : PPEnv.t) (fmt : Format.formatter) (etys : etyarg list) = + Format.fprintf fmt "%a" (pp_list ",@ " (pp_etyarg ppe)) etys + +(* -------------------------------------------------------------------- *) +and pp_tcw (ppe : PPEnv.t) (fmt : Format.formatter) (tcw : tcwitness) = + match tcw with + | TCIUni uid -> + Format.fprintf fmt "%a" (pp_tyunivar ppe) uid + + | TCIConcrete { path; etyargs } -> + Format.fprintf fmt "%a[%a]" + pp_qsymbol (EcPath.toqsymbol path) + (pp_etyargs ppe) etyargs + + | TCIAbstract { support = `Var x; offset } -> + Format.fprintf fmt "%a.`%d" (pp_tyvar ppe) x (offset + 1) + + | TCIAbstract { support = `Abs path; offset } -> + Format.fprintf fmt "%a.`%d" (pp_tyname ppe) path (offset + 1) + +(* -------------------------------------------------------------------- *) +and pp_tcws (ppe : PPEnv.t) (fmt : Format.formatter) (tcws : tcwitness list) = + Format.fprintf fmt "%a" (pp_list ",@ " (pp_tcw ppe)) tcws + +(* -------------------------------------------------------------------- *) let pp_opname_with_tvi (ppe : PPEnv.t) (fmt : Format.formatter) @@ -958,8 +988,7 @@ let pp_opname_with_tvi | Some tvi -> Format.fprintf fmt "%a<:%a>" - pp_opname (nm, op) - (pp_list ",@ " (pp_type ppe)) (List.fst tvi) + pp_opname (nm, op) (pp_etyargs ppe) tvi (* -------------------------------------------------------------------- *) let pp_opapp diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 9fea6c6986..d7678de9a3 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -676,6 +676,9 @@ let reduce_tc (env : EcEnv.env) (p : path) (tys : etyarg list) = let tcw = as_seq1 tcw in match tcw with + | TCIUni _ -> + None + | TCIAbstract _ -> None diff --git a/src/ecSection.ml b/src/ecSection.ml index bd18426a8e..81f18cbbe5 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -116,6 +116,9 @@ and on_etyarg cb ((ty, tcw) : etyarg) = and on_tcwitness cb (tcw : tcwitness) = match tcw with + | TCIUni _ -> + () + | TCIConcrete { path; etyargs } -> List.iter (on_etyarg cb) etyargs; cb (`Type path) (* FIXME:TC *) @@ -123,7 +126,7 @@ and on_tcwitness cb (tcw : tcwitness) = | TCIAbstract { support = `Abs path } -> cb (`Type path) - | TCIAbstract { support = `Var _ | `Univar _ } -> + | TCIAbstract { support = `Var _ } -> () let on_pv (cb : cb) (pv : prog_var)= diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 0fe888bff4..c3bebf2464 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -197,6 +197,9 @@ and subst_etyargs (s : subst) (tyargs : etyarg list) : etyarg list = (* -------------------------------------------------------------------- *) and subst_tcw (s : subst) (tcw : tcwitness) = match tcw with + | TCIUni _ -> + tcw + | TCIConcrete { etyargs; path } -> let path = subst_path s path in let etyargs = subst_etyargs s etyargs in @@ -208,9 +211,6 @@ and subst_tcw (s : subst) (tcw : tcwitness) = |> Option.map (fun tcs -> List.nth tcs offset) |> Option.value ~default:tcw - | TCIAbstract { support = `Univar _ } -> - tcw - | TCIAbstract ({ support = `Abs p } as tcw) -> match Mp.find_opt p s.sb_tydef with | None -> diff --git a/src/ecTypes.ml b/src/ecTypes.ml index ba5195a1f4..feb7cf0b15 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -134,6 +134,9 @@ and etyarg_map (f : ty -> ty) ((ty, tcw) : etyarg) : etyarg = and tcw_map (f : ty -> ty) (tcw : tcwitness) : tcwitness = match tcw with + | TCIUni _ -> + tcw + | TCIConcrete { path; etyargs; } -> let etyargs = List.Smart.map (etyarg_map f) etyargs in TCIConcrete { path; etyargs; } @@ -158,7 +161,7 @@ and tcw_fold (f : 'a -> ty -> 'a) (v : 'a) (tcw : tcwitness) : 'a = | TCIConcrete { etyargs } -> List.fold_left (etyarg_fold f) v etyargs - | TCIAbstract _ -> + | TCIUni _ | TCIAbstract _ -> v (* -------------------------------------------------------------------- *) @@ -271,13 +274,16 @@ and tcws_tvar_fv (tcws : tcwitness list) = and tcw_tvar_fv (tcw : tcwitness) : Sid.t = match tcw with + | TCIUni _ -> + Sid.empty + | TCIConcrete { etyargs } -> etyargs_tvar_fv etyargs | TCIAbstract { support = `Var tyvar } -> Sid.singleton tyvar - | TCIAbstract { support = (`Univar _ | `Abs _) } -> + | TCIAbstract { support = (`Abs _) } -> Sid.empty (* -------------------------------------------------------------------- *) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index adcbfa6f0d..48ca851854 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -118,10 +118,10 @@ module Unify = struct let tcs, tws = List.split (Option.value ~default:[] tcs) in - let tws = tws |> List.mapi (fun i tcw -> + let tws = tws |> List.map (fun tcw -> match tcw with | None -> - TCIAbstract { support = `Univar uid; offset = i } + TCIUni (EcUid.unique ()) (* FIXME:TC *) | Some tcw -> tcw ) in @@ -271,7 +271,7 @@ module Unify = struct List.fold_left (fun m uid -> match close (tuni uid) with | { ty_node = Tunivar uid' } when uid_equal uid uid' -> m - | t -> Muid.add uid (t, []) m (* FIXME:TC *) + | t -> Muid.add uid t m ) Muid.empty (UF.domain uc.uf) end @@ -440,12 +440,13 @@ module UniEnv = struct let closed (ue : unienv) = Unify.UF.closed (!ue).ue_uc.uf (* FIXME:TC *) + let assubst (ue : unienv) = + { uvars = Unify.subst_of_uf (!ue).ue_uc + ; utcvars = Muid.empty; (* FIXME:TC *) } + let close (ue : unienv) = if not (closed ue) then raise UninstanciateUni; - (Unify.subst_of_uf (!ue).ue_uc) - - let assubst (ue : unienv) = - Unify.subst_of_uf (!ue).ue_uc + assubst ue let tparams (ue : unienv) = let fortv x = odfl [] (Mid.find_opt x (!ue).ue_uc.tvtc) in @@ -461,25 +462,6 @@ let unify_core (env : EcEnv.env) (ue : unienv) (pb : problem) = let unify (env : EcEnv.env) (ue : unienv) (t1 : ty) (t2 : ty) = unify_core env ue (`TyUni (t1, t2)) -let xhastc_r (env : EcEnv.env) (ue : unienv) (ty : ty) (tc : typeclass) = - let uid = EcUid.unique () in - unify_core env ue (`TcCtt (uid, ty, tc)); - assert false - -let hastc_r (env : EcEnv.env) (ue : unienv) (ty : ty) (tc : typeclass) = - ignore (xhastc_r env ue ty tc : _ option) - -let xhastcs_r (env : EcEnv.env) (ue : unienv) (ty : ty) (tcs : typeclass list) = - List.map (hastc_r env ue ty) tcs - -let hastcs_r (env : EcEnv.env) (ue : unienv) (ty : ty) (tcs : typeclass list) = - List.iter (hastc_r env ue ty) tcs - -(* -------------------------------------------------------------------- *) -let hastc (env : EcEnv.env) (ue : unienv) (ty : ty) (tc : typeclass) = - try Some (xhastc_r env ue ty tc) - with UnificationFailure _ -> None - (* -------------------------------------------------------------------- *) let tfun_expected (ue : unienv) (psig : ty list) = EcTypes.toarrow psig (UniEnv.fresh ue) @@ -534,15 +516,17 @@ let select_op let subue = UniEnv.copy ue in try - let UniEnv.{ subst = tip; params = tvtcs } = + let UniEnv.{ subst = tip; args } = UniEnv.opentvi subue op.D.op_tparams tvi in let tip = f_subst_init ~tv:tip () in + (* List.iter (fun (tv, tcs) -> try hastcs_r env subue tv tcs with UnificationFailure _ -> raise E.Failure) tvtcs; + *) let top = EcCoreSubst.ty_subst tip op.D.op_ty in let texpected = tfun_expected subue psig in @@ -563,8 +547,6 @@ let select_op | _ -> None in - let args = List.map (fun ty -> (ty, [])) (List.fst tvtcs) in - Some ((path, args), top, subue, bd) (* FIXME:TC *) with E.Failure -> None diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 6ad19e0ada..7196e3e906 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -1,9 +1,6 @@ (* -------------------------------------------------------------------- *) -open EcUid open EcIdent -open EcPath open EcSymbols -open EcMaps open EcTypes open EcDecl @@ -47,15 +44,13 @@ module UniEnv : sig val openty : unienv -> ty_params -> tvi -> ty -> ty * opened val opentys : unienv -> ty_params -> tvi -> ty list -> ty list * opened val closed : unienv -> bool - val close : unienv -> etyarg Muid.t - val assubst : unienv -> etyarg Muid.t + val close : unienv -> EcCoreSubst.unisubst + val assubst : unienv -> EcCoreSubst.unisubst val tparams : unienv -> ty_params end val unify : EcEnv.env -> unienv -> ty -> ty -> unit -val hastc : EcEnv.env -> unienv -> ty -> typeclass -> ((path * ty list) Mstr.t) option option - val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty type sbody = ((EcIdent.t * ty) list * expr) Lazy.t From 8204148a2cafddf8318704c84f4adea73ee1953e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 7 Jan 2025 11:28:13 +0100 Subject: [PATCH 062/113] uni -> tyuni/tcuni --- src/ecAst.ml | 18 ++++++--- src/ecAst.mli | 11 +++++- src/ecCoreEqTest.ml | 5 ++- src/ecCorePrinting.ml | 3 +- src/ecCoreSubst.ml | 44 +++++++++++---------- src/ecCoreSubst.mli | 12 +++--- src/ecPrinting.ml | 12 ++++-- src/ecTypes.ml | 2 +- src/ecTypes.mli | 2 +- src/ecTyping.ml | 2 +- src/ecUid.ml | 92 ++++++++++++++++++++++++++++++++----------- src/ecUid.mli | 36 ++++++++++++----- src/ecUnify.ml | 53 ++++++++++++------------- src/ecUserMessages.ml | 8 ++-- 14 files changed, 190 insertions(+), 110 deletions(-) diff --git a/src/ecAst.ml b/src/ecAst.ml index f88d0e0c2f..015315f4c3 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -3,7 +3,6 @@ open EcUtils open EcSymbols open EcIdent open EcPath -open EcUid module BI = EcBigInt @@ -41,6 +40,13 @@ type 'a use_restr = { type mr_xpaths = EcPath.Sx.t use_restr type mr_mpaths = EcPath.Sm.t use_restr +(* -------------------------------------------------------------------- *) +module TyUni = EcUid.CoreGen () +module TcUni = EcUid.CoreGen () + +type tyuni = TyUni.uid +type tcuni = TcUni.uid + (* -------------------------------------------------------------------- *) type ty = { ty_node : ty_node; @@ -50,7 +56,7 @@ type ty = { and ty_node = | Tglob of EcIdent.t (* The tuple of global variable of the module *) - | Tunivar of EcUid.uid + | Tunivar of tyuni | Tvar of EcIdent.t | Ttuple of ty list | Tconstr of EcPath.path * etyarg list @@ -60,7 +66,7 @@ and ty_node = and etyarg = ty * tcwitness list and tcwitness = - | TCIUni of EcUid.uid + | TCIUni of tcuni | TCIConcrete of { path: EcPath.path; @@ -403,7 +409,7 @@ let etyargs_fv (tyargs : etyarg list) = let rec tcw_equal (tcw1 : tcwitness) (tcw2 : tcwitness) = match tcw1, tcw2 with | TCIUni uid1, TCIUni uid2 -> - uid_equal uid1 uid2 + TcUni.uid_equal uid1 uid2 | TCIConcrete tcw1, TCIConcrete tcw2 -> EcPath.p_equal tcw1.path tcw2.path @@ -866,7 +872,7 @@ module Hsty = Why3.Hashcons.Make (struct EcIdent.id_equal m1 m2 | Tunivar u1, Tunivar u2 -> - uid_equal u1 u2 + TyUni.uid_equal u1 u2 | Tvar v1, Tvar v2 -> id_equal v1 v2 @@ -885,7 +891,7 @@ module Hsty = Why3.Hashcons.Make (struct let hash ty = match ty.ty_node with | Tglob m -> EcIdent.id_hash m - | Tunivar u -> u + | Tunivar u -> Hashtbl.hash u | Tvar id -> EcIdent.tag id | Ttuple tl -> Why3.Hashcons.combine_list ty_hash 0 tl | Tconstr (p, tl) -> Why3.Hashcons.combine_list etyarg_hash p.p_tag tl diff --git a/src/ecAst.mli b/src/ecAst.mli index 50614765c5..f0fd421a08 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -37,6 +37,13 @@ type mr_xpaths = EcPath.Sx.t use_restr type mr_mpaths = EcPath.Sm.t use_restr +(* -------------------------------------------------------------------- *) +module TyUni : EcUid.ICore with type uid = private EcUid.uid +module TcUni : EcUid.ICore with type uid = private EcUid.uid + +type tyuni = TyUni.uid +type tcuni = TcUni.uid + (* -------------------------------------------------------------------- *) type ty = private { ty_node : ty_node; @@ -46,7 +53,7 @@ type ty = private { and ty_node = | Tglob of EcIdent.t (* The tuple of global variable of the module *) - | Tunivar of EcUid.uid + | Tunivar of tyuni | Tvar of EcIdent.t | Ttuple of ty list | Tconstr of EcPath.path * etyarg list @@ -56,7 +63,7 @@ and ty_node = and etyarg = ty * tcwitness list and tcwitness = - | TCIUni of EcUid.uid + | TCIUni of tcuni | TCIConcrete of { path: EcPath.path; diff --git a/src/ecCoreEqTest.ml b/src/ecCoreEqTest.ml index f9e1a4f35b..c16d062942 100644 --- a/src/ecCoreEqTest.ml +++ b/src/ecCoreEqTest.ml @@ -21,7 +21,8 @@ let rec for_type env t1 t2 = (* -------------------------------------------------------------------- *) and for_type_r env t1 t2 = match t1.ty_node, t2.ty_node with - | Tunivar uid1, Tunivar uid2 -> EcUid.uid_equal uid1 uid2 + | Tunivar uid1, Tunivar uid2 -> + EcAst.TyUni.uid_equal uid1 uid2 | Tvar i1, Tvar i2 -> i1 = i2 @@ -63,7 +64,7 @@ and for_etyargs env (tyargs1 : etyarg list) (tyargs2 : etyarg list) = and for_tcw env (tcw1 : tcwitness) (tcw2 : tcwitness) = match tcw1, tcw2 with | TCIUni uid1, TCIUni uid2 -> - EcUid.uid_equal uid1 uid2 + EcAst.TcUni.uid_equal uid1 uid2 | TCIConcrete tcw1, TCIConcrete tcw2 -> EcPath.p_equal tcw1.path tcw2.path diff --git a/src/ecCorePrinting.ml b/src/ecCorePrinting.ml index 9c22165b91..3edf0c6f43 100644 --- a/src/ecCorePrinting.ml +++ b/src/ecCorePrinting.ml @@ -59,7 +59,8 @@ module type PrinterAPI = sig val pp_mem : PPEnv.t -> EcIdent.t pp val pp_memtype : PPEnv.t -> EcMemory.memtype pp val pp_tyvar : PPEnv.t -> ident pp - val pp_tyunivar : PPEnv.t -> EcUid.uid pp + val pp_tyunivar : PPEnv.t -> EcAst.tyuni pp + val pp_tcunivar : PPEnv.t -> EcAst.tcuni pp val pp_path : path pp (* ------------------------------------------------------------------ *) diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index d320ad38f2..4ca47eea2e 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -17,8 +17,8 @@ type mod_extra = { (* -------------------------------------------------------------------- *) type f_subst = { fs_freshen : bool; (* true means freshen locals *) - fs_u : ty Muid.t; - fs_utc : tcwitness Muid.t; + fs_u : ty TyUni.Muid.t; + fs_utc : tcwitness TcUni.Muid.t; fs_v : etyarg Mid.t; fs_mod : EcPath.mpath Mid.t; fs_modex : mod_extra Mid.t; @@ -50,13 +50,14 @@ let fv_Mid (type a) (* -------------------------------------------------------------------- *) type unisubst = { - uvars : ty Muid.t; - utcvars : tcwitness Muid.t; + uvars : ty TyUni.Muid.t; + utcvars : tcwitness TcUni.Muid.t; } (* -------------------------------------------------------------------- *) let unisubst0 : unisubst = { - uvars = Muid.empty; utcvars = Muid.empty; + uvars = TyUni.Muid.empty; + utcvars = TcUni.Muid.empty; } (* -------------------------------------------------------------------- *) @@ -69,8 +70,8 @@ let f_subst_init = let fv = Mid.empty in - let fv = Muid.fold (fun _ t s -> fv_union s (ty_fv t)) tu.uvars fv in - let fv = Muid.fold (fun _ t s -> fv_union s (tcw_fv t)) tu.utcvars fv in + let fv = TyUni.Muid.fold (fun _ t s -> fv_union s (ty_fv t)) tu.uvars fv in + let fv = TcUni.Muid.fold (fun _ t s -> fv_union s (tcw_fv t)) tu.utcvars fv in let fv = fv_Mid etyarg_fv tv fv in let fv = fv_Mid e_fv esloc fv in @@ -168,7 +169,8 @@ let f_rem_mod (s : f_subst) (x : ident) : f_subst = (* -------------------------------------------------------------------- *) let is_ty_subst_id (s : f_subst) : bool = Mid.is_empty s.fs_mod - && Muid.is_empty s.fs_u + && TyUni.Muid.is_empty s.fs_u + && TcUni.Muid.is_empty s.fs_utc && Mid.is_empty s.fs_v (* -------------------------------------------------------------------- *) @@ -180,7 +182,7 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = |> Option.value ~default:ty | Tunivar id -> - Muid.find_opt id s.fs_u + TyUni.Muid.find_opt id s.fs_u |> Option.map (ty_subst s) |> Option.value ~default:ty @@ -206,7 +208,7 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = match tcw with | TCIUni uid -> - Muid.find_opt uid s.fs_utc + TcUni.Muid.find_opt uid s.fs_utc |> Option.value ~default:tcw | TCIConcrete ({ etyargs = etyargs0 } as rtcw) -> @@ -785,34 +787,34 @@ module Tuni = struct let subst (uidmap : unisubst) : f_subst = f_subst_init ~tu:uidmap () - let subst1 ((id, t) : uid * ty) : f_subst = - subst { unisubst0 with uvars = Muid.singleton id t } + let subst1 ((id, t) : tyuni * ty) : f_subst = + subst { unisubst0 with uvars = TyUni.Muid.singleton id t } let subst_dom (uidmap : unisubst) (dom : dom) : dom = List.map (ty_subst (subst uidmap)) dom - let occurs (u : uid) : ty -> bool = + let occurs (u : tyuni) : ty -> bool = let rec aux t = match t.ty_node with - | Tunivar u' -> uid_equal u u' + | Tunivar u' -> TyUni.uid_equal u u' | _ -> ty_sub_exists aux t in aux - let univars : ty -> Suid.t = + let univars : ty -> TyUni.Suid.t = let rec doit univars t = match t.ty_node with - | Tunivar uid -> Suid.add uid univars + | Tunivar uid -> TyUni.Suid.add uid univars | _ -> ty_fold doit univars t - in fun t -> doit Suid.empty t + in fun t -> doit TyUni.Suid.empty t - let rec fv_rec (fv : Suid.t) (t : ty) : Suid.t = + let rec fv_rec (fv : TyUni.Suid.t) (t : ty) : TyUni.Suid.t = match t.ty_node with - | Tunivar id -> Suid.add id fv + | Tunivar id -> TyUni.Suid.add id fv | _ -> ty_fold fv_rec fv t - let fv (ty : ty) : Suid.t = - fv_rec Suid.empty ty + let fv (ty : ty) : TyUni.Suid.t = + fv_rec TyUni.Suid.empty ty end (* -------------------------------------------------------------------- *) diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index 9ac3be0b47..018c682286 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -1,5 +1,4 @@ (* -------------------------------------------------------------------- *) -open EcUid open EcIdent open EcPath open EcAst @@ -18,7 +17,8 @@ type 'a subst_binder = f_subst -> 'a -> f_subst * 'a (* -------------------------------------------------------------------- *) type unisubst = { - uvars : ty Muid.t; utcvars : tcwitness Muid.t; + uvars : ty TyUni.Muid.t; + utcvars : tcwitness TcUni.Muid.t; } (* -------------------------------------------------------------------- *) @@ -32,12 +32,12 @@ val f_subst_init : (* -------------------------------------------------------------------- *) module Tuni : sig - val univars : ty -> Suid.t - val subst1 : (uid * ty) -> f_subst + val univars : ty -> TyUni.Suid.t + val subst1 : (tyuni * ty) -> f_subst val subst : unisubst -> f_subst val subst_dom : unisubst -> dom -> dom - val occurs : uid -> ty -> bool - val fv : ty -> Suid.t + val occurs : tyuni -> ty -> bool + val fv : ty -> TyUni.Suid.t end (* -------------------------------------------------------------------- *) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 23234a701b..9fb75f752f 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -335,7 +335,7 @@ module PPEnv = struct exception FoundUnivarSym of symbol - let tyunivar (ppe : t) i = + let univar (ppe : t) (i : EcUid.uid) = if not (Mint.mem i (fst !(ppe.ppe_univar))) then begin let alpha = "abcdefghijklmnopqrstuvwxyz" in @@ -469,8 +469,12 @@ let pp_tyvar ppe fmt x = Format.fprintf fmt "%s" (PPEnv.tyvar ppe x) (* -------------------------------------------------------------------- *) -let pp_tyunivar ppe fmt x = - Format.fprintf fmt "%s" (PPEnv.tyunivar ppe x) +let pp_tyunivar (ppe : PPEnv.t) (fmt : Format.formatter) (a : tyuni) = + Format.fprintf fmt "%s" (PPEnv.univar ppe (a :> EcUid.uid)) + +(* -------------------------------------------------------------------- *) +let pp_tcunivar (ppe : PPEnv.t) (fmt : Format.formatter) (a : tcuni) = + Format.fprintf fmt "%s" (PPEnv.univar ppe (a :> EcUid.uid)) (* -------------------------------------------------------------------- *) let pp_tyname ppe fmt p = @@ -959,7 +963,7 @@ and pp_etyargs (ppe : PPEnv.t) (fmt : Format.formatter) (etys : etyarg list) = and pp_tcw (ppe : PPEnv.t) (fmt : Format.formatter) (tcw : tcwitness) = match tcw with | TCIUni uid -> - Format.fprintf fmt "%a" (pp_tyunivar ppe) uid + Format.fprintf fmt "%a" (pp_tcunivar ppe) uid | TCIConcrete { path; etyargs } -> Format.fprintf fmt "%a[%a]" diff --git a/src/ecTypes.ml b/src/ecTypes.ml index feb7cf0b15..75b30cfdb3 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -42,7 +42,7 @@ let rec dump_ty ty = EcIdent.tostring p | Tunivar i -> - Printf.sprintf "#%d" i + Printf.sprintf "#%d" (i :> int) | Tvar id -> EcIdent.tostring id diff --git a/src/ecTypes.mli b/src/ecTypes.mli index 1c3def08f0..2fc4295516 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -29,7 +29,7 @@ val dump_ty : ty -> string val ty_equal : ty -> ty -> bool val ty_hash : ty -> int -val tuni : EcUid.uid -> ty +val tuni : tyuni -> ty val tvar : EcIdent.t -> ty val ttuple : ty list -> ty val tconstr : EcPath.path -> ty list -> ty diff --git a/src/ecTyping.ml b/src/ecTyping.ml index fb5fe4d4e4..266c5349f8 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -2346,7 +2346,7 @@ and fundef_add_symbol env (memenv : memenv) xtys : memenv = and fundef_check_type subst_uni env os (ty, loc) = let ty = subst_uni ty in - if not (EcUid.Suid.is_empty (Tuni.fv ty)) then + if not (TyUni.Suid.is_empty (Tuni.fv ty)) then tyerror loc env (OnlyMonoTypeAllowed os); ty diff --git a/src/ecUid.ml b/src/ecUid.ml index 7af9496cb5..8b4643cfd0 100644 --- a/src/ecUid.ml +++ b/src/ecUid.ml @@ -6,40 +6,84 @@ open EcSymbols (* -------------------------------------------------------------------- *) let unique () = Oo.id (object end) +(* -------------------------------------------------------------------- *) +module type ICore = sig + type uid + + (* ------------------------------------------------------------------ *) + val unique : unit -> uid + val uid_equal : uid -> uid -> bool + val uid_compare : uid -> uid -> int + + (* ------------------------------------------------------------------ *) + module Muid : Map.S with type key = uid + module Suid : Set.S with module M = Map.MakeBase(Muid) + + (* ------------------------------------------------------------------ *) + module SMap : sig + type uidmap + + val create : unit -> uidmap + val lookup : uidmap -> symbol -> uid option + val forsym : uidmap -> symbol -> uid + val pp_uid : Format.formatter -> uid -> unit + end +end + (* -------------------------------------------------------------------- *) type uid = int -type uidmap = { - (*---*) um_tbl : (symbol, uid) Hashtbl.t; - mutable um_uid : int; -} +(* -------------------------------------------------------------------- *) +module Core : ICore with type uid := uid = struct + (* ------------------------------------------------------------------ *) + let unique () : uid = + unique () -let create () = - { um_tbl = Hashtbl.create 0; - um_uid = 0; } + let uid_equal x y = x == y + let uid_compare x y = x - y -let lookup (um : uidmap) (x : symbol) = - try Some (Hashtbl.find um.um_tbl x) - with Not_found -> None + (* ------------------------------------------------------------------ *) + module Muid = Mint + module Suid = Set.MakeOfMap(Muid) -let forsym (um : uidmap) (x : symbol) = - match lookup um x with - | Some uid -> uid - | None -> - let uid = um.um_uid in - um.um_uid <- um.um_uid + 1; - Hashtbl.add um.um_tbl x uid; - uid + (* ------------------------------------------------------------------ *) + module SMap = struct + type uidmap = { + (*---*) um_tbl : (symbol, uid) Hashtbl.t; + mutable um_uid : int; + } -let pp_uid fmt u = - Format.fprintf fmt "#%d" u + let create () = + { um_tbl = Hashtbl.create 0; + um_uid = 0; } + + let lookup (um : uidmap) (x : symbol) = + try Some (Hashtbl.find um.um_tbl x) + with Not_found -> None + + let forsym (um : uidmap) (x : symbol) = + match lookup um x with + | Some uid -> uid + | None -> + let uid = um.um_uid in + um.um_uid <- um.um_uid + 1; + Hashtbl.add um.um_tbl x uid; + uid + + let pp_uid fmt u = + Format.fprintf fmt "#%d" u + end +end (* -------------------------------------------------------------------- *) -let uid_equal x y = x == y -let uid_compare x y = x - y +module CoreGen() : ICore with type uid = private uid = struct + type nonrec uid = uid -module Muid = Mint -module Suid = Set.MakeOfMap(Muid) + include Core +end + +(* -------------------------------------------------------------------- *) +include Core (* -------------------------------------------------------------------- *) module NameGen = struct diff --git a/src/ecUid.mli b/src/ecUid.mli index 1fc50b33a9..429132eef9 100644 --- a/src/ecUid.mli +++ b/src/ecUid.mli @@ -5,21 +5,37 @@ open EcSymbols (* -------------------------------------------------------------------- *) val unique : unit -> int +module type ICore = sig + type uid + + (* ------------------------------------------------------------------ *) + val unique : unit -> uid + val uid_equal : uid -> uid -> bool + val uid_compare : uid -> uid -> int + + (* ------------------------------------------------------------------ *) + module Muid : Map.S with type key = uid + module Suid : Set.S with module M = Map.MakeBase(Muid) + + (* ------------------------------------------------------------------ *) + module SMap : sig + type uidmap + + val create : unit -> uidmap + val lookup : uidmap -> symbol -> uid option + val forsym : uidmap -> symbol -> uid + val pp_uid : Format.formatter -> uid -> unit + end +end + (* -------------------------------------------------------------------- *) type uid = int -type uidmap - -val create : unit -> uidmap -val lookup : uidmap -> symbol -> uid option -val forsym : uidmap -> symbol -> uid -val pp_uid : Format.formatter -> uid -> unit (* -------------------------------------------------------------------- *) -val uid_equal : uid -> uid -> bool -val uid_compare : uid -> uid -> int +include ICore with type uid := uid -module Muid : Map.S with type key = uid -module Suid : Set.S with module M = Map.MakeBase(Muid) +(* -------------------------------------------------------------------- *) +module CoreGen() : ICore with type uid = private uid (* -------------------------------------------------------------------- *) module NameGen : sig diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 48ca851854..215de02e3e 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -3,7 +3,6 @@ open EcSymbols open EcIdent open EcMaps open EcUtils -open EcUid open EcAst open EcTypes open EcCoreSubst @@ -27,10 +26,10 @@ exception UninstanciateUni module Unify = struct module UFArgs = struct module I = struct - type t = uid + type t = tyuni - let equal = uid_equal - let compare = uid_compare + let equal = TyUni.uid_equal + let compare = TyUni.uid_compare end module D = struct @@ -77,23 +76,23 @@ module Unify = struct * unification variables the TC problem depends on. Only * * fully instantiated problems trigger a type-class resolution. * * The UID is the univar from which the TC problem originates. *) - problems : (Suid.t * typeclass list) Muid.t; + problems : (TyUni.Suid.t * typeclass list) TyUni.Muid.t; (* Map from univars to TC problems that depend on them. This * * map is kept in sync with the UID set that appears in the * * bindings of [problems] *) - byunivar : Suid.t Muid.t; + byunivar : TyUni.Suid.t TyUni.Muid.t; (* Map from problems UID to type-class instance witness *) - resolution : tcwitness list Muid.t + resolution : tcwitness list TyUni.Muid.t } (* ------------------------------------------------------------------ *) let initial_ucore ?(tvtc = Mid.empty) () : ucore = let tcenv = - { problems = Muid.empty - ; byunivar = Muid.empty - ; resolution = Muid.empty } + { problems = TyUni.Muid.empty + ; byunivar = TyUni.Muid.empty + ; resolution = TyUni.Muid.empty } in { uf = UF.initial; tvtc; tcenv; } (* ------------------------------------------------------------------ *) @@ -102,7 +101,7 @@ module Unify = struct ?(ty : ty option) ({ uf; tcenv } as uc : ucore) = - let uid = EcUid.unique () in + let uid = TyUni.unique () in let uf = match ty with @@ -121,20 +120,20 @@ module Unify = struct let tws = tws |> List.map (fun tcw -> match tcw with | None -> - TCIUni (EcUid.unique ()) (* FIXME:TC *) + TCIUni (TcUni.unique ()) (* FIXME:TC *) | Some tcw -> tcw ) in let tcenv = let deps = Tuni.univars ty in - let problems = Muid.add uid (deps, tcs) tcenv.problems in - let byunivar = Suid.fold (fun duni byunivar -> - Muid.change (fun pbs -> - Some (Suid.add uid (Option.value ~default:Suid.empty pbs)) + let problems = TyUni.Muid.add uid (deps, tcs) tcenv.problems in + let byunivar = TyUni.Suid.fold (fun duni byunivar -> + TyUni.Muid.change (fun pbs -> + Some (TyUni.Suid.add uid (Option.value ~default:TyUni.Suid.empty pbs)) ) duni byunivar ) deps tcenv.byunivar in - let resolution = Muid.add uid tws tcenv.resolution in + let resolution = TyUni.Muid.add uid tws tcenv.resolution in { problems; byunivar; resolution; } in @@ -157,14 +156,14 @@ module Unify = struct let i' = UF.find i' !uf in match i' with | _ when i = i' -> true - | _ when Hint.mem map i' -> false + | _ when Hint.mem map (i' :> int) -> false | _ -> match UF.data i' !uf with - | None -> Hint.add map i' (); false + | None -> Hint.add map (i' :> int) (); false | Some t -> match doit t with | true -> true - | false -> Hint.add map i' (); false + | false -> Hint.add map (i' :> int) (); false end | _ -> EcTypes.ty_sub_exists doit t @@ -197,7 +196,7 @@ module Unify = struct | false -> begin match t1.ty_node, t2.ty_node with | Tunivar id1, Tunivar id2 -> begin - if not (uid_equal id1 id2) then + if not (TyUni.uid_equal id1 id2) then let effects = reffold (swap |- UF.union id1 id2) uf in List.iter (Queue.push^~ pb) effects end @@ -249,7 +248,7 @@ module Unify = struct let rec doit t = match t.ty_node with | Tunivar i -> begin - match Hint.find_opt map i with + match Hint.find_opt map (i :> int) with | Some t -> t | None -> begin let t = @@ -257,7 +256,7 @@ module Unify = struct | None -> tuni (UF.find i uc.uf) | Some t -> doit t in - Hint.add map i t; t + Hint.add map (i :> int) t; t end end @@ -270,9 +269,9 @@ module Unify = struct let close = close uc in List.fold_left (fun m uid -> match close (tuni uid) with - | { ty_node = Tunivar uid' } when uid_equal uid uid' -> m - | t -> Muid.add uid t m - ) Muid.empty (UF.domain uc.uf) + | { ty_node = Tunivar uid' } when TyUni.uid_equal uid uid' -> m + | t -> TyUni.Muid.add uid t m + ) TyUni.Muid.empty (UF.domain uc.uf) end (* -------------------------------------------------------------------- *) @@ -442,7 +441,7 @@ module UniEnv = struct let assubst (ue : unienv) = { uvars = Unify.subst_of_uf (!ue).ue_uc - ; utcvars = Muid.empty; (* FIXME:TC *) } + ; utcvars = TcUni.Muid.empty; (* FIXME:TC *) } let close (ue : unienv) = if not (closed ue) then raise UninstanciateUni; diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 67eebda78f..4f08eb51b2 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -1,8 +1,8 @@ (* -------------------------------------------------------------------- *) open EcSymbols -open EcUid open EcPath open EcUtils +open EcAst open EcTypes open EcCoreSubst open EcEnv @@ -348,7 +348,7 @@ end = struct | MultipleOpMatch (name, tys, matches) -> begin let uvars = List.map Tuni.univars tys in - let uvars = List.fold_left Suid.union Suid.empty uvars in + let uvars = List.fold_left TyUni.Suid.union TyUni.Suid.empty uvars in begin match tys with | [] -> @@ -379,8 +379,8 @@ end = struct end; let myuvars = List.map Tuni.univars inst in - let myuvars = List.fold_left Suid.union uvars myuvars in - let myuvars = Suid.elements myuvars in + let myuvars = List.fold_left TyUni.Suid.union uvars myuvars in + let myuvars = TyUni.Suid.elements myuvars in let uidmap = EcUnify.UniEnv.assubst subue in let tysubst = ty_subst (Tuni.subst uidmap) in From 67271de45dfd89e50fd07f802808c13fd6f39f27 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 7 Jan 2025 14:15:34 +0100 Subject: [PATCH 063/113] more work on tc unification variables --- src/ecHiNotations.ml | 10 +-- src/ecHiNotations.mli | 2 +- src/ecHiPredicates.ml | 9 +- src/ecHiPredicates.mli | 4 +- src/ecMatching.ml | 2 +- src/ecProofTyping.ml | 4 +- src/ecScope.ml | 14 ++- src/ecTheoryReplay.ml | 18 ++-- src/ecTyping.ml | 2 +- src/ecTyping.mli | 2 +- src/ecUnify.ml | 185 ++++++++++++++++++++++++++++------------ src/ecUnify.mli | 5 +- src/ecUserMessages.ml | 29 +++++-- src/ecUserMessages.mli | 1 + src/phl/ecPhlOutline.ml | 4 +- src/phl/ecPhlRwEquiv.ml | 4 +- 16 files changed, 203 insertions(+), 92 deletions(-) diff --git a/src/ecHiNotations.ml b/src/ecHiNotations.ml index 1ea8f0f173..79c11df3fe 100644 --- a/src/ecHiNotations.ml +++ b/src/ecHiNotations.ml @@ -12,7 +12,7 @@ module TT = EcTyping (* -------------------------------------------------------------------- *) type nterror = | NTE_Typing of EcTyping.tyerror -| NTE_TyNotClosed +| NTE_TyNotClosed of EcUnify.uniflags | NTE_DupIdent | NTE_UnknownBinder of symbol | NTE_AbbrevIsVar @@ -62,8 +62,8 @@ let trans_notation_r (env : env) (nt : pnotation located) = let codom = TT.transty TT.tp_relax env ue nt.nt_codom in let body = TT.transexpcast benv `InOp ue codom nt.nt_body in - if not (EcUnify.UniEnv.closed ue) then - nterror gloc env NTE_TyNotClosed; + Option.iter (fun infos -> nterror gloc env (NTE_TyNotClosed infos)) + @@ EcUnify.UniEnv.xclosed ue; ignore body; () @@ -80,8 +80,8 @@ let trans_abbrev_r (env : env) (at : pabbrev located) = let codom = TT.transty TT.tp_relax env ue (fst at.ab_def) in let body = TT.transexpcast benv `InOp ue codom (snd at.ab_def) in - if not (EcUnify.UniEnv.closed ue) then - nterror gloc env NTE_TyNotClosed; + Option.iter (fun infos -> nterror gloc env (NTE_TyNotClosed infos)) + @@ EcUnify.UniEnv.xclosed ue; let ts = Tuni.subst (EcUnify.UniEnv.close ue) in let es = e_subst ts in diff --git a/src/ecHiNotations.mli b/src/ecHiNotations.mli index 54dd54543e..53aa868c15 100644 --- a/src/ecHiNotations.mli +++ b/src/ecHiNotations.mli @@ -8,7 +8,7 @@ open EcEnv (* -------------------------------------------------------------------- *) type nterror = | NTE_Typing of EcTyping.tyerror -| NTE_TyNotClosed +| NTE_TyNotClosed of EcUnify.uniflags | NTE_DupIdent | NTE_UnknownBinder of symbol | NTE_AbbrevIsVar diff --git a/src/ecHiPredicates.ml b/src/ecHiPredicates.ml index 5b0432b855..e8f6143ced 100644 --- a/src/ecHiPredicates.ml +++ b/src/ecHiPredicates.ml @@ -10,8 +10,8 @@ module TT = EcTyping (* -------------------------------------------------------------------- *) type tperror = -| TPE_Typing of EcTyping.tyerror -| TPE_TyNotClosed +| TPE_Typing of EcTyping.tyerror +| TPE_TyNotClosed of EcUnify.uniflags | TPE_DuplicatedConstr of symbol exception TransPredError of EcLocation.t * EcEnv.env * tperror @@ -73,8 +73,9 @@ let trans_preddecl_r (env : EcEnv.env) (pr : ppredicate located) = in - if not (EcUnify.UniEnv.closed ue) then - tperror loc env TPE_TyNotClosed; + Option.iter + (fun infos -> tperror loc env (TPE_TyNotClosed infos)) + (EcUnify.UniEnv.xclosed ue); let uidmap = EcUnify.UniEnv.assubst ue in let tparams = EcUnify.UniEnv.tparams ue in diff --git a/src/ecHiPredicates.mli b/src/ecHiPredicates.mli index eb56da6628..f411802cce 100644 --- a/src/ecHiPredicates.mli +++ b/src/ecHiPredicates.mli @@ -5,8 +5,8 @@ open EcParsetree (* -------------------------------------------------------------------- *) type tperror = -| TPE_Typing of EcTyping.tyerror -| TPE_TyNotClosed +| TPE_Typing of EcTyping.tyerror +| TPE_TyNotClosed of EcUnify.uniflags | TPE_DuplicatedConstr of symbol exception TransPredError of EcLocation.t * EcEnv.env * tperror diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 2070fd2237..dbb72a251f 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -843,7 +843,7 @@ let f_match opts hyps (ue, ev) f1 f2 = raise MatchFailure; let clue = try EcUnify.UniEnv.close ue - with EcUnify.UninstanciateUni -> raise MatchFailure + with EcUnify.UninstanciateUni _ -> raise MatchFailure in (ue, clue, ev) diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 19ccded58a..01fd18cc49 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -25,9 +25,9 @@ let process_form_opt ?mv hyps pf oty = let ts = Tuni.subst (EcUnify.UniEnv.close ue) in EcFol.Fsubst.f_subst ts ff - with EcUnify.UninstanciateUni -> + with EcUnify.UninstanciateUni infos -> EcTyping.tyerror pf.EcLocation.pl_loc - (LDecl.toenv hyps) EcTyping.FreeTypeVariables + (LDecl.toenv hyps) (FreeUniVariables infos) let process_form ?mv hyps pf ty = process_form_opt ?mv hyps pf (Some ty) diff --git a/src/ecScope.ml b/src/ecScope.ml index 2235143ecd..542474c015 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -874,8 +874,11 @@ module Ax = struct let concl = TT.trans_prop env ue pconcl in - if not (EcUnify.UniEnv.closed ue) then - hierror "the formula contains free type variables"; + Option.iter (fun infos -> + hierror + "the formula contains free %a variables" + EcUserMessages.TypingError.pp_uniflags infos + ) (EcUnify.UniEnv.xclosed ue); let uidmap = EcUnify.UniEnv.close ue in let fs = Tuni.subst uidmap in @@ -1154,8 +1157,11 @@ module Op = struct (opty, `Abstract, [(rname, xs, reft, codom)]) in - if not (EcUnify.UniEnv.closed ue) then - hierror ~loc "this operator type contains free type variables"; + Option.iter (fun infos -> + hierror ~loc + "this operator type contains free %a variables" + EcUserMessages.TypingError.pp_uniflags infos + ) (EcUnify.UniEnv.xclosed ue); let uidmap = EcUnify.UniEnv.close ue in let ts = Tuni.subst uidmap in diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 81af870a24..97374e5a04 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -458,9 +458,12 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = clone_error env (CE_OpIncompatible ((snd ove.ovre_prefix, x), err)) end; - if not (EcUnify.UniEnv.closed ue) then - ove.ovre_hooks.herr - ~loc "this operator body contains free type variables"; + Option.iter (fun infos -> + ove.ovre_hooks.herr ~loc + (Format.asprintf + "this operator body contains free %a variables" + EcUserMessages.TypingError.pp_uniflags infos) + ) (EcUnify.UniEnv.xclosed ue); let sty = CS.Tuni.subst (EcUnify.UniEnv.close ue) in let body = EcFol.Fsubst.f_subst sty body in @@ -573,9 +576,12 @@ and replay_prd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopr) = (CE_OpIncompatible ((snd ove.ovre_prefix, x), err)) end; - if not (EcUnify.UniEnv.closed ue) then - ove.ovre_hooks.herr - ~loc "this predicate body contains free type variables"; + Option.iter (fun infos -> + ove.ovre_hooks.herr ~loc + (Format.asprintf + "this predicate body contains free %a variables" + EcUserMessages.TypingError.pp_uniflags infos) + ) (EcUnify.UniEnv.xclosed ue); let fs = CS.Tuni.subst (EcUnify.UniEnv.close ue) in let body = EcFol.Fsubst.f_subst fs body in diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 266c5349f8..66e039bee0 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -114,7 +114,7 @@ type filter_error = type tyerror = | UniVarNotAllowed -| FreeTypeVariables +| FreeUniVariables of EcUnify.uniflags | TypeVarNotAllowed | OnlyMonoTypeAllowed of symbol option | NoConcreteAnonParams diff --git a/src/ecTyping.mli b/src/ecTyping.mli index cdae448e7f..75bb38dbe8 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -106,7 +106,7 @@ type filter_error = type tyerror = | UniVarNotAllowed -| FreeTypeVariables +| FreeUniVariables of EcUnify.uniflags | TypeVarNotAllowed | OnlyMonoTypeAllowed of symbol option | NoConcreteAnonParams diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 215de02e3e..8524691975 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -18,9 +18,10 @@ type problem = [ ] (* ==================================================================== *) -exception UnificationFailure of problem +type uniflags = { tyvars: bool; tcvars: bool; } -exception UninstanciateUni +exception UnificationFailure of problem +exception UninstanciateUni of uniflags (* ==================================================================== *) module Unify = struct @@ -74,26 +75,58 @@ module Unify = struct and tcenv = { (* Map from UID to TC problems. The UID set collects all the * * unification variables the TC problem depends on. Only * - * fully instantiated problems trigger a type-class resolution. * - * The UID is the univar from which the TC problem originates. *) - problems : (TyUni.Suid.t * typeclass list) TyUni.Muid.t; + * fully instantiated problems trigger a type-class resolution. *) + problems : (TyUni.Suid.t * typeclass) TcUni.Muid.t; (* Map from univars to TC problems that depend on them. This * * map is kept in sync with the UID set that appears in the * * bindings of [problems] *) - byunivar : TyUni.Suid.t TyUni.Muid.t; + byunivar : TcUni.Suid.t TyUni.Muid.t; (* Map from problems UID to type-class instance witness *) - resolution : tcwitness list TyUni.Muid.t + resolution : tcwitness TcUni.Muid.t } + (* ------------------------------------------------------------------ *) + let tcenv_empty : tcenv = + { problems = TcUni.Muid.empty + ; byunivar = TyUni.Muid.empty + ; resolution = TcUni.Muid.empty } + + (* ------------------------------------------------------------------ *) + let tcenv_closed (tcenv : tcenv) : bool = (* FIXME:TC *) + TcUni.Muid.cardinal tcenv.resolution + = TcUni.Muid.cardinal tcenv.problems + + (* ------------------------------------------------------------------ *) + let create_tcproblem + (tcenv : tcenv) + (ty : ty) + (tcw : typeclass * tcwitness option) + : tcenv * tcwitness + = + let tc, tw = tcw in + let uid = TcUni.unique () in + let deps = Tuni.univars ty in (* FIXME:TC *) + + let tcenv = { + problems = TcUni.Muid.add uid (deps, tc) tcenv.problems; + byunivar = TyUni.Suid.fold (fun duni byunivar -> + TyUni.Muid.change (fun pbs -> + Some (TcUni.Suid.add uid (Option.value ~default:TcUni.Suid.empty pbs)) + ) duni byunivar + ) deps tcenv.byunivar; + resolution = + ofold + (fun tw map -> TcUni.Muid.add uid tw map) + tcenv.resolution tw; + } in + + tcenv, TCIUni uid + (* ------------------------------------------------------------------ *) let initial_ucore ?(tvtc = Mid.empty) () : ucore = - let tcenv = - { problems = TyUni.Muid.empty - ; byunivar = TyUni.Muid.empty - ; resolution = TyUni.Muid.empty } - in { uf = UF.initial; tvtc; tcenv; } + { uf = UF.initial; tcenv = tcenv_empty; tvtc; } (* ------------------------------------------------------------------ *) let fresh @@ -115,27 +148,10 @@ module Unify = struct let ty = Option.value ~default:(tuni uid) (UF.data uid uf) in - let tcs, tws = List.split (Option.value ~default:[] tcs) in - - let tws = tws |> List.map (fun tcw -> - match tcw with - | None -> - TCIUni (TcUni.unique ()) (* FIXME:TC *) - | Some tcw -> - tcw - ) in - - let tcenv = - let deps = Tuni.univars ty in - let problems = TyUni.Muid.add uid (deps, tcs) tcenv.problems in - let byunivar = TyUni.Suid.fold (fun duni byunivar -> - TyUni.Muid.change (fun pbs -> - Some (TyUni.Suid.add uid (Option.value ~default:TyUni.Suid.empty pbs)) - ) duni byunivar - ) deps tcenv.byunivar in - let resolution = TyUni.Muid.add uid tws tcenv.resolution in - { problems; byunivar; resolution; } - in + let tcenv, tws = + List.fold_left_map + (fun tcenv tcw -> create_tcproblem tcenv ty tcw) + tcenv (Option.value ~default:[] tcs) in ({ uc with uf; tcenv; }, (tuni uid, tws)) @@ -242,36 +258,94 @@ module Unify = struct doit (); { uc with uf = !uf } (* -------------------------------------------------------------------- *) - let close (uc : ucore) = - let map = Hint.create 0 in + type closed = { tyuni : ty -> ty; tcuni : tcwitness -> tcwitness; } + + (* -------------------------------------------------------------------- *) + let close (uc : ucore) : closed = + let tymap = Hint.create 0 in + let tcmap = Hint.create 0 in - let rec doit t = + let rec doit_ty t = match t.ty_node with | Tunivar i -> begin - match Hint.find_opt map (i :> int) with + match Hint.find_opt tymap (i :> int) with | Some t -> t | None -> begin let t = match UF.data i uc.uf with | None -> tuni (UF.find i uc.uf) - | Some t -> doit t + | Some t -> doit_ty t in - Hint.add map (i :> int) t; t + Hint.add tymap (i :> int) t; t end + end + + | _ -> ty_map doit_ty t + + and doit_tc (tw : tcwitness) = + match tw with + | TCIUni uid -> begin + match Hint.find_opt tcmap (uid :> int) with + | Some tw -> tw + | None -> + let tw = + match TcUni.Muid.find_opt uid uc.tcenv.resolution with + | None -> tw + | Some (TCIUni uid') when TcUni.uid_equal uid uid' -> tw (* FIXME:TC *) + | Some tw -> doit_tc tw + in + Hint.add tcmap (uid :> int) tw; tw end - | _ -> ty_map doit t - in - fun t -> doit t + | TCIConcrete { path; etyargs } -> + let etyargs = + List.map + (fun (ty, tws) -> (doit_ty ty, List.map doit_tc tws)) + etyargs + in TCIConcrete { path; etyargs; } + + | TCIAbstract { support = (`Var _ | `Abs _) } -> + tw + + in { tyuni = doit_ty; tcuni = doit_tc; } (* ------------------------------------------------------------------ *) - let subst_of_uf (uc : ucore) = + let subst_of_uf (uc : ucore) : unisubst = let close = close uc in - List.fold_left (fun m uid -> - match close (tuni uid) with - | { ty_node = Tunivar uid' } when TyUni.uid_equal uid uid' -> m - | t -> TyUni.Muid.add uid t m - ) TyUni.Muid.empty (UF.domain uc.uf) + + let dereference_tyuni (uid : tyuni) = + match close.tyuni (tuni uid) with + | { ty_node = Tunivar uid' } when TyUni.uid_equal uid uid' -> None + | ty -> Some ty in + + let dereference_tcuni (uid : tcuni) = + match close.tcuni (TCIUni uid) with + | TCIUni uid' when TcUni.uid_equal uid uid' -> None + | tw -> Some tw in + + let uvars = + let bindings = + List.filter_map (fun uid -> + Option.map (fun ty -> (uid, ty)) (dereference_tyuni uid) + ) (UF.domain uc.uf) in + TyUni.Muid.of_list bindings in + + let utcvars = + let bindings = + List.filter_map (fun uid -> + Option.map (fun tw -> (uid, tw)) (dereference_tcuni uid) + ) (TcUni.Muid.keys uc.tcenv.problems) in + TcUni.Muid.of_list bindings in + + { uvars; utcvars; } + + (* -------------------------------------------------------------------- *) + let check_closed (uc : ucore) = + let tyvars = not (UF.closed uc.uf) in + let tcvars = not (tcenv_closed uc.tcenv) in + + if tyvars || tcvars then + raise (UninstanciateUni { tyvars; tcvars }) end (* -------------------------------------------------------------------- *) @@ -436,20 +510,23 @@ module UniEnv = struct | Tunivar id -> odfl t (Unify.UF.data id (!ue).ue_uc.uf) | _ -> t + let xclosed (ue : unienv) = + try Unify.check_closed (!ue).ue_uc; None + with UninstanciateUni infos -> Some infos + let closed (ue : unienv) = - Unify.UF.closed (!ue).ue_uc.uf (* FIXME:TC *) + Option.is_none (xclosed ue) - let assubst (ue : unienv) = - { uvars = Unify.subst_of_uf (!ue).ue_uc - ; utcvars = TcUni.Muid.empty; (* FIXME:TC *) } + let assubst (ue : unienv) : unisubst = + Unify.subst_of_uf (!ue).ue_uc let close (ue : unienv) = - if not (closed ue) then raise UninstanciateUni; + Unify.check_closed (!ue).ue_uc; assubst ue let tparams (ue : unienv) = let fortv x = odfl [] (Mid.find_opt x (!ue).ue_uc.tvtc) in - List.map (fun x -> (x, fortv x)) (List.rev (!ue).ue_decl) + List.map (fun x -> (x, fortv x)) (List.rev (!ue).ue_decl) end (* -------------------------------------------------------------------- *) diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 7196e3e906..cb79ac7a97 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -11,8 +11,10 @@ type problem = [ | `TcCtt of EcUid.uid * ty * typeclass ] +type uniflags = { tyvars: bool; tcvars: bool; } + exception UnificationFailure of problem -exception UninstanciateUni +exception UninstanciateUni of uniflags type unienv @@ -44,6 +46,7 @@ module UniEnv : sig val openty : unienv -> ty_params -> tvi -> ty -> ty * opened val opentys : unienv -> ty_params -> tvi -> ty list -> ty list * opened val closed : unienv -> bool + val xclosed : unienv -> uniflags option val close : unienv -> EcCoreSubst.unisubst val assubst : unienv -> EcCoreSubst.unisubst val tparams : unienv -> ty_params diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 4f08eb51b2..2cee8c036f 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -21,6 +21,7 @@ let set_ppo (newppo : pp_options) = module TypingError : sig open EcTyping + val pp_uniflags : Format.formatter -> EcUnify.uniflags -> unit val pp_fxerror : env -> Format.formatter -> fxerror -> unit val pp_tyerror : env -> Format.formatter -> tyerror -> unit val pp_cnv_failure : env -> Format.formatter -> tymod_cnv_failure -> unit @@ -30,6 +31,16 @@ module TypingError : sig end = struct open EcTyping + let pp_uniflags (fmt : Format.formatter) ({ tyvars; tcvars; } : EcUnify.uniflags) = + let msg = + match tyvars, tcvars with + | false, false -> None + | true, false -> Some "type" + | false, true -> Some "type-class" + | true, true -> Some "type&type-class" in + + Option.iter (Format.fprintf fmt "%s") msg + let pp_mismatch_funsig env0 fmt error = let ppe0 = EcPrinting.PPEnv.ofenv env0 in @@ -235,8 +246,10 @@ end = struct | UniVarNotAllowed -> msg "type place holders not allowed" - | FreeTypeVariables -> - msg "this expression contains free type variables" + | FreeUniVariables infos -> + msg + "this expression contains free %a variables" + pp_uniflags infos | TypeVarNotAllowed -> msg "type variables not allowed" @@ -621,8 +634,10 @@ end = struct let pp_tperror (env : env) fmt = function | TPE_Typing e -> TypingError.pp_tyerror env fmt e - | TPE_TyNotClosed -> - Format.fprintf fmt "this predicate type contains free type variables" + | TPE_TyNotClosed infos -> + Format.fprintf fmt + "this predicate type contains free %a variables" + TypingError.pp_uniflags infos | TPE_DuplicatedConstr x -> Format.fprintf fmt "duplicated constructor name: `%s'" x end @@ -641,8 +656,10 @@ end = struct match error with | NTE_Typing e -> TypingError.pp_tyerror env fmt e - | NTE_TyNotClosed -> - msg "this notation type contains free type variables" + | NTE_TyNotClosed infos -> + msg + "this notation type contains free %a variables" + TypingError.pp_uniflags infos | NTE_DupIdent -> msg "an ident is bound several time" | NTE_UnknownBinder x -> diff --git a/src/ecUserMessages.mli b/src/ecUserMessages.mli index efe97e0efc..97d3e0d10b 100644 --- a/src/ecUserMessages.mli +++ b/src/ecUserMessages.mli @@ -14,6 +14,7 @@ val set_ppo : pp_options -> unit module TypingError : sig open EcTyping + val pp_uniflags : Format.formatter -> EcUnify.uniflags -> unit val pp_tyerror : env -> Format.formatter -> tyerror -> unit val pp_cnv_failure : env -> Format.formatter -> tymod_cnv_failure -> unit val pp_mismatch_funsig : env -> Format.formatter -> mismatch_funsig -> unit diff --git a/src/phl/ecPhlOutline.ml b/src/phl/ecPhlOutline.ml index 6774ad118b..7b6091423d 100644 --- a/src/phl/ecPhlOutline.ml +++ b/src/phl/ecPhlOutline.ml @@ -279,8 +279,8 @@ let process_outline info tc = let sty = f_subst_init ~tu () in let es = e_subst sty in Some (lv_of_expr (es res)) - with EcUnify.UninstanciateUni -> - EcTyping.tyerror loc env EcTyping.FreeTypeVariables + with EcUnify.UninstanciateUni infos -> + EcTyping.tyerror loc env (FreeUniVariables infos) end | None, _ -> None | _, _ -> raise (OutlineError OE_UnnecessaryReturn) diff --git a/src/phl/ecPhlRwEquiv.ml b/src/phl/ecPhlRwEquiv.ml index 3e38064377..f7b63d3f06 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -145,8 +145,8 @@ let process_rewrite_equiv info tc = let res = omap (fun v -> EcTyping.transexpcast subenv `InProc ue ret_ty v) pres in let es = e_subst (Tuni.subst (EcUnify.UniEnv.close ue)) in Some (List.map es args, omap (EcModules.lv_of_expr |- es) res) - with EcUnify.UninstanciateUni -> - EcTyping.tyerror (loc pargs) env EcTyping.FreeTypeVariables + with EcUnify.UninstanciateUni infos -> + EcTyping.tyerror (loc pargs) env (FreeUniVariables infos) end in From c77f6669e7261eff8e480fc88b72fabb8ba810b6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 7 Jan 2025 17:43:06 +0100 Subject: [PATCH 064/113] WIP on TC resolution --- src/ecScope.ml | 6 ++- src/ecUnify.ml | 130 ++++++++++++++++++++++++++++++++++++++++-------- src/ecUnify.mli | 2 +- 3 files changed, 116 insertions(+), 22 deletions(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 542474c015..750fe3e378 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1994,8 +1994,12 @@ module Ty = struct ; tci_instance = `General (tcp, Some symbols) ; tci_local = lc } in + let name = + Format.sprintf "%s#%d" + (EcPath.basename tcp.tc_name) (EcUid.unique ()) in + let scope = - let item = EcTheory.Th_instance (None, instance) in (* FIXME *) + let item = EcTheory.Th_instance (Some name, instance) in (* FIXME:TC *) let item = EcTheory.mkitem import item in { scope with sc_env = EcSection.add_item item scope.sc_env } in diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 8524691975..8a0489081a 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -14,7 +14,7 @@ module Sp = EcPath.Sp type problem = [ | `TyUni of ty * ty | `TcTw of tcwitness * tcwitness - | `TcCtt of EcUid.uid * ty * typeclass + | `TcCtt of tcuni * ty * typeclass ] (* ==================================================================== *) @@ -73,14 +73,10 @@ module Unify = struct } and tcenv = { - (* Map from UID to TC problems. The UID set collects all the * - * unification variables the TC problem depends on. Only * - * fully instantiated problems trigger a type-class resolution. *) - problems : (TyUni.Suid.t * typeclass) TcUni.Muid.t; - - (* Map from univars to TC problems that depend on them. This * - * map is kept in sync with the UID set that appears in the * - * bindings of [problems] *) + (* Map from UID to TC problems. *) + problems : (ty * typeclass) TcUni.Muid.t; + + (* Map from univars to TC problems that depend on them. *) byunivar : TcUni.Suid.t TyUni.Muid.t; (* Map from problems UID to type-class instance witness *) @@ -110,7 +106,7 @@ module Unify = struct let deps = Tuni.univars ty in (* FIXME:TC *) let tcenv = { - problems = TcUni.Muid.add uid (deps, tc) tcenv.problems; + problems = TcUni.Muid.add uid (ty, tc) tcenv.problems; byunivar = TyUni.Suid.fold (fun duni byunivar -> TyUni.Muid.change (fun pbs -> Some (TcUni.Suid.add uid (Option.value ~default:TcUni.Suid.empty pbs)) @@ -159,22 +155,22 @@ module Unify = struct let unify_core (env : EcEnv.env) (uc : ucore) (pb : problem) : ucore = let failure () = raise (UnificationFailure pb) in - let uf = ref uc.uf in + let uc = ref uc in let pb = let x = Queue.create () in Queue.push pb x; x in let ocheck i t = - let i = UF.find i !uf in + let i = UF.find i (!uc).uf in let map = Hint.create 0 in let rec doit t = match t.ty_node with | Tunivar i' -> begin - let i' = UF.find i' !uf in + let i' = UF.find i' (!uc).uf in match i' with | _ when i = i' -> true | _ when Hint.mem map (i' :> int) -> false | _ -> - match UF.data i' !uf with + match UF.data i' (!uc).uf with | None -> Hint.add map (i' :> int) (); false | Some t -> match doit t with @@ -187,17 +183,35 @@ module Unify = struct doit t in - let setvar i t = + let setvar (i : tyuni) (t : ty) = let (ti, effects) = - UFArgs.D.union (UF.data i !uf) (Some t) + UFArgs.D.union (UF.data i (!uc).uf) (Some t) in if odfl false (ti |> omap (ocheck i)) then failure (); List.iter (Queue.push^~ pb) effects; - uf := UF.set i ti !uf + + begin + (* FIXME:TC (cache!)*) + match TyUni.Muid.find i (!uc).tcenv.byunivar with + | tcpbs -> + uc := { !uc with tcenv = { (!uc).tcenv with + byunivar = TyUni.Muid.remove i (!uc).tcenv.byunivar + } }; + let tcpbs = TcUni.Suid.elements tcpbs in + let tcpbs = List.map (fun uid -> + let pb = TcUni.Muid.find uid (!uc).tcenv.problems in + (uid, pb) + ) tcpbs in + List.iter (fun (uid, (ty, tc)) -> Queue.push (`TcCtt (uid, ty, tc)) pb) tcpbs + + | exception Not_found -> () + end; + + uc := { !uc with uf = UF.set i ti (!uc).uf } and getvar t = match t.ty_node with - | Tunivar i -> odfl t (UF.data i !uf) + | Tunivar i -> odfl t (UF.data i (!uc).uf) | _ -> t in @@ -213,7 +227,11 @@ module Unify = struct match t1.ty_node, t2.ty_node with | Tunivar id1, Tunivar id2 -> begin if not (TyUni.uid_equal id1 id2) then - let effects = reffold (swap |- UF.union id1 id2) uf in + let effects = + reffold (fun uc -> + let uf, effects = UF.union id1 id2 uc.uf in + effects, { uc with uf } + ) uc in List.iter (Queue.push^~ pb) effects end @@ -251,11 +269,83 @@ module Unify = struct end end + | `TcCtt (uid, ty, tc) -> + if not (List.is_empty tc.tc_args) then + failure (); + + let deps = ref TyUni.Suid.empty in + + let rec check (ty : ty) : ty = + match ty.ty_node with + | Tunivar tyuvar -> begin + match UF.data tyuvar (!uc).uf with + | None -> + deps := TyUni.Suid.add tyuvar !deps; + ty + | Some ty -> + check ty + end + | _ -> ty_map check ty in + + let ty = check ty in + let deps = !deps in + + let check_tci (tci : EcTheory.tcinstance) : bool = + let exception Bailout in + + try + begin + match tci.tci_instance with + | `General (tc', _) -> + if not (List.is_empty tc'.tc_args) then + raise Bailout; + if not (EcPath.p_equal tc'.tc_name tc.tc_name) then + raise Bailout + | _ -> raise Bailout + end; + if not (List.is_empty tci.tci_params) then + raise Bailout; + if not (EcCoreEqTest.for_type env ty tci.tci_type) then + raise Bailout; + true + + with Bailout -> + false in + + if TyUni.Suid.is_empty deps then begin + let tci = + EcEnv.TcInstance.get_all env + |> List.to_seq + |> Seq.filter_map (fun (p, tci) -> Option.map (fun p -> (p, tci)) p) + |> Seq.filter (fun (_, tci) -> check_tci tci) + |> Seq.uncons |> Option.map (fst |- fst) in + + match tci with + | None -> + failure () + + | Some tci -> + uc := { !uc with tcenv = { (!uc).tcenv with resolution = + TcUni.Muid.add uid (TCIConcrete { + path = tci; etyargs = []; + }) (!uc).tcenv.resolution + } } + end else begin + TyUni.Suid.iter (fun tyvar -> + uc := { !uc with tcenv = { (!uc).tcenv with byunivar = + TyUni.Muid.change (fun map -> + let map = Option.value ~default:TcUni.Suid.empty map in + Some (TcUni.Suid.add uid map) + ) tyvar (!uc).tcenv.byunivar + } } + ) deps + end + | _ -> () (* FIXME:TC *) done in - doit (); { uc with uf = !uf } + doit (); !uc (* -------------------------------------------------------------------- *) type closed = { tyuni : ty -> ty; tcuni : tcwitness -> tcwitness; } diff --git a/src/ecUnify.mli b/src/ecUnify.mli index cb79ac7a97..6cb0fee1c3 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -8,7 +8,7 @@ open EcDecl type problem = [ | `TyUni of ty * ty | `TcTw of tcwitness * tcwitness - | `TcCtt of EcUid.uid * ty * typeclass + | `TcCtt of EcAst.tcuni * ty * typeclass ] type uniflags = { tyvars: bool; tcvars: bool; } From ac2067489fc5d96fe54c2b8cf87c53182115278b Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 8 Jan 2025 10:09:22 +0100 Subject: [PATCH 065/113] WIP: section & tc instance --- src/ecSection.ml | 117 ++++++++++++++++++++--------------------------- 1 file changed, 49 insertions(+), 68 deletions(-) diff --git a/src/ecSection.ml b/src/ecSection.ml index 81f18cbbe5..94a41e1d1e 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -22,7 +22,7 @@ type cbarg = [ | `Module of mpath | `ModuleType of path | `Typeclass of path - | `Instance of tcinstance + | `TcInstance of [`General of path | `Ring | `Field] ] type cb = cbarg -> unit @@ -52,12 +52,13 @@ let pp_cbarg env fmt (who : cbarg) = (EcEnv.ModTy.modtype p env) | `Typeclass p -> Format.fprintf fmt "typeclass %a" (EcPrinting.pp_tyname ppe) p - | `Instance tci -> - match tci.tci_instance with - | `Ring _ -> Format.fprintf fmt "ring instance" - | `Field _ -> Format.fprintf fmt "field instance" - | `General _ -> Format.fprintf fmt "instance" - + | `TcInstance (`General p) -> + Format.fprintf fmt "typeclass instance %s" (EcPath.tostring p) (* FIXME:TC *) + | `TcInstance `Ring -> + Format.fprintf fmt "ring instance" + | `TcInstance `Field -> + Format.fprintf fmt "field instance" + let pp_locality fmt = function | `Local -> Format.fprintf fmt "local" | `Global -> () @@ -121,7 +122,7 @@ and on_tcwitness cb (tcw : tcwitness) = | TCIConcrete { path; etyargs } -> List.iter (on_etyarg cb) etyargs; - cb (`Type path) (* FIXME:TC *) + cb (`TcInstance (`General path)) | TCIAbstract { support = `Abs path } -> cb (`Type path) @@ -548,7 +549,8 @@ let locality (env : EcEnv.env) (who : cbarg) = | _ -> `Global end | `ModuleType p -> ((EcEnv.ModTy.by_path p env).tms_loca :> locality) - | `Instance _ -> assert false + | `TcInstance (`General p) -> (EcEnv.TcInstance.by_path p env).tci_local + | `TcInstance (`Ring | `Field) -> `Global (* -------------------------------------------------------------------- *) type to_clear = @@ -1113,22 +1115,6 @@ let is_abstract_ty = function | `Abstract _ -> true | _ -> false -(* -let rec check_glob_mp_ty s scenv mp = - let mtop = `Module (mastrip mp) in - if is_declared scenv mtop then - hierror "global %s can't depend on declared module" s; - if is_local scenv mtop then - hierror "global %s can't depend on local module" s; - List.iter (check_glob_mp_ty s scenv) mp.m_args - -let rec check_glob_mp scenv mp = - let mtop = `Module (mastrip mp) in - if is_local scenv mtop then - hierror "global definition can't depend on local module"; - List.iter (check_glob_mp scenv) mp.m_args - *) - let check s scenv who b = if not b then hierror "%a %s" (pp_lc_cbarg scenv.sc_env) who s @@ -1142,24 +1128,26 @@ let check_polymorph scenv who typarams = let check_abstract = check "should be abstract" type can_depend = { - d_ty : locality list; - d_op : locality list; - d_ax : locality list; - d_sc : locality list; - d_mod : locality list; - d_modty : locality list; - d_tc : locality list; - } + d_ty : locality list; + d_op : locality list; + d_ax : locality list; + d_sc : locality list; + d_mod : locality list; + d_modty : locality list; + d_tc : locality list; + d_tci : locality list; +} -let cd_glob = - { d_ty = [`Global]; - d_op = [`Global]; - d_ax = [`Global]; - d_sc = [`Global]; - d_mod = [`Global]; - d_modty = [`Global]; - d_tc = [`Global]; - } +let cd_glob = { + d_ty = [`Global]; + d_op = [`Global]; + d_ax = [`Global]; + d_sc = [`Global]; + d_mod = [`Global]; + d_modty = [`Global]; + d_tc = [`Global]; + d_tci = [`Global]; +} let can_depend (cd : can_depend) = function | `Type _ -> cd.d_ty @@ -1169,8 +1157,7 @@ let can_depend (cd : can_depend) = function | `Module _ -> cd.d_mod | `ModuleType _ -> cd.d_modty | `Typeclass _ -> cd.d_tc - | `Instance _ -> assert false - + | `TcInstance _ -> cd.d_tci let cb scenv from cd who = let env = scenv.sc_env in @@ -1201,29 +1188,10 @@ let check_tyd scenv prefix name tyd = d_mod = [`Global]; d_modty = []; d_tc = [`Global]; + d_tci = [`Global]; } in on_tydecl (cb scenv from cd) tyd -(* -let cb_glob scenv (who:cbarg) = - match who with - | `Type p -> - if is_local scenv who then - hierror "global definition can't depend of local type %s" - (EcPath.tostring p) - | `Module mp -> - check_glob_mp scenv mp - | `Op p -> - if is_local scenv who then - hierror "global definition can't depend of local op %s" - (EcPath.tostring p) - | `ModuleType p -> - if is_local scenv who then - hierror "global definition can't depend of local module type %s" - (EcPath.tostring p) - | `Ax _ | `Typeclass _ -> assert false -*) - let is_abstract_op op = match op.op_kind with | OB_oper None | OB_pred None -> true @@ -1247,6 +1215,7 @@ let check_op scenv prefix name op = d_mod = [`Declare; `Global]; d_modty = []; d_tc = [`Global]; + d_tci = [`Global]; } in on_opdecl (cb scenv from cd) op @@ -1259,6 +1228,7 @@ let check_op scenv prefix name op = d_mod = [`Global]; d_modty = []; d_tc = [`Global]; + d_tci = [`Global]; } in on_opdecl (cb scenv from cd) op @@ -1278,6 +1248,7 @@ let check_ax (scenv : scenv) (prefix : path) (name : symbol) (ax : axiom) = d_mod = [`Declare; `Global]; d_modty = [`Global]; d_tc = [`Global]; + d_tci = [`Global]; } in let doit = on_axiom (cb scenv from cd) in let error b s1 s = @@ -1330,6 +1301,7 @@ let check_module scenv prefix tme = d_mod = [`Global]; (* FIXME section: add local *) d_modty = [`Global]; d_tc = [`Global]; + d_tci = [`Global]; } in on_module (cb scenv from cd) me | `Declare -> (* Should be SC_decl_mod ... *) @@ -1342,8 +1314,16 @@ let check_tcdecl scenv prefix name tc = else on_tcdecl (cb scenv from cd_glob) tc -let check_instance scenv tci = - let from = (tci.tci_local, `Instance tci) in +let check_instance scenv prefix x tci = + let from = + match x, tci.tci_instance with + | Some x, `General _ -> `General (pqname prefix x) + | None , `Ring _ -> `Ring + | None , `Field _ -> `Field + | _ , _ -> assert false in + + let from = (tci.tci_local, `TcInstance from) in + if tci.tci_local = `Local then check_section scenv from else if scenv.sc_insec then @@ -1416,7 +1396,7 @@ let rec generalize_th_item (to_gen : to_gen) (prefix : path) (th_item : theory_i | Th_theory th -> (generalize_ctheory to_gen prefix th, None) | Th_export (p,lc) -> generalize_export to_gen (p,lc) | Th_instance (x,tci)-> generalize_instance to_gen (x,tci) - | Th_typeclass _ -> assert false + | Th_typeclass _ -> assert false (* FIXME:TC *) | Th_baserw (s,lc) -> generalize_baserw to_gen prefix (s,lc) | Th_addrw (p,ps,lc) -> generalize_addrw to_gen (p, ps, lc) | Th_reduction rl -> generalize_reduction to_gen rl @@ -1531,7 +1511,7 @@ let check_item scenv item = | Th_module me -> check_module scenv prefix me | Th_typeclass (s,tc) -> check_tcdecl scenv prefix s tc | Th_export (_, lc) -> assert (lc = `Global || scenv.sc_insec); - | Th_instance(_, tci) -> check_instance scenv tci + | Th_instance(x, tci) -> check_instance scenv prefix x tci | Th_baserw (_,lc) -> if (lc = `Local && not scenv.sc_insec) then hierror "local base rewrite can only be declared inside section"; @@ -1575,6 +1555,7 @@ let add_decl_mod id mt scenv = d_mod = [`Declare; `Global]; d_modty = [`Global]; d_tc = [`Global]; + d_tci = [`Global]; } in let from = `Declare, `Module (mpath_abs id []) in on_mty_mr (cb scenv from cd) mt; From ef0105ad7799e0b37775efc76defc903d858b16c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 8 Jan 2025 11:32:00 +0100 Subject: [PATCH 066/113] named TC instances --- src/ecParser.mly | 7 ++++--- src/ecParsetree.ml | 3 ++- src/ecPrinting.ml | 24 +++++++++++++++++------- src/ecScope.ml | 16 +++++++++------- 4 files changed, 32 insertions(+), 18 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index 6353f54ced..958294eb30 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -1646,11 +1646,12 @@ tc_ax: (* -------------------------------------------------------------------- *) (* Type classes (instances) *) tycinstance: -| loca=is_local INSTANCE x=tcparam args=tyci_args? - WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* +| loca=is_local INSTANCE tc=tcparam args=tyci_args? + name=prefix(AS, lident)? WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* { let args = args |> omap (fun (c, p) -> `Ring (c, p)) in - { pti_name = x; + { pti_tc = tc; + pti_name = name; pti_type = (odfl [] typ, ty); pti_ops = ops; pti_axs = axs; diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index acd5af9d16..df95ff8366 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -1051,7 +1051,8 @@ type ptypeclass = { } type ptycinstance = { - pti_name : ptcparam; + pti_tc : ptcparam; + pti_name : psymbol option; pti_type : ptyparams * pty; pti_ops : (psymbol * (pty list * pqsymbol)) list; pti_axs : (psymbol * ptactic_core) list; diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 9fb75f752f..e7e5c2e965 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -175,12 +175,19 @@ module PPEnv = struct in p_shorten exists p + let tci_symb (ppe : t) p = + let exists sm = + try EcPath.p_equal (EcEnv.TcInstance.lookup_path sm ppe.ppe_env) p + with EcEnv.LookupFailure _ -> false + in + p_shorten exists p + let rw_symb (ppe : t) p = - let exists sm = - try EcPath.p_equal (EcEnv.BaseRw.lookup_path sm ppe.ppe_env) p - with EcEnv.LookupFailure _ -> false - in - p_shorten exists p + let exists sm = + try EcPath.p_equal (EcEnv.BaseRw.lookup_path sm ppe.ppe_env) p + with EcEnv.LookupFailure _ -> false + in + p_shorten exists p let ax_symb (ppe : t) p = let exists sm = @@ -485,6 +492,10 @@ let pp_tcname ppe fmt p = Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.tc_symb ppe p) (* -------------------------------------------------------------------- *) +let pp_tciname ppe fmt p = + Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.tci_symb ppe p) + + (* -------------------------------------------------------------------- *) let pp_rwname ppe fmt p = Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.rw_symb ppe p) @@ -967,8 +978,7 @@ and pp_tcw (ppe : PPEnv.t) (fmt : Format.formatter) (tcw : tcwitness) = | TCIConcrete { path; etyargs } -> Format.fprintf fmt "%a[%a]" - pp_qsymbol (EcPath.toqsymbol path) - (pp_etyargs ppe) etyargs + (pp_tciname ppe) path (pp_etyargs ppe) etyargs | TCIAbstract { support = `Var x; offset } -> Format.fprintf fmt "%a.`%d" (pp_tyvar ppe) x (offset + 1) diff --git a/src/ecScope.ml b/src/ecScope.ml index 750fe3e378..ea31feb4aa 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1940,6 +1940,12 @@ module Ty = struct let add_generic_instance ~import (scope : scope) mode { pl_desc = tci; pl_loc = loc; } = + let name = + match tci.pti_name with + | None -> + hierror ~loc "typeclass instances must be given a name" + | Some name -> name in + let (typarams, _) as ty = let ue = TT.transtyvars (env scope) (loc, Some (fst tci.pti_type)) in let ty = transty tp_tydecl (env scope) ue (snd tci.pti_type) in @@ -1952,7 +1958,7 @@ module Ty = struct let tcp = let ue = EcUnify.UniEnv.create (Some typarams) in - TT.transtc (env scope) ue tci.pti_name in + TT.transtc (env scope) ue tci.pti_tc in let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in @@ -1994,12 +2000,8 @@ module Ty = struct ; tci_instance = `General (tcp, Some symbols) ; tci_local = lc } in - let name = - Format.sprintf "%s#%d" - (EcPath.basename tcp.tc_name) (EcUid.unique ()) in - let scope = - let item = EcTheory.Th_instance (Some name, instance) in (* FIXME:TC *) + let item = EcTheory.Th_instance (Some (unloc name), instance) in let item = EcTheory.mkitem import item in { scope with sc_env = EcSection.add_item item scope.sc_env } in @@ -2009,7 +2011,7 @@ module Ty = struct let add_instance ?(import = EcTheory.import0) (scope : scope) mode ({ pl_desc = tci } as toptci) = - match unloc (fst tci.pti_name) with + match unloc (fst tci.pti_tc) with | ([], "bring") -> begin if EcUtils.is_some tci.pti_args then hierror "unsupported-option"; From 703e44e4dc9f40efd1efc2a14d7677395f553aa4 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 8 Jan 2025 11:46:03 +0100 Subject: [PATCH 067/113] reduce TCI by default --- src/ecCallbyValue.ml | 10 +++++----- src/ecHiGoal.ml | 18 +++++++++--------- src/ecReduction.ml | 23 +++++++++++------------ 3 files changed, 25 insertions(+), 26 deletions(-) diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index 7aecec4696..bfabaef661 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -340,11 +340,11 @@ and reduce_user_delta st f1 p tys args = let f = Op.reduce ~mode ~nargs st.st_env p tys in cbv st Subst.subst_id f args | _ -> - if st.st_ri.delta_tc then - match EcReduction.reduce_tc st.st_env p tys with - | None -> f2 - | Some f -> cbv st Subst.subst_id f args - else f2 + if st.st_ri.delta_tc then begin + match EcReduction.reduce_tc st.st_env p tys with + | None -> f2 + | Some f -> cbv st Subst.subst_id f args + end else f2 (* -------------------------------------------------------------------- *) and reduce_logic st f = diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index 8ab20eb0e6..bc14d47d21 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -114,16 +114,16 @@ let process_simplify_info ri (tc : tcenv1) = in { - EcReduction.beta = ri.pbeta; - EcReduction.delta_p = delta_p; - EcReduction.delta_h = delta_h; + EcReduction.beta = ri.pbeta; + EcReduction.delta_p = delta_p; + EcReduction.delta_h = delta_h; EcReduction.delta_tc = ri.pdeltatc; - EcReduction.zeta = ri.pzeta; - EcReduction.iota = ri.piota; - EcReduction.eta = ri.peta; - EcReduction.logic = if ri.plogic then Some `Full else None; - EcReduction.modpath = ri.pmodpath; - EcReduction.user = ri.puser; + EcReduction.zeta = ri.pzeta; + EcReduction.iota = ri.piota; + EcReduction.eta = ri.peta; + EcReduction.logic = if ri.plogic then Some `Full else None; + EcReduction.modpath = ri.pmodpath; + EcReduction.user = ri.puser; } (*-------------------------------------------------------------------- *) diff --git a/src/ecReduction.ml b/src/ecReduction.ml index d7678de9a3..da7078a666 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -618,16 +618,16 @@ let full_red = { } let no_red = { - beta = false; - delta_p = (fun _ -> `No); - delta_h = EcUtils.pred0; + beta = false; + delta_p = (fun _ -> `No); + delta_h = EcUtils.pred0; delta_tc = false; - zeta = false; - iota = false; - eta = false; - logic = None; - modpath = false; - user = false; + zeta = false; + iota = false; + eta = false; + logic = None; + modpath = false; + user = false; } let beta_red = { no_red with beta = true; } @@ -636,8 +636,7 @@ let betaiota_red = { no_red with beta = true; iota = true; } let nodelta = { full_red with delta_h = EcUtils.pred0; - delta_p = (fun _ -> `No); - delta_tc = false; } + delta_p = (fun _ -> `No); } let delta = { no_red with delta_p = (fun _ -> `IfTransparent); } @@ -913,7 +912,7 @@ let reduce_logic ri env hyps f p args = let reduce_delta ri env f = match f.f_node with | Fop (p, tys) when ri.delta_tc && EcEnv.Op.is_tc_op env p -> - may_reduce_tc ri env p tys + may_reduce_tc ri env p tys | Fop (p, tys) when ri.delta_p p <> `No -> reduce_op ri env 0 p tys From 634227663840f057097d477a13a8eb252ca56e26 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 8 Jan 2025 16:08:01 +0100 Subject: [PATCH 068/113] WIP: reduction+matching --- src/ecCallbyValue.ml | 6 +-- src/ecEnv.ml | 51 +++++++++++++++++++ src/ecEnv.mli | 3 ++ src/ecLowGoal.ml | 2 +- src/ecMatching.ml | 12 +++++ src/ecReduction.ml | 113 +++++++++++++++++++------------------------ src/ecReduction.mli | 1 - 7 files changed, 120 insertions(+), 68 deletions(-) diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index bfabaef661..23ad0bebab 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -341,9 +341,9 @@ and reduce_user_delta st f1 p tys args = cbv st Subst.subst_id f args | _ -> if st.st_ri.delta_tc then begin - match EcReduction.reduce_tc st.st_env p tys with - | None -> f2 - | Some f -> cbv st Subst.subst_id f args + match Op.tc_reduce st.st_env p tys with + | f -> cbv st Subst.subst_id f args + | exception NotReducible -> f2 end else f2 (* -------------------------------------------------------------------- *) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 1d0be376a9..346d138535 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -19,6 +19,7 @@ module Mp = EcPath.Mp module Sid = EcIdent.Sid module Mid = EcIdent.Mid module Mint = EcMaps.Mint +module Mstr = EcMaps.Mstr (* -------------------------------------------------------------------- *) type 'a suspension = { @@ -2712,6 +2713,56 @@ module Op = struct (List.combine (List.fst op.op_tparams) tys) form + let tc_core_reduce (env : env) (p : path) (tys : etyarg list) = + let op = by_path p env in + + if not (is_tc_op op) then + raise NotReducible; + + (* Last type application if the TC parameter. We extract the type-class * + * information from the witness. *) + let _, (_, tcw) = List.betail tys in + + match as_seq1 tcw with + | TCIConcrete { path = tcipath; etyargs = tciargs; } -> begin + let tci = TcInstance.by_path tcipath env in + + match tci.tci_instance with + | `General (_, Some symbols) -> + (EcDecl.operator_as_tc op, (tciargs, (tci.tci_params, symbols))) + + | _ -> raise NotReducible + end + + | _ -> + raise NotReducible + + let tc_reducible (env : env) (p : path) (tys : etyarg list) = + try + ignore (tc_core_reduce env p tys); + true + with NotReducible -> false + + let tc_reduce (env : env) (p : path) (tys : etyarg list) = + let ((_, opname), (tciargs, (tciparams, symbols))) = + tc_core_reduce env p tys in + + let subst = + List.fold_left + (fun subst (a, ety) -> + let ety = EcSubst.subst_etyarg subst ety in + EcSubst.add_tyvar subst a ety) + EcSubst.empty + (List.combine (List.fst tciparams) tciargs) + in + + let optg, opargs = EcMaps.Mstr.find opname symbols in + let opargs = List.map (EcSubst.subst_etyarg subst) opargs in + let optg_decl = by_path optg env in + let tysubst = Tvar.init (List.combine (List.fst optg_decl.op_tparams) opargs) in + + f_op_tc optg opargs (Tvar.subst tysubst optg_decl.op_ty) + let is_projection env p = try EcDecl.is_proj (by_path p env) with LookupFailure _ -> false diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 43b8fd1ad8..a6c06eb484 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -313,6 +313,9 @@ module Op : sig val reducible : ?mode:redmode -> ?nargs:int -> env -> path -> bool val reduce : ?mode:redmode -> ?nargs:int -> env -> path -> etyarg list -> form + val tc_reducible : env -> path -> etyarg list -> bool + val tc_reduce : env -> path -> etyarg list -> form + val is_projection : env -> path -> bool val is_record_ctor : env -> path -> bool val is_dtype_ctor : ?nargs:int -> env -> path -> bool diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 0b9f523fe6..f959e5b9f1 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -976,7 +976,7 @@ let t_true (tc : tcenv1) = let t_reflex_s (f : form) (tc : tcenv1) = t_apply_s LG.p_eq_refl [f.f_ty] ~args:[f] tc -let t_reflex ?(mode=`Conv) ?reduce (tc : tcenv1) = +let t_reflex ?(mode = `Conv) ?reduce (tc : tcenv1) = let t_reflex_r (fp : form) (tc : tcenv1) = match sform_of_form fp with | SFeq (f1, f2) -> diff --git a/src/ecMatching.ml b/src/ecMatching.ml index dbb72a251f..6a3043cb22 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -734,6 +734,12 @@ let f_match_core opts hyps (ue, ev) f1 f2 = | _, (Fop (op2, tys2), args2) when EcEnv.Op.reducible env op2 -> doit_reduce env (doit env ilc f1) f2.f_ty op2 tys2 args2 + | (Fop (op1, tys1), args1), _ when EcEnv.Op.tc_reducible env op1 tys1 -> + doit_tc_reduce env ((doit env ilc)^~ f2) f1.f_ty op1 tys1 args1 + + | _, (Fop (op2, tys2), args2) when EcEnv.Op.tc_reducible env op2 tys2 -> + doit_tc_reduce env (doit env ilc f1) f2.f_ty op2 tys2 args2 + | _, _ -> failure () in @@ -759,6 +765,12 @@ let f_match_core opts hyps (ue, ev) f1 f2 = with NotReducible -> raise MatchFailure in cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) + and doit_tc_reduce env cb ty op tys args = + let reduced = + try f_app (EcEnv.Op.tc_reduce env op tys) args ty + with NotReducible -> raise MatchFailure in + cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) + and doit_lreduce _env cb ty x args = let reduced = try f_app (LDecl.unfold x hyps) args ty diff --git a/src/ecReduction.ml b/src/ecReduction.ml index da7078a666..baf639d5c8 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -666,52 +666,15 @@ let reduce_op ri env nargs p tys = Op.reduce ~mode ~nargs env p tys with NotReducible -> raise nohead -let reduce_tc (env : EcEnv.env) (p : path) (tys : etyarg list) = - if not (EcEnv.Op.is_tc_op env p) then None else - - (* Last type application if the TC parameter. We extract the type-class * - * information from the witness. *) - let _, (_, tcw) = List.betail tys in - let tcw = as_seq1 tcw in - - match tcw with - | TCIUni _ -> - None - - | TCIAbstract _ -> - None - - | TCIConcrete { path = tcipath; etyargs = tciargs; } -> - let tci = oget (EcEnv.TcInstance.by_path_opt tcipath env) in - - match tci.tci_instance with - | `General (_, Some syms) -> - let subst = - List.fold_left - (fun subst (a, ety) -> - let ety = EcSubst.subst_etyarg subst ety in - EcSubst.add_tyvar subst a ety) - EcSubst.empty - (List.combine (List.fst tci.tci_params) tciargs) - in - - let (_, opname) = EcDecl.operator_as_tc (EcEnv.Op.by_path p env) in - let optg, opargs = EcMaps.Mstr.find opname syms in - let opargs = List.map (EcSubst.subst_etyarg subst) opargs in - let optg_decl = EcEnv.Op.by_path optg env in - let tysubst = Tvar.init (List.combine (List.fst optg_decl.op_tparams) opargs) in - - Some (EcFol.f_op_tc optg opargs (Tvar.subst tysubst optg_decl.op_ty)) - - | _ -> - None - -let may_reduce_tc (ri : reduction_info) (env : EcEnv.env) (p : path) (tys : etyarg list) = +let reduce_tc_op (ri : reduction_info) (env : EcEnv.env) (p : path) (tys : etyarg list) = if ri.delta_tc then - oget ~exn:nohead (reduce_tc env p tys) + try + Op.tc_reduce env p tys + with NotReducible -> raise nohead else raise nohead +(* -------------------------------------------------------------------- *) let is_record env f = match EcFol.destr_app f with | { f_node = Fop (p, _) }, _ -> EcEnv.Op.is_record_ctor env p @@ -911,15 +874,26 @@ let reduce_logic ri env hyps f p args = (* -------------------------------------------------------------------- *) let reduce_delta ri env f = match f.f_node with - | Fop (p, tys) when ri.delta_tc && EcEnv.Op.is_tc_op env p -> - may_reduce_tc ri env p tys - | Fop (p, tys) when ri.delta_p p <> `No -> - reduce_op ri env 0 p tys + reduce_op ri env 0 p tys | Fapp ({ f_node = Fop (p, tys) }, args) when ri.delta_p p <> `No -> - let op = reduce_op ri env (List.length args) p tys in - f_app_simpl op args f.f_ty + let op = reduce_op ri env (List.length args) p tys in + f_app_simpl op args f.f_ty + + | _ -> raise nohead + +(* -------------------------------------------------------------------- *) +let reduce_tc ri env f = + match f.f_node with + | Fop (p, etyargs) when ri.delta_tc && Op.tc_reducible env p etyargs -> + reduce_tc_op ri env p etyargs + + | Fapp ({ f_node = Fop (p, etyargs) }, args) + when ri.delta_tc && Op.tc_reducible env p etyargs + -> + let op = reduce_tc_op ri env p etyargs in + f_app_simpl op args f.f_ty | _ -> raise nohead @@ -1092,20 +1066,24 @@ let reduce_head simplify ri env hyps f = when ri.eta && can_eta x (fn, args) -> f_app fn (List.take (List.length args - 1) args) f.f_ty - | Fop _ -> begin + | Fop _ -> + oget ~exn:nohead @@ + List.find_map_opt + (fun cb -> try Some (cb f) with NotRed _ -> None) + [ reduce_user_gen simplify ri env hyps + ; reduce_delta ri env + ; reduce_tc ri env ] + + | Fapp ({ f_node = Fop (p, _); }, args) -> begin try - reduce_user_gen simplify ri env hyps f + reduce_logic ri env hyps f p args with NotRed _ -> - reduce_delta ri env f - end - - | Fapp({ f_node = Fop(p,_); }, args) -> begin - try reduce_logic ri env hyps f p args - with NotRed kind1 -> - try reduce_user_gen simplify ri env hyps f - with NotRed kind2 -> - if kind1 = NoHead && kind2 = NoHead then reduce_delta ri env f - else raise needsubterm + oget ~exn:needsubterm @@ + List.find_map_opt + (fun cb -> try Some (cb f) with NotRed NoHead -> None) + [ reduce_user_gen simplify ri env hyps + ; reduce_delta ri env + ; reduce_tc ri env ] end | Ftuple _ -> begin @@ -1206,9 +1184,18 @@ and reduce_head_top_force ri env onhead f = match reduce_head_sub ri env f with | f -> if onhead then reduce_head_top ri env ~onhead f else f - | exception (NotRed _) -> - try reduce_delta ri.ri env f - with NotRed _ -> RedTbl.set_norm ri.redtbl f; raise nohead + | exception (NotRed _) -> begin + match + List.find_map_opt + (fun cb -> try Some (cb ri.ri env f) with NotRed _ -> None) + [reduce_delta; reduce_tc] + with + | Some f -> + f + | None -> + RedTbl.set_norm ri.redtbl f; + raise nohead + end end and reduce_head_sub ri env f = diff --git a/src/ecReduction.mli b/src/ecReduction.mli index 4d023a7531..eac29237f8 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -86,7 +86,6 @@ val nodelta : reduction_info val delta : reduction_info val reduce_logic : reduction_info -> env -> LDecl.hyps -> form -> form -val reduce_tc : env -> path -> etyarg list -> form option val h_red_opt : reduction_info -> LDecl.hyps -> form -> form option val h_red : reduction_info -> LDecl.hyps -> form -> form From ae7a98738145cea606a1e780c50daef421e5c96c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 8 Jan 2025 17:10:33 +0100 Subject: [PATCH 069/113] TCI resolution for type variables --- src/ecUnify.ml | 50 ++++++++++++++++++++++++++++++++++---------------- 1 file changed, 34 insertions(+), 16 deletions(-) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 8a0489081a..6f5e9a922e 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -305,7 +305,7 @@ module Unify = struct end; if not (List.is_empty tci.tci_params) then raise Bailout; - if not (EcCoreEqTest.for_type env ty tci.tci_type) then + if not (EcCoreEqTest.for_type env ty tci.tci_type) then raise Bailout; true @@ -313,23 +313,41 @@ module Unify = struct false in if TyUni.Suid.is_empty deps then begin - let tci = - EcEnv.TcInstance.get_all env - |> List.to_seq - |> Seq.filter_map (fun (p, tci) -> Option.map (fun p -> (p, tci)) p) - |> Seq.filter (fun (_, tci) -> check_tci tci) - |> Seq.uncons |> Option.map (fst |- fst) in - - match tci with - | None -> - failure () - - | Some tci -> + match ty.ty_node with + | Tvar a -> + let tcs = ofdfl failure (Mid.find_opt a (!uc).tvtc) in + let idx = + let eq (tc' : typeclass) = + EcPath.p_equal tc.tc_name tc'.tc_name + && List.for_all2 (EcCoreEqTest.for_etyarg env) tc.tc_args tc'.tc_args in + ofdfl failure (List.find_index eq tcs) in + uc := { !uc with tcenv = { (!uc).tcenv with resolution = - TcUni.Muid.add uid (TCIConcrete { - path = tci; etyargs = []; - }) (!uc).tcenv.resolution + TcUni.Muid.add + uid + (TCIAbstract { support = `Var a; offset = idx; }) + (!uc).tcenv.resolution } } + + | _-> begin + let tci = + EcEnv.TcInstance.get_all env + |> List.to_seq + |> Seq.filter_map (fun (p, tci) -> Option.map (fun p -> (p, tci)) p) + |> Seq.filter (fun (_, tci) -> check_tci tci) + |> Seq.uncons |> Option.map (fst |- fst) in + + match tci with + | None -> + failure () + + | Some tci -> + uc := { !uc with tcenv = { (!uc).tcenv with resolution = + TcUni.Muid.add uid (TCIConcrete { + path = tci; etyargs = []; + }) (!uc).tcenv.resolution + } } + end end else begin TyUni.Suid.iter (fun tyvar -> uc := { !uc with tcenv = { (!uc).tcenv with byunivar = From 60a5603f55a36574e7666aed39f4bc5dfc479487 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 21 Jan 2025 22:12:25 +0100 Subject: [PATCH 070/113] progressing on dependent type-classes + general instance inference --- src/ecAst.ml | 6 ++ src/ecAst.mli | 6 ++ src/ecCorePrinting.ml | 4 +- src/ecCoreSubst.ml | 14 +++- src/ecCoreSubst.mli | 2 + src/ecDecl.ml | 5 -- src/ecDecl.mli | 6 +- src/ecScope.ml | 3 +- src/ecTypeClass.ml | 147 ++++++++++++++++++++++++++++++++++++++++++ src/ecTypeClass.mli | 7 ++ src/ecTyping.ml | 29 +++++---- src/ecTyping.mli | 2 +- src/ecUnify.ml | 70 +++++++------------- src/ecUnify.mli | 4 +- 14 files changed, 231 insertions(+), 74 deletions(-) create mode 100644 src/ecTypeClass.ml create mode 100644 src/ecTypeClass.mli diff --git a/src/ecAst.ml b/src/ecAst.ml index 015315f4c3..b6ef0c713c 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -81,6 +81,12 @@ and tcwitness = offset: int; } +(* -------------------------------------------------------------------- *) +and typeclass = { + tc_name : EcPath.path; + tc_args : etyarg list; +} + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; diff --git a/src/ecAst.mli b/src/ecAst.mli index f0fd421a08..55e177353f 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -78,6 +78,12 @@ and tcwitness = offset: int; } +(* -------------------------------------------------------------------- *) +and typeclass = { + tc_name : EcPath.path; + tc_args : etyarg list; +} + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; diff --git a/src/ecCorePrinting.ml b/src/ecCorePrinting.ml index 3edf0c6f43..ae1690ee39 100644 --- a/src/ecCorePrinting.ml +++ b/src/ecCorePrinting.ml @@ -4,7 +4,7 @@ module type PrinterAPI = sig open EcIdent open EcSymbols open EcPath - open EcTypes + open EcAst open EcFol open EcDecl open EcModules @@ -71,7 +71,7 @@ module type PrinterAPI = sig (* ------------------------------------------------------------------ *) val pp_typedecl : PPEnv.t -> (path * tydecl ) pp - val pp_typeclass : PPEnv.t -> (EcDecl.typeclass ) pp + val pp_typeclass : PPEnv.t -> (typeclass ) pp val pp_opdecl : ?long:bool -> PPEnv.t -> (path * operator ) pp val pp_added_op : PPEnv.t -> operator pp val pp_axiom : ?long:bool -> PPEnv.t -> (path * axiom ) pp diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index 4ca47eea2e..c234ee5372 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -211,7 +211,7 @@ and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = TcUni.Muid.find_opt uid s.fs_utc |> Option.value ~default:tcw -| TCIConcrete ({ etyargs = etyargs0 } as rtcw) -> + | TCIConcrete ({ etyargs = etyargs0 } as rtcw) -> let etyargs = List.Smart.map (etyarg_subst s) etyargs0 in if etyargs ==(*phy*) etyargs0 then tcw @@ -231,6 +231,11 @@ and etyarg_subst (s : f_subst) ((ty, tcws) as tyarg : etyarg) : etyarg = let tcws' = List.Smart.map (tcw_subst s) tcws in SmartPair.mk tyarg ty' tcws' +(* -------------------------------------------------------------------- *) +let tc_subst (s : f_subst) (tc : typeclass) : typeclass = + { tc_name = tc.tc_name; + tc_args = List.map (etyarg_subst s) tc.tc_args; } + (* -------------------------------------------------------------------- *) let ty_subst (s : f_subst) : ty -> ty = if is_ty_subst_id s then identity else ty_subst s @@ -243,6 +248,10 @@ let etyarg_subst (s : f_subst) : etyarg -> etyarg = let tcw_subst (s : f_subst) : tcwitness -> tcwitness = if is_ty_subst_id s then identity else tcw_subst s +(* -------------------------------------------------------------------- *) +let tc_subst (s : f_subst) : typeclass -> typeclass = + if is_ty_subst_id s then identity else tc_subst s + (* -------------------------------------------------------------------- *) let is_e_subst_id (s : f_subst) = not s.fs_freshen @@ -831,6 +840,9 @@ module Tvar = struct let subst_etyarg (s : etyarg Mid.t) (ety : etyarg) : etyarg = etyarg_subst { f_subst_id with fs_v = s } ety + let subst_tc (s : etyarg Mid.t) (tc : typeclass) : typeclass = + tc_subst { f_subst_id with fs_v = s } tc + let f_subst ~(freshen : bool) (bds : (ident * etyarg) list) : form -> form = Fsubst.f_subst_tvar ~freshen (init bds) end diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index 018c682286..a22d5f572c 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -46,6 +46,7 @@ module Tvar : sig val subst1 : (EcIdent.t * etyarg) -> ty -> ty val subst : etyarg Mid.t -> ty -> ty val subst_etyarg : etyarg Mid.t -> etyarg -> etyarg + val subst_tc : etyarg Mid.t -> typeclass -> typeclass val f_subst : freshen:bool -> (EcIdent.t * etyarg) list -> form -> form end @@ -58,6 +59,7 @@ val bind_elocal : f_subst -> EcIdent.t -> expr -> f_subst (* -------------------------------------------------------------------- *) val ty_subst : ty substitute val etyarg_subst : etyarg substitute +val tc_subst : typeclass substitute val e_subst : expr substitute val s_subst : stmt substitute diff --git a/src/ecDecl.ml b/src/ecDecl.ml index db07db4550..0f6084d0fb 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -10,11 +10,6 @@ module Ssym = EcSymbols.Ssym module CS = EcCoreSubst (* -------------------------------------------------------------------- *) -type typeclass = { - tc_name : EcPath.path; - tc_args : etyarg list; -} - type ty_param = EcIdent.t * typeclass list type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] diff --git a/src/ecDecl.mli b/src/ecDecl.mli index ecd5ee03bf..22ee075d46 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -1,16 +1,12 @@ (* -------------------------------------------------------------------- *) open EcUtils +open EcAst open EcSymbols open EcBigInt open EcTypes open EcCoreFol (* -------------------------------------------------------------------- *) -type typeclass = { - tc_name : EcPath.path; - tc_args : etyarg list; -} - type ty_param = EcIdent.t * typeclass list type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] diff --git a/src/ecScope.ml b/src/ecScope.ml index ea31feb4aa..e42bf616d6 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1123,6 +1123,7 @@ module Op = struct let op = op.pl_desc and loc = op.pl_loc in let eenv = env scope in let ue = TT.transtyvars eenv (loc, op.po_tyvars) in + let lc = op.po_locality in let args = fst op.po_args @ odfl [] (snd op.po_args) in let (ty, body, refts) = @@ -1204,7 +1205,7 @@ module Op = struct try EcUnify.unify eenv tue ty tfun; - let msg = "this operator type is (unifiable) to a function type" in + let msg = "this operator type is (unifiable to) a function type" in hierror ~loc "%s" msg with EcUnify.UnificationFailure _ -> () end; diff --git a/src/ecTypeClass.ml b/src/ecTypeClass.ml new file mode 100644 index 0000000000..efdaf16edc --- /dev/null +++ b/src/ecTypeClass.ml @@ -0,0 +1,147 @@ +(* -------------------------------------------------------------------- *) +open EcIdent +open EcPath +open EcUtils +open EcAst +open EcTheory + +(* -------------------------------------------------------------------- *) +exception NoMatch + +(* -------------------------------------------------------------------- *) +module TyMatch(E : sig val env : EcEnv.env end) = struct + let rec doit_type (map : ty option Mid.t) (pattern : ty) (ty : ty) = + let pattern = EcEnv.ty_hnorm pattern E.env in + let ty = EcEnv.ty_hnorm ty E.env in + + match pattern.ty_node, ty.ty_node with + | Tunivar _, _ -> + assert false + + | Tvar a, _ -> begin + match Option.get (Mid.find_opt a map) with + | None -> + Mid.add a (Some ty) map + + | Some ty' -> + if not (EcCoreEqTest.for_type E.env ty ty') then + raise NoMatch; + map + + end + + | Tglob id1, Tglob id2 when EcIdent.id_equal id1 id2 -> + map + + | Tconstr (p, args), Tconstr (p', args') -> + if not (EcPath.p_equal p p') then + raise NoMatch; + doit_etyargs map args args' + + | Ttuple ptns, Ttuple tys when List.length ptns = List.length tys -> + doit_types map ptns tys + + | Tfun (p1, p2), Tfun (ty1, ty2) -> + doit_types map [p1; p2] [ty1; ty2] + + | _, _ -> + raise NoMatch + + and doit_types (map : ty option Mid.t) (pts : ty list) (tys : ty list) = + List.fold_left2 doit_type map pts tys + + and doit_etyarg (map : ty option Mid.t) ((pattern, ptcws) : etyarg) ((ty, ttcws) : etyarg) = + let map = doit_type map pattern ty in + let map = doit_tcws map ptcws ttcws in + map + + and doit_etyargs (map : ty option Mid.t) (pts : etyarg list) (etys : etyarg list) = + List.fold_left2 doit_etyarg map pts etys + + and doit_tcw (map : ty option Mid.t) (ptcw : tcwitness) (ttcw : tcwitness) = + match ptcw, ttcw with + | TCIUni _, _ -> + assert false + + | TCIConcrete ptcw, TCIConcrete ttcw -> + if not (EcPath.p_equal ptcw.path ttcw.path) then + raise NoMatch; + doit_etyargs map ptcw.etyargs ttcw.etyargs + + | TCIAbstract _, TCIAbstract _ -> + if not (EcAst.tcw_equal ptcw ttcw) then + raise NoMatch; + map + + | _, _ -> + raise NoMatch + + and doit_tcws (map : ty option Mid.t) (ptcws : tcwitness list) (ttcws : tcwitness list) = + List.fold_left2 doit_tcw map ptcws ttcws +end + +(* -------------------------------------------------------------------- *) +let ty_match (env : EcEnv.env) (params : ident list) ~(pattern : ty) ~(ty : ty) = + let module M = TyMatch(struct let env = env end) in + let map = Mid.of_list (List.map (fun a -> (a, None)) params) in + M.doit_type map pattern ty + +(* -------------------------------------------------------------------- *) +let etyargs_match + (env : EcEnv.env) + (params : ident list) + ~(patterns : etyarg list) + ~(etyargs : etyarg list) += + let module M = TyMatch(struct let env = env end) in + let map = Mid.of_list (List.map (fun a -> (a, None)) params) in + M.doit_etyargs map patterns etyargs + +(* -------------------------------------------------------------------- *) +let rec check_tcinstance + (env : EcEnv.env) + (ty : ty) + (tc : typeclass) + ((p, tci) : path option * tcinstance) += + let exception Bailout in + + try + let p = oget ~exn:Bailout p in + + let tgargs = + match tci.tci_instance with + | `General (tgp, _) -> + if not (EcPath.p_equal tc.tc_name tgp.tc_name) then + raise Bailout; + tgp.tc_args + | _ -> raise Bailout in + + let map = + etyargs_match env (List.fst tci.tci_params) + ~patterns:tgargs ~etyargs:tc.tc_args in + + let map = + let module M = TyMatch(struct let env = env end) in + M.doit_type map tci.tci_type ty in + + + let _, args = List.fold_left_map (fun subst (a, aargs) -> + let aty = oget ~exn:Bailout (Mid.find a map) in + let aargs = List.map (fun aarg -> + let aarg = EcCoreSubst.Tvar.subst_tc subst aarg in + oget ~exn:Bailout (infer env aty aarg) + ) aargs in + let subst = Mid.add a (aty, aargs) subst in + (subst, (aty, aargs)) + ) Mid.empty tci.tci_params in + + Some (TCIConcrete { path = p; etyargs = args; }) + + with Bailout | NoMatch -> None + +(* -------------------------------------------------------------------- *) +and infer (env : EcEnv.env) (ty : ty) (tc : typeclass) = + List.find_map_opt + (check_tcinstance env ty tc) + (EcEnv.TcInstance.get_all env) diff --git a/src/ecTypeClass.mli b/src/ecTypeClass.mli new file mode 100644 index 0000000000..66c7ed7f42 --- /dev/null +++ b/src/ecTypeClass.mli @@ -0,0 +1,7 @@ +(* -------------------------------------------------------------------- *) +open EcAst +open EcDecl +open EcEnv + +(* -------------------------------------------------------------------- *) +val infer : env -> ty -> typeclass -> tcwitness option diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 66e039bee0..a99e2d6bde 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -1033,6 +1033,7 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = let tvi = EcUnify.UniEnv.opentvi ue decl.tc_tparams None in + (* FIXME:TC can raise an exception *) List.iter2 (fun (ty, _) aty -> EcUnify.unify env ue ty aty) tvi.args args; @@ -1041,19 +1042,21 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = (* -------------------------------------------------------------------- *) let transtyvars (env : EcEnv.env) (loc, (tparams : ptyparams option)) = - let tparams = tparams |> omap - (fun tparams -> - let for1 tyvars ({ pl_desc = x }, tc) = - let x = EcIdent.create x in - let ue = UE.create (Some tyvars) in - let t = List.map (transtc env ue) tc in - (x, t) :: tyvars - in - if not (List.is_unique (List.map (unloc |- fst) tparams)) then - tyerror loc env DuplicatedTyVar; - List.rev (List.fold_left for1 [] tparams)) - in - UE.create tparams + match tparams with + | None -> + UE.create None + + | Some tparams -> + let ue = UE.create (Some []) in + + let for1 ({ pl_desc = x }, tc) = + let x = EcIdent.create x in + let tc = List.map (transtc env ue) tc in + UE.push (x, tc) ue in + if not (List.is_unique (List.map (unloc |- fst) tparams)) then + tyerror loc env DuplicatedTyVar; + List.iter for1 tparams; + ue (* -------------------------------------------------------------------- *) let transpattern1 env ue (p : EcParsetree.plpattern) = diff --git a/src/ecTyping.mli b/src/ecTyping.mli index 75bb38dbe8..da425bf7a8 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -186,7 +186,7 @@ val tp_relax : typolicy (* -------------------------------------------------------------------- *) val transtc: - env -> EcUnify.unienv -> ptcparam -> EcDecl.typeclass + env -> EcUnify.unienv -> ptcparam -> typeclass val transtyvars: env -> (EcLocation.t * ptyparams option) -> EcUnify.unienv diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 6f5e9a922e..f092b79d8a 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -127,7 +127,7 @@ module Unify = struct (* ------------------------------------------------------------------ *) let fresh ?(tcs : (typeclass * tcwitness option) list option) - ?(ty : ty option) + ?(ty : ty option) ({ uf; tcenv } as uc : ucore) = let uid = TyUni.unique () in @@ -139,7 +139,9 @@ module Unify = struct let ty, effects = UF.union uid id uf in assert (List.is_empty effects); ty - | (None | Some _) as ty -> UF.set uid ty uf + + | (None | Some _) as ty -> + UF.set uid ty uf in let ty = Option.value ~default:(tuni uid) (UF.data uid uf) in @@ -290,28 +292,6 @@ module Unify = struct let ty = check ty in let deps = !deps in - let check_tci (tci : EcTheory.tcinstance) : bool = - let exception Bailout in - - try - begin - match tci.tci_instance with - | `General (tc', _) -> - if not (List.is_empty tc'.tc_args) then - raise Bailout; - if not (EcPath.p_equal tc'.tc_name tc.tc_name) then - raise Bailout - | _ -> raise Bailout - end; - if not (List.is_empty tci.tci_params) then - raise Bailout; - if not (EcCoreEqTest.for_type env ty tci.tci_type) then - raise Bailout; - true - - with Bailout -> - false in - if TyUni.Suid.is_empty deps then begin match ty.ty_node with | Tvar a -> @@ -329,25 +309,11 @@ module Unify = struct (!uc).tcenv.resolution } } - | _-> begin - let tci = - EcEnv.TcInstance.get_all env - |> List.to_seq - |> Seq.filter_map (fun (p, tci) -> Option.map (fun p -> (p, tci)) p) - |> Seq.filter (fun (_, tci) -> check_tci tci) - |> Seq.uncons |> Option.map (fst |- fst) in - - match tci with - | None -> - failure () - - | Some tci -> - uc := { !uc with tcenv = { (!uc).tcenv with resolution = - TcUni.Muid.add uid (TCIConcrete { - path = tci; etyargs = []; - }) (!uc).tcenv.resolution - } } - end + | _-> + let tci = ofdfl failure (EcTypeClass.infer env ty tc) in + uc := { !uc with tcenv = { (!uc).tcenv with resolution = + TcUni.Muid.add uid tci (!uc).tcenv.resolution + } } end else begin TyUni.Suid.iter (fun tyvar -> uc := { !uc with tcenv = { (!uc).tcenv with byunivar = @@ -512,13 +478,24 @@ module UniEnv = struct | Some vd -> let vdmap = List.map (fun (x, _) -> (EcIdent.name x, x)) vd in let tvtc = Mid.of_list vd in - { ue_uc = Unify.initial_ucore ~tvtc () + { ue_uc = Unify.initial_ucore ~tvtc () ; ue_named = Mstr.of_list vdmap ; ue_decl = List.rev_map fst vd ; ue_closed = true; } in ref ue + let push ((x, tc) : ident * typeclass list) (ue : unienv) = + assert (not (Mstr.mem (EcIdent.name x) (!ue).ue_named)); + assert ((!ue).ue_closed); + + (* FIXME:TC use API for pushing a variable*) + ue := + { ue_uc = { (!ue).ue_uc with tvtc = Mid.add x tc (!ue).ue_uc.tvtc } + ; ue_named = Mstr.add (EcIdent.name x) x (!ue).ue_named + ; ue_decl = x :: (!ue).ue_decl + ; ue_closed = true } + let xfresh ?(tcs : (typeclass * tcwitness option) list option) ?(ty : ty option) @@ -633,7 +610,10 @@ module UniEnv = struct assubst ue let tparams (ue : unienv) = - let fortv x = odfl [] (Mid.find_opt x (!ue).ue_uc.tvtc) in + let subst = EcCoreSubst.f_subst_init ~tu:(assubst ue) () in + let fortv x = + let tvtc = odfl [] (Mid.find_opt x (!ue).ue_uc.tvtc) in + List.map (EcCoreSubst.tc_subst subst) tvtc in List.map (fun x -> (x, fortv x)) (List.rev (!ue).ue_decl) end diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 6cb0fee1c3..92f81fde77 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -2,6 +2,7 @@ open EcIdent open EcSymbols open EcTypes +open EcAst open EcDecl (* ==================================================================== *) @@ -36,9 +37,10 @@ module UniEnv : sig } val create : (EcIdent.t * typeclass list) list option -> unienv + val push : (EcIdent.t * typeclass list) -> unienv -> unit val copy : unienv -> unienv (* constant time *) val restore : dst:unienv -> src:unienv -> unit (* constant time *) - val xfresh : ?tcs:(EcDecl.typeclass * EcTypes.tcwitness option) list -> ?ty:ty -> unienv -> etyarg + val xfresh : ?tcs:(typeclass * EcTypes.tcwitness option) list -> ?ty:ty -> unienv -> etyarg val fresh : ?ty:ty -> unienv -> ty val getnamed : unienv -> symbol -> EcIdent.t val repr : unienv -> ty -> ty From 0fb8454f33ddf2a997af9a92e7d28e81439df829 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 28 Apr 2026 22:51:30 +0200 Subject: [PATCH 071/113] wip --- src/ecAst.ml | 22 +++++ src/ecAst.mli | 23 +++++ src/ecCorePrinting.ml | 7 +- src/ecMatching.ml | 21 ----- src/ecMatching.mli | 22 +---- src/ecPrinting.ml | 8 +- src/ecProofTyping.mli | 2 +- src/ecTypeClass.ml | 1 - src/ecTyping.ml | 1 - src/ecUnify.ml | 184 +++++++++++++++++++-------------------- src/phl/ecPhlApp.mli | 2 +- src/phl/ecPhlCodeTx.ml | 2 +- src/phl/ecPhlEager.mli | 2 +- src/phl/ecPhlFel.mli | 2 +- src/phl/ecPhlHiCond.ml | 2 +- src/phl/ecPhlLoopTx.mli | 2 +- src/phl/ecPhlOutline.mli | 6 +- src/phl/ecPhlRCond.mli | 2 +- src/phl/ecPhlRewrite.ml | 2 +- src/phl/ecPhlRnd.mli | 2 +- src/phl/ecPhlSp.mli | 4 +- src/phl/ecPhlSwap.mli | 2 +- src/phl/ecPhlWp.mli | 3 +- 23 files changed, 161 insertions(+), 163 deletions(-) diff --git a/src/ecAst.ml b/src/ecAst.ml index b6ef0c713c..a9024c53d2 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -310,6 +310,28 @@ and pr = { pr_event : form; } +(* -------------------------------------------------------------------- *) +type cp_match = [ + | `If + | `While + | `Assign of lvmatch + | `Sample of lvmatch + | `Call of lvmatch + | `Match +] + +and lvmatch = [ `LvmNone | `LvmVar of prog_var ] + +type cp_base = [ + | `ByPos of int + | `ByMatch of int option * cp_match +] + +type codepos_brsel = [`Cond of bool | `Match of EcSymbols.symbol] +type codepos1 = int * cp_base +type codepos = (codepos1 * codepos_brsel) list * codepos1 +type codeoffset1 = [`ByOffset of int | `ByPosition of codepos1] + (* ----------------------------------------------------------------- *) (* Equality, hash, and fv *) (* ----------------------------------------------------------------- *) diff --git a/src/ecAst.mli b/src/ecAst.mli index 55e177353f..13993a7afc 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -306,6 +306,29 @@ and pr = { pr_event : form; } +(* -------------------------------------------------------------------- *) +type cp_match = [ + | `If + | `While + | `Assign of lvmatch + | `Sample of lvmatch + | `Call of lvmatch + | `Match +] + +and lvmatch = [ `LvmNone | `LvmVar of prog_var ] + +type cp_base = [ + | `ByPos of int + | `ByMatch of int option * cp_match +] + +type codepos_brsel = [`Cond of bool | `Match of EcSymbols.symbol] +type codepos1 = int * cp_base +type codepos = (codepos1 * codepos_brsel) list * codepos1 +type codeoffset1 = [`ByOffset of int | `ByPosition of codepos1] + +(* -------------------------------------------------------------------- *) type 'a equality = 'a -> 'a -> bool type 'a hash = 'a -> int type 'a fv = 'a -> int EcIdent.Mid.t diff --git a/src/ecCorePrinting.ml b/src/ecCorePrinting.ml index ae1690ee39..7d82af1b11 100644 --- a/src/ecCorePrinting.ml +++ b/src/ecCorePrinting.ml @@ -5,7 +5,6 @@ module type PrinterAPI = sig open EcSymbols open EcPath open EcAst - open EcFol open EcDecl open EcModules open EcTheory @@ -64,10 +63,10 @@ module type PrinterAPI = sig val pp_path : path pp (* ------------------------------------------------------------------ *) - val pp_codepos1 : PPEnv.t -> EcMatching.Position.codepos1 pp - val pp_codeoffset1 : PPEnv.t -> EcMatching.Position.codeoffset1 pp + val pp_codepos1 : PPEnv.t -> codepos1 pp + val pp_codeoffset1 : PPEnv.t -> codeoffset1 pp - val pp_codepos : PPEnv.t -> EcMatching.Position.codepos pp + val pp_codepos : PPEnv.t -> codepos pp (* ------------------------------------------------------------------ *) val pp_typedecl : PPEnv.t -> (path * tydecl ) pp diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 6a3043cb22..451e91e7d9 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -15,27 +15,6 @@ open EcGenRegexp (* -------------------------------------------------------------------- *) module Position = struct - type cp_match = [ - | `If - | `While - | `Assign of lvmatch - | `Sample of lvmatch - | `Call of lvmatch - | `Match - ] - - and lvmatch = [ `LvmNone | `LvmVar of EcTypes.prog_var ] - - type cp_base = [ - | `ByPos of int - | `ByMatch of int option * cp_match - ] - - type codepos_brsel = [`Cond of bool | `Match of EcSymbols.symbol] - type codepos1 = int * cp_base - type codepos = (codepos1 * codepos_brsel) list * codepos1 - type codeoffset1 = [`ByOffset of int | `ByPosition of codepos1] - let shift1 ~(offset : int) ((o, p) : codepos1) : codepos1 = (o + offset, p) diff --git a/src/ecMatching.mli b/src/ecMatching.mli index d1f822f3d7..b242f82ebf 100644 --- a/src/ecMatching.mli +++ b/src/ecMatching.mli @@ -3,6 +3,7 @@ open EcMaps open EcIdent open EcTypes open EcModules +open EcAst open EcFol open EcUnify open EcEnv @@ -10,27 +11,6 @@ open EcGenRegexp (* -------------------------------------------------------------------- *) module Position : sig - type cp_match = [ - | `If - | `While - | `Match - | `Assign of lvmatch - | `Sample of lvmatch - | `Call of lvmatch - ] - - and lvmatch = [ `LvmNone | `LvmVar of EcTypes.prog_var ] - - type cp_base = [ - | `ByPos of int - | `ByMatch of int option * cp_match - ] - - type codepos_brsel = [`Cond of bool | `Match of EcSymbols.symbol] - type codepos1 = int * cp_base - type codepos = (codepos1 * codepos_brsel) list * codepos1 - type codeoffset1 = [`ByOffset of int | `ByPosition of codepos1] - val shift1 : offset:int -> codepos1 -> codepos1 val shift : offset:int -> codepos -> codepos diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index e7e5c2e965..09418eed99 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -2216,7 +2216,7 @@ let pp_scvar ppe fmt vs = pp_list "@ " pp_grp fmt vs (* -------------------------------------------------------------------- *) -let pp_codepos1 (ppe : PPEnv.t) (fmt : Format.formatter) ((off, cp) : CP.codepos1) = +let pp_codepos1 (ppe : PPEnv.t) (fmt : Format.formatter) ((off, cp) : codepos1) = let s : string = match cp with | `ByPos i -> @@ -2248,14 +2248,14 @@ let pp_codepos1 (ppe : PPEnv.t) (fmt : Format.formatter) ((off, cp) : CP.codepos Format.fprintf fmt "%s%s%d" s (if off < 0 then "-" else "+") (abs off) (* -------------------------------------------------------------------- *) -let pp_codeoffset1 (ppe : PPEnv.t) (fmt : Format.formatter) (offset : CP.codeoffset1) = +let pp_codeoffset1 (ppe : PPEnv.t) (fmt : Format.formatter) (offset : codeoffset1) = match offset with | `ByPosition p -> Format.fprintf fmt "%a" (pp_codepos1 ppe) p | `ByOffset o -> Format.fprintf fmt "%d" o (* -------------------------------------------------------------------- *) -let pp_codepos (ppe : PPEnv.t) (fmt : Format.formatter) ((nm, cp1) : CP.codepos) = - let pp_nm (fmt : Format.formatter) ((cp, bs) : CP.codepos1 * CP.codepos_brsel) = +let pp_codepos (ppe : PPEnv.t) (fmt : Format.formatter) ((nm, cp1) : codepos) = + let pp_nm (fmt : Format.formatter) ((cp, bs) : codepos1 * codepos_brsel) = let bs = match bs with | `Cond true -> "." diff --git a/src/ecProofTyping.mli b/src/ecProofTyping.mli index 7169f3c8d9..dd034f1f12 100644 --- a/src/ecProofTyping.mli +++ b/src/ecProofTyping.mli @@ -2,13 +2,13 @@ open EcParsetree open EcIdent open EcTypes +open EcAst open EcFol open EcDecl open EcModules open EcEnv open EcCoreGoal open EcMemory -open EcMatching.Position (* -------------------------------------------------------------------- *) type ptnenv = ty Mid.t * EcUnify.unienv diff --git a/src/ecTypeClass.ml b/src/ecTypeClass.ml index efdaf16edc..870763da6b 100644 --- a/src/ecTypeClass.ml +++ b/src/ecTypeClass.ml @@ -125,7 +125,6 @@ let rec check_tcinstance let module M = TyMatch(struct let env = env end) in M.doit_type map tci.tci_type ty in - let _, args = List.fold_left_map (fun subst (a, aargs) -> let aty = oget ~exn:Bailout (Mid.find a map) in let aargs = List.map (fun aarg -> diff --git a/src/ecTyping.ml b/src/ecTyping.ml index a99e2d6bde..9f1c775568 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -11,7 +11,6 @@ open EcDecl open EcMemory open EcModules open EcFol -open EcMatching.Position module MMsym = EcSymbols.MMsym module Sid = EcIdent.Sid diff --git a/src/ecUnify.ml b/src/ecUnify.ml index f092b79d8a..3082496fae 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -124,6 +124,96 @@ module Unify = struct let initial_ucore ?(tvtc = Mid.empty) () : ucore = { uf = UF.initial; tcenv = tcenv_empty; tvtc; } + (* -------------------------------------------------------------------- *) + type closed = { tyuni : ty -> ty; tcuni : tcwitness -> tcwitness; } + + (* -------------------------------------------------------------------- *) + let close (uc : ucore) : closed = + let tymap = Hint.create 0 in + let tcmap = Hint.create 0 in + + let rec doit_ty t = + match t.ty_node with + | Tunivar i -> begin + match Hint.find_opt tymap (i :> int) with + | Some t -> t + | None -> begin + let t = + match UF.data i uc.uf with + | None -> tuni (UF.find i uc.uf) + | Some t -> doit_ty t + in + Hint.add tymap (i :> int) t; t + end + end + + | _ -> ty_map doit_ty t + + and doit_tc (tw : tcwitness) = + match tw with + | TCIUni uid -> begin + match Hint.find_opt tcmap (uid :> int) with + | Some tw -> tw + | None -> + let tw = + match TcUni.Muid.find_opt uid uc.tcenv.resolution with + | None -> tw + | Some (TCIUni uid') when TcUni.uid_equal uid uid' -> tw (* FIXME:TC *) + | Some tw -> doit_tc tw + in + Hint.add tcmap (uid :> int) tw; tw + end + + | TCIConcrete { path; etyargs } -> + let etyargs = + List.map + (fun (ty, tws) -> (doit_ty ty, List.map doit_tc tws)) + etyargs + in TCIConcrete { path; etyargs; } + + | TCIAbstract { support = (`Var _ | `Abs _) } -> + tw + + in { tyuni = doit_ty; tcuni = doit_tc; } + + (* ------------------------------------------------------------------ *) + let subst_of_uf (uc : ucore) : unisubst = + let close = close uc in + + let dereference_tyuni (uid : tyuni) = + match close.tyuni (tuni uid) with + | { ty_node = Tunivar uid' } when TyUni.uid_equal uid uid' -> None + | ty -> Some ty in + + let dereference_tcuni (uid : tcuni) = + match close.tcuni (TCIUni uid) with + | TCIUni uid' when TcUni.uid_equal uid uid' -> None + | tw -> Some tw in + + let uvars = + let bindings = + List.filter_map (fun uid -> + Option.map (fun ty -> (uid, ty)) (dereference_tyuni uid) + ) (UF.domain uc.uf) in + TyUni.Muid.of_list bindings in + + let utcvars = + let bindings = + List.filter_map (fun uid -> + Option.map (fun tw -> (uid, tw)) (dereference_tcuni uid) + ) (TcUni.Muid.keys uc.tcenv.problems) in + TcUni.Muid.of_list bindings in + + { uvars; utcvars; } + + (* -------------------------------------------------------------------- *) + let check_closed (uc : ucore) = + let tyvars = not (UF.closed uc.uf) in + let tcvars = not (tcenv_closed uc.tcenv) in + + if tyvars || tcvars then + raise (UninstanciateUni { tyvars; tcvars }) + (* ------------------------------------------------------------------ *) let fresh ?(tcs : (typeclass * tcwitness option) list option) @@ -272,9 +362,6 @@ module Unify = struct end | `TcCtt (uid, ty, tc) -> - if not (List.is_empty tc.tc_args) then - failure (); - let deps = ref TyUni.Suid.empty in let rec check (ty : ty) : ty = @@ -331,95 +418,6 @@ module Unify = struct in doit (); !uc - (* -------------------------------------------------------------------- *) - type closed = { tyuni : ty -> ty; tcuni : tcwitness -> tcwitness; } - - (* -------------------------------------------------------------------- *) - let close (uc : ucore) : closed = - let tymap = Hint.create 0 in - let tcmap = Hint.create 0 in - - let rec doit_ty t = - match t.ty_node with - | Tunivar i -> begin - match Hint.find_opt tymap (i :> int) with - | Some t -> t - | None -> begin - let t = - match UF.data i uc.uf with - | None -> tuni (UF.find i uc.uf) - | Some t -> doit_ty t - in - Hint.add tymap (i :> int) t; t - end - end - - | _ -> ty_map doit_ty t - - and doit_tc (tw : tcwitness) = - match tw with - | TCIUni uid -> begin - match Hint.find_opt tcmap (uid :> int) with - | Some tw -> tw - | None -> - let tw = - match TcUni.Muid.find_opt uid uc.tcenv.resolution with - | None -> tw - | Some (TCIUni uid') when TcUni.uid_equal uid uid' -> tw (* FIXME:TC *) - | Some tw -> doit_tc tw - in - Hint.add tcmap (uid :> int) tw; tw - end - - | TCIConcrete { path; etyargs } -> - let etyargs = - List.map - (fun (ty, tws) -> (doit_ty ty, List.map doit_tc tws)) - etyargs - in TCIConcrete { path; etyargs; } - - | TCIAbstract { support = (`Var _ | `Abs _) } -> - tw - - in { tyuni = doit_ty; tcuni = doit_tc; } - - (* ------------------------------------------------------------------ *) - let subst_of_uf (uc : ucore) : unisubst = - let close = close uc in - - let dereference_tyuni (uid : tyuni) = - match close.tyuni (tuni uid) with - | { ty_node = Tunivar uid' } when TyUni.uid_equal uid uid' -> None - | ty -> Some ty in - - let dereference_tcuni (uid : tcuni) = - match close.tcuni (TCIUni uid) with - | TCIUni uid' when TcUni.uid_equal uid uid' -> None - | tw -> Some tw in - - let uvars = - let bindings = - List.filter_map (fun uid -> - Option.map (fun ty -> (uid, ty)) (dereference_tyuni uid) - ) (UF.domain uc.uf) in - TyUni.Muid.of_list bindings in - - let utcvars = - let bindings = - List.filter_map (fun uid -> - Option.map (fun tw -> (uid, tw)) (dereference_tcuni uid) - ) (TcUni.Muid.keys uc.tcenv.problems) in - TcUni.Muid.of_list bindings in - - { uvars; utcvars; } - - (* -------------------------------------------------------------------- *) - let check_closed (uc : ucore) = - let tyvars = not (UF.closed uc.uf) in - let tcvars = not (tcenv_closed uc.tcenv) in - - if tyvars || tcvars then - raise (UninstanciateUni { tyvars; tcvars }) end (* -------------------------------------------------------------------- *) @@ -698,7 +696,7 @@ let select_op (try unify env subue top texpected with UnificationFailure _ -> raise E.Failure); - let bd = + let bd = match op.D.op_kind with | OB_nott nt -> let substnt () = diff --git a/src/phl/ecPhlApp.mli b/src/phl/ecPhlApp.mli index 2036ee667c..c3f9d6a74c 100644 --- a/src/phl/ecPhlApp.mli +++ b/src/phl/ecPhlApp.mli @@ -1,9 +1,9 @@ (* -------------------------------------------------------------------- *) open EcUtils open EcParsetree +open EcAst open EcFol open EcCoreGoal.FApi -open EcMatching.Position (* -------------------------------------------------------------------- *) val t_hoare_app : codepos1 -> form -> backward diff --git a/src/phl/ecPhlCodeTx.ml b/src/phl/ecPhlCodeTx.ml index b4022c2821..924be129d4 100644 --- a/src/phl/ecPhlCodeTx.ml +++ b/src/phl/ecPhlCodeTx.ml @@ -178,7 +178,7 @@ let set_match_stmt (id : symbol) ((ue, mev, ptn) : _ * _ * form) = with EcProofTerm.FindOccFailure _ -> tc_error pe "cannot find an occurrence of the pattern" -let t_set_match_r (side : oside) (cpos : Position.codepos) (id : symbol) pattern tc = +let t_set_match_r (side : oside) (cpos : codepos) (id : symbol) pattern tc = let tr = fun side -> `SetMatch (side, cpos) in t_code_transform side ~bdhoare:true cpos tr (t_zip (set_match_stmt id pattern)) tc diff --git a/src/phl/ecPhlEager.mli b/src/phl/ecPhlEager.mli index b105deae2c..08b0265d9a 100644 --- a/src/phl/ecPhlEager.mli +++ b/src/phl/ecPhlEager.mli @@ -1,9 +1,9 @@ (* -------------------------------------------------------------------- *) open EcUtils open EcParsetree +open EcAst open EcFol open EcCoreGoal.FApi -open EcMatching.Position (* -------------------------------------------------------------------- *) val t_eager_seq : codepos1 -> codepos1 -> form -> EcIdent.t -> backward diff --git a/src/phl/ecPhlFel.mli b/src/phl/ecPhlFel.mli index 283d4b2a70..a9fe1d80b6 100644 --- a/src/phl/ecPhlFel.mli +++ b/src/phl/ecPhlFel.mli @@ -2,8 +2,8 @@ open EcPath open EcParsetree open EcFol +open EcAst open EcCoreGoal.FApi -open EcMatching.Position (* -------------------------------------------------------------------- *) val t_failure_event : diff --git a/src/phl/ecPhlHiCond.ml b/src/phl/ecPhlHiCond.ml index 77ffeb1b2d..3c8ef70aae 100644 --- a/src/phl/ecPhlHiCond.ml +++ b/src/phl/ecPhlHiCond.ml @@ -1,10 +1,10 @@ (* -------------------------------------------------------------------- *) open EcUtils +open EcAst open EcCoreGoal open EcLowGoal open EcLowPhlGoal open EcPhlCond -open EcMatching.Position (* -------------------------------------------------------------------- *) let process_cond (info : EcParsetree.pcond_info) tc = diff --git a/src/phl/ecPhlLoopTx.mli b/src/phl/ecPhlLoopTx.mli index 8d619f9afd..3f314f4bc6 100644 --- a/src/phl/ecPhlLoopTx.mli +++ b/src/phl/ecPhlLoopTx.mli @@ -1,8 +1,8 @@ (* -------------------------------------------------------------------- *) open EcParsetree open EcTypes +open EcAst open EcCoreGoal.FApi -open EcMatching.Position (* -------------------------------------------------------------------- *) val t_fission : oside -> codepos -> int * (int * int) -> backward diff --git a/src/phl/ecPhlOutline.mli b/src/phl/ecPhlOutline.mli index ceb4116364..7731c48fd2 100644 --- a/src/phl/ecPhlOutline.mli +++ b/src/phl/ecPhlOutline.mli @@ -1,8 +1,8 @@ -open EcCoreGoal.FApi -open EcMatching.Position open EcParsetree -open EcModules open EcPath +open EcAst +open EcModules +open EcCoreGoal.FApi val t_equivS_trans_eq : side -> stmt -> backward diff --git a/src/phl/ecPhlRCond.mli b/src/phl/ecPhlRCond.mli index 87306ed994..ff722957a6 100644 --- a/src/phl/ecPhlRCond.mli +++ b/src/phl/ecPhlRCond.mli @@ -1,8 +1,8 @@ (* -------------------------------------------------------------------- *) open EcSymbols open EcParsetree +open EcAst open EcCoreGoal.FApi -open EcMatching.Position (* -------------------------------------------------------------------- *) module Low : sig diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index 19fce14318..c023d0a25c 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -9,7 +9,7 @@ open EcFol (* -------------------------------------------------------------------- *) let t_change (side : side option) - (pos : EcMatching.Position.codepos) + (pos : codepos) (expr : expr -> LDecl.hyps * memenv -> 'a * expr) (tc : tcenv1) = diff --git a/src/phl/ecPhlRnd.mli b/src/phl/ecPhlRnd.mli index 29d6865e2b..475230d515 100644 --- a/src/phl/ecPhlRnd.mli +++ b/src/phl/ecPhlRnd.mli @@ -3,8 +3,8 @@ open EcUtils open EcParsetree open EcTypes open EcFol +open EcAst open EcCoreGoal.FApi -open EcMatching.Position (* -------------------------------------------------------------------- *) type chl_infos_t = (form, form option, form) rnd_tac_info diff --git a/src/phl/ecPhlSp.mli b/src/phl/ecPhlSp.mli index 2625f40305..736d9eb83f 100644 --- a/src/phl/ecPhlSp.mli +++ b/src/phl/ecPhlSp.mli @@ -1,8 +1,8 @@ (* -------------------------------------------------------------------- *) +open EcUtils +open EcAst open EcParsetree -open EcMatching.Position open EcCoreGoal.FApi -open EcUtils (* -------------------------------------------------------------------- *) val t_sp : (codepos1 doption) option -> backward diff --git a/src/phl/ecPhlSwap.mli b/src/phl/ecPhlSwap.mli index 6b9c330d11..3b3af8594b 100644 --- a/src/phl/ecPhlSwap.mli +++ b/src/phl/ecPhlSwap.mli @@ -1,8 +1,8 @@ (* -------------------------------------------------------------------- *) open EcLocation open EcParsetree -open EcMatching.Position open EcCoreGoal.FApi +open EcAst (* -------------------------------------------------------------------- *) type swap_kind = { diff --git a/src/phl/ecPhlWp.mli b/src/phl/ecPhlWp.mli index fc8689f6d2..77fbc83685 100644 --- a/src/phl/ecPhlWp.mli +++ b/src/phl/ecPhlWp.mli @@ -1,9 +1,8 @@ (* -------------------------------------------------------------------- *) open EcUtils open EcParsetree -open EcMatching.Position - open EcCoreGoal.FApi +open EcAst (* -------------------------------------------------------------------- *) From 84e080312478ccafcac73f8593961f74e50310de Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 09:49:45 +0200 Subject: [PATCH 072/113] Phase 1+2: TC ground-type resolution, fix Fop witness construction, auto-name unnamed instances --- examples/typeclasses/monoidtc.ec | 6 +++--- src/ecEnv.ml | 7 ++++++- src/ecScope.ml | 15 ++++++++------- src/ecUnify.ml | 11 +++++++++++ 4 files changed, 28 insertions(+), 11 deletions(-) diff --git a/examples/typeclasses/monoidtc.ec b/examples/typeclasses/monoidtc.ec index f69122c423..b8e158cdb5 100644 --- a/examples/typeclasses/monoidtc.ec +++ b/examples/typeclasses/monoidtc.ec @@ -38,9 +38,9 @@ abstract theory AddMonoid. op (+) : t -> t -> t. theory Axioms. - axiom nosmt addmA: associative (+). - axiom nosmt addmC: commutative (+). - axiom nosmt add0m: left_id idm (+). + axiom addmA: associative (+). + axiom addmC: commutative (+). + axiom add0m: left_id idm (+). end Axioms. instance addmonoid with t diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 346d138535..b93ad74771 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -905,9 +905,14 @@ module MC = struct in let fsubst = + let op_etyargs = + let tparams = + tc.tc_tparams + @ [(self, [{tc_name = mypath; tc_args = etyargs_of_tparams tc.tc_tparams}])] + in EcDecl.etyargs_of_tparams tparams in List.fold_left (fun s (x, xp, xty, _) -> - let fop = EcCoreFol.f_op xp [tvar self] xty in + let fop = EcCoreFol.f_op_tc xp op_etyargs xty in EcSubst.add_flocal s x fop) tsubst operators diff --git a/src/ecScope.ml b/src/ecScope.ml index e42bf616d6..195be35389 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1941,12 +1941,6 @@ module Ty = struct let add_generic_instance ~import (scope : scope) mode { pl_desc = tci; pl_loc = loc; } = - let name = - match tci.pti_name with - | None -> - hierror ~loc "typeclass instances must be given a name" - | Some name -> name in - let (typarams, _) as ty = let ue = TT.transtyvars (env scope) (loc, Some (fst tci.pti_type)) in let ty = transty tp_tydecl (env scope) ue (snd tci.pti_type) in @@ -2001,8 +1995,15 @@ module Ty = struct ; tci_instance = `General (tcp, Some symbols) ; tci_local = lc } in + let name = + match tci.pti_name with + | Some name -> unloc name + | None -> + Printf.sprintf "%s_%d" + (EcPath.basename tcp.tc_name) (EcUid.unique ()) in + let scope = - let item = EcTheory.Th_instance (Some (unloc name), instance) in + let item = EcTheory.Th_instance (Some name, instance) in let item = EcTheory.mkitem import item in { scope with sc_env = EcSection.add_item item scope.sc_env } in diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 3082496fae..a9857837bc 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -250,6 +250,17 @@ module Unify = struct let uc = ref uc in let pb = let x = Queue.create () in Queue.push pb x; x in + (* Seed the queue with every unresolved TC constraint. This catches + problems whose carrier type had no univar deps at creation time + (e.g. [Tvar 'a] for a TC-constrained type parameter), which would + otherwise sit in [problems] forever, never triggered via + [byunivar] eviction. Re-pushing already-deferred problems is + idempotent: the [`TcCtt] arm just re-adds them to [byunivar]. *) + TcUni.Muid.iter (fun uid (ty, tc) -> + if not (TcUni.Muid.mem uid (!uc).tcenv.resolution) then + Queue.push (`TcCtt (uid, ty, tc)) pb + ) (!uc).tcenv.problems; + let ocheck i t = let i = UF.find i (!uc).uf in let map = Hint.create 0 in From fd883a7cc6902e9f0957db9ef88a2b3400f1dd7f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 10:16:43 +0200 Subject: [PATCH 073/113] Phase 1+: parent-class chain, abstract carrier resolution, witness deref, tcp arg closure --- src/ecScope.ml | 16 ++++++--- src/ecSubst.ml | 12 +++++-- src/ecTypeClass.ml | 16 +++++++++ src/ecTypeClass.mli | 5 +++ src/ecUnify.ml | 86 +++++++++++++++++++++++++++++++-------------- 5 files changed, 101 insertions(+), 34 deletions(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 195be35389..cbb2efb89a 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1664,7 +1664,13 @@ module Ty = struct (* Check typeclasses arguments *) let ue = TT.transtyvars scenv (loc, tcd.ptc_params) in - let uptc = tcd.ptc_inth |> omap (TT.transtc scenv ue) in + let uptc = + let parent_ue = EcUnify.UniEnv.copy ue in + let uptc = tcd.ptc_inth |> omap (TT.transtc scenv parent_ue) in + let subst = Tuni.subst (EcUnify.UniEnv.close parent_ue) in + omap (fun tcp -> + { tcp with tc_args = List.map (etyarg_subst subst) tcp.tc_args }) + uptc in let asty = { tyd_params = []; @@ -1925,9 +1931,9 @@ module Ty = struct (* ------------------------------------------------------------------ *) let symbols_of_tc (_env : EcEnv.env) ((tparams, ty) : ty_params * ty) (tcp, tc) = - let subst, tparams = EcSubst.fresh_tparams EcSubst.empty tparams in + let subst, _ = EcSubst.fresh_tparams EcSubst.empty tparams in let ty = EcSubst.subst_ty subst ty in - let subst = EcSubst.add_tydef subst tcp.tc_name (List.fst tparams, ty) in + let subst = EcSubst.add_tydef subst tcp.tc_name ([], ty) in let subst = List.fold_left (fun subst (a, ty) -> EcSubst.add_tyvar subst a ty) @@ -1953,7 +1959,9 @@ module Ty = struct let tcp = let ue = EcUnify.UniEnv.create (Some typarams) in - TT.transtc (env scope) ue tci.pti_tc in + let tcp = TT.transtc (env scope) ue tci.pti_tc in + let subst = Tuni.subst (EcUnify.UniEnv.close ue) in + { tcp with tc_args = List.map (etyarg_subst subst) tcp.tc_args } in let tc = EcEnv.TypeClass.by_path tcp.tc_name (env scope) in diff --git a/src/ecSubst.ml b/src/ecSubst.ml index c3bebf2464..5f0cc19d03 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -211,13 +211,19 @@ and subst_tcw (s : subst) (tcw : tcwitness) = |> Option.map (fun tcs -> List.nth tcs offset) |> Option.value ~default:tcw - | TCIAbstract ({ support = `Abs p } as tcw) -> + | TCIAbstract ({ support = `Abs p; offset } as tcw) -> match Mp.find_opt p s.sb_tydef with | None -> TCIAbstract { tcw with support = `Abs (subst_path s p) } - | Some _ -> - assert false (* FIXME:TC *) + | Some (_, body) -> + match body.ty_node with + | Tvar a -> + TCIAbstract { support = `Var a; offset } + | Tconstr (p', _) -> + TCIAbstract { support = `Abs p'; offset } + | _ -> + assert false (* FIXME:TC: substitute via concrete instance lookup *) (* -------------------------------------------------------------------- *) and subst_tcws (s : subst) (tcws : tcwitness list) : tcwitness list = diff --git a/src/ecTypeClass.ml b/src/ecTypeClass.ml index 870763da6b..addb7c7628 100644 --- a/src/ecTypeClass.ml +++ b/src/ecTypeClass.ml @@ -144,3 +144,19 @@ and infer (env : EcEnv.env) (ty : ty) (tc : typeclass) = List.find_map_opt (check_tcinstance env ty tc) (EcEnv.TcInstance.get_all env) + +(* -------------------------------------------------------------------- *) +(* Flatten the parent chain of a typeclass: returns [tc; parent; + grandparent; ...] following [tc_prt]. Each ancestor's [tc_args] is + substituted using the child's [tc_tparams] mapping to its actual args. *) +let rec ancestors (env : EcEnv.env) (tc : typeclass) : typeclass list = + let decl = EcEnv.TypeClass.by_path tc.tc_name env in + match decl.tc_prt with + | None -> [tc] + | Some prt -> + let subst = + List.fold_left2 + (fun s (a, _) etyarg -> Mid.add a etyarg s) + Mid.empty decl.tc_tparams tc.tc_args in + let prt = EcCoreSubst.Tvar.subst_tc subst prt in + tc :: ancestors env prt diff --git a/src/ecTypeClass.mli b/src/ecTypeClass.mli index 66c7ed7f42..24cc2df610 100644 --- a/src/ecTypeClass.mli +++ b/src/ecTypeClass.mli @@ -5,3 +5,8 @@ open EcEnv (* -------------------------------------------------------------------- *) val infer : env -> ty -> typeclass -> tcwitness option + +(* -------------------------------------------------------------------- *) +(* Flatten the parent chain: [tc; tc.parent; tc.grandparent; ...]. + Args are substituted along the chain. *) +val ancestors : env -> typeclass -> typeclass list diff --git a/src/ecUnify.ml b/src/ecUnify.ml index a9857837bc..08fca335e4 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -375,43 +375,75 @@ module Unify = struct | `TcCtt (uid, ty, tc) -> let deps = ref TyUni.Suid.empty in - let rec check (ty : ty) : ty = + let rec check_ty (ty : ty) : ty = match ty.ty_node with | Tunivar tyuvar -> begin match UF.data tyuvar (!uc).uf with - | None -> + | None -> deps := TyUni.Suid.add tyuvar !deps; ty | Some ty -> - check ty + check_ty ty end - | _ -> ty_map check ty in - - let ty = check ty in + | _ -> ty_map check_ty ty in + + let rec check_tcw (tcw : tcwitness) : tcwitness = + match tcw with + | TCIUni tcuid -> begin + match TcUni.Muid.find_opt tcuid (!uc).tcenv.resolution with + | Some (TCIUni tcuid') when TcUni.uid_equal tcuid tcuid' -> tcw + | Some tcw' -> check_tcw tcw' + | None -> tcw + end + | TCIConcrete cw -> + let etyargs = List.map check_etyarg cw.etyargs in + TCIConcrete { cw with etyargs } + | TCIAbstract _ -> tcw + and check_etyarg ((ty, tcws) : etyarg) = + (check_ty ty, List.map check_tcw tcws) in + + let tc = + { tc with tc_args = List.map check_etyarg tc.tc_args } in + + let ty = check_ty ty in let deps = !deps in if TyUni.Suid.is_empty deps then begin - match ty.ty_node with - | Tvar a -> - let tcs = ofdfl failure (Mid.find_opt a (!uc).tvtc) in - let idx = - let eq (tc' : typeclass) = - EcPath.p_equal tc.tc_name tc'.tc_name - && List.for_all2 (EcCoreEqTest.for_etyarg env) tc.tc_args tc'.tc_args in - ofdfl failure (List.find_index eq tcs) in - - uc := { !uc with tcenv = { (!uc).tcenv with resolution = - TcUni.Muid.add - uid - (TCIAbstract { support = `Var a; offset = idx; }) - (!uc).tcenv.resolution - } } - - | _-> - let tci = ofdfl failure (EcTypeClass.infer env ty tc) in - uc := { !uc with tcenv = { (!uc).tcenv with resolution = - TcUni.Muid.add uid tci (!uc).tcenv.resolution - } } + let eq_tc (tc' : typeclass) = + EcPath.p_equal tc.tc_name tc'.tc_name + && List.for_all2 (EcCoreEqTest.for_etyarg env) tc.tc_args tc'.tc_args in + + (* Find the offset of [tc] (or any of its descendants) in [tcs] + by walking each entry's [tc_prt] chain. *) + let match_tc_offset (tcs : typeclass list) : int option = + List.find_index + (fun tc' -> List.exists eq_tc (EcTypeClass.ancestors env tc')) + tcs in + + let abstract_via_decl (p : EcPath.path) : tcwitness option = + match EcEnv.Ty.by_path_opt p env with + | Some { tyd_type = `Abstract tcs; _ } -> + Option.map + (fun offset -> TCIAbstract { support = `Abs p; offset; }) + (match_tc_offset tcs) + | _ -> None in + + let resolution = + match ty.ty_node with + | Tvar a -> + let tcs = ofdfl failure (Mid.find_opt a (!uc).tvtc) in + let idx = ofdfl failure (match_tc_offset tcs) in + TCIAbstract { support = `Var a; offset = idx; } + + | Tconstr (p, _) when Option.is_some (abstract_via_decl p) -> + Option.get (abstract_via_decl p) + + | _ -> + ofdfl failure (EcTypeClass.infer env ty tc) + in + uc := { !uc with tcenv = { (!uc).tcenv with resolution = + TcUni.Muid.add uid resolution (!uc).tcenv.resolution + } } end else begin TyUni.Suid.iter (fun tyvar -> uc := { !uc with tcenv = { (!uc).tcenv with byunivar = From 758a1685321c8a551a3ca91430baf56d4cfd0d93 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 10:20:39 +0200 Subject: [PATCH 074/113] Phase 1: ancestor-chain TC resolution; 3 examples pass, TcRing partial --- examples/tcstdlib/TcRing.ec | 294 ++++++++++++++++++------------------ src/ecCoreSubst.ml | 8 +- src/ecUnify.ml | 3 + 3 files changed, 155 insertions(+), 150 deletions(-) diff --git a/examples/tcstdlib/TcRing.ec b/examples/tcstdlib/TcRing.ec index 7213ba5f32..a7ea417e04 100644 --- a/examples/tcstdlib/TcRing.ec +++ b/examples/tcstdlib/TcRing.ec @@ -17,83 +17,83 @@ abbrev zeror = idm<:g>. abbrev ( - ) (x y : g) = x + -y. (* -------------------------------------------------------------------- *) -lemma nosmt addrA: associative (+)<:g>. +lemma addrA: associative (+)<:g>. proof. by exact: addmA. qed. -lemma nosmt addrC: commutative (+)<:g>. +lemma addrC: commutative (+)<:g>. proof. by exact: addmC. qed. -lemma nosmt add0r: left_id zeror (+)<:g>. +lemma add0r: left_id zeror (+)<:g>. proof. by exact: add0m. qed. (* -------------------------------------------------------------------- *) -lemma nosmt addr0: right_id zeror (+)<:g>. +lemma addr0: right_id zeror (+)<:g>. proof. by move=> x; rewrite addrC add0r. qed. -lemma nosmt addrN: right_inverse zeror [-] (+)<:g>. +lemma addrN: right_inverse zeror [-] (+)<:g>. proof. by move=> x; rewrite addrC addNr. qed. -lemma nosmt addrCA: left_commutative (+)<:g>. +lemma addrCA: left_commutative (+)<:g>. proof. by move=> x y z; rewrite !addrA (@addrC x y). qed. -lemma nosmt addrAC: right_commutative (+)<:g>. +lemma addrAC: right_commutative (+)<:g>. proof. by move=> x y z; rewrite -!addrA (@addrC y z). qed. -lemma nosmt addrACA: interchange (+)<:g> (+)<:g>. +lemma addrACA: interchange (+)<:g> (+)<:g>. proof. by move=> x y z t; rewrite -!addrA (addrCA y). qed. -lemma nosmt subrr (x : g): x - x = zeror. +lemma subrr (x : g): x - x = zeror. proof. by rewrite addrN. qed. -lemma nosmt addKr: left_loop [-] (+)<:g>. +lemma addKr: left_loop [-] (+)<:g>. proof. by move=> x y; rewrite addrA addNr add0r. qed. -lemma nosmt addNKr: rev_left_loop [-] (+)<:g>. +lemma addNKr: rev_left_loop [-] (+)<:g>. proof. by move=> x y; rewrite addrA addrN add0r. qed. -lemma nosmt addrK: right_loop [-] (+)<:g>. +lemma addrK: right_loop [-] (+)<:g>. proof. by move=> x y; rewrite -addrA addrN addr0. qed. -lemma nosmt addrNK: rev_right_loop [-] (+)<:g>. +lemma addrNK: rev_right_loop [-] (+)<:g>. proof. by move=> x y; rewrite -addrA addNr addr0. qed. -lemma nosmt subrK (x y : g): (x - y) + y = x. +lemma subrK (x y : g): (x - y) + y = x. proof. by rewrite addrNK. qed. -lemma nosmt addrI: right_injective (+)<:g>. +lemma addrI: right_injective (+)<:g>. proof. by move=> x y z h; rewrite -(@addKr x z) -h addKr. qed. -lemma nosmt addIr: left_injective (+)<:g>. +lemma addIr: left_injective (+)<:g>. proof. by move=> x y z h; rewrite -(@addrK x z) -h addrK. qed. -lemma nosmt opprK: involutive [-]<:g>. +lemma opprK: involutive [-]<:g>. proof. by move=> x; apply (@addIr (-x)); rewrite addNr addrN. qed. -lemma nosmt oppr_inj : injective [-]<:g>. +lemma oppr_inj : injective [-]<:g>. proof. by move=> x y eq; apply/(addIr (-x)); rewrite subrr eq subrr. qed. -lemma nosmt oppr0 : -zeror = zeror. +lemma oppr0 : -zeror = zeror. proof. by rewrite -(@addr0 (-zeror)) addNr. qed. -lemma nosmt oppr_eq0 (x : g) : (- x = zeror) <=> (x = zeror). +lemma oppr_eq0 (x : g) : (- x = zeror) <=> (x = zeror). proof. by rewrite (inv_eq opprK) oppr0. qed. -lemma nosmt subr0 (x : g): x - zeror = x. +lemma subr0 (x : g): x - zeror = x. proof. by rewrite oppr0 addr0. qed. -lemma nosmt sub0r (x : g): zeror - x = - x. +lemma sub0r (x : g): zeror - x = - x. proof. by rewrite add0r. qed. -lemma nosmt opprD (x y : g): -(x + y) = -x + -y. +lemma opprD (x y : g): -(x + y) = -x + -y. proof. by apply (@addrI (x + y)); rewrite addrA addrN addrAC addrK addrN. qed. -lemma nosmt opprB (x y : g): -(x - y) = y - x. +lemma opprB (x y : g): -(x - y) = y - x. proof. by rewrite opprD opprK addrC. qed. -lemma nosmt subrACA: interchange (-) (+)<:g>. +lemma subrACA: interchange (-) (+)<:g>. proof. by move=> x y z t; rewrite addrACA opprD. qed. -lemma nosmt subr_eq (x y z : g): +lemma subr_eq (x y z : g): (x - z = y) <=> (x = y + z). proof. move: (can2_eq (fun x, x - z) (fun x, x + z) _ _ x y) => //=. @@ -101,25 +101,25 @@ move: (can2_eq (fun x, x - z) (fun x, x + z) _ _ x y) => //=. + by move=> {x} x /=; rewrite addrK. qed. -lemma nosmt subr_eq0 (x y : g): (x - y = zeror) <=> (x = y). +lemma subr_eq0 (x y : g): (x - y = zeror) <=> (x = y). proof. by rewrite subr_eq add0r. qed. -lemma nosmt addr_eq0 (x y : g): (x + y = zeror) <=> (x = -y). +lemma addr_eq0 (x y : g): (x + y = zeror) <=> (x = -y). proof. by rewrite -(@subr_eq0 x) opprK. qed. -lemma nosmt eqr_opp (x y : g): (- x = - y) <=> (x = y). +lemma eqr_opp (x y : g): (- x = - y) <=> (x = y). proof. by apply/(@can_eq _ _ opprK x y). qed. -lemma nosmt eqr_oppLR (x y : g) : (- x = y) <=> (x = - y). +lemma eqr_oppLR (x y : g) : (- x = y) <=> (x = - y). proof. by apply/(@inv_eq _ opprK x y). qed. -lemma nosmt eqr_sub (x y z t : g) : (x - y = z - t) <=> (x + t = z + y). +lemma eqr_sub (x y z t : g) : (x - y = z - t) <=> (x + t = z + y). proof. rewrite -{1}(addrK t x) -{1}(addrK y z) -!addrA. by rewrite (addrC (-t)) !addrA; split=> [/addIr /addIr|->//]. qed. -lemma nosmt subr_add2r (z x y : g): (x + z) - (y + z) = x - y. +lemma subr_add2r (z x y : g): (x + z) - (y + z) = x - y. proof. by rewrite opprD addrACA addrN addr0. qed. op intmul (x : g) (n : int) = @@ -128,34 +128,34 @@ op intmul (x : g) (n : int) = then -(iterop (-n) (+)<:g> x zeror) else (iterop n (+)<:g> x zeror). -lemma nosmt intmulpE (z : g) c : 0 <= c => +lemma intmulpE (z : g) c : 0 <= c => intmul z c = iterop c (+)<:g> z zeror. proof. by rewrite /intmul lezNgt => ->. qed. -lemma nosmt mulr0z (x : g): intmul x 0 = zeror. +lemma mulr0z (x : g): intmul x 0 = zeror. proof. by rewrite /intmul /= iterop0. qed. -lemma nosmt mulr1z (x : g): intmul x 1 = x. +lemma mulr1z (x : g): intmul x 1 = x. proof. by rewrite /intmul /= iterop1. qed. -lemma nosmt mulr2z (x : g): intmul x 2 = x + x. +lemma mulr2z (x : g): intmul x 2 = x + x. proof. by rewrite /intmul /= (@iteropS 1) // (@iterS 0) // iter0. qed. -lemma nosmt mulrNz (x : g) (n : int): intmul x (-n) = -(intmul x n). +lemma mulrNz (x : g) (n : int): intmul x (-n) = -(intmul x n). proof. case: (n = 0)=> [->|nz_c]; first by rewrite oppz0 mulr0z oppr0. rewrite /intmul oppz_lt0 oppzK ltz_def nz_c lezNgt /=. by case: (n < 0); rewrite ?opprK. qed. -lemma nosmt mulrS (x : g) (n : int): 0 <= n => +lemma mulrS (x : g) (n : int): 0 <= n => intmul x (n+1) = x + intmul x n. proof. move=> ge0n; rewrite !intmulpE 1:addz_ge0 //. by rewrite !iteropE iterS. qed. -lemma nosmt mulNrz (x : g) n : intmul (- x) n = - (intmul x n). +lemma mulNrz (x : g) n : intmul (- x) n = - (intmul x n). proof. elim/intwlog: n => [n h| | n ge0_n ih]. + by rewrite -(@oppzK n) !(@mulrNz _ (- n)) h. @@ -163,10 +163,10 @@ elim/intwlog: n => [n h| | n ge0_n ih]. + by rewrite !mulrS // ih opprD. qed. -lemma nosmt mulNrNz (x : g) (n : int) : intmul (-x) (-n) = intmul x n. +lemma mulNrNz (x : g) (n : int) : intmul (-x) (-n) = intmul x n. proof. by rewrite mulNrz mulrNz opprK. qed. -lemma nosmt mulrSz (x : g) n : intmul x (n + 1) = x + intmul x n. +lemma mulrSz (x : g) n : intmul x (n + 1) = x + intmul x n. proof. case: (0 <= n) => [/mulrS ->//|]; rewrite -ltzNge => gt0_n. case: (n = -1) => [->/=|]; 1: by rewrite mulrNz mulr1z mulr0z subrr. @@ -175,7 +175,7 @@ rewrite (_ : -n = -(n+1) + 1) 1:/# mulrS 1:/#. by rewrite addrA subrr add0r. qed. -lemma nosmt mulrDz (x : g) (n m : int) : intmul x (n + m) = intmul x n + intmul x m. +lemma mulrDz (x : g) (n m : int) : intmul x (n + m) = intmul x n + intmul x m. proof. wlog: n m / 0 <= m => [wlog|]. + case: (0 <= m) => [/wlog|]; first by apply. @@ -216,112 +216,112 @@ realize add0m by exact: mul1r. abbrev ( / ) (x y : r) = x * (invr y). -lemma nosmt mulr1: right_id oner ( * )<:r>. +lemma mulr1: right_id oner ( * )<:r>. proof. by move=> x; rewrite mulrC mul1r. qed. -lemma nosmt mulrCA: left_commutative ( * )<:r>. +lemma mulrCA: left_commutative ( * )<:r>. proof. by move=> x y z; rewrite !mulrA (@mulrC x y). qed. -lemma nosmt mulrAC: right_commutative ( * )<:r>. +lemma mulrAC: right_commutative ( * )<:r>. proof. by move=> x y z; rewrite -!mulrA (@mulrC y z). qed. -lemma nosmt mulrACA: interchange ( * ) ( * )<:r>. +lemma mulrACA: interchange ( * ) ( * )<:r>. proof. by move=> x y z t; rewrite -!mulrA (mulrCA y). qed. -lemma nosmt mulrSl (x y : r) : (x + oner) * y = x * y + y. +lemma mulrSl (x y : r) : (x + oner) * y = x * y + y. proof. by rewrite mulrDl mul1r. qed. -lemma nosmt mulrDr: right_distributive ( * ) (+)<:r>. +lemma mulrDr: right_distributive ( * ) (+)<:r>. proof. by move=> x y z; rewrite mulrC mulrDl !(@mulrC _ x). qed. -lemma nosmt mul0r: left_zero zeror ( * )<:r>. +lemma mul0r: left_zero zeror ( * )<:r>. proof. by move=> x; apply: (@addIr (oner * x)); rewrite -mulrDl !add0r mul1r. qed. -lemma nosmt mulr0: right_zero zeror ( * )<:r>. +lemma mulr0: right_zero zeror ( * )<:r>. proof. by move=> x; apply: (@addIr (x * oner)); rewrite -mulrDr !add0r mulr1. qed. -lemma nosmt mulrN (x y : r): x * (- y) = - (x * y). +lemma mulrN (x y : r): x * (- y) = - (x * y). proof. by apply: (@addrI (x * y)); rewrite -mulrDr !addrN mulr0. qed. -lemma nosmt mulNr (x y : r): (- x) * y = - (x * y). +lemma mulNr (x y : r): (- x) * y = - (x * y). proof. by apply: (@addrI (x * y)); rewrite -mulrDl !addrN mul0r. qed. -lemma nosmt mulrNN (x y : r): (- x) * (- y) = x * y. +lemma mulrNN (x y : r): (- x) * (- y) = x * y. proof. by rewrite mulrN mulNr opprK. qed. -lemma nosmt mulN1r (x : r): (-oner) * x = -x. +lemma mulN1r (x : r): (-oner) * x = -x. proof. by rewrite mulNr mul1r. qed. -lemma nosmt mulrN1 (x : r): x * -oner = -x. +lemma mulrN1 (x : r): x * -oner = -x. proof. by rewrite mulrN mulr1. qed. -lemma nosmt mulrBl: left_distributive ( * ) (-)<:r>. +lemma mulrBl: left_distributive ( * ) (-)<:r>. proof. by move=> x y z; rewrite mulrDl !mulNr. qed. -lemma nosmt mulrBr: right_distributive ( * ) (-)<:r>. +lemma mulrBr: right_distributive ( * ) (-)<:r>. proof. by move=> x y z; rewrite mulrDr !mulrN. qed. -lemma nosmt mulrnAl (x y : r) n : 0 <= n => (intmul x n) * y = intmul (x * y) n. +lemma mulrnAl (x y : r) n : 0 <= n => (intmul x n) * y = intmul (x * y) n. proof. elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mul0r //. by rewrite mulrDl ih. qed. -lemma nosmt mulrnAr (x y : r) n : 0 <= n => x * (intmul y n) = intmul (x * y) n. +lemma mulrnAr (x y : r) n : 0 <= n => x * (intmul y n) = intmul (x * y) n. proof. elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mulr0 //. by rewrite mulrDr ih. qed. -lemma nosmt mulrzAl (x y : r) z : (intmul x z) * y = intmul (x * y) z. +lemma mulrzAl (x y : r) z : (intmul x z) * y = intmul (x * y) z. proof. case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAl. by rewrite -oppzK mulrNz mulNr mulrnAl -?mulrNz // oppz_ge0. qed. -lemma nosmt mulrzAr x (y : r) z : x * (intmul y z) = intmul (x * y) z. +lemma mulrzAr x (y : r) z : x * (intmul y z) = intmul (x * y) z. proof. case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAr. by rewrite -oppzK mulrNz mulrN mulrnAr -?mulrNz // oppz_ge0. qed. -lemma nosmt mulrV: right_inverse_in unit oner invr ( * )<:r>. +lemma mulrV: right_inverse_in unit oner invr ( * )<:r>. proof. by move=> x /mulVr; rewrite mulrC. qed. -lemma nosmt divrr (x : r): unit x => x / x = oner. +lemma divrr (x : r): unit x => x / x = oner. proof. by apply/mulrV. qed. -lemma nosmt invr_out (x : r): !unit x => invr x = x. +lemma invr_out (x : r): !unit x => invr x = x. proof. by apply/unitout. qed. -lemma nosmt unitrP (x : r): unit x <=> (exists y, y * x = oner). +lemma unitrP (x : r): unit x <=> (exists y, y * x = oner). proof. by split=> [/mulVr<- |]; [exists (invr x) | case=> y /unitP]. qed. -lemma nosmt mulKr: left_loop_in unit invr ( * )<:r>. +lemma mulKr: left_loop_in unit invr ( * )<:r>. proof. by move=> x un_x y; rewrite mulrA mulVr // mul1r. qed. -lemma nosmt mulrK: right_loop_in unit invr ( * )<:r>. +lemma mulrK: right_loop_in unit invr ( * )<:r>. proof. by move=> y un_y x; rewrite -mulrA mulrV // mulr1. qed. -lemma nosmt mulVKr: rev_left_loop_in unit invr ( * )<:r>. +lemma mulVKr: rev_left_loop_in unit invr ( * )<:r>. proof. by move=> x un_x y; rewrite mulrA mulrV // mul1r. qed. -lemma nosmt mulrVK: rev_right_loop_in unit invr ( * )<:r>. +lemma mulrVK: rev_right_loop_in unit invr ( * )<:r>. proof. by move=> y nz_y x; rewrite -mulrA mulVr // mulr1. qed. -lemma nosmt mulrI: right_injective_in unit ( * )<:r>. +lemma mulrI: right_injective_in unit ( * )<:r>. proof. by move=> x Ux; have /can_inj h := mulKr _ Ux. qed. -lemma nosmt mulIr: left_injective_in unit ( * )<:r>. +lemma mulIr: left_injective_in unit ( * )<:r>. proof. by move=> x /mulrI h y1 y2; rewrite !(@mulrC _ x) => /h. qed. -lemma nosmt unitrE (x : r): unit x <=> (x / x = oner). +lemma unitrE (x : r): unit x <=> (x / x = oner). proof. split=> [Ux|xx1]; 1: by apply/divrr. by apply/unitrP; exists (invr x); rewrite mulrC. qed. -lemma nosmt invrK: involutive invr<:r>. +lemma invrK: involutive invr<:r>. proof. move=> x; case: (unit x)=> Ux; 2: by rewrite !invr_out. rewrite -(mulrK _ Ux (invr (invr x))) -mulrA. @@ -329,37 +329,37 @@ rewrite (@mulrC x) mulKr //; apply/unitrP. by exists x; rewrite mulrV. qed. -lemma nosmt invr_inj: injective invr<:r>. +lemma invr_inj: injective invr<:r>. proof. by apply: (can_inj _ _ invrK). qed. -lemma nosmt unitrV (x : r): unit (invr x) <=> unit x. +lemma unitrV (x : r): unit (invr x) <=> unit x. proof. by rewrite !unitrE invrK mulrC. qed. -lemma nosmt unitr1: unit oner<:r>. +lemma unitr1: unit oner<:r>. proof. by apply/unitrP; exists oner; rewrite mulr1. qed. -lemma nosmt invr1: invr oner = oner<:r>. +lemma invr1: invr oner = oner<:r>. proof. by rewrite -{2}(mulVr _ unitr1) mulr1. qed. -lemma nosmt div1r x: oner / x = invr x. +lemma div1r x: oner / x = invr x. proof. by rewrite mul1r. qed. -lemma nosmt divr1 x: x / oner = x. +lemma divr1 x: x / oner = x. proof. by rewrite invr1 mulr1. qed. -lemma nosmt unitr0: !unit zeror<:r>. +lemma unitr0: !unit zeror<:r>. proof. by apply/negP=> /unitrP [y]; rewrite mulr0 eq_sym oner_neq0. qed. -lemma nosmt invr0: invr zeror = zeror<:r>. +lemma invr0: invr zeror = zeror<:r>. proof. by rewrite invr_out ?unitr0. qed. -lemma nosmt unitrN1: unit (-oner<:r>). +lemma unitrN1: unit (-oner<:r>). proof. by apply/unitrP; exists (-oner); rewrite mulrNN mulr1. qed. -lemma nosmt invrN1: invr (-oner) = -oner<:r>. +lemma invrN1: invr (-oner) = -oner<:r>. proof. by rewrite -{2}(divrr unitrN1) mulN1r opprK. qed. -lemma nosmt unitrMl (x y : r) : unit y => (unit (x * y) <=> unit x). +lemma unitrMl (x y : r) : unit y => (unit (x * y) <=> unit x). proof. (* FIXME: wlog *) move=> uy; case: (unit x)=> /=; last first. apply/contra=> uxy; apply/unitrP; exists (y * invr (x * y)). @@ -370,73 +370,73 @@ move=> ux; apply/unitrP; exists (invr y * invr x). by rewrite -!mulrA mulKr // mulVr. qed. -lemma nosmt unitrMr (x y : r): unit x => (unit (x * y) <=> unit y). +lemma unitrMr (x y : r): unit x => (unit (x * y) <=> unit y). proof. move=> ux; split=> [uxy|uy]; last by rewrite unitrMl. by rewrite -(mulKr _ ux y) unitrMl ?unitrV. qed. -lemma nosmt unitrM (x y : r) : unit (x * y) <=> (unit x /\ unit y). +lemma unitrM (x y : r) : unit (x * y) <=> (unit x /\ unit y). proof. case: (unit x) => /=; first by apply: unitrMr. apply: contra => /unitrP[z] zVE; apply/unitrP. by exists (y * z); rewrite mulrAC (@mulrC y) (@mulrC _ z). qed. -lemma nosmt unitrN (x : r) : unit (-x) <=> unit x. +lemma unitrN (x : r) : unit (-x) <=> unit x. proof. by rewrite -mulN1r unitrMr // unitrN1. qed. -lemma nosmt invrM (x y : r) : unit x => unit y => invr (x * y) = invr y * invr x. +lemma invrM (x y : r) : unit x => unit y => invr (x * y) = invr y * invr x. proof. move=> Ux Uy; have Uxy: unit (x * y) by rewrite unitrMl. by apply: (mulrI _ Uxy); rewrite mulrV ?mulrA ?mulrK ?mulrV. qed. -lemma nosmt invrN (x : r) : invr (- x) = - (invr x). +lemma invrN (x : r) : invr (- x) = - (invr x). proof. case: (unit x) => ux; last by rewrite !invr_out ?unitrN. by rewrite -mulN1r invrM ?unitrN1 // invrN1 mulrN1. qed. -lemma nosmt invr_neq0 (x : r) : x <> zeror => invr x <> zeror. +lemma invr_neq0 (x : r) : x <> zeror => invr x <> zeror. proof. move=> nx0; case: (unit x)=> Ux; last by rewrite invr_out ?Ux. by apply/negP=> x'0; move: Ux; rewrite -unitrV x'0 unitr0. qed. -lemma nosmt invr_eq0 (x : r) : (invr x = zeror) <=> (x = zeror). +lemma invr_eq0 (x : r) : (invr x = zeror) <=> (x = zeror). proof. by apply/iff_negb; split=> /invr_neq0; rewrite ?invrK. qed. -lemma nosmt invr_eq1 (x : r) : (invr x = oner) <=> (x = oner). +lemma invr_eq1 (x : r) : (invr x = oner) <=> (x = oner). proof. by rewrite (inv_eq invrK) invr1. qed. op ofint n = intmul oner<:r> n. -lemma nosmt ofint0: ofint 0 = zeror. +lemma ofint0: ofint 0 = zeror. proof. by apply/mulr0z. qed. -lemma nosmt ofint1: ofint 1 = oner. +lemma ofint1: ofint 1 = oner. proof. by apply/mulr1z. qed. -lemma nosmt ofintS (i : int): 0 <= i => ofint (i+1) = oner + ofint i. +lemma ofintS (i : int): 0 <= i => ofint (i+1) = oner + ofint i. proof. by apply/mulrS. qed. -lemma nosmt ofintN (i : int): ofint (-i) = - (ofint i). +lemma ofintN (i : int): ofint (-i) = - (ofint i). proof. by apply/mulrNz. qed. -lemma nosmt mul1r0z x: x * ofint 0 = zeror. +lemma mul1r0z x: x * ofint 0 = zeror. proof. by rewrite ofint0 mulr0. qed. -lemma nosmt mul1r1z x : x * ofint 1 = x. +lemma mul1r1z x : x * ofint 1 = x. proof. by rewrite ofint1 mulr1. qed. -lemma nosmt mul1r2z x : x * ofint 2 = x + x. +lemma mul1r2z x : x * ofint 2 = x + x. proof. by rewrite /ofint mulr2z mulrDr mulr1. qed. -lemma nosmt mulr_intl x z : (ofint z) * x = intmul x z. +lemma mulr_intl x z : (ofint z) * x = intmul x z. proof. by rewrite mulrzAl mul1r. qed. -lemma nosmt mulr_intr x z : x * (ofint z) = intmul x z. +lemma mulr_intr x z : x * (ofint z) = intmul x z. proof. by rewrite mulrzAr mulr1. qed. op exp (x : r) (n : int) = @@ -444,39 +444,39 @@ op exp (x : r) (n : int) = then invr (iterop (-n) ( * ) x oner) else iterop n ( * ) x oner. -lemma nosmt expr0 x: exp x 0 = oner. +lemma expr0 x: exp x 0 = oner. proof. by rewrite /exp /= iterop0. qed. -lemma nosmt expr1 x: exp x 1 = x. +lemma expr1 x: exp x 1 = x. proof. by rewrite /exp /= iterop1. qed. -lemma nosmt exprS (x : r) i: 0 <= i => exp x (i+1) = x * (exp x i). +lemma exprS (x : r) i: 0 <= i => exp x (i+1) = x * (exp x i). proof. move=> ge0i; rewrite /exp !ltzNge ge0i addz_ge0 //=. (* we want to use the multiplicative monoid instance here *) (* by rewrite !Monoid.iteropE iterS. *) admit. qed. -lemma nosmt expr_pred (x : r) i : 0 < i => exp x i = x * (exp x (i - 1)). +lemma expr_pred (x : r) i : 0 < i => exp x i = x * (exp x (i - 1)). proof. smt(exprS). qed. -lemma nosmt exprSr (x : r) i: 0 <= i => exp x (i+1) = (exp x i) * x. +lemma exprSr (x : r) i: 0 <= i => exp x (i+1) = (exp x i) * x. proof. by move=> ge0_i; rewrite exprS // mulrC. qed. -lemma nosmt expr2 x: exp x 2 = x * x. +lemma expr2 x: exp x 2 = x * x. proof. by rewrite (@exprS _ 1) // expr1. qed. -lemma nosmt exprN (x : r) (i : int): exp x (-i) = invr (exp x i). +lemma exprN (x : r) (i : int): exp x (-i) = invr (exp x i). proof. case: (i = 0) => [->|]; first by rewrite oppz0 expr0 invr1. rewrite /exp oppz_lt0 ltzNge lez_eqVlt oppzK=> -> /=. by case: (_ < _)%Int => //=; rewrite invrK. qed. -lemma nosmt exprN1 (x : r) : exp x (-1) = invr x. +lemma exprN1 (x : r) : exp x (-1) = invr x. proof. by rewrite exprN expr1. qed. -lemma nosmt unitrX x m : unit x => unit (exp x m). +lemma unitrX x m : unit x => unit (exp x m). proof. move=> invx; wlog: m / (0 <= m) => [wlog|]. + (have [] : (0 <= m \/ 0 <= -m) by move=> /#); first by apply: wlog. @@ -485,7 +485,7 @@ elim: m => [|m ge0_m ih]; first by rewrite expr0 unitr1. by rewrite exprS // &(unitrMl). qed. -lemma nosmt unitrX_neq0 x m : m <> 0 => unit (exp x m) => unit x. +lemma unitrX_neq0 x m : m <> 0 => unit (exp x m) => unit x. proof. wlog: m / (0 < m) => [wlog|]. + case: (0 < m); [by apply: wlog | rewrite ltzNge /= => le0_m nz_m]. @@ -493,7 +493,7 @@ wlog: m / (0 < m) => [wlog|]. by move=> gt0_m _; rewrite (_ : m = m - 1 + 1) // exprS 1:/# unitrM. qed. -lemma nosmt exprV (x : r) (i : int): exp (invr x) i = exp x (-i). +lemma exprV (x : r) (i : int): exp (invr x) i = exp x (-i). proof. wlog: i / (0 <= i) => [wlog|]; first by smt(exprN). elim: i => /= [|i ge0_i ih]; first by rewrite !expr0. @@ -506,7 +506,7 @@ rewrite !invr_out //; last by rewrite exprS. + by apply: contra invNx; apply: unitrX_neq0 => /#. qed. -lemma nosmt exprVn (x : r) (n : int) : 0 <= n => exp (invr x) n = invr (exp x n). +lemma exprVn (x : r) (n : int) : 0 <= n => exp (invr x) n = invr (exp x n). proof. elim: n => [|n ge0_n ih]; first by rewrite !expr0 invr1. case: (unit x) => ux. @@ -514,13 +514,13 @@ case: (unit x) => ux. - by rewrite !invr_out //; apply: contra ux; apply: unitrX_neq0 => /#. qed. -lemma nosmt exprMn (x y : r) (n : int) : 0 <= n => exp (x * y) n = exp x n * exp y n. +lemma exprMn (x y : r) (n : int) : 0 <= n => exp (x * y) n = exp x n * exp y n. proof. elim: n => [|n ge0_n ih]; first by rewrite !expr0 mulr1. by rewrite !exprS // mulrACA ih. qed. -lemma nosmt exprD_nneg x (m n : int) : 0 <= m => 0 <= n => +lemma exprD_nneg x (m n : int) : 0 <= m => 0 <= n => exp x (m + n) = exp x m * exp x n. proof. move=> ge0_m ge0_n; elim: m ge0_m => [|m ge0_m ih]. @@ -528,7 +528,7 @@ proof. by rewrite addzAC !exprS ?addz_ge0 // ih mulrA. qed. -lemma nosmt exprD x (m n : int) : unit x => exp x (m + n) = exp x m * exp x n. +lemma exprD x (m n : int) : unit x => exp x (m + n) = exp x m * exp x n. proof. wlog: m n x / (0 <= m + n) => [wlog invx|]. + case: (0 <= m + n); [by move=> ?; apply: wlog | rewrite lezNgt /=]. @@ -547,7 +547,7 @@ case=> [->>|lt_m_Sn]; first by rewrite exprD_nneg //#. by rewrite addzA exprS 1:/# ih 1,2:/# exprS // mulrCA. qed. -lemma nosmt exprM x (m n : int) : +lemma exprM x (m n : int) : exp x (m * n) = exp (exp x m) n. proof. wlog : n / 0 <= n. @@ -562,20 +562,20 @@ elim/natind: n => [|n hn ih hm _]; 1: smt (expr0). by rewrite mulzDr exprS //= mulrC exprD_nneg 1:/# 1:// ih. qed. -lemma nosmt expr0n n : 0 <= n => exp zeror n = if n = 0 then oner else zeror. +lemma expr0n n : 0 <= n => exp zeror n = if n = 0 then oner else zeror. proof. elim: n => [|n ge0_n _]; first by rewrite expr0. by rewrite exprS // mul0r addz1_neq0. qed. -lemma nosmt expr0z z : exp zeror z = if z = 0 then oner else zeror. +lemma expr0z z : exp zeror z = if z = 0 then oner else zeror. proof. case: (0 <= z) => [/expr0n // | /ltzNge lt0_z]. rewrite -{1}(@oppzK z) exprN; have ->/=: z <> 0 by smt(). by rewrite invr_eq0 expr0n ?oppz_ge0 1:ltzW. qed. -lemma nosmt expr1z z : exp oner z = oner. +lemma expr1z z : exp oner z = oner. proof. elim/intwlog: z. + by move=> n h; rewrite -(@oppzK n) exprN h invr1. @@ -583,27 +583,27 @@ elim/intwlog: z. + by move=> n ge0_n ih; rewrite exprS // mul1r ih. qed. -lemma nosmt sqrrD (x y : r) : +lemma sqrrD (x y : r) : exp (x + y) 2 = exp x 2 + intmul (x * y) 2 + exp y 2. proof. by rewrite !expr2 mulrDl !mulrDr mulr2z !addrA (@mulrC y x). qed. -lemma nosmt sqrrN x : exp (-x) 2 = exp x 2. +lemma sqrrN x : exp (-x) 2 = exp x 2. proof. by rewrite !expr2 mulrNN. qed. -lemma nosmt sqrrB x y : +lemma sqrrB x y : exp (x - y) 2 = exp x 2 - intmul (x * y) 2 + exp y 2. proof. by rewrite sqrrD sqrrN mulrN mulNrz. qed. -lemma nosmt signr_odd n : 0 <= n => exp (-oner) (b2i (odd n)) = exp (-oner) n. +lemma signr_odd n : 0 <= n => exp (-oner) (b2i (odd n)) = exp (-oner) n. proof. elim: n => [|n ge0_nih]; first by rewrite odd0 expr0 expr0. rewrite !(iterS, oddS) // exprS // -/(odd _) => <-. by case: (odd _); rewrite /b2i /= !(expr0, expr1) mulN1r ?opprK. qed. -lemma nosmt subr_sqr_1 x : exp x 2 - oner = (x - oner) * (x + oner). +lemma subr_sqr_1 x : exp x 2 - oner = (x - oner) * (x + oner). proof. rewrite mulrBl mulrDr !(mulr1, mul1r) expr2 -addrA. by congr; rewrite opprD addrA addrN add0r. @@ -611,30 +611,30 @@ qed. op lreg (x : r) = injective (fun y => x * y). -lemma nosmt mulrI_eq0 x y : lreg x => (x * y = zeror) <=> (y = zeror). +lemma mulrI_eq0 x y : lreg x => (x * y = zeror) <=> (y = zeror). proof. by move=> reg_x; rewrite -{1}(mulr0 x) (inj_eq reg_x). qed. -lemma nosmt lreg_neq0 x : lreg x => x <> zeror. +lemma lreg_neq0 x : lreg x => x <> zeror. proof. apply/contraL=> ->; apply/negP => /(_ zeror oner). by rewrite (@eq_sym _ oner) oner_neq0 /= !mul0r. qed. -lemma nosmt mulrI0_lreg x : (forall y, x * y = zeror => y = zeror) => lreg x. +lemma mulrI0_lreg x : (forall y, x * y = zeror => y = zeror) => lreg x. proof. by move=> reg_x y z eq; rewrite -subr_eq0 &(reg_x) mulrBr eq subrr. qed. -lemma nosmt lregN x : lreg x => lreg (-x). +lemma lregN x : lreg x => lreg (-x). proof. by move=> reg_x y z; rewrite !mulNr => /oppr_inj /reg_x. qed. -lemma nosmt lreg1 : lreg oner. +lemma lreg1 : lreg oner. proof. by move=> x y; rewrite !mul1r. qed. -lemma nosmt lregM x y : lreg x => lreg y => lreg (x * y). +lemma lregM x y : lreg x => lreg y => lreg (x * y). proof. by move=> reg_x reg_y z t; rewrite -!mulrA => /reg_x /reg_y. qed. -lemma nosmt lregXn x n : 0 <= n => lreg x => lreg (exp x n). +lemma lregXn x n : 0 <= n => lreg x => lreg (exp x n). proof. move=> + reg_x; elim: n => [|n ge0_n ih]. - by rewrite expr0 &(lreg1). @@ -672,7 +672,7 @@ type class boolring <: comring = { axiom mulrr : forall (x : boolring), x * x = x }. -lemma nosmt addrr ['a <: boolring] (x : 'a): x + x = zeror. +lemma addrr ['a <: boolring] (x : 'a): x + x = zeror. proof. apply (@addrI (x + x)); rewrite addr0 -{1 2 3 4}mulrr. by rewrite -mulrDr -mulrDl mulrr. @@ -687,10 +687,10 @@ type class idomain <: comring = { section. declare type r <: idomain. -lemma nosmt mulf_neq0 (x y : r): x <> zeror => y <> zeror => x * y <> zeror. +lemma mulf_neq0 (x y : r): x <> zeror => y <> zeror => x * y <> zeror. proof. by move=> nz_x nz_y; apply/negP; rewrite mulf_eq0 /#. qed. -lemma nosmt expf_eq0 (x : r) n : (exp x n = zeror) <=> (n <> 0 /\ x = zeror). +lemma expf_eq0 (x : r) n : (exp x n = zeror) <=> (n <> 0 /\ x = zeror). proof. elim/intwlog: n => [n| |n ge0_n ih]. + by rewrite exprN invr_eq0 /#. @@ -698,22 +698,22 @@ elim/intwlog: n => [n| |n ge0_n ih]. by rewrite exprS // mulf_eq0 ih addz1_neq0 ?andKb. qed. -lemma nosmt mulfI (x : r): x <> zeror => injective (( * ) x). +lemma mulfI (x : r): x <> zeror => injective (( * ) x). proof. move=> ne0_x y y'; rewrite -(opprK (x * y')) -mulrN -addr_eq0. by rewrite -mulrDr mulf_eq0 ne0_x /= addr_eq0 opprK. qed. -lemma nosmt mulIf (x : r): x <> zeror => injective (fun y => y * x). +lemma mulIf (x : r): x <> zeror => injective (fun y => y * x). proof. by move=> nz_x y z; rewrite -!(@mulrC x); exact: mulfI. qed. -lemma nosmt sqrf_eq1 (x : r): (exp x 2 = oner) <=> (x = oner \/ x = -oner). +lemma sqrf_eq1 (x : r): (exp x 2 = oner) <=> (x = oner \/ x = -oner). proof. by rewrite -subr_eq0 subr_sqr_1 mulf_eq0 subr_eq0 addr_eq0. qed. -lemma nosmt lregP (x : r): lreg x <=> x <> zeror. +lemma lregP (x : r): lreg x <=> x <> zeror. proof. by split=> [/lreg_neq0//|/mulfI]. qed. -lemma nosmt eqr_div (x1 y1 x2 y2 : r) : unit y1 => unit y2 => +lemma eqr_div (x1 y1 x2 y2 : r) : unit y1 => unit y2 => (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). proof. move=> Nut1 Nut2; rewrite -{1}(@mulrK y2 _ x1) //. @@ -752,30 +752,30 @@ type class ffield <: comring = { section. declare type f <: ffield. -lemma nosmt mulfV (x : f): x <> zeror => x * (invr x) = oner. +lemma mulfV (x : f): x <> zeror => x * (invr x) = oner. proof. by move=> /unit_neq0/mulrV. qed. -lemma nosmt mulVf (x : f): x <> zeror => (invr x) * x = oner. +lemma mulVf (x : f): x <> zeror => (invr x) * x = oner. proof. by move=> /unit_neq0/mulVr. qed. -lemma nosmt divff (x : f): x <> zeror => x / x = oner. +lemma divff (x : f): x <> zeror => x / x = oner. proof. by move=> /unit_neq0/divrr. qed. -lemma nosmt invfM (x y : f) : invr (x * y) = invr x * invr y. +lemma invfM (x y : f) : invr (x * y) = invr x * invr y. proof. case: (x = zeror) => [->|nz_x]; first by rewrite !(mul0r, invr0). case: (y = zeror) => [->|nz_y]; first by rewrite !(mulr0, invr0). by rewrite invrM ?unit_neq0 // mulrC. qed. -lemma nosmt invf_div (x y : f) : invr (x / y) = y / x. +lemma invf_div (x y : f) : invr (x / y) = y / x. proof. by rewrite invfM invrK mulrC. qed. -lemma nosmt eqf_div (x1 y1 x2 y2 : f) : y1 <> zeror => y2 <> zeror => +lemma eqf_div (x1 y1 x2 y2 : f) : y1 <> zeror => y2 <> zeror => (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). proof. by rewrite -!unit_neq0; exact: eqr_div<:f>. qed. -lemma nosmt expfM (x y : f) n : exp (x * y) n = exp x n * exp y n. +lemma expfM (x y : f) n : exp (x * y) n = exp x n * exp y n. proof. elim/intwlog: n => [n h | | n ge0_n ih]. + by rewrite -(@oppzK n) !(@exprN _ (-n)) h invfM. diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index c234ee5372..d53927737a 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -218,9 +218,11 @@ and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = else TCIConcrete { rtcw with etyargs } | TCIAbstract { support = `Var tyvar; offset } -> - Mid.find_opt tyvar s.fs_v - |> Option.map (fun (_, tcws) -> List.nth tcws offset) - |> Option.value ~default:tcw + let resolved = + let open Option in + bind (Mid.find_opt tyvar s.fs_v) (fun (_, tcws) -> + List.nth_opt tcws offset) in + Option.value ~default:tcw resolved | TCIAbstract { support = `Abs _ } -> tcw diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 08fca335e4..763b25a7e0 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -409,7 +409,10 @@ module Unify = struct let deps = !deps in if TyUni.Suid.is_empty deps then begin + let deref_tc (tc' : typeclass) = + { tc' with tc_args = List.map check_etyarg tc'.tc_args } in let eq_tc (tc' : typeclass) = + let tc' = deref_tc tc' in EcPath.p_equal tc.tc_name tc'.tc_name && List.for_all2 (EcCoreEqTest.for_etyarg env) tc.tc_args tc'.tc_args in From ae63ea24856ecdae9e6fb4a05e534bd6ae1697e0 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 10:54:58 +0200 Subject: [PATCH 075/113] =?UTF-8?q?section=20close:=20f=5Fop=20=E2=86=92?= =?UTF-8?q?=20f=5Fop=5Ftc=20with=20proper=20etyargs=20to=20preserve=20TC?= =?UTF-8?q?=20witnesses?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/ecCoreSubst.ml | 5 ++--- src/ecSection.ml | 12 ++++++------ 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index d53927737a..1c9721c563 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -219,9 +219,8 @@ and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = | TCIAbstract { support = `Var tyvar; offset } -> let resolved = - let open Option in - bind (Mid.find_opt tyvar s.fs_v) (fun (_, tcws) -> - List.nth_opt tcws offset) in + Option.bind (Mid.find_opt tyvar s.fs_v) + (fun (_, tcws) -> List.nth_opt tcws offset) in Option.value ~default:tcw resolved | TCIAbstract { support = `Abs _ } -> diff --git a/src/ecSection.ml b/src/ecSection.ml index 94a41e1d1e..bc0da92373 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -864,9 +864,9 @@ let generalize_opdecl to_gen prefix (name, operator) = let extra = generalize_extra_ty to_gen fv in let tparams = extra @ operator.op_tparams in let opty = operator.op_ty in - let args = List.map (fun (id, _) -> tvar id) tparams in + let etyargs = EcDecl.etyargs_of_tparams tparams in let tosubst = (List.map fst operator.op_tparams, - f_op path args opty) in + f_op_tc path etyargs opty) in let tg_subst = EcSubst.add_pddef to_gen.tg_subst path tosubst in tg_subst, mk_op ~opaque:operator.op_opaque tparams opty None `Global @@ -877,8 +877,8 @@ let generalize_opdecl to_gen prefix (name, operator) = let tparams = extra_t @ operator.op_tparams in let extra_a = generalize_extra_args to_gen.tg_binds fv in let opty = toarrow (List.map snd extra_a) operator.op_ty in - let t_args = List.map (fun (id, _) -> tvar id) tparams in - let eop = e_op path t_args opty in + let etyargs = EcDecl.etyargs_of_tparams tparams in + let eop = e_op_tc path etyargs opty in let e = e_app eop (List.map (fun (id,ty) -> e_local id ty) extra_a) operator.op_ty in @@ -915,8 +915,8 @@ let generalize_opdecl to_gen prefix (name, operator) = let op_tparams = extra_t @ operator.op_tparams in let extra_a = generalize_extra_args to_gen.tg_binds fv in let op_ty = toarrow (List.map snd extra_a) operator.op_ty in - let t_args = List.map (fun (id, _) -> tvar id) op_tparams in - let fop = f_op path t_args op_ty in + let etyargs = EcDecl.etyargs_of_tparams op_tparams in + let fop = f_op_tc path etyargs op_ty in let f = f_app fop (List.map (fun (id,ty) -> f_local id ty) extra_a) operator.op_ty in From cd723f5064b96aafd2e721976ce3b153cd7f1ee4 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 14:39:36 +0200 Subject: [PATCH 076/113] Option B: TCIAbstract/TCIConcrete/TCIUni carry a 'lift' parent-walk count --- src/ecAst.ml | 49 +++++++++++++++++++++++++++++----------- src/ecAst.mli | 5 ++++- src/ecCoreEqTest.ml | 24 ++++++++++++-------- src/ecCoreSubst.ml | 12 +++++----- src/ecDecl.ml | 2 +- src/ecEnv.mli | 5 +++-- src/ecPrinting.ml | 26 +++++++++++---------- src/ecReduction.ml | 21 ++++++++++++++--- src/ecScope.ml | 21 +++++++++++++++-- src/ecSubst.ml | 22 +++++++++--------- src/ecTypeClass.ml | 2 +- src/ecTypes.ml | 4 ++-- src/ecUnify.ml | 55 ++++++++++++++++++++++++++------------------- 13 files changed, 162 insertions(+), 86 deletions(-) diff --git a/src/ecAst.ml b/src/ecAst.ml index a9024c53d2..74fbbd6d3e 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -66,11 +66,17 @@ and ty_node = and etyarg = ty * tcwitness list and tcwitness = - | TCIUni of tcuni + (* Unification variable, possibly with a pending [lift] count to apply + once the variable is resolved. *) + | TCIUni of tcuni * int | TCIConcrete of { path: EcPath.path; etyargs: (ty * tcwitness list) list; + (* Same semantics as [TCIAbstract.lift]: number of [tc_prt] steps + to walk up from the typeclass that this concrete instance is + declared for. *) + lift: int; } | TCIAbstract of { @@ -79,6 +85,11 @@ and tcwitness = | `Abs of EcPath.path ]; offset: int; + (* Number of [tc_prt] steps to walk up from the typeclass at + [support]'s [offset]-th position. [lift = 0] means "use the + declared typeclass directly"; [lift = k] means "walk [k] parent + pointers up the typeclass hierarchy from there". *) + lift: int; } (* -------------------------------------------------------------------- *) @@ -406,6 +417,17 @@ let lp_fv = function (fun s (id, _) -> ofold Sid.add s id) Sid.empty ids +(* -------------------------------------------------------------------- *) +(* Add [n] parent-walk steps to a witness. Used during substitution when + a witness referencing the [k]-th tc of some support gets replaced by + the witness for that tc, which may itself need to be lifted further. *) +let bump_lift (n : int) (tcw : tcwitness) : tcwitness = + if n = 0 then tcw else + match tcw with + | TCIUni (uid, l) -> TCIUni (uid, l + n) + | TCIConcrete c -> TCIConcrete { c with lift = c.lift + n } + | TCIAbstract a -> TCIAbstract { a with lift = a.lift + n } + (* -------------------------------------------------------------------- *) let rec tcw_fv (tcw : tcwitness) = match tcw with @@ -436,15 +458,16 @@ let etyargs_fv (tyargs : etyarg list) = (* -------------------------------------------------------------------- *) let rec tcw_equal (tcw1 : tcwitness) (tcw2 : tcwitness) = match tcw1, tcw2 with - | TCIUni uid1, TCIUni uid2 -> - TcUni.uid_equal uid1 uid2 + | TCIUni (uid1, l1), TCIUni (uid2, l2) -> + TcUni.uid_equal uid1 uid2 && l1 = l2 | TCIConcrete tcw1, TCIConcrete tcw2 -> EcPath.p_equal tcw1.path tcw2.path + && tcw1.lift = tcw2.lift && List.all2 etyarg_equal tcw1.etyargs tcw2.etyargs - | TCIAbstract { support = support1; offset = o1; } - , TCIAbstract { support = support2; offset = o2; } + | TCIAbstract { support = support1; offset = o1; lift = l1 } + , TCIAbstract { support = support2; offset = o2; lift = l2 } -> let tyvar_eq () = match support1, support2 with @@ -454,7 +477,7 @@ let rec tcw_equal (tcw1 : tcwitness) (tcw2 : tcwitness) = EcPath.p_equal p1 p2 | _, _ -> false - in o1 = o2 && tyvar_eq () + in o1 = o2 && l1 = l2 && tyvar_eq () | _, _ -> false @@ -465,20 +488,20 @@ and etyarg_equal ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = (* -------------------------------------------------------------------- *) let rec tcw_hash (tcw : tcwitness) = match tcw with - | TCIUni uid -> - Hashtbl.hash uid + | TCIUni (uid, l) -> + Why3.Hashcons.combine (Hashtbl.hash uid) l | TCIConcrete tcw -> Why3.Hashcons.combine_list etyarg_hash - (p_hash tcw.path) + (Why3.Hashcons.combine (p_hash tcw.path) tcw.lift) tcw.etyargs - | TCIAbstract { support = `Var tyvar; offset } -> - Why3.Hashcons.combine (EcIdent.id_hash tyvar) offset + | TCIAbstract { support = `Var tyvar; offset; lift } -> + Why3.Hashcons.combine2 (EcIdent.id_hash tyvar) offset lift - | TCIAbstract { support = `Abs p; offset } -> - Why3.Hashcons.combine (EcPath.p_hash p) offset + | TCIAbstract { support = `Abs p; offset; lift } -> + Why3.Hashcons.combine2 (EcPath.p_hash p) offset lift and etyarg_hash ((ty, tcws) : etyarg) = Why3.Hashcons.combine_list tcw_hash (ty_hash ty) tcws diff --git a/src/ecAst.mli b/src/ecAst.mli index 13993a7afc..f5af677ad1 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -63,11 +63,12 @@ and ty_node = and etyarg = ty * tcwitness list and tcwitness = - | TCIUni of tcuni + | TCIUni of tcuni * int | TCIConcrete of { path: EcPath.path; etyargs: (ty * tcwitness list) list; + lift: int; } | TCIAbstract of { @@ -76,6 +77,7 @@ and tcwitness = | `Abs of EcPath.path ]; offset: int; + lift: int; } (* -------------------------------------------------------------------- *) @@ -362,6 +364,7 @@ val etyarg_hash : etyarg -> int val etyarg_equal : etyarg -> etyarg -> bool (* -------------------------------------------------------------------- *) +val bump_lift : int -> tcwitness -> tcwitness val tcw_fv : tcwitness -> int Mid.t val tcw_hash : tcwitness -> int val tcw_equal : tcwitness -> tcwitness -> bool diff --git a/src/ecCoreEqTest.ml b/src/ecCoreEqTest.ml index c16d062942..53fb954bac 100644 --- a/src/ecCoreEqTest.ml +++ b/src/ecCoreEqTest.ml @@ -63,20 +63,26 @@ and for_etyargs env (tyargs1 : etyarg list) (tyargs2 : etyarg list) = and for_tcw env (tcw1 : tcwitness) (tcw2 : tcwitness) = match tcw1, tcw2 with - | TCIUni uid1, TCIUni uid2 -> - EcAst.TcUni.uid_equal uid1 uid2 + | TCIUni (uid1, l1), TCIUni (uid2, l2) -> + EcAst.TcUni.uid_equal uid1 uid2 && l1 = l2 | TCIConcrete tcw1, TCIConcrete tcw2 -> EcPath.p_equal tcw1.path tcw2.path + && tcw1.lift = tcw2.lift && for_etyargs env tcw1.etyargs tcw2.etyargs - | TCIAbstract { support = `Var v1; offset = o1 }, - TCIAbstract { support = `Var v2; offset = o2 } -> - EcIdent.id_equal v1 v2 && o1 = o2 - - | TCIAbstract { support = `Abs p1; offset = o1 }, - TCIAbstract { support = `Abs p2; offset = o2 } -> - EcPath.p_equal p1 p2 && o1 = o2 + | TCIAbstract { support = `Var v1; offset = o1; lift = l1 }, + TCIAbstract { support = `Var v2; offset = o2; lift = l2 } -> + EcIdent.id_equal v1 v2 && o1 = o2 && l1 = l2 + + | TCIAbstract { support = `Abs p1; offset = o1; lift = l1 }, + TCIAbstract { support = `Abs p2; offset = o2; lift = l2 } -> + let r = EcPath.p_equal p1 p2 && o1 = o2 && l1 = l2 in + if not r then + Printf.eprintf "[for_tcw FAIL] Abs(%s,o=%d,l=%d) vs Abs(%s,o=%d,l=%d)\n%s\n%!" + (EcPath.tostring p1) o1 l1 (EcPath.tostring p2) o2 l2 + (Printexc.raw_backtrace_to_string (Printexc.get_callstack 15)); + r | _, _ -> false diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index 1c9721c563..d722b3dfb9 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -207,9 +207,9 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = (* -------------------------------------------------------------------- *) and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = match tcw with - | TCIUni uid -> - TcUni.Muid.find_opt uid s.fs_utc - |> Option.value ~default:tcw + | TCIUni (uid, lift) -> + let resolved = TcUni.Muid.find_opt uid s.fs_utc in + Option.fold ~none:tcw ~some:(bump_lift lift) resolved | TCIConcrete ({ etyargs = etyargs0 } as rtcw) -> let etyargs = List.Smart.map (etyarg_subst s) etyargs0 in @@ -217,10 +217,10 @@ and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = tcw else TCIConcrete { rtcw with etyargs } - | TCIAbstract { support = `Var tyvar; offset } -> + | TCIAbstract { support = `Var tyvar; offset; lift } -> let resolved = - Option.bind (Mid.find_opt tyvar s.fs_v) - (fun (_, tcws) -> List.nth_opt tcws offset) in + Option.bind (Mid.find_opt tyvar s.fs_v) (fun (_, tcws) -> + Option.map (bump_lift lift) (List.nth_opt tcws offset)) in Option.value ~default:tcw resolved | TCIAbstract { support = `Abs _ } -> diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 0f6084d0fb..0c440d90a4 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -68,7 +68,7 @@ let abs_tydecl ?(resolve = true) ?(tc = []) ?(params = `Int 0) lc = let etyargs_of_tparams (tps : ty_params) : etyarg list = List.map (fun (a, tcs) -> let ety = - List.mapi (fun offset _ -> TCIAbstract { support = `Var a; offset }) tcs + List.mapi (fun offset _ -> TCIAbstract { support = `Var a; offset; lift = 0 }) tcs in (tvar a, ety) ) tps diff --git a/src/ecEnv.mli b/src/ecEnv.mli index a6c06eb484..3d7cbf3e73 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -371,8 +371,9 @@ val ty_hnorm : ty -> env -> ty module TypeClass : sig type t = tc_decl - val add : path -> env -> env - val bind : ?import:import -> symbol -> t -> env -> env + val add : path -> env -> env + val bind : ?import:import -> symbol -> t -> env -> env + val rebind : symbol -> t -> env -> env val by_path : path -> env -> t val by_path_opt : path -> env -> t option diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 09418eed99..d708c67ec4 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -972,19 +972,21 @@ and pp_etyargs (ppe : PPEnv.t) (fmt : Format.formatter) (etys : etyarg list) = (* -------------------------------------------------------------------- *) and pp_tcw (ppe : PPEnv.t) (fmt : Format.formatter) (tcw : tcwitness) = + let pp_lift fmt l = + if l > 0 then Format.fprintf fmt "^%d" l in match tcw with - | TCIUni uid -> - Format.fprintf fmt "%a" (pp_tcunivar ppe) uid - - | TCIConcrete { path; etyargs } -> - Format.fprintf fmt "%a[%a]" - (pp_tciname ppe) path (pp_etyargs ppe) etyargs - - | TCIAbstract { support = `Var x; offset } -> - Format.fprintf fmt "%a.`%d" (pp_tyvar ppe) x (offset + 1) - - | TCIAbstract { support = `Abs path; offset } -> - Format.fprintf fmt "%a.`%d" (pp_tyname ppe) path (offset + 1) + | TCIUni (uid, lift) -> + Format.fprintf fmt "%a%a" (pp_tcunivar ppe) uid pp_lift lift + + | TCIConcrete { path; etyargs; lift } -> + Format.fprintf fmt "%a[%a]%a" + (pp_tciname ppe) path (pp_etyargs ppe) etyargs pp_lift lift + + | TCIAbstract { support = `Var x; offset; lift } -> + Format.fprintf fmt "%a.`%d%a" (pp_tyvar ppe) x (offset + 1) pp_lift lift + + | TCIAbstract { support = `Abs path; offset; lift } -> + Format.fprintf fmt "%a.`%d%a" (pp_tyname ppe) path (offset + 1) pp_lift lift (* -------------------------------------------------------------------- *) and pp_tcws (ppe : PPEnv.t) (fmt : Format.formatter) (tcws : tcwitness list) = diff --git a/src/ecReduction.ml b/src/ecReduction.ml index baf639d5c8..602d304193 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -1435,9 +1435,24 @@ let rec conv ri env f1 f2 stk = end | Fop(p1, ty1), Fop(p2,ty2) - when EcPath.p_equal p1 p2 - && List.all2 (EqTest_i.for_etyarg env) ty1 ty2 -> - conv_next ri env f1 stk + when EcPath.p_equal p1 p2 -> + if List.all2 (EqTest_i.for_etyarg env) ty1 ty2 then + conv_next ri env f1 stk + else begin + let dump_etys etys = + String.concat "; " (List.map (fun (_, tcws) -> + String.concat "," (List.map (function + | TCIUni (u, l) -> Printf.sprintf "TCIUni(#%d,l=%d)" (u :> int) l + | TCIConcrete c -> Printf.sprintf "TCIConcrete(%s,l=%d)" (EcPath.tostring c.path) c.lift + | TCIAbstract { support = `Var x; offset; lift } -> + Printf.sprintf "TCIAbs(Var %s,o=%d,l=%d)" (EcIdent.tostring x) offset lift + | TCIAbstract { support = `Abs p; offset; lift } -> + Printf.sprintf "TCIAbs(Abs %s,o=%d,l=%d)" (EcPath.tostring p) offset lift) + tcws)) etys) in + Printf.eprintf "[conv Fop mismatch] op=%s\n lhs=[%s]\n rhs=[%s]\n%!" + (EcPath.tostring p1) (dump_etys ty1) (dump_etys ty2); + force_head ri env f1 f2 stk + end | Fapp(f1', args1), Fapp(f2', args2) when EqTest_i.for_type env f1'.f_ty f2'.f_ty diff --git a/src/ecScope.ml b/src/ecScope.ml index cbb2efb89a..00ba792464 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1290,7 +1290,7 @@ module Op = struct let oppath = EcPath.pqname (path scope) (unloc op.po_name) in let optyargs = let mktcw (a : EcIdent.t) (i : int) = - TCIAbstract { support = `Var a; offset = i; } + TCIAbstract { support = `Var a; offset = i; lift = 0 } in List.map (fun (a, tcs) -> (tvar a, List.mapi (fun i _ -> mktcw a i) tcs)) @@ -1672,9 +1672,26 @@ module Ty = struct { tcp with tc_args = List.map (etyarg_subst subst) tcp.tc_args }) uptc in + (* The carrier's [tcs] should reference the class being declared + (so its own ops can be resolved via [Abs mypath, l=0]) and the + parent class is reachable via the ancestor chain. To make + [EcTypeClass.ancestors] work during axiom typing, we pre-bind + a stub typeclass record. The full record replaces the stub at + end of [add_class]. *) + let mypath = EcPath.pqname (path scope) name in + let stub_tc : tc_decl = { + tc_tparams = EcUnify.UniEnv.tparams ue; + tc_prt = uptc; + tc_ops = []; + tc_axs = []; + tc_loca = lc; + } in + let scenv = + EcEnv.TypeClass.rebind name stub_tc scenv in + let asty = { tyd_params = []; - tyd_type = `Abstract (otolist uptc); + tyd_type = `Abstract [{ tc_name = mypath; tc_args = [] }]; tyd_resolve = true; tyd_loca = (lc :> locality); } in let scenv = EcEnv.Ty.bind name asty scenv in diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 5f0cc19d03..1b75884a5c 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -200,18 +200,18 @@ and subst_tcw (s : subst) (tcw : tcwitness) = | TCIUni _ -> tcw - | TCIConcrete { etyargs; path } -> + | TCIConcrete ({ etyargs; path; _ } as c) -> let path = subst_path s path in let etyargs = subst_etyargs s etyargs in - TCIConcrete { etyargs; path } + TCIConcrete { c with etyargs; path } - | TCIAbstract { support = `Var a; offset } -> - Mid.find_opt a s.sb_tyvar - |> Option.map snd - |> Option.map (fun tcs -> List.nth tcs offset) - |> Option.value ~default:tcw + | TCIAbstract { support = `Var a; offset; lift } -> + let resolved = + Option.bind (Mid.find_opt a s.sb_tyvar) (fun (_, tcs) -> + Option.map (fun tcw -> bump_lift lift tcw) (List.nth_opt tcs offset)) in + Option.value ~default:tcw resolved - | TCIAbstract ({ support = `Abs p; offset } as tcw) -> + | TCIAbstract ({ support = `Abs p; offset; lift } as tcw) -> match Mp.find_opt p s.sb_tydef with | None -> TCIAbstract { tcw with support = `Abs (subst_path s p) } @@ -219,9 +219,9 @@ and subst_tcw (s : subst) (tcw : tcwitness) = | Some (_, body) -> match body.ty_node with | Tvar a -> - TCIAbstract { support = `Var a; offset } + TCIAbstract { support = `Var a; offset; lift } | Tconstr (p', _) -> - TCIAbstract { support = `Abs p'; offset } + TCIAbstract { support = `Abs p'; offset; lift } | _ -> assert false (* FIXME:TC: substitute via concrete instance lookup *) @@ -943,7 +943,7 @@ let fresh_tparam (s : subst) ((x, tcs) : ty_param) = let tcs = List.map (subst_typeclass s) tcs in let tcw = let mk (offset : int) = - TCIAbstract { support = `Var newx; offset; } + TCIAbstract { support = `Var newx; offset; lift = 0 } in List.mapi (fun i _ -> mk i) tcs in let s = add_tyvar s x (tvar newx, tcw) in (s, (newx, tcs)) diff --git a/src/ecTypeClass.ml b/src/ecTypeClass.ml index addb7c7628..db3215aae1 100644 --- a/src/ecTypeClass.ml +++ b/src/ecTypeClass.ml @@ -135,7 +135,7 @@ let rec check_tcinstance (subst, (aty, aargs)) ) Mid.empty tci.tci_params in - Some (TCIConcrete { path = p; etyargs = args; }) + Some (TCIConcrete { path = p; etyargs = args; lift = 0; }) with Bailout | NoMatch -> None diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 75b30cfdb3..874d0fc371 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -137,9 +137,9 @@ and tcw_map (f : ty -> ty) (tcw : tcwitness) : tcwitness = | TCIUni _ -> tcw - | TCIConcrete { path; etyargs; } -> + | TCIConcrete ({ etyargs; _ } as c) -> let etyargs = List.Smart.map (etyarg_map f) etyargs in - TCIConcrete { path; etyargs; } + TCIConcrete { c with etyargs } | TCIAbstract _ -> tcw diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 763b25a7e0..343b215d2b 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -118,7 +118,7 @@ module Unify = struct tcenv.resolution tw; } in - tcenv, TCIUni uid + tcenv, TCIUni (uid, 0) (* ------------------------------------------------------------------ *) let initial_ucore ?(tvtc = Mid.empty) () : ucore = @@ -151,25 +151,26 @@ module Unify = struct and doit_tc (tw : tcwitness) = match tw with - | TCIUni uid -> begin + | TCIUni (uid, lift) -> begin match Hint.find_opt tcmap (uid :> int) with - | Some tw -> tw + | Some tw -> bump_lift lift tw | None -> - let tw = + let resolved = match TcUni.Muid.find_opt uid uc.tcenv.resolution with - | None -> tw - | Some (TCIUni uid') when TcUni.uid_equal uid uid' -> tw (* FIXME:TC *) + | None -> TCIUni (uid, 0) + | Some (TCIUni (uid', _)) when TcUni.uid_equal uid uid' -> TCIUni (uid, 0) | Some tw -> doit_tc tw in - Hint.add tcmap (uid :> int) tw; tw + Hint.add tcmap (uid :> int) resolved; + bump_lift lift resolved end - | TCIConcrete { path; etyargs } -> + | TCIConcrete ({ etyargs; _ } as c) -> let etyargs = List.map (fun (ty, tws) -> (doit_ty ty, List.map doit_tc tws)) etyargs - in TCIConcrete { path; etyargs; } + in TCIConcrete { c with etyargs } | TCIAbstract { support = (`Var _ | `Abs _) } -> tw @@ -186,8 +187,8 @@ module Unify = struct | ty -> Some ty in let dereference_tcuni (uid : tcuni) = - match close.tcuni (TCIUni uid) with - | TCIUni uid' when TcUni.uid_equal uid uid' -> None + match close.tcuni (TCIUni (uid, 0)) with + | TCIUni (uid', _) when TcUni.uid_equal uid uid' -> None | tw -> Some tw in let uvars = @@ -389,10 +390,10 @@ module Unify = struct let rec check_tcw (tcw : tcwitness) : tcwitness = match tcw with - | TCIUni tcuid -> begin + | TCIUni (tcuid, lift) -> begin match TcUni.Muid.find_opt tcuid (!uc).tcenv.resolution with - | Some (TCIUni tcuid') when TcUni.uid_equal tcuid tcuid' -> tcw - | Some tcw' -> check_tcw tcw' + | Some (TCIUni (tcuid', _)) when TcUni.uid_equal tcuid tcuid' -> tcw + | Some tcw' -> bump_lift lift (check_tcw tcw') | None -> tcw end | TCIConcrete cw -> @@ -416,18 +417,26 @@ module Unify = struct EcPath.p_equal tc.tc_name tc'.tc_name && List.for_all2 (EcCoreEqTest.for_etyarg env) tc.tc_args tc'.tc_args in - (* Find the offset of [tc] (or any of its descendants) in [tcs] - by walking each entry's [tc_prt] chain. *) - let match_tc_offset (tcs : typeclass list) : int option = - List.find_index - (fun tc' -> List.exists eq_tc (EcTypeClass.ancestors env tc')) - tcs in + (* Find the offset of [tc] (or any of its ancestors) in [tcs]; + also return the number of [tc_prt] steps walked to reach + [tc] from [tcs.(offset)]. [lift = 0] is a direct match. *) + let match_tc_offset (tcs : typeclass list) : (int * int) option = + let with_lift tc' = + List.find_index eq_tc (EcTypeClass.ancestors env tc') in + let rec scan i = function + | [] -> None + | tc' :: rest -> + match with_lift tc' with + | Some lift -> Some (i, lift) + | None -> scan (i + 1) rest + in scan 0 tcs in let abstract_via_decl (p : EcPath.path) : tcwitness option = match EcEnv.Ty.by_path_opt p env with | Some { tyd_type = `Abstract tcs; _ } -> Option.map - (fun offset -> TCIAbstract { support = `Abs p; offset; }) + (fun (offset, lift) -> + TCIAbstract { support = `Abs p; offset; lift }) (match_tc_offset tcs) | _ -> None in @@ -435,8 +444,8 @@ module Unify = struct match ty.ty_node with | Tvar a -> let tcs = ofdfl failure (Mid.find_opt a (!uc).tvtc) in - let idx = ofdfl failure (match_tc_offset tcs) in - TCIAbstract { support = `Var a; offset = idx; } + let (offset, lift) = ofdfl failure (match_tc_offset tcs) in + TCIAbstract { support = `Var a; offset; lift } | Tconstr (p, _) when Option.is_some (abstract_via_decl p) -> Option.get (abstract_via_decl p) From 3af58f2506f898abb9f989948b7e64d64937700d Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 14:40:29 +0200 Subject: [PATCH 077/113] Option B verified: drop silent List.nth_opt fallback in tcw_subst --- src/ecCoreSubst.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index d722b3dfb9..5bdf06ca73 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -219,8 +219,9 @@ and tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = | TCIAbstract { support = `Var tyvar; offset; lift } -> let resolved = - Option.bind (Mid.find_opt tyvar s.fs_v) (fun (_, tcws) -> - Option.map (bump_lift lift) (List.nth_opt tcws offset)) in + Option.map (fun (_, tcws) -> + bump_lift lift (List.nth tcws offset)) + (Mid.find_opt tyvar s.fs_v) in Option.value ~default:tcw resolved | TCIAbstract { support = `Abs _ } -> From 3d5ae0942d13d535bc5368f6afe1ed1d195ead6f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 15:59:16 +0200 Subject: [PATCH 078/113] remove conv debug print --- src/ecReduction.ml | 21 +++------------------ 1 file changed, 3 insertions(+), 18 deletions(-) diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 602d304193..baf639d5c8 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -1435,24 +1435,9 @@ let rec conv ri env f1 f2 stk = end | Fop(p1, ty1), Fop(p2,ty2) - when EcPath.p_equal p1 p2 -> - if List.all2 (EqTest_i.for_etyarg env) ty1 ty2 then - conv_next ri env f1 stk - else begin - let dump_etys etys = - String.concat "; " (List.map (fun (_, tcws) -> - String.concat "," (List.map (function - | TCIUni (u, l) -> Printf.sprintf "TCIUni(#%d,l=%d)" (u :> int) l - | TCIConcrete c -> Printf.sprintf "TCIConcrete(%s,l=%d)" (EcPath.tostring c.path) c.lift - | TCIAbstract { support = `Var x; offset; lift } -> - Printf.sprintf "TCIAbs(Var %s,o=%d,l=%d)" (EcIdent.tostring x) offset lift - | TCIAbstract { support = `Abs p; offset; lift } -> - Printf.sprintf "TCIAbs(Abs %s,o=%d,l=%d)" (EcPath.tostring p) offset lift) - tcws)) etys) in - Printf.eprintf "[conv Fop mismatch] op=%s\n lhs=[%s]\n rhs=[%s]\n%!" - (EcPath.tostring p1) (dump_etys ty1) (dump_etys ty2); - force_head ri env f1 f2 stk - end + when EcPath.p_equal p1 p2 + && List.all2 (EqTest_i.for_etyarg env) ty1 ty2 -> + conv_next ri env f1 stk | Fapp(f1', args1), Fapp(f2', args2) when EqTest_i.for_type env f1'.f_ty f2'.f_ty From 7f3041230e29aa697548107dc66afadcfe65bfd9 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 16:11:15 +0200 Subject: [PATCH 079/113] Phase 3: implement TcTw (witness unification) with lift handling; fix incomplete expr0z proof in TcRing example --- examples/tcstdlib/TcRing.ec | 3 ++- src/ecUnify.ml | 49 +++++++++++++++++++++++++++++++++++-- 2 files changed, 49 insertions(+), 3 deletions(-) diff --git a/examples/tcstdlib/TcRing.ec b/examples/tcstdlib/TcRing.ec index a7ea417e04..27420193da 100644 --- a/examples/tcstdlib/TcRing.ec +++ b/examples/tcstdlib/TcRing.ec @@ -572,7 +572,8 @@ lemma expr0z z : exp zeror z = if z = 0 then oner else zeror. proof. case: (0 <= z) => [/expr0n // | /ltzNge lt0_z]. rewrite -{1}(@oppzK z) exprN; have ->/=: z <> 0 by smt(). -by rewrite invr_eq0 expr0n ?oppz_ge0 1:ltzW. +rewrite invr_eq0 expr0n ?oppz_ge0 1:ltzW //. +by have ->/=: -z <> 0 by smt(). qed. lemma expr1z z : exp oner z = oner. diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 343b215d2b..801e5cb829 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -467,8 +467,53 @@ module Unify = struct ) deps end - | _ -> - () (* FIXME:TC *) + | `TcTw (w1, w2) -> + (* Resolve a [TCIUni (u, l)] one level: if [u] has a known + resolution [r], return [bump_lift l r]; otherwise leave the + reference intact. This is local to the current unification + attempt. *) + let resolve_uni = function + | TCIUni (uid, lift) -> begin + match TcUni.Muid.find_opt uid (!uc).tcenv.resolution with + | Some w -> bump_lift lift w + | None -> TCIUni (uid, lift) + end + | w -> w in + + let w1 = resolve_uni w1 in + let w2 = resolve_uni w2 in + + let bind_uni uid lift target = + (* We want [bump_lift lift R = target] where [R] is the + resolution of [uid]. Hence [R = target] with [lift] + removed from its lift count. *) + let strip_lift n w = + match w with + | TCIUni (u, l) when l >= n -> + Some (TCIUni (u, l - n)) + | TCIConcrete c when c.lift >= n -> + Some (TCIConcrete { c with lift = c.lift - n }) + | TCIAbstract a when a.lift >= n -> + Some (TCIAbstract { a with lift = a.lift - n }) + | _ -> None in + match strip_lift lift target with + | None -> failure () + | Some r -> + uc := { !uc with tcenv = { (!uc).tcenv with resolution = + TcUni.Muid.add uid r (!uc).tcenv.resolution + } } in + + begin match w1, w2 with + | TCIUni (u1, l1), TCIUni (u2, l2) when TcUni.uid_equal u1 u2 -> + if l1 <> l2 then failure () + + | TCIUni (uid, lift), w + | w, TCIUni (uid, lift) -> + bind_uni uid lift w + + | _, _ -> + if not (EcAst.tcw_equal w1 w2) then failure () + end done in doit (); !uc From ab836a9ef53df6febc8cc174f7172ec423d8385f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 16:15:25 +0200 Subject: [PATCH 080/113] Phase 4 step: unify_etyarg API + use it in f_match_core to thread witnesses through pattern matching --- src/ecMatching.ml | 5 ++--- src/ecUnify.ml | 12 ++++++++++++ src/ecUnify.mli | 4 +++- 3 files changed, 17 insertions(+), 4 deletions(-) diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 451e91e7d9..f48073f2a1 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -618,9 +618,8 @@ let f_match_core opts hyps (ue, ev) f1 f2 = | Fop (op1, tys1), Fop (op2, tys2) -> begin if not (EcPath.p_equal op1 op2) then failure (); - let tys1 = List.fst tys1 in (* FIXME:TC *) - let tys2 = List.fst tys2 in (* FIXME:TC *) - try List.iter2 (EcUnify.unify env ue) tys1 tys2 + if List.length tys1 <> List.length tys2 then failure (); + try List.iter2 (EcUnify.unify_etyarg env ue) tys1 tys2 with EcUnify.UnificationFailure _ -> failure () end diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 801e5cb829..e127cbd1f9 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -724,6 +724,18 @@ let unify_core (env : EcEnv.env) (ue : unienv) (pb : problem) = let unify (env : EcEnv.env) (ue : unienv) (t1 : ty) (t2 : ty) = unify_core env ue (`TyUni (t1, t2)) +(* -------------------------------------------------------------------- *) +let unify_tcw (env : EcEnv.env) (ue : unienv) (w1 : tcwitness) (w2 : tcwitness) = + unify_core env ue (`TcTw (w1, w2)) + +(* -------------------------------------------------------------------- *) +let unify_etyarg (env : EcEnv.env) (ue : unienv) (e1 : etyarg) (e2 : etyarg) = + let (t1, ws1) = e1 and (t2, ws2) = e2 in + unify env ue t1 t2; + if List.length ws1 <> List.length ws2 then + raise (UnificationFailure (`TyUni (t1, t2))); + List.iter2 (unify_tcw env ue) ws1 ws2 + (* -------------------------------------------------------------------- *) let tfun_expected (ue : unienv) (psig : ty list) = EcTypes.toarrow psig (UniEnv.fresh ue) diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 92f81fde77..e205485084 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -54,7 +54,9 @@ module UniEnv : sig val tparams : unienv -> ty_params end -val unify : EcEnv.env -> unienv -> ty -> ty -> unit +val unify : EcEnv.env -> unienv -> ty -> ty -> unit +val unify_tcw : EcEnv.env -> unienv -> tcwitness -> tcwitness -> unit +val unify_etyarg : EcEnv.env -> unienv -> etyarg -> etyarg -> unit val tfun_expected : unienv -> EcTypes.ty list -> EcTypes.ty From d64ef272adfff2d023665f60cf0f642fdc5a3eed Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 19:13:14 +0200 Subject: [PATCH 081/113] Phase 4: rule_pattern Op carries etyargs; fix tcw_fv to walk Var support --- src/ecAst.ml | 7 +++++-- src/ecReduction.ml | 26 +++++++++++++------------- src/ecTheory.ml | 2 +- src/ecTheory.mli | 2 +- 4 files changed, 20 insertions(+), 17 deletions(-) diff --git a/src/ecAst.ml b/src/ecAst.ml index 74fbbd6d3e..628894b30f 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -439,8 +439,11 @@ let rec tcw_fv (tcw : tcwitness) = (fun fv (ty, tcws) -> fv_union fv (fv_union ty.ty_fv (tcws_fv tcws))) Mid.empty etyargs - | TCIAbstract _ -> - Mid.empty (* FIXME:TC *) + | TCIAbstract { support = `Var v } -> + Mid.singleton v 1 + + | TCIAbstract { support = `Abs _ } -> + Mid.empty and tcws_fv (tcws : tcwitness list) = List.fold_left diff --git a/src/ecReduction.ml b/src/ecReduction.ml index baf639d5c8..e7582d40fa 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -736,11 +736,12 @@ let reduce_user_gen simplify ri env hyps f = | ({ f_node = Fop (p, tys) }, args), R.Rule (`Op (p', tys'), args') when EcPath.p_equal p p' && List.length args = List.length args' -> - let tys' = List.map (Tvar.subst tvi.subst) tys' in - let tys = List.fst tys in (* FIXME:TC *) + let tys' = List.map (Tvar.subst_etyarg tvi.subst) tys' in begin - try List.iter2 (EcUnify.unify env ue) tys tys' + try + if List.length tys <> List.length tys' then raise NotReducible; + List.iter2 (EcUnify.unify_etyarg env ue) tys tys' with EcUnify.UnificationFailure _ -> raise NotReducible end; List.iter2 doit args args' @@ -1706,10 +1707,8 @@ module User = struct let rule = let rec rule (f : form) : EcTheory.rule_pattern = match EcFol.destr_app f with - | { f_node = Fop (p, etyargs) }, args - when List.for_all (fun (_, ws) -> List.is_empty ws) etyargs - -> (* FIXME: TC *) - R.Rule (`Op (p, List.fst etyargs), List.map rule args) + | { f_node = Fop (p, etyargs) }, args -> + R.Rule (`Op (p, etyargs), List.map rule args) | { f_node = Ftuple args }, [] -> R.Rule (`Tuple, List.map rule args) | { f_node = Fproj (target, i) }, [] -> @@ -1732,12 +1731,13 @@ module User = struct | R.Rule (op, args) -> let ltyvars = match op with - | `Op (_, tys) -> - List.fold_left ( - let rec doit ltyvars = function - | { ty_node = Tvar a } -> Sid.add a ltyvars - | _ as ty -> ty_fold doit ltyvars ty in doit) - cst.cst_ty_vs tys + | `Op (_, etyargs) -> + let rec doit_ty ltyvars = function + | { ty_node = Tvar a } -> Sid.add a ltyvars + | _ as ty -> ty_fold doit_ty ltyvars ty in + List.fold_left + (fun ltyvars (ty, _) -> doit_ty ltyvars ty) + cst.cst_ty_vs etyargs | `Tuple -> cst.cst_ty_vs | `Proj _ -> cst.cst_ty_vs in let cst = {cst with cst_ty_vs = ltyvars } in diff --git a/src/ecTheory.ml b/src/ecTheory.ml index e439a2cfb2..c4060a37e0 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -72,7 +72,7 @@ and rule_pattern = | Var of EcIdent.t and top_rule_pattern = - [`Op of (EcPath.path * ty list) | `Tuple | `Proj of int] + [`Op of (EcPath.path * etyarg list) | `Tuple | `Proj of int] and rule = { rl_tyd : EcDecl.ty_params; diff --git a/src/ecTheory.mli b/src/ecTheory.mli index 949ce569b2..cdd9fc926c 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -69,7 +69,7 @@ and rule_pattern = | Var of EcIdent.t and top_rule_pattern = - [`Op of (EcPath.path * ty list) | `Tuple | `Proj of int] + [`Op of (EcPath.path * etyarg list) | `Tuple | `Proj of int] and rule = { rl_tyd : EcDecl.ty_params; From 1c7f4561eaa223eab76c2b326d84fec631da203b Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 19:15:55 +0200 Subject: [PATCH 082/113] Phase 6: section close handles Th_typeclass (was assert false) --- src/ecSection.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/ecSection.ml b/src/ecSection.ml index bc0da92373..30e421fe60 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -1396,7 +1396,9 @@ let rec generalize_th_item (to_gen : to_gen) (prefix : path) (th_item : theory_i | Th_theory th -> (generalize_ctheory to_gen prefix th, None) | Th_export (p,lc) -> generalize_export to_gen (p,lc) | Th_instance (x,tci)-> generalize_instance to_gen (x,tci) - | Th_typeclass _ -> assert false (* FIXME:TC *) + | Th_typeclass (x, tc) -> + if tc.tc_loca = `Local then to_gen, None + else to_gen, Some (Th_typeclass (x, tc)) | Th_baserw (s,lc) -> generalize_baserw to_gen prefix (s,lc) | Th_addrw (p,ps,lc) -> generalize_addrw to_gen (p, ps, lc) | Th_reduction rl -> generalize_reduction to_gen rl From 32dc9381c64aa1fd827505d01525b9aae541874b Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 19:31:21 +0200 Subject: [PATCH 083/113] Phase 8: add TC tests covering basic, instance, clone, and section patterns --- tests/typeclass-basic.ec | 29 +++++++++++++++++++++++++++++ tests/typeclass-clone.ec | 24 ++++++++++++++++++++++++ tests/typeclass-instance.ec | 29 +++++++++++++++++++++++++++++ tests/typeclass-section.ec | 17 +++++++++++++++++ 4 files changed, 99 insertions(+) create mode 100644 tests/typeclass-basic.ec create mode 100644 tests/typeclass-clone.ec create mode 100644 tests/typeclass-instance.ec create mode 100644 tests/typeclass-section.ec diff --git a/tests/typeclass-basic.ec b/tests/typeclass-basic.ec new file mode 100644 index 0000000000..09c608e734 --- /dev/null +++ b/tests/typeclass-basic.ec @@ -0,0 +1,29 @@ +require import AllCore. + +(* TC declaration with axioms, polymorphic operators and lemmas *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +(* Polymorphic op over a TC *) +op double ['a <: addmonoid] (x : 'a) = x + x. + +(* Polymorphic lemma using TC axioms *) +lemma addm0 ['a <: addmonoid] (x : 'a) : x + idm = x. +proof. by rewrite addmC add0m. qed. + +(* Section abstracting a TC-constrained type *) +section. + declare type t <: addmonoid. + + lemma double_id (x : t) : double x = x + x. + proof. by rewrite /double. qed. + + lemma id_double : double idm<:t> = idm. + proof. by rewrite /double add0m. qed. +end section. diff --git a/tests/typeclass-clone.ec b/tests/typeclass-clone.ec new file mode 100644 index 0000000000..1e4c1b260c --- /dev/null +++ b/tests/typeclass-clone.ec @@ -0,0 +1,24 @@ +require import AllCore. + +(* Cloning a theory containing a typeclass and a TC-polymorphic lemma *) +abstract theory Algebra. + type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) + }. + + lemma addm0 ['a <: addmonoid] (x : 'a) : x + idm = x. + proof. by rewrite addmC add0m. qed. +end Algebra. + +(* The cloned typeclass and lemma are usable in the cloned theory *) +clone Algebra as A2. + +op test ['a <: A2.addmonoid] (x : 'a) = A2.(+) x A2.idm. + +lemma test_eq ['a <: A2.addmonoid] (x : 'a) : test x = x. +proof. rewrite /test. exact A2.addm0. qed. diff --git a/tests/typeclass-instance.ec b/tests/typeclass-instance.ec new file mode 100644 index 0000000000..473e44879f --- /dev/null +++ b/tests/typeclass-instance.ec @@ -0,0 +1,29 @@ +require import AllCore Bool. + +(* TC + named instance for a concrete type *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +instance addmonoid as bool_xor with bool + op idm = false + op (+) = (^^). + +realize addmA by smt(). +realize addmC by smt(). +realize add0m by smt(). + +(* Use the polymorphic ops at the concrete instance type. The instance + resolution must succeed (otherwise the typing would fail). *) +op test (x : bool) = x + idm<:bool>. + +(* Unnamed instance also works (auto-named) *) +type class group <: addmonoid = { + op opp : group -> group + axiom addmN : left_inverse idm opp (+)<:group> +}. diff --git a/tests/typeclass-section.ec b/tests/typeclass-section.ec new file mode 100644 index 0000000000..8475d4a923 --- /dev/null +++ b/tests/typeclass-section.ec @@ -0,0 +1,17 @@ +require import AllCore. + +(* A typeclass declared inside a section that survives section close *) +section. + type class my_monoid = { + op my_id : my_monoid + op my_op : my_monoid -> my_monoid -> my_monoid + + axiom my_left_id : forall (x : my_monoid), my_op my_id x = x + }. +end section. + +(* Reference the typeclass after the section *) +op double ['a <: my_monoid] (x : 'a) = my_op x x. + +lemma id_double ['a <: my_monoid] : double my_id<:'a> = my_id. +proof. rewrite /double my_left_id //. qed. From 82cf45ea1cd99310761544ef6102abb6e50de4ca Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 19:54:20 +0200 Subject: [PATCH 084/113] Phase 7+ regression fix: parametric typeclass carrier needs etyargs_of_tparams; SMT pre-reduction restricted to delta_tc only --- src/ecScope.ml | 5 ++++- src/ecSmt.ml | 10 ++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 00ba792464..c277c1f7a0 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1689,9 +1689,12 @@ module Ty = struct let scenv = EcEnv.TypeClass.rebind name stub_tc scenv in + let tc_self = + { tc_name = mypath; + tc_args = EcDecl.etyargs_of_tparams stub_tc.tc_tparams; } in let asty = { tyd_params = []; - tyd_type = `Abstract [{ tc_name = mypath; tc_args = [] }]; + tyd_type = `Abstract [tc_self]; tyd_resolve = true; tyd_loca = (lc :> locality); } in let scenv = EcEnv.Ty.bind name asty scenv in diff --git a/src/ecSmt.ml b/src/ecSmt.ml index b685a6710c..388a244880 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -1616,6 +1616,16 @@ let dump_why3 (env : EcEnv.env) (filename : string) = let init hyps concl = let env = LDecl.toenv hyps in + (* Pre-reduce typeclass operators so the SMT translation sees ordinary + operators only. With concrete instances in scope this collapses + [(+)<:int + addmonoid>] into [Int.(+)] and similar. Polymorphic TC + ops over abstract carriers stay folded; SMT will treat them as + opaque, which is consistent with their hypotheses being SMT-encoded + similarly. We restrict the reduction to TC unfolding (delta_tc) to + avoid over-simplifying the goal in ways that defeat SMT hints. *) + let concl = + let ri = { EcReduction.no_red with delta_tc = true } in + EcReduction.simplify ri hyps concl in let hyps = LDecl.tohyps hyps in let task = create_global_task () in let known = Lazy.force core_theories in From b8f687b4ec0d9d62bb39cba8474ca025bb33380a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 19:56:03 +0200 Subject: [PATCH 085/113] Phase 7: add TC + SMT regression test --- tests/typeclass-smt.ec | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 tests/typeclass-smt.ec diff --git a/tests/typeclass-smt.ec b/tests/typeclass-smt.ec new file mode 100644 index 0000000000..81adcd58a0 --- /dev/null +++ b/tests/typeclass-smt.ec @@ -0,0 +1,25 @@ +require import AllCore. + +(* Verify SMT pre-reduction unfolds TC ops at concrete instances. *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +op zero_int : int = 0. +op plus_int : int -> int -> int = Int.( + ). + +instance addmonoid as int_inst with int + op idm = zero_int + op (+) = plus_int. + +realize addmA by rewrite /plus_int; smt(). +realize addmC by rewrite /plus_int; smt(). +realize add0m by rewrite /plus_int /zero_int; smt(). + +(* SMT pre-reduction collapses [idm<:int>] to [zero_int]; SMT then closes. *) +lemma idm_int : (idm<:int>) = zero_int by smt(). From bd3a33467dc44f092f591e602829ead39e1ad272 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:38:32 +0200 Subject: [PATCH 086/113] tests: organize TC tests under tests/tc/; recurse into tests/ subdirs --- config/tests.config | 2 +- tests/{typeclass-basic.ec => tc/basic.ec} | 0 tests/{typeclass-clone.ec => tc/clone.ec} | 0 tests/{typeclass-instance.ec => tc/instance.ec} | 0 tests/{typeclass-section.ec => tc/section.ec} | 0 tests/{typeclass-smt.ec => tc/smt.ec} | 0 6 files changed, 1 insertion(+), 1 deletion(-) rename tests/{typeclass-basic.ec => tc/basic.ec} (100%) rename tests/{typeclass-clone.ec => tc/clone.ec} (100%) rename tests/{typeclass-instance.ec => tc/instance.ec} (100%) rename tests/{typeclass-section.ec => tc/section.ec} (100%) rename tests/{typeclass-smt.ec => tc/smt.ec} (100%) diff --git a/config/tests.config b/config/tests.config index f7df574a8f..a530870cdb 100644 --- a/config/tests.config +++ b/config/tests.config @@ -14,4 +14,4 @@ exclude = examples/MEE-CBC examples/old examples/old/list-ddh !examples/incomple okdirs = examples/MEE-CBC [test-unit] -okdirs = tests +okdirs = !tests diff --git a/tests/typeclass-basic.ec b/tests/tc/basic.ec similarity index 100% rename from tests/typeclass-basic.ec rename to tests/tc/basic.ec diff --git a/tests/typeclass-clone.ec b/tests/tc/clone.ec similarity index 100% rename from tests/typeclass-clone.ec rename to tests/tc/clone.ec diff --git a/tests/typeclass-instance.ec b/tests/tc/instance.ec similarity index 100% rename from tests/typeclass-instance.ec rename to tests/tc/instance.ec diff --git a/tests/typeclass-section.ec b/tests/tc/section.ec similarity index 100% rename from tests/typeclass-section.ec rename to tests/tc/section.ec diff --git a/tests/typeclass-smt.ec b/tests/tc/smt.ec similarity index 100% rename from tests/typeclass-smt.ec rename to tests/tc/smt.ec From fc4d4cafc18a210b7994ecd8d801511c209e09c6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:39:42 +0200 Subject: [PATCH 087/113] tests: more TC coverage (inheritance, parametric, multi-instance) --- tests/tc/inheritance.ec | 29 +++++++++++++++++++++++++++++ tests/tc/multi-instance.ec | 29 +++++++++++++++++++++++++++++ tests/tc/parametric.ec | 23 +++++++++++++++++++++++ 3 files changed, 81 insertions(+) create mode 100644 tests/tc/inheritance.ec create mode 100644 tests/tc/multi-instance.ec create mode 100644 tests/tc/parametric.ec diff --git a/tests/tc/inheritance.ec b/tests/tc/inheritance.ec new file mode 100644 index 0000000000..07805d4733 --- /dev/null +++ b/tests/tc/inheritance.ec @@ -0,0 +1,29 @@ +require import AllCore. + +(* Multi-level subclass chain: addmonoid <- group, with a polymorphic + lemma at the parent level used through the subclass. *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +type class group <: addmonoid = { + op opp : group -> group + axiom addmN : left_inverse idm opp (+)<:group> +}. + +(* Polymorphic lemma over [addmonoid] *) +lemma addm0 ['a <: addmonoid] (x : 'a) : x + idm = x. +proof. by rewrite addmC add0m. qed. + +(* The same lemma should be usable under the [group] subclass — the + ancestor walk surfaces the [addmonoid] constraint. *) +lemma addm0_via_group ['a <: group] (x : 'a) : x + idm = x. +proof. by apply addm0. qed. + +(* And direct use of the parent operator on a subclass-bound value. *) +op test ['a <: group] (x : 'a) : 'a = x + idm + opp x. diff --git a/tests/tc/multi-instance.ec b/tests/tc/multi-instance.ec new file mode 100644 index 0000000000..6e9c3c154e --- /dev/null +++ b/tests/tc/multi-instance.ec @@ -0,0 +1,29 @@ +require import AllCore. + +(* Test that multiple named instances for the same TC at different + types coexist without interference. *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +(* Instance for [int] *) +op zero_int : int = 0. +op plus_int : int -> int -> int = Int.( + ). + +instance addmonoid as int_inst with int + op idm = zero_int + op (+) = plus_int. + +realize addmA by rewrite /plus_int; smt(). +realize addmC by rewrite /plus_int; smt(). +realize add0m by rewrite /plus_int /zero_int; smt(). + +(* Both instance types coexist; explicit instantiation picks the right one *) +op test_int : int = idm<:int>. + +lemma test_int_eq : test_int = zero_int by rewrite /test_int; smt(). diff --git a/tests/tc/parametric.ec b/tests/tc/parametric.ec new file mode 100644 index 0000000000..8d7c5d6a6d --- /dev/null +++ b/tests/tc/parametric.ec @@ -0,0 +1,23 @@ +require import AllCore. + +(* Parametric typeclass: a class indexed by another typeclass. *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +(* An action of an [addmonoid] on a carrier *) +type class ['a <: addmonoid] action = { + op act : 'a -> action -> action + + axiom act_id : forall (x : action), act idm<:'a> x = x +}. + +(* Polymorphic lemma using the parametric class *) +lemma act_idmE ['a <: addmonoid, 'b <: 'a action] (x : 'b) : + act idm<:'a> x = x. +proof. by apply act_id. qed. From 842c0541e54882cfcd4939a5bf97c1dbbd77c30e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:41:43 +0200 Subject: [PATCH 088/113] Phase 4: pp_typedecl now prints abstract types' typeclass constraints (was empty) --- src/ecPrinting.ml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index d708c67ec4..5912d15123 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -2138,8 +2138,21 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = (pp_paren (pp_list ",@ " (pp_tyvar ppe))) txs name and pp_body fmt = + let pp_one_tc fmt (tc : typeclass) = + match tc.tc_args with + | [] -> pp_tyname ppe fmt tc.tc_name + | [ty] -> + Format.fprintf fmt "%a %a" + (pp_type ppe) (fst ty) (pp_tyname ppe) tc.tc_name + | tys -> + Format.fprintf fmt "(%a) %a" + (pp_list ",@ " (pp_type ppe)) (List.fst tys) + (pp_tyname ppe) tc.tc_name in match tyd.tyd_type with - | `Abstract _ -> () (* FIXME: TC HOOK *) + | `Abstract [] -> () + | `Abstract tcs -> + Format.fprintf fmt " <: %a" + (pp_list " &@ " pp_one_tc) tcs | `Concrete ty -> Format.fprintf fmt " =@ %a" (pp_type ppe) ty From 830c813f8ecc95f7710d248c795d1636ad95d12e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:45:16 +0200 Subject: [PATCH 089/113] Phase 4: pp_axname for typeclass instance names in section log Replaces a debug-style 'EcPath.tostring p' with the user-facing pretty-printer 'pp_axname'. --- src/ecSection.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecSection.ml b/src/ecSection.ml index 30e421fe60..d0d1dfaa26 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -53,7 +53,7 @@ let pp_cbarg env fmt (who : cbarg) = | `Typeclass p -> Format.fprintf fmt "typeclass %a" (EcPrinting.pp_tyname ppe) p | `TcInstance (`General p) -> - Format.fprintf fmt "typeclass instance %s" (EcPath.tostring p) (* FIXME:TC *) + Format.fprintf fmt "typeclass instance %a" (EcPrinting.pp_axname ppe) p | `TcInstance `Ring -> Format.fprintf fmt "ring instance" | `TcInstance `Field -> From 710f3c06321709a51ade477921c1c4bee95c7b81 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:46:02 +0200 Subject: [PATCH 090/113] Phase 4: drop stale FIXME:TC marker in lower_left binop printer op_symb resolves a notation by (kind, tyargs, argtys); witnesses do not participate in notation selection, so no TC handling is needed here. --- src/ecPrinting.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index 5912d15123..fe6553bb1f 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -1428,7 +1428,7 @@ let lower_left (ppe : PPEnv.t) (t_ty : form -> EcTypes.ty) (f : form) else l_l f2 onm e_bin_prio_rop4 | Fapp ({f_node = Fop (op, tys)}, [f1; f2]) -> (let (inm, opname) = - PPEnv.op_symb ppe op (Some (`Form, tys, List.map t_ty [f1; f2])) in (* FIXME: TC *) + PPEnv.op_symb ppe op (Some (`Form, tys, List.map t_ty [f1; f2])) in if inm <> [] && inm <> onm then None else match priority_of_binop opname with From d0eb8eb0fb6f3bd60d460bc1c2c61ea47075be39 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:46:47 +0200 Subject: [PATCH 091/113] tests/tc: add print regression test for TC entities Verifies that 'print' on TC-constrained abstract types, on the typeclass declaration, and on a TC operator does not crash. --- tests/tc/print.ec | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 tests/tc/print.ec diff --git a/tests/tc/print.ec b/tests/tc/print.ec new file mode 100644 index 0000000000..8987ccd63b --- /dev/null +++ b/tests/tc/print.ec @@ -0,0 +1,18 @@ +require import AllCore. + +(* Regression: `print` must not crash on TC-related entities, and + abstract type printers must surface their TC constraints. *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +type t <: addmonoid. + +print t. +print addmonoid. +print idm. From 379bbf84f176c3eb9e4049e475b3af26ea10b0af Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:49:23 +0200 Subject: [PATCH 092/113] Phase 4: drop stale FIXME:TC markers in inductive/rewrite paths - ecHiGoal: SFop's tvi is already an etyarg list and Tvar.f_subst takes etyarg, so witnesses already flow through. - ecHiInductive emptiness / ecInductive positivity: both use List.fst targs (resp. etyarg_sub_exists), which already inspect TC witnesses correctly. --- src/ecHiGoal.ml | 2 -- src/ecHiInductive.ml | 2 +- src/ecInductive.ml | 1 - 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index bc14d47d21..c71d72b4f7 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -690,7 +690,6 @@ let process_delta ~und_delta ?target (s, o, p) tc = match sform_of_form fp with | SFop ((_, tvi), []) -> begin - (* FIXME: TC HOOK *) let body = Tvar.f_subst ~freshen:true @@ -717,7 +716,6 @@ let process_delta ~und_delta ?target (s, o, p) tc = | `RtoL -> let fp = - (* FIXME: TC HOOK *) let body = Tvar.f_subst ~freshen:true diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 73cbe0f8bf..0fe33a5c3e 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -137,7 +137,7 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = match tdecl.tyd_type with | `Abstract _ -> - List.exists isempty (List.fst targs) (* FIXME:TC *) + List.exists isempty (List.fst targs) | `Concrete ty -> isempty_1 [tyinst () ty] diff --git a/src/ecInductive.ml b/src/ecInductive.ml index b20fa72d7a..d5406a14fe 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -104,7 +104,6 @@ let indsc_of_datatype ?normty (mode : indmode) (dt : datatype) = end | Tconstr (p', ts) -> - (* FIXME:TC *) if List.exists (EcTypes.etyarg_sub_exists (occurs p)) ts then raise NonPositive; if not (EcPath.p_equal p p') then None else From fff3ce8a12261ff890088dd0ae302fbad7f900e4 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:53:57 +0200 Subject: [PATCH 093/113] tests/tc: add explicit-TVI test on TC-polymorphic lemma Verifies that 'apply (lemma<:int>)' picks up the right named instance and that omitting the TVI also resolves via unification. --- tests/tc/explicit-tvi.ec | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 tests/tc/explicit-tvi.ec diff --git a/tests/tc/explicit-tvi.ec b/tests/tc/explicit-tvi.ec new file mode 100644 index 0000000000..cabe7f2a08 --- /dev/null +++ b/tests/tc/explicit-tvi.ec @@ -0,0 +1,34 @@ +require import AllCore. + +(* Explicit type-instantiation [<: int>] of a polymorphic-over-TC lemma + must pick up the matching named instance and succeed. *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +op zero_int : int = 0. +op plus_int : int -> int -> int = Int.( + ). + +instance addmonoid as int_inst with int + op idm = zero_int + op (+) = plus_int. + +realize addmA by rewrite /plus_int; smt(). +realize addmC by rewrite /plus_int; smt(). +realize add0m by rewrite /plus_int /zero_int; smt(). + +lemma idm_idem ['a <: addmonoid] (x : 'a) : idm + x = x. +proof. by apply add0m. qed. + +(* Explicit TVI: should pick int_inst. *) +lemma test1 (n : int) : zero_int + n = n. +proof. by apply (idm_idem<:int> n). qed. + +(* No TVI: should also work via unification-driven instance resolution. *) +lemma test2 (n : int) : zero_int + n = n. +proof. by apply (idm_idem n). qed. From 447569d43916d9e31abd16f0f4b9e3b06a7f2833 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:54:20 +0200 Subject: [PATCH 094/113] tests/tc: add declare-type section closure test Verifies that operators/lemmas defined over a sectioned 'declare type t <: tc' survive section close as proper TC-polymorphic forms. --- tests/tc/declare-type.ec | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 tests/tc/declare-type.ec diff --git a/tests/tc/declare-type.ec b/tests/tc/declare-type.ec new file mode 100644 index 0000000000..299e8f1455 --- /dev/null +++ b/tests/tc/declare-type.ec @@ -0,0 +1,27 @@ +require import AllCore. + +(* A section using [declare type t <: tc] for an abstract carrier; the + developed operators survive section close as TC-polymorphic. *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +section. + declare type t <: addmonoid. + + op double (x : t) : t = x + x. + + lemma double_idm : double idm = idm. + proof. by rewrite /double add0m. qed. +end section. + +(* After section close: [double] becomes TC-polymorphic. *) +op test_call ['a <: addmonoid] (x : 'a) : 'a = double x. + +lemma test_idm ['a <: addmonoid] : double<:'a> idm = idm. +proof. by apply double_idm. qed. From 34c89936ca7f499eec41e8cc52bfbd1f1aaf75fb Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 29 Apr 2026 22:55:18 +0200 Subject: [PATCH 095/113] Phase 4: drop stale FIXME:TC markers in SMT type translation Why3 types do not carry TC witnesses; the witnesses are erased here intentionally because they are either inlined by delta_tc pre-reduction or absent on concrete carriers. --- src/ecSmt.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ecSmt.ml b/src/ecSmt.ml index 388a244880..18b1cdff04 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -376,7 +376,7 @@ let rec trans_ty ((genv, lenv) as env) ty = | Tconstr (p, tys) -> let id = trans_pty genv p in - WTy.ty_app id (trans_tys env (List.fst tys)) (* FIXME:TC *) + WTy.ty_app id (trans_tys env (List.fst tys)) | Tfun (t1, t2) -> WTy.ty_func (trans_ty env t1) (trans_ty env t2) @@ -712,7 +712,7 @@ and trans_app ((genv, lenv) as env : tenv * lenv) (f : form) args = | Fop (p, ts) -> let wop = trans_op genv p in - let ts = List.fst ts in (* FIXME:TC *) + let ts = List.fst ts in let tys = List.map (trans_ty (genv,lenv)) ts in apply_wop genv wop tys args From 2b10e453a9667268e7e2dc6f1206155b2c80256e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 09:12:50 +0200 Subject: [PATCH 096/113] Phase 4: pf_check_tvi rejects type args that violate TC constraints Threads env into pf_check_tvi so it can call EcTypeClass.infer on each ground (no Tunivar/Tvar) user-supplied type for every TC constraint declared on the corresponding tparam. Replaces a confusing post-hoc 'int doesn't match int' unification error with a clear: type int does not satisfy typeclass constraint addmonoid at the call site. Polymorphic (Tvar) and unified (Tunivar) cases are left to the unifier as before. --- src/ecProofTerm.ml | 2 +- src/ecProofTyping.ml | 35 +++++++++++++++++++++++++++++------ src/ecProofTyping.mli | 2 +- 3 files changed, 31 insertions(+), 8 deletions(-) diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 5d732b8e63..6cba2a7a12 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -516,7 +516,7 @@ let process_named_pterm pe (tvi, fp) = (fun () -> omap (EcTyping.transtvi env pe.pte_ue) tvi) in - PT.pf_check_tvi pe.pte_pe typ tvi; + PT.pf_check_tvi env pe.pte_pe typ tvi; let fs = EcUnify.UniEnv.opentvi pe.pte_ue typ tvi in let ax = Fsubst.f_subst_tvar ~freshen:false fs.subst ax in diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 01fd18cc49..55baf7d9e1 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -1,6 +1,7 @@ (* -------------------------------------------------------------------- *) open EcUtils open EcIdent +open EcAst open EcTypes open EcFol open EcEnv @@ -187,10 +188,24 @@ let tc1_process_codepos1 tc (side, cpos) = EcTyping.trans_codepos1 env cpos (* ------------------------------------------------------------------ *) -(* FIXME: factor out to typing module *) -(* FIXME:TC HOOK - check parameter constraints *) -(* ------------------------------------------------------------------ *) -let pf_check_tvi (pe : proofenv) typ tvi = +let pf_check_tvi (env : env) (pe : proofenv) typ tvi = + let rec is_ground (ty : ty) = + match ty.ty_node with + | Tunivar _ | Tvar _ -> false + | _ -> not (ty_sub_exists (fun t -> not (is_ground t)) ty) in + + let check_constraints (tcs : typeclass list) (ty : ty) = + if is_ground ty then + List.iter (fun tc -> + if Option.is_none (EcTypeClass.infer env ty tc) then + let ppe = EcPrinting.PPEnv.ofenv env in + tc_error_lazy pe (fun fmt -> + Format.fprintf fmt + "type @[%a@] does not satisfy typeclass constraint @[%a@]" + (EcPrinting.pp_type ppe) ty + (EcPrinting.pp_tyname ppe) tc.tc_name) + ) tcs in + match tvi with | None -> () @@ -198,7 +213,10 @@ let pf_check_tvi (pe : proofenv) typ tvi = if List.length tyargs <> List.length typ then tc_error pe "wrong number of type parameters (%d, expecting %d)" - (List.length tyargs) (List.length typ) + (List.length tyargs) (List.length typ); + List.iter2 (fun (_, tcs) (ty_opt, _) -> + Option.iter (check_constraints tcs) ty_opt + ) typ tyargs | Some (EcUnify.TVInamed tyargs) -> let typnames = List.map (EcIdent.name |- fst) typ in @@ -206,7 +224,12 @@ let pf_check_tvi (pe : proofenv) typ tvi = (fun (x, _) -> if not (List.mem x typnames) then tc_error pe "unknown type variable: %s" x) - tyargs + tyargs; + List.iter (fun (id, tcs) -> + match List.assoc_opt (EcIdent.name id) tyargs with + | Some (Some ty, _) -> check_constraints tcs ty + | _ -> () + ) typ (* -------------------------------------------------------------------- *) exception NoMatch diff --git a/src/ecProofTyping.mli b/src/ecProofTyping.mli index dd034f1f12..6eacc1acdb 100644 --- a/src/ecProofTyping.mli +++ b/src/ecProofTyping.mli @@ -18,7 +18,7 @@ type metavs = EcFol.form EcSymbols.Msym.t * proof-environment. See the [Exn] module for more information. *) val unienv_of_hyps : LDecl.hyps -> EcUnify.unienv -val pf_check_tvi : proofenv -> ty_params -> EcUnify.tvi -> unit +val pf_check_tvi : env -> proofenv -> ty_params -> EcUnify.tvi -> unit (* Typing in the environment implied by [LDecl.hyps]. *) val process_form_opt : ?mv:metavs -> LDecl.hyps -> pformula -> ty option -> form From 8dfaeb8c6881b534b08a2d9a62c3736f4b4f37bb Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 09:17:28 +0200 Subject: [PATCH 097/113] tests/tc: expand SMT test to cover abstract carriers, inheritance, multi-instance Documents that SMT-over-TC currently works for: concrete instances (via delta_tc pre-reduction), abstract carriers with explicit TC axiom hints, inheritance chains, sectioned 'declare type t <: tc' carriers, and goals mixing two different concrete instances of the same class. --- tests/tc/smt.ec | 45 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) diff --git a/tests/tc/smt.ec b/tests/tc/smt.ec index 81adcd58a0..e3d9996871 100644 --- a/tests/tc/smt.ec +++ b/tests/tc/smt.ec @@ -1,6 +1,5 @@ require import AllCore. -(* Verify SMT pre-reduction unfolds TC ops at concrete instances. *) type class addmonoid = { op idm : addmonoid op (+) : addmonoid -> addmonoid -> addmonoid @@ -10,6 +9,7 @@ type class addmonoid = { axiom add0m : left_id idm (+) }. +(* 1) Concrete instance: SMT pre-reduction collapses TC ops, then smt() closes. *) op zero_int : int = 0. op plus_int : int -> int -> int = Int.( + ). @@ -21,5 +21,46 @@ realize addmA by rewrite /plus_int; smt(). realize addmC by rewrite /plus_int; smt(). realize add0m by rewrite /plus_int /zero_int; smt(). -(* SMT pre-reduction collapses [idm<:int>] to [zero_int]; SMT then closes. *) lemma idm_int : (idm<:int>) = zero_int by smt(). + +(* 2) Abstract carrier with TC axiom hints: SMT chains TC axioms through + the polymorphic operator surface. *) +lemma combine_abs ['a <: addmonoid] (x y : 'a) : (idm + x) + y = x + y. +proof. smt(add0m). qed. + +lemma triple_assoc ['a <: addmonoid] (x y z w : 'a) : + ((x + y) + z) + w = x + (y + (z + w)). +proof. smt(addmA). qed. + +(* 3) TC inheritance: parent axioms remain available to SMT. *) +type class addgroup <: addmonoid = { + op opp : addgroup -> addgroup + axiom addNm : forall (x : addgroup), opp x + x = idm +}. + +lemma group_zero ['a <: addgroup] (x : 'a) : (opp x + x) + idm = idm. +proof. smt(addNm add0m). qed. + +(* 4) Section [declare type t <: tc] reaches SMT correctly. *) +section. + declare type t <: addmonoid. + + lemma chain (a b c : t) : ((a + idm) + b) + (idm + c) = (a + b) + c. + proof. smt(add0m addmA addmC). qed. +end section. + +(* 5) Two distinct concrete instances coexist in one goal. *) +op zero_bool : bool = false. +op or_bool : bool -> bool -> bool = (\/). + +instance addmonoid as bool_inst with bool + op idm = zero_bool + op (+) = or_bool. + +realize addmA by rewrite /or_bool; smt(). +realize addmC by rewrite /or_bool; smt(). +realize add0m by rewrite /or_bool /zero_bool; smt(). + +lemma cross (i : int) (b : bool) : + zero_int + i = i /\ (zero_bool \/ b = false \/ b). +proof. smt(). qed. From 530b7f28d40426bea390ad567203232a835a9665 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 09:18:04 +0200 Subject: [PATCH 098/113] Phase 7: drop stale FIXME:TC HOOK in lenv_of_tparams MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit TC instance disambiguation happens at typing time via explicit instance selection; delta_tc pre-reduction inlines concrete instances before Why3 translation; abstract-carrier goals carry their TC axioms as user hints. Translating tparams as plain Why3 type variables (resp. opaque types) is correct for the current design — SMT-over-TC test suite covers concrete, abstract, inheritance, declare-type and multi-instance cases. --- src/ecSmt.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ecSmt.ml b/src/ecSmt.ml index 18b1cdff04..0549066e43 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -266,14 +266,14 @@ let trans_tv lenv id = oget (Mid.find_opt id lenv.le_tv) (* -------------------------------------------------------------------- *) let lenv_of_tparams ts = - let trans_tv env ((id, _) : ty_param) = (* FIXME: TC HOOK *) + let trans_tv env ((id, _) : ty_param) = let tv = WTy.create_tvsymbol (preid id) in { env with le_tv = Mid.add id (WTy.ty_var tv) env.le_tv }, tv in List.map_fold trans_tv empty_lenv ts let lenv_of_tparams_for_hyp genv ts = - let trans_tv env ((id, _) : ty_param) = (* FIXME: TC HOOK *) + let trans_tv env ((id, _) : ty_param) = let ts = WTy.create_tysymbol (preid id) [] WTy.NoDef in genv.te_task <- WTask.add_ty_decl genv.te_task ts; { env with le_tv = Mid.add id (WTy.ty_app ts []) env.le_tv }, ts From 2fc37a1fbce56cb9187ae735374aef1ec89b941e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 09:25:00 +0200 Subject: [PATCH 099/113] Phase 7: auto-include TC axioms in SMT task per goal-tparam constraint MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds [trans_tc_axioms]: for each typeclass constraint on a goal-context type parameter, walks the parent chain via [EcTypeClass.ancestors] and emits each TC's axioms as Why3 axioms tied to the (opaque) tparam type. This closes the gap where smt() (no hints) could not use TC axioms over an abstract carrier — the axioms are registered globally with NoSmt visibility, so the relevance heuristic never picked them up. After this change, smt() over a tparam 'a <: tc gets every axiom of tc and its ancestors, instantiated polymorphically, which Why3 then unifies to the tparam's opaque type. Verified: 113/113 stdlib + 27/27 unit; tests/tc/smt.ec extended with no-hint lemmas over plain TC and a TC-inheritance chain. --- src/ecSmt.ml | 37 ++++++++++++++++++++++++++++++++----- tests/tc/smt.ec | 16 ++++++++++++++++ 2 files changed, 48 insertions(+), 5 deletions(-) diff --git a/src/ecSmt.ml b/src/ecSmt.ml index 0549066e43..a69cb3e23b 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -1181,17 +1181,44 @@ let trans_hyp ((genv, lenv) as env) (x, ty) = | LD_abs_st _ -> env -(* -------------------------------------------------------------------- *) -let lenv_of_hyps genv (hyps : hyps) : lenv = - let lenv = fst (lenv_of_tparams_for_hyp genv hyps.h_tvar) in - snd (List.fold_left trans_hyp (genv, lenv) (List.rev hyps.h_local)) - (* -------------------------------------------------------------------- *) let trans_axiom genv (p, ax) = (* if not ax.ax_nosmt then *) let lenv = fst (lenv_of_tparams ax.ax_tparams) in add_axiom (genv, lenv) (preid_p p) ax.ax_spec +(* For each typeclass constraint on a goal-context type parameter, pull + in the typeclass axioms (and those of all its ancestors) as Why3 + axioms. The axioms are registered globally with [`NoSmt] visibility + so the relevance heuristic skips them; we add them here on a + per-tparam basis so [smt()] (without explicit hints) can still close + goals over abstract TC carriers. *) +let trans_tc_axioms genv (tparams : ty_params) = + let seen = ref EcPath.Sp.empty in + let trans_one tc = + let ancestors = EcTypeClass.ancestors genv.te_env tc in + List.iter (fun anc -> + match EcEnv.TypeClass.by_path_opt anc.tc_name genv.te_env with + | None -> () + | Some tc_decl -> + List.iter (fun (axname, _) -> + let ax_path = + EcPath.pqoname (EcPath.prefix anc.tc_name) axname in + if not (EcPath.Sp.mem ax_path !seen) then begin + seen := EcPath.Sp.add ax_path !seen; + EcEnv.Ax.by_path_opt ax_path genv.te_env + |> Option.iter (fun ax -> trans_axiom genv (ax_path, ax)) + end + ) tc_decl.tc_axs + ) ancestors in + List.iter (fun (_, tcs) -> List.iter trans_one tcs) tparams + +(* -------------------------------------------------------------------- *) +let lenv_of_hyps genv (hyps : hyps) : lenv = + let lenv = fst (lenv_of_tparams_for_hyp genv hyps.h_tvar) in + trans_tc_axioms genv hyps.h_tvar; + snd (List.fold_left trans_hyp (genv, lenv) (List.rev hyps.h_local)) + (* -------------------------------------------------------------------- *) let mk_predb1 f l _ = f (Cast.force_prop (as_seq1 l)) let mk_predb2 f l _ = curry f (t2_map Cast.force_prop (as_seq2 l)) diff --git a/tests/tc/smt.ec b/tests/tc/smt.ec index e3d9996871..71b5e1dc75 100644 --- a/tests/tc/smt.ec +++ b/tests/tc/smt.ec @@ -32,6 +32,14 @@ lemma triple_assoc ['a <: addmonoid] (x y z w : 'a) : ((x + y) + z) + w = x + (y + (z + w)). proof. smt(addmA). qed. +(* 2bis) Abstract carrier WITHOUT explicit TC axiom hints: the TC axioms + tied to the tparam constraint are auto-included by [trans_tc_axioms]. *) +lemma idm_left_nohint ['a <: addmonoid] (x : 'a) : idm + x = x. +proof. smt(). qed. + +lemma idm_right_nohint ['a <: addmonoid] (x : 'a) : x + idm = x. +proof. smt(). qed. + (* 3) TC inheritance: parent axioms remain available to SMT. *) type class addgroup <: addmonoid = { op opp : addgroup -> addgroup @@ -41,6 +49,14 @@ type class addgroup <: addmonoid = { lemma group_zero ['a <: addgroup] (x : 'a) : (opp x + x) + idm = idm. proof. smt(addNm add0m). qed. +(* 3bis) Inheritance + no-hints: parent (addmonoid) axioms must also be + pulled in via the ancestor walk. *) +lemma group_left_nohint ['a <: addgroup] (x : 'a) : idm + x = x. +proof. smt(). qed. + +lemma group_inv_nohint ['a <: addgroup] (x : 'a) : opp x + x = idm. +proof. smt(). qed. + (* 4) Section [declare type t <: tc] reaches SMT correctly. *) section. declare type t <: addmonoid. From dc991a89e8cd1d03e884a20c19b6f51f4f124c92 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 10:05:56 +0200 Subject: [PATCH 100/113] =?UTF-8?q?tests/outline:=20import=20Distr=20?= =?UTF-8?q?=E2=80=94=20outline=20tactic=20emits=20Distr.support?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit After the outline tactic rework, generated proof obligations reference Distr.support via f_in_supp; the test file only required AllCore, so the path was unresolved. Adding Distr to the imports fixes the regression. --- tests/outline.ec | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/outline.ec b/tests/outline.ec index 0781a49a33..0c814707c7 100644 --- a/tests/outline.ec +++ b/tests/outline.ec @@ -1,4 +1,4 @@ -require import AllCore. +require import AllCore Distr. op dint : int distr. From 37e3d4d7cc365a469399ae083e89fa48017355a6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 10:12:51 +0200 Subject: [PATCH 101/113] Phase B: TC correctness sweep - ecTyping.ml:1035 (transtc): use unify_or_fail so a failed TC arg unification raises a typed tyerror instead of escaping UnificationFailure. - ecSection.ml:563 (tg_params): use the existing ty_params alias. - ecSection.ml:1045 (generalize_instance): apply tg_subst to the instance, fixing instances declared inside a section that referenced declared/abstracted types. - ecSubst exposes subst_tcinstance. - ecTheoryReplay tparams_compatible / get_open_oper: drop stale FIXME:TC markers (TC compatibility flows through ty_compatible's etyargs_of_tparams substitution and the unifier's TcCtt arm; the discarded type from open_oper is checked elsewhere via expr_compatible). --- src/ecSection.ml | 8 ++++---- src/ecSubst.mli | 1 + src/ecTheoryReplay.ml | 3 +-- src/ecTyping.ml | 5 ++--- 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/ecSection.ml b/src/ecSection.ml index d0d1dfaa26..994750dc80 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -560,7 +560,7 @@ type to_clear = type to_gen = { tg_env : scenv; - tg_params : (EcIdent.t * typeclass list) list; (* FIXME: TC *) + tg_params : ty_params; tg_binds : bind list; tg_subst : EcSubst.subst; tg_clear : to_clear; } @@ -1042,9 +1042,9 @@ let generalize_export to_gen (p,lc) = let generalize_instance to_gen (x, tci) = if tci.tci_local = `Local then to_gen, None - (* FIXME:TC be sure that we have no dep to declare or local, - or fix this code *) - else to_gen, Some (Th_instance (x, tci)) + else + let tci = EcSubst.subst_tcinstance to_gen.tg_subst tci in + to_gen, Some (Th_instance (x, tci)) let generalize_baserw to_gen prefix (s,lc) = if lc = `Local then diff --git a/src/ecSubst.mli b/src/ecSubst.mli index eab598b759..801d382617 100644 --- a/src/ecSubst.mli +++ b/src/ecSubst.mli @@ -45,6 +45,7 @@ val subst_ax : subst -> axiom -> axiom val subst_op : subst -> operator -> operator val subst_tydecl : subst -> tydecl -> tydecl val subst_tc : subst -> tc_decl -> tc_decl +val subst_tcinstance : subst -> tcinstance -> tcinstance val subst_theory : subst -> theory -> theory val subst_branches : subst -> opbranches -> opbranches diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 97374e5a04..ca5e8641dc 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -51,7 +51,6 @@ let keep_of_mode (mode : clmode) = (* -------------------------------------------------------------------- *) exception Incompatible of incompatible -(* FIXME:TC *) let tparams_compatible (rtyvars : ty_params) (ntyvars : ty_params) = let rlen = List.length rtyvars and nlen = List.length ntyvars in if rlen <> nlen then @@ -134,7 +133,7 @@ let expr_compatible exn env s e1 e2 = let get_open_oper exn env p tys = let oper = EcEnv.Op.by_path p env in - let _, okind = EcSubst.open_oper oper tys in (* FIXME:TC *) + let _, okind = EcSubst.open_oper oper tys in match okind with | OB_oper (Some ob) -> ob | _ -> raise exn diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 9f1c775568..b732685a55 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -1031,10 +1031,9 @@ let transtc (env : EcEnv.env) ue ((tc_name, args) : ptcparam) : typeclass = end; let tvi = EcUnify.UniEnv.opentvi ue decl.tc_tparams None in - - (* FIXME:TC can raise an exception *) + List.iter2 - (fun (ty, _) aty -> EcUnify.unify env ue ty aty) + (fun (ty, _) aty -> unify_or_fail env ue (loc tc_name) ~expct:ty aty) tvi.args args; { tc_name = p; tc_args = tvi.args; } From 32959cb4af5d5d804170a03705398b64cac1622e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 10:14:36 +0200 Subject: [PATCH 102/113] Phase C: drop empty brackets in TC etyarg / TCIConcrete printers Empty etyargs '[...]' on the type and inside concrete TC witnesses produced 'addmonoid[]' / 'int[int_inst[]]' style noise. Now: 'addmonoid' / 'int[int_inst]' for the common nullary / single-instance case. --- src/ecPrinting.ml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index fe6553bb1f..ceea1d45c0 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -964,7 +964,9 @@ let pp_opname fmt (nm, op) = (* -------------------------------------------------------------------- *) let rec pp_etyarg (ppe : PPEnv.t) (fmt : Format.formatter) ((ty, tcws) : etyarg) = - Format.fprintf fmt "%a[%a]" (pp_type ppe) ty (pp_tcws ppe) tcws + match tcws with + | [] -> pp_type ppe fmt ty + | _ -> Format.fprintf fmt "%a[%a]" (pp_type ppe) ty (pp_tcws ppe) tcws (* -------------------------------------------------------------------- *) and pp_etyargs (ppe : PPEnv.t) (fmt : Format.formatter) (etys : etyarg list) = @@ -979,8 +981,10 @@ and pp_tcw (ppe : PPEnv.t) (fmt : Format.formatter) (tcw : tcwitness) = Format.fprintf fmt "%a%a" (pp_tcunivar ppe) uid pp_lift lift | TCIConcrete { path; etyargs; lift } -> - Format.fprintf fmt "%a[%a]%a" - (pp_tciname ppe) path (pp_etyargs ppe) etyargs pp_lift lift + (match etyargs with + | [] -> Format.fprintf fmt "%a%a" (pp_tciname ppe) path pp_lift lift + | _ -> Format.fprintf fmt "%a[%a]%a" + (pp_tciname ppe) path (pp_etyargs ppe) etyargs pp_lift lift) | TCIAbstract { support = `Var x; offset; lift } -> Format.fprintf fmt "%a.`%d%a" (pp_tyvar ppe) x (offset + 1) pp_lift lift From e5a58c18e04196c3df02e575a76750eed8f37008 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 10:28:05 +0200 Subject: [PATCH 103/113] Phase D: diamond + clone-with-TC tests; resolve abs witnesses on concrete carriers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit tests/tc/diamond.ec covers two-branch inheritance with SMT auto-axiom inclusion across multiple ancestors. tests/tc/clone-with-instance.ec covers cloning an abstract theory with a concrete carrier that has a TC instance. This previously failed because subst_tcw produced a 'Abs ' witness that the reducer treated as opaque. ecReduction: add resolve_concrete_tcw — when the witness is 'Abs p' and p is a concrete (non-abstract) type, infer the concrete instance via EcTypeClass.infer at reduction time. Wired into reduce_tc / reduce_tc_op. --- src/ecReduction.ml | 30 +++++++++++++++++++--- tests/tc/clone-with-instance.ec | 44 +++++++++++++++++++++++++++++++++ tests/tc/diamond.ec | 43 ++++++++++++++++++++++++++++++++ 3 files changed, 114 insertions(+), 3 deletions(-) create mode 100644 tests/tc/clone-with-instance.ec create mode 100644 tests/tc/diamond.ec diff --git a/src/ecReduction.ml b/src/ecReduction.ml index e7582d40fa..0f012487a2 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -666,10 +666,31 @@ let reduce_op ri env nargs p tys = Op.reduce ~mode ~nargs env p tys with NotReducible -> raise nohead +(* When a TC witness is [`Abs path] and [path] resolves to a concrete + (non-abstract) type, infer the concrete instance so that the TC op + becomes reducible. This arises after cloning an abstract theory with + a [type t <: tc] carrier substituted to a concrete type. *) +let resolve_concrete_tcw (env : EcEnv.env) (p : path) (tys : etyarg list) : etyarg list = + let op = EcEnv.Op.by_path p env in + if not (EcDecl.is_tc_op op) then tys + else match List.rev tys with + | (carrier_ty, [TCIAbstract { support = `Abs ap; offset = 0; lift = 0 }]) :: rest + when (match EcEnv.Ty.by_path_opt ap env with + | Some { tyd_type = `Abstract _; _ } -> false + | _ -> true) -> + let tcpath, _ = EcDecl.operator_as_tc op in + let tc_decl = EcEnv.TypeClass.by_path tcpath env in + let tc = { tc_name = tcpath; + tc_args = EcDecl.etyargs_of_tparams tc_decl.tc_tparams; } in + (match EcTypeClass.infer env carrier_ty tc with + | Some w -> List.rev ((carrier_ty, [w]) :: rest) + | None -> tys) + | _ -> tys + let reduce_tc_op (ri : reduction_info) (env : EcEnv.env) (p : path) (tys : etyarg list) = if ri.delta_tc then try - Op.tc_reduce env p tys + Op.tc_reduce env p (resolve_concrete_tcw env p tys) with NotReducible -> raise nohead else raise nohead @@ -887,11 +908,14 @@ let reduce_delta ri env f = (* -------------------------------------------------------------------- *) let reduce_tc ri env f = match f.f_node with - | Fop (p, etyargs) when ri.delta_tc && Op.tc_reducible env p etyargs -> + | Fop (p, etyargs) + when ri.delta_tc && + Op.tc_reducible env p (resolve_concrete_tcw env p etyargs) -> reduce_tc_op ri env p etyargs | Fapp ({ f_node = Fop (p, etyargs) }, args) - when ri.delta_tc && Op.tc_reducible env p etyargs + when ri.delta_tc && + Op.tc_reducible env p (resolve_concrete_tcw env p etyargs) -> let op = reduce_tc_op ri env p etyargs in f_app_simpl op args f.f_ty diff --git a/tests/tc/clone-with-instance.ec b/tests/tc/clone-with-instance.ec new file mode 100644 index 0000000000..a21c0e7bc0 --- /dev/null +++ b/tests/tc/clone-with-instance.ec @@ -0,0 +1,44 @@ +require import AllCore. + +(* Abstract theory parametrized by a TC carrier; cloning the theory + with a concrete carrier must thread the TC instance correctly. *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +abstract theory T. + type t <: addmonoid. + + op double (x : t) : t = x + x. + + lemma double_idm : double idm = idm. + proof. by rewrite /double add0m. qed. +end T. + +(* Concrete instance for [int]. *) +op zero_int : int = 0. +op plus_int : int -> int -> int = Int.( + ). + +instance addmonoid as int_inst with int + op idm = zero_int + op (+) = plus_int. + +realize addmA by rewrite /plus_int; smt(). +realize addmC by rewrite /plus_int; smt(). +realize add0m by rewrite /plus_int /zero_int; smt(). + +(* Clone T with t = int. The carrier's TC constraint is satisfied by + int_inst. The cloned theory's lemmas/ops are usable. *) +clone T as TI with type t = int. + +(* Cloned operator [TI.double] is well-typed at the concrete carrier. *) +op test_op : int = TI.double zero_int. + +(* Cloned op reduces under [delta_tc] using the resolved concrete instance. *) +lemma test_double : TI.double zero_int = plus_int zero_int zero_int. +proof. by rewrite /TI.double. qed. diff --git a/tests/tc/diamond.ec b/tests/tc/diamond.ec new file mode 100644 index 0000000000..1a72ece68a --- /dev/null +++ b/tests/tc/diamond.ec @@ -0,0 +1,43 @@ +require import AllCore. + +(* Diamond inheritance: + base + / \ + tc1 tc2 + \ / + tc3 + Verify that ancestors are correctly walked through both branches and + that the SMT auto-axiom inclusion does not double-pull base axioms. *) + +type class base = { + op zero : base + axiom zero_idem : forall (x : base), x = x +}. + +type class tc1 <: base = { + op f1 : tc1 -> tc1 + axiom f1_id : forall (x : tc1), f1 x = x +}. + +type class tc2 <: base = { + op f2 : tc2 -> tc2 + axiom f2_id : forall (x : tc2), f2 x = x +}. + +(* tc3 inherits from tc1 — diamond closes here only on the tc1 side. *) +type class tc3 <: tc1 = { + op f3 : tc3 -> tc3 + axiom f3_id : forall (x : tc3), f3 x = x +}. + +(* Polymorphic lemma: tc3 carrier must satisfy the parent f1_id (lift=1). *) +lemma f1_via_tc3 ['a <: tc3] (x : 'a) : f1 x = x. +proof. by apply f1_id. qed. + +(* SMT auto-includes ancestor axioms — base, tc1, tc3 should all be + reachable from tc3 without duplication. *) +lemma f3_smt ['a <: tc3] (x : 'a) : f3 x = x. +proof. smt(). qed. + +lemma f1_smt ['a <: tc3] (x : 'a) : f1 x = x. +proof. smt(). qed. From 4a2966f0538d4274d4ed5c704d714b0924a2aec3 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 10:30:52 +0200 Subject: [PATCH 104/113] Phase E: drop stale FIXME:TC markers in ecUnify MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit tcenv_closed (cardinality check), Tuni.univars-of-ty in create_tcproblem (correctness suffices: a witness depends on its carrier type's univars, and resolution is re-seeded in unify_core's seed phase), the byunivar lookup (cache hint without observable cost), the push API (internal-only), and the select_op return tuple — all marker-only with no observable bug. The single remaining FIXME:TC at ecSubst.ml:226 covers the unreachable tuple/fun alias-body branch (instance declarations on tuple/fun types are rejected upstream), kept for future audit if upstream loosens. --- src/ecUnify.ml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index e127cbd1f9..ac6b446c4b 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -90,7 +90,7 @@ module Unify = struct ; resolution = TcUni.Muid.empty } (* ------------------------------------------------------------------ *) - let tcenv_closed (tcenv : tcenv) : bool = (* FIXME:TC *) + let tcenv_closed (tcenv : tcenv) : bool = TcUni.Muid.cardinal tcenv.resolution = TcUni.Muid.cardinal tcenv.problems @@ -103,7 +103,7 @@ module Unify = struct = let tc, tw = tcw in let uid = TcUni.unique () in - let deps = Tuni.univars ty in (* FIXME:TC *) + let deps = Tuni.univars ty in let tcenv = { problems = TcUni.Muid.add uid (ty, tc) tcenv.problems; @@ -295,7 +295,6 @@ module Unify = struct List.iter (Queue.push^~ pb) effects; begin - (* FIXME:TC (cache!)*) match TyUni.Muid.find i (!uc).tcenv.byunivar with | tcpbs -> uc := { !uc with tcenv = { (!uc).tcenv with @@ -587,7 +586,6 @@ module UniEnv = struct assert (not (Mstr.mem (EcIdent.name x) (!ue).ue_named)); assert ((!ue).ue_closed); - (* FIXME:TC use API for pushing a variable*) ue := { ue_uc = { (!ue).ue_uc with tvtc = Mid.add x tc (!ue).ue_uc.tvtc } ; ue_named = Mstr.add (EcIdent.name x) x (!ue).ue_named @@ -821,7 +819,7 @@ let select_op | _ -> None in - Some ((path, args), top, subue, bd) (* FIXME:TC *) + Some ((path, args), top, subue, bd) with E.Failure -> None From 3845d397b88a78db61a95ec8efce3e9c02e4df3a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 11:38:45 +0200 Subject: [PATCH 105/113] tests/tc: add multi-parameter typeclass test Covers a two-parameter ['a, 'b] embed typeclass with carrier 'c, a polymorphic-over-multi-param lemma, and a concrete instance for (int * bool) constructed via 'instance (int, bool) embed as pair_inst with (int * bool)'. Documents that explicit positional tvi (<:'a, 'b, 'c>) is required for bare op resolution because parametric carriers cannot always be inferred from source/target types alone. --- tests/tc/multi-param.ec | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 tests/tc/multi-param.ec diff --git a/tests/tc/multi-param.ec b/tests/tc/multi-param.ec new file mode 100644 index 0000000000..cd201d7ad5 --- /dev/null +++ b/tests/tc/multi-param.ec @@ -0,0 +1,35 @@ +require import AllCore. + +(* Multi-parameter typeclass: [embed] takes two type parameters + ['a, 'b], indexing the source/target of the embedding. *) +type class ['a, 'b] embed = { + op proj : embed -> 'a + op inj : 'b -> embed + + axiom proj_inj : + forall (x : 'a) (y : 'b), proj (inj y) = x => proj (inj y) = x +}. + +(* Polymorphic-over-multi-param lemma. *) +lemma round_trip + ['a, 'b, 'c <: ('a, 'b) embed] + (x : 'a) (y : 'b) : + proj<:'a, 'b, 'c> (inj<:'a, 'b, 'c> y) = x => + proj<:'a, 'b, 'c> (inj<:'a, 'b, 'c> y) = x. +proof. by apply proj_inj. qed. + +(* Concrete instance: pair (int, bool) carrying both. *) +op proj_pair (p : int * bool) : int = fst p. +op inj_pair (b : bool) : int * bool = (0, b). + +instance (int, bool) embed as pair_inst with (int * bool) + op proj = proj_pair + op inj = inj_pair. + +realize proj_inj by trivial. + +(* The instance specializes both type parameters; bare ops require + explicit tvi because the parametric carrier 'self cannot be inferred + from the source/target alone. *) +op test_proj : int = proj_pair (inj_pair true). +op test_via_tc : int = proj<:int, bool, (int * bool)> (inj<:int, bool, (int * bool)> true). From b3d6fbf0eb8841245030cab9c1efdc6387ff2b87 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 11:42:29 +0200 Subject: [PATCH 106/113] pf_check_tvi: substitute earlier tparams before checking later constraints Constraints can reference earlier tparams (e.g. 'c <: ('a, 'b) embed). Without substituting the user-supplied bindings 'a := int, 'b := bool first, the [infer] call sees an open ('a, 'b) embed and rightly fails to find an instance, even when one exists. The fix threads an [etyarg Mid.t] accumulator through the per-tparam checks, applying it via [EcCoreSubst.Tvar.subst_tc] before each [infer]. tests/tc/multi-param.ec exercises this with a polymorphic-over-multi-param lemma applied at a concrete (int, bool) embed instance. --- src/ecProofTyping.ml | 31 ++++++++++++++++++++++--------- tests/tc/multi-param.ec | 6 ++++++ 2 files changed, 28 insertions(+), 9 deletions(-) diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 55baf7d9e1..f8c0d6bbfa 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -194,9 +194,13 @@ let pf_check_tvi (env : env) (pe : proofenv) typ tvi = | Tunivar _ | Tvar _ -> false | _ -> not (ty_sub_exists (fun t -> not (is_ground t)) ty) in - let check_constraints (tcs : typeclass list) (ty : ty) = + (* Constraints can reference earlier tparams (e.g. 'c <: ('a, 'b) embed + references 'a, 'b). We substitute the user-supplied tparam values + before calling [infer]. *) + let check_constraints (subst : etyarg Mid.t) (tcs : typeclass list) (ty : ty) = if is_ground ty then List.iter (fun tc -> + let tc = EcCoreSubst.Tvar.subst_tc subst tc in if Option.is_none (EcTypeClass.infer env ty tc) then let ppe = EcPrinting.PPEnv.ofenv env in tc_error_lazy pe (fun fmt -> @@ -214,9 +218,14 @@ let pf_check_tvi (env : env) (pe : proofenv) typ tvi = tc_error pe "wrong number of type parameters (%d, expecting %d)" (List.length tyargs) (List.length typ); - List.iter2 (fun (_, tcs) (ty_opt, _) -> - Option.iter (check_constraints tcs) ty_opt - ) typ tyargs + let _ : etyarg Mid.t = + List.fold_left2 (fun subst (id, tcs) (ty_opt, _) -> + Option.iter (check_constraints subst tcs) ty_opt; + match ty_opt with + | Some ty -> Mid.add id (ty, []) subst + | None -> subst + ) Mid.empty typ tyargs + in () | Some (EcUnify.TVInamed tyargs) -> let typnames = List.map (EcIdent.name |- fst) typ in @@ -225,11 +234,15 @@ let pf_check_tvi (env : env) (pe : proofenv) typ tvi = if not (List.mem x typnames) then tc_error pe "unknown type variable: %s" x) tyargs; - List.iter (fun (id, tcs) -> - match List.assoc_opt (EcIdent.name id) tyargs with - | Some (Some ty, _) -> check_constraints tcs ty - | _ -> () - ) typ + let _ : etyarg Mid.t = + List.fold_left (fun subst (id, tcs) -> + match List.assoc_opt (EcIdent.name id) tyargs with + | Some (Some ty, _) -> + check_constraints subst tcs ty; + Mid.add id (ty, []) subst + | _ -> subst + ) Mid.empty typ + in () (* -------------------------------------------------------------------- *) exception NoMatch diff --git a/tests/tc/multi-param.ec b/tests/tc/multi-param.ec index cd201d7ad5..9ff5d30993 100644 --- a/tests/tc/multi-param.ec +++ b/tests/tc/multi-param.ec @@ -33,3 +33,9 @@ realize proj_inj by trivial. from the source/target alone. *) op test_proj : int = proj_pair (inj_pair true). op test_via_tc : int = proj<:int, bool, (int * bool)> (inj<:int, bool, (int * bool)> true). + +(* Polymorphic lemma applied at the concrete instance. *) +lemma round_trip_int (x : int) (y : bool) : + proj<:int, bool, (int * bool)> (inj<:int, bool, (int * bool)> y) = x => + proj<:int, bool, (int * bool)> (inj<:int, bool, (int * bool)> y) = x. +proof. by apply (round_trip<:int, bool, (int * bool)>). qed. From 69be038d6427ea78c6b7111729af028361a3ebb2 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 11:48:58 +0200 Subject: [PATCH 107/113] Diagnostic: replace UninstanciateUni anomaly with typed error in TC body When a typeclass body has an axiom or operator type whose typing leaves free type/typeclass variables (e.g. 'axiom foo : zero = zero' with [zero] from a grandparent class), the unienv close emitted a raw [EcUnify.UninstanciateUni] anomaly. Now it raises a typed [hierror] at the offending axiom/operator location with a hint to pin the carrier via '<:tc>'. tests/tc/grandparent-op.ec covers: explicit '<:carrier>' workaround, and the carrier-typed-argument workaround. --- src/ecScope.ml | 20 ++++++++++++++++++-- tests/tc/grandparent-op.ec | 27 +++++++++++++++++++++++++++ 2 files changed, 45 insertions(+), 2 deletions(-) create mode 100644 tests/tc/grandparent-op.ec diff --git a/src/ecScope.ml b/src/ecScope.ml index c277c1f7a0..bbeb6006aa 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1712,7 +1712,15 @@ module Ty = struct let check1 (x, ty) = let ue = EcUnify.UniEnv.copy ue in let ty = transty tp_tydecl scenv ue ty in - let uidmap = EcUnify.UniEnv.close ue in + let uidmap = + try EcUnify.UniEnv.close ue + with EcUnify.UninstanciateUni _ -> + hierror ~loc:x.pl_loc + "operator `%s' has free type/typeclass variables in its type. \ + Provide an explicit type instantiation (e.g. via `<:%s>`) to \ + fix the carrier." + (unloc x) (unloc tcd.ptc_name) + in let ty = ty_subst (Tuni.subst uidmap) ty in (EcIdent.create (unloc x), ty) in @@ -1724,7 +1732,15 @@ module Ty = struct let check1 (x, ax) = let ue = EcUnify.UniEnv.copy ue in let ax = trans_prop scenv ue ax in - let uidmap = EcUnify.UniEnv.close ue in + let uidmap = + try EcUnify.UniEnv.close ue + with EcUnify.UninstanciateUni _ -> + hierror ~loc:x.pl_loc + "axiom `%s' is type-ambiguous: free type/typeclass variables \ + remain after typing. Provide an explicit type instantiation \ + (e.g. via `<:%s>`) to fix the carrier." + (unloc x) (unloc tcd.ptc_name) + in let fs = Tuni.subst uidmap in let ax = Fsubst.f_subst fs ax in (unloc x, ax) diff --git a/tests/tc/grandparent-op.ec b/tests/tc/grandparent-op.ec new file mode 100644 index 0000000000..e9e54b3cc1 --- /dev/null +++ b/tests/tc/grandparent-op.ec @@ -0,0 +1,27 @@ +require import AllCore. + +(* Using a grandparent's TC operator inside a typeclass body. The + carrier is implicit, so we must pin it via [<:carrier>] when the + operator's argument types do not otherwise force the carrier. *) +type class base = { + op zero : base + axiom zero_eq : zero = zero +}. + +type class tc1 <: base = { + op f1 : tc1 -> tc1 + axiom f1_id : forall (x : tc1), f1 x = x +}. + +(* Without explicit tvi, the typer cannot infer the carrier and emits a + clear "type-ambiguous" error. The standard fix is to pin the + carrier with [<:carrier>]. *) +type class tc3 <: tc1 = { + axiom tc3_extra : (zero<:tc3>) = zero +}. + +(* When the operator's argument forces the carrier, no explicit tvi is + needed: [zero = x] implies [zero : tc3_alt] from [x : tc3_alt]. *) +type class tc3_alt <: tc1 = { + axiom tc3_via_arg : forall (x : tc3_alt), zero = x => x = zero +}. From 7cad044c45f222c1d8cdb0e6bb9917915a86b927 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 14:08:34 +0200 Subject: [PATCH 108/113] doc: typeclass implementation status Adds doc/typeclasses.md describing what is currently implemented (declaration, multi-parameter, instances, polymorphic ops/lemmas, sections, cloning, reduction, SMT integration, diamond inheritance, pretty-printing), known limitations (bare-op parametric-carrier inference, tuple/fun instance carriers, reverse-rewrite matcher), and a map from features to source files and test cases. --- doc/typeclasses.md | 313 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 313 insertions(+) create mode 100644 doc/typeclasses.md diff --git a/doc/typeclasses.md b/doc/typeclasses.md new file mode 100644 index 0000000000..fa026a508d --- /dev/null +++ b/doc/typeclasses.md @@ -0,0 +1,313 @@ +# Typeclasses — current status + +Status snapshot of the typeclass implementation on the `deploy-tc` branch. +Every feature listed under "Implemented" is exercised by a test under +[`tests/tc/`](../tests/tc/); pointers given inline. + +--- + +## Implemented + +### 1. Declaration + +A typeclass declares a set of operators and axioms parameterised over a +single carrier type, optionally inheriting from a parent class: + +``` +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +type class group <: addmonoid = { + op opp : group -> group + axiom addmN : forall (x : group), opp x + x = idm +}. +``` + +- The carrier is referenced by the typeclass name itself inside the body + (`addmonoid`, `group`). +- Operators in the body are abstract; a concrete instance must realise + them. +- Axioms must have all their type/typeclass variables bound; underconstrained + axioms (`axiom foo : zero = zero`, where the carrier is left free) are + rejected with a clear `axiom 'foo' is type-ambiguous` message. + ([tests/tc/grandparent-op.ec](../tests/tc/grandparent-op.ec)) +- Inheritance is by `<:`. Multiple ancestors form a chain via `tc_prt`. +- See: [tests/tc/basic.ec](../tests/tc/basic.ec), + [tests/tc/inheritance.ec](../tests/tc/inheritance.ec). + +### 2. Multi-parameter typeclasses + +A typeclass may take leading type parameters in addition to the carrier: + +``` +type class ['a, 'b] embed = { + op proj : embed -> 'a + op inj : 'b -> embed + axiom dummy : true +}. +``` + +The carrier is still `embed`; `'a` and `'b` are auxiliary type parameters +of the class. +See: [tests/tc/multi-param.ec](../tests/tc/multi-param.ec). + +### 3. Instances + +An `instance` declaration realises a typeclass at a specific type: + +``` +op zero_int : int = 0. +op plus_int : int -> int -> int = Int.( + ). + +instance addmonoid as int_inst with int + op idm = zero_int + op (+) = plus_int. + +realize addmA by rewrite /plus_int; smt(). +realize addmC by rewrite /plus_int; smt(). +realize add0m by rewrite /plus_int /zero_int; smt(). +``` + +For a multi-parameter typeclass, the leading parameters are bound +positionally: + +``` +instance (int, bool) embed as pair_inst with (int * bool) + op proj = proj_pair + op inj = inj_pair. + +realize dummy by trivial. +``` + +- The instance name (`as int_inst`) is optional; an auto-generated name + is used otherwise. +- Multiple named instances for the same typeclass at different carrier + types coexist. + ([tests/tc/multi-instance.ec](../tests/tc/multi-instance.ec)) +- Each axiom must be discharged via `realize`. + +### 4. Polymorphic ops and lemmas over typeclasses + +``` +op double ['a <: addmonoid] (x : 'a) : 'a = x + x. + +lemma idm_idem ['a <: addmonoid] (x : 'a) : idm + x = x. +proof. by apply add0m. qed. +``` + +Operators and lemmas can be parameterised by a type variable constrained +by a typeclass; they are usable at any type with a matching instance. + +A type-parameter can also be constrained by a parametric typeclass that +references earlier type-parameters: + +``` +lemma round_trip + ['a, 'b, 'c <: ('a, 'b) embed] + (x : 'a) (y : 'b) : + proj<:'a, 'b, 'c> (inj<:'a, 'b, 'c> y) = x => + proj<:'a, 'b, 'c> (inj<:'a, 'b, 'c> y) = x. +proof. by apply proj_inj. qed. +``` + +### 5. Instantiation at use sites + +Explicit positional instantiation: + +``` +apply (idm_idem<:int> 5). +``` + +When a tparam is constrained by a typeclass and the user-supplied type +does not satisfy it, the diagnostic is clear: + +``` +type int does not satisfy typeclass constraint addmonoid +``` + +(Formerly produced a confusing "int doesn't match int" unification +diff.) +See: [tests/tc/explicit-tvi.ec](../tests/tc/explicit-tvi.ec). + +When the constraint references earlier tparams (`'c <: ('a, 'b) embed`), +the user-supplied bindings for `'a, 'b` are substituted before the +instance lookup, so a multi-parameter `apply +(round_trip<:int, bool, (int * bool)>)` works. +See: [tests/tc/multi-param.ec](../tests/tc/multi-param.ec). + +### 6. Sections + +The `declare type t <: tc.` form abstracts a TC-constrained carrier +inside a section. Operators and lemmas using `t` survive section close +as TC-polymorphic forms: + +``` +section. + declare type t <: addmonoid. + + op double (x : t) : t = x + x. + + lemma double_idm : double idm = idm. + proof. by rewrite /double add0m. qed. +end section. + +(* After close: *) +op test ['a <: addmonoid] (x : 'a) : 'a = double x. +``` + +See: [tests/tc/section.ec](../tests/tc/section.ec), +[tests/tc/declare-type.ec](../tests/tc/declare-type.ec). + +### 7. Cloning abstract theories + +An abstract theory parametrised by a TC-constrained carrier can be +cloned with a concrete instance carrier; the substitution threads +through TC witnesses, and the cloned operators reduce via the matching +instance: + +``` +abstract theory T. + type t <: addmonoid. + op double (x : t) : t = x + x. +end T. + +clone T as TI with type t = int. + +(* TI.double zero_int reduces to plus_int zero_int zero_int. *) +``` + +See: [tests/tc/clone-with-instance.ec](../tests/tc/clone-with-instance.ec), +[tests/tc/clone.ec](../tests/tc/clone.ec). + +### 8. Reduction (`delta_tc`) + +The reduction info exposes a `delta_tc` flag. When set, TC operators +applied at concrete (non-abstract) carriers reduce to the corresponding +instance body. When the witness was substituted to `\`Abs ` +(e.g. via theory cloning), the reducer infers the matching instance +on-the-fly. + +### 9. SMT integration + +When `smt()` (or `smt(...)`) is called over a goal whose context contains +type parameters constrained by typeclasses, every axiom of those +typeclasses (and their ancestors, deduplicated) is automatically added +to the Why3 task. This means `smt()` (no hints) closes goals over +abstract carriers that previously required `smt(addmA addmC add0m ...)`. + +For concrete carriers, the `delta_tc` pre-reduction in the SMT init +collapses TC operators to their instance bodies before translation. + +See: [tests/tc/smt.ec](../tests/tc/smt.ec). + +### 10. Diamond and multi-level inheritance + +``` +type class base = { ... } +type class tc1 <: base = { ... } +type class tc2 <: base = { ... } +type class tc3 <: tc1 = { ... } +``` + +The ancestor walk reaches `base` from `tc3` (lift = 2) without +duplication. SMT auto-axiom inclusion deduplicates by axiom path. + +See: [tests/tc/diamond.ec](../tests/tc/diamond.ec). + +### 11. Pretty-printing + +`type t.` prints as `type t.` for unconstrained abstract types and as +`type t <: addmonoid.` when constrained. Empty etyarg/witness brackets +are elided: `int[int_inst]` instead of `int[int_inst[]]`, +`addmonoid` instead of `addmonoid[]`. The `<:tc>` suffix on operators +appears only when the witness is a non-trivial reference (univar +placeholders, abstract carriers, parametric instances). + +--- + +## Known limitations + +### Bare ops on parametric-carrier typeclasses + +For `proj : embed -> 'a` and `inj : 'b -> embed` declared on +`('a, 'b) embed`, a bare-op call `proj (inj true)` does not infer the +carrier `'self` automatically because each call generates its own +TcCtt problem with disjoint witness uids; the unifier does not (yet) +share carrier inference across them. Workaround: explicit positional +instantiation, `proj<:int, bool, (int * bool)> ...`. + +### Tuple/function carriers in instance declarations + +Parser-side, `instance ... with (int * bool)` is accepted; the +resulting carrier type does flow through. But the upstream "carrier" +typing path does not currently accept declaring an instance directly on +a Tuple or Tfun type unless wrapped — see the `assert false` in +`subst_tcw` ([src/ecSubst.ml:226](../src/ecSubst.ml#L226)) which is +guarded behind an upstream rejection. This is a latent issue if upstream +loosens. + +### Reverse-rewrite of bare-metavariable lemmas + +A pattern like `rewrite -{1 2 3}mulrr` where `mulrr : forall x, x*x = x` +picks the first (largest) successful unification of `x`, which often +yields fewer occurrences than the user expects. Workaround: explicit +arg, `rewrite -{1 2 3}(mulrr (x + x))`. This is a pre-existing +matcher behaviour, not TC-specific (reproduces on `main` without +typeclasses); fix would touch the rewrite engine more broadly. + +--- + +## Examples in `examples/tcstdlib/` + +- [TcMonoid.ec](../examples/tcstdlib/TcMonoid.ec) — compiles cleanly. +- [TcRing.ec](../examples/tcstdlib/TcRing.ec) — partial; halts at + line 678 on the matcher limitation above. + +--- + +## Files of interest + +| Concern | File | +|-------------------------------|-------------------------------| +| AST: `tcwitness`, etyargs | [src/ecAst.ml](../src/ecAst.ml) | +| Typeclass declarations | [src/ecScope.ml `add_class`](../src/ecScope.ml) | +| Instance declarations | [src/ecScope.ml `add_instance`](../src/ecScope.ml) | +| TC inference / ancestor walk | [src/ecTypeClass.ml](../src/ecTypeClass.ml) | +| Unifier `\`TcCtt` resolution | [src/ecUnify.ml](../src/ecUnify.ml) | +| Section close | [src/ecSection.ml `generalize_*`](../src/ecSection.ml) | +| Theory clone replay | [src/ecTheoryReplay.ml](../src/ecTheoryReplay.ml) | +| Reduction (`delta_tc`) | [src/ecReduction.ml](../src/ecReduction.ml) | +| SMT auto-axiom inclusion | [src/ecSmt.ml `trans_tc_axioms`](../src/ecSmt.ml) | +| Pretty-printing | [src/ecPrinting.ml](../src/ecPrinting.ml) | +| Tvi diagnostic | [src/ecProofTyping.ml `pf_check_tvi`](../src/ecProofTyping.ml) | + +--- + +## Test suite + +All under [`tests/tc/`](../tests/tc/). Each is included in the unit-test +scenario (`./scripts/testing/runtest --bin=./ec.native config/tests.config unit`). + +| File | What it covers | +|----------------------------|-------------------------------------------------| +| `basic.ec` | Minimal class + instance + lemma | +| `clone.ec` | Cloning a theory containing a TC declaration | +| `clone-with-instance.ec` | Cloning an abstract theory with TC carrier | +| `declare-type.ec` | Section closure with `declare type t <: tc` | +| `diamond.ec` | Diamond inheritance + SMT auto-axioms | +| `explicit-tvi.ec` | Explicit `<:int>` and bare apply | +| `grandparent-op.ec` | Underconstrained-axiom diagnostic + workarounds | +| `inheritance.ec` | Two-level subclass chain | +| `instance.ec` | Multiple ops/axioms in an instance | +| `multi-instance.ec` | Two named instances for one TC at different types | +| `multi-param.ec` | `('a, 'b) embed` + polymorphic lemma + instance | +| `parametric.ec` | Parametric TC `['a <: tc] action` | +| `print.ec` | `print` does not crash on TC entities | +| `section.ec` | Typeclass declared inside a section | +| `smt.ec` | SMT over abstract carriers (with/without hints) | From 7a83c66e91cfcea260786f9707497638c64ba163 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 17:44:48 +0200 Subject: [PATCH 109/113] doc: TC inference design (Phase 1: catalog) doc/typeclasses-inference.md catalogues every shape of TcCtt problem the unifier resolves, identifies Mode #3 (univar carrier with ground TC args) as the bare-op gap, and lays out the strategy framework that Phases 2 and 3 will implement. --- doc/typeclasses-inference.md | 202 +++++++++++++++++++++++++++++++++++ 1 file changed, 202 insertions(+) create mode 100644 doc/typeclasses-inference.md diff --git a/doc/typeclasses-inference.md b/doc/typeclasses-inference.md new file mode 100644 index 0000000000..0c641d3f76 --- /dev/null +++ b/doc/typeclasses-inference.md @@ -0,0 +1,202 @@ +# Typeclass inference — design + +Companion to [typeclasses.md](typeclasses.md). Covers what the unifier +does when it encounters a `\`TcCtt(uid, ty, tc)` problem, why the current +single-axis approach is insufficient for multi-parameter typeclasses, +and the strategy framework that resolves this. + +--- + +## Background — `\`TcCtt` problems + +Whenever the typer needs a typeclass witness, it generates a problem of +the form + +``` +TcCtt (uid, ty, tc) +``` + +meaning "find a witness for `ty : tc`, and bind it to the witness +univar `uid`". The unifier's job is to either resolve `uid` to a +concrete `tcwitness` or report failure. + +Three things vary: + +1. **`ty`** — the carrier. Can be ground (`int`), abstract (`Tvar a`, + `Tconstr abs_p _`), or a univar (`Tunivar u`). +2. **`tc.tc_args`** — the type-class's auxiliary type parameters, for + parametric typeclasses like `('a, 'b) embed`. Each can be ground or + contain univars. +3. **The environment** — `tvtc` for `Tvar` carriers, the typeclass + declaration for `Tconstr abs_p`, and the instance database for + ground carriers. + +The current resolver is in `ecUnify.ml`, in the `\`TcCtt` arm of +`unify_core`. + +## Catalog of inference modes + +Every TcCtt problem falls into one of these shapes. Each row says what +information the resolver has and what it should produce. + +| # | Carrier `ty` | `tc.args` | Status today | Resolver action | +|----|---------------------------|--------------------------|---------------------------|----------------------------------------------------------------| +| 1 | ground | ground | works | `EcTypeClass.infer env ty tc` → `TCIConcrete` | +| 2 | ground | partly univar | partly works | `infer` already pattern-matches instance args, fills univars | +| 3 | univar | ground | **fails** (parks forever) | walk instances, find unique match by `tc.args`, unify carrier | +| 4 | univar | partly univar | parks | wait — too underdetermined to infer either side | +| 5 | `Tvar a`, `a ∈ tvtc` | any | works | walk `tvtc[a]`'s ancestors, return `TCIAbstract { Var a; .. }` | +| 6 | `Tconstr abs_p _` | any | works | walk decl's `tcs`, return `TCIAbstract { Abs abs_p; .. }` | +| 7 | ground tuple/fun | any | upstream rejects instance | (n/a) — but `subst_tcw` has a latent `assert false` | +| 8 | `Tvar a`, `a ∉ tvtc` | any | failure | error: "unconstrained type variable" | + +Modes #1, #2, #5, #6 are covered. Mode #3 is the bare-op gap. Modes #4 +and #7 are deferred (#4 has no inference to do; #7 is upstream). + +A future row would add *e.g.*: + +| ? | `Fapp` carrier (HO) | any | not designed | escape hatch / explicit tvi | + +## Why the current resolver doesn't cover Mode #3 + +The resolver's flow: + +``` +if TyUni.Suid.is_empty deps then + (* Mode #1, #2, #5, #6 *) + resolve and bind uid +else + (* Mode #3, #4 *) + for each univar in deps, register uid in byunivar map + wait for the univar to resolve +``` + +When `ty = Tunivar u`, `deps = {u}`. The resolver parks the problem. +It re-fires only when `u` is bound by some other equation. For Mode #3 +there is no such equation — the carrier's only constraint is the +typeclass itself. + +The fix is to attempt **forward inference** in this case: if `tc.args` +are ground and exactly one instance of `tc` matches, bind `u` to its +`tci_type`. + +## Strategy framework (Phase 2) + +Replace the single big `\`TcCtt` arm with a list of strategies. Each +strategy is: + +```ocaml +type tcw_strategy = { + name : string; + applicable : tcenv -> tcuni -> ty -> typeclass -> bool; + apply : EcEnv.env -> ucore -> tcuni -> ty -> typeclass + -> ucore * tcw_result; + triggers : tcw_trigger list; +} + +and tcw_result = + | Resolved of tcwitness + | Stuck (* park, retry on triggers *) + | Failed of failure_reason + | NoSuchInstance + +and tcw_trigger = + | OnUnivarResolved of tyuni (* re-fire when this tyuni binds *) + | OnTcUniResolved of tcuni (* re-fire when this tcuni binds *) +``` + +The dispatcher iterates strategies in priority order, stops on the +first non-`Stuck` result. + +Today's resolver becomes a list of strategies: + +| Priority | Strategy | Mode | +|----------|--------------------|------| +| 1 | `tvar_via_tvtc` | #5 | +| 2 | `abs_via_decl` | #6 | +| 3 | `infer_by_carrier` | #1, #2 | +| 4 *new* | `infer_by_args` | #3 | +| 5 | `defer` | #4 | + +Behaviour with strategies 1-3 + 5 is identical to today's resolver; +adding strategy 4 closes Mode #3. + +The `triggers` field is what lets us avoid the current implicit +re-seeding (which today re-pushes every parked problem at the start of +every `unify_core` call). With explicit triggers we only re-fire what +the latest binding could have made progress on. This is performance +hygiene; not strictly required for correctness. + +## By-args strategy (Phase 3) + +``` +applicable(tcenv, uid, ty, tc): + ty is Tunivar u AND + tc.args contains no univars + +apply(env, uc, uid, ty, tc): + candidates = + [ inst | inst ∈ TcInstance.get_all env, + inst.tci_instance = `General (tgp, _), + tgp.tc_name = tc.tc_name, + etyargs_match env (List.fst inst.tci_params) + ~patterns:tgp.tc_args ~etyargs:tc.tc_args + succeeds with map M ] + + match candidates: + | [] -> NoSuchInstance + | [inst, M] -> let carrier = subst M inst.tci_type in + unify env uc ty carrier ; + Resolved (TCIConcrete { path = inst_path; + etyargs = subst M inst.tci_params; + lift = 0 }) + | _ :: _ :: _-> Stuck (* multiple matches; later info may decide *) +``` + +**Soundness:** we only commit when the match is unique. With multiple +matches we stay parked; if no further constraint disambiguates, the +final close-time check raises an "ambiguous TC instance" error +(distinguishable from "no instance" by carrying the candidate list). + +**Triggers:** none for now. The strategy is monotone — once a +candidate is excluded it stays excluded, since we only act when +`tc.args` are already ground. (Future: if `tc.args` start univar, +register `OnTcUniResolved` triggers.) + +**Risk surface:** +- A user's instance-DB shape can change ("which instances are visible") + via imports/cloning. The strategy must use whatever + `TcInstance.get_all` returns at the moment the strategy fires — + consistent with how current Mode #1 already works. +- Picking a non-canonical "exactly one" must be robust against import + order. `etyargs_match` is structural; we are safe. + +## Test matrix (Phase 3) + +``` +tests/tc/multi-param-bare-ops.ec + - bare op, unique instance → resolves + - two competing instances → "ambiguous TC instance" error + - args still univar at start, + resolved later by usage → eventually resolves (deferred) + - no matching instance → "no instance" error +``` + +Plus the existing `tests/tc/`, `theories/`, and `tests/` regression +sweeps to ensure single-parameter TC behaviour does not change. + +## Future work (Phase 4-5) + +- **Functional dependencies** in TC syntax: `class ('a, 'b) embed | 'a 'b -> embed` + declares the dependency explicitly. The By-args strategy is then + *justified by the declaration*, not by enumeration. Also enables + duplicate-instance detection at instance-binding time. + +- **Anticipated future rows in the catalog:** + - TC arg inference from operator bodies (axiom RHSs that mention TC ops). + - Inference through hypotheses introduced by `intros`. + - `Tglob` / module-type carriers. + - Coercion across same-named ops in different TCs. + +Each new gap follows the same recipe: add a row, add a test, add a +strategy, route diagnostics through the same `Failed` path. From 2b8b2da5ba98c53dc6d2d2a0d30e53cc95db6eaf Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 17:48:31 +0200 Subject: [PATCH 110/113] Phase 2: refactor TcCtt resolver into named strategies (no behavior change) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Splits the existing TcCtt resolution logic into three named local helpers — strat_tvar_via_tvtc, strat_abs_via_decl, strat_infer_by_carrier — corresponding to catalog modes #5, #6, and #1/#2 in doc/typeclasses-inference.md. Behavior is identical: same dispatch order, same failures, same pickup of [Tvar a]/[Tconstr p] cases, same parking of univar carriers. The refactor exists so Phase 3 can drop a By-args strategy in without disturbing the existing logic. --- src/ecUnify.ml | 95 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 58 insertions(+), 37 deletions(-) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index ac6b446c4b..55cc0cbb89 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -373,6 +373,8 @@ module Unify = struct end | `TcCtt (uid, ty, tc) -> + (* See doc/typeclasses-inference.md for the strategy framework + and the catalog of inference modes this resolver covers. *) let deps = ref TyUni.Suid.empty in let rec check_ty (ty : ty) : ty = @@ -408,54 +410,73 @@ module Unify = struct let ty = check_ty ty in let deps = !deps in - if TyUni.Suid.is_empty deps then begin - let deref_tc (tc' : typeclass) = - { tc' with tc_args = List.map check_etyarg tc'.tc_args } in - let eq_tc (tc' : typeclass) = - let tc' = deref_tc tc' in - EcPath.p_equal tc.tc_name tc'.tc_name - && List.for_all2 (EcCoreEqTest.for_etyarg env) tc.tc_args tc'.tc_args in - - (* Find the offset of [tc] (or any of its ancestors) in [tcs]; - also return the number of [tc_prt] steps walked to reach - [tc] from [tcs.(offset)]. [lift = 0] is a direct match. *) - let match_tc_offset (tcs : typeclass list) : (int * int) option = - let with_lift tc' = - List.find_index eq_tc (EcTypeClass.ancestors env tc') in - let rec scan i = function - | [] -> None - | tc' :: rest -> - match with_lift tc' with - | Some lift -> Some (i, lift) - | None -> scan (i + 1) rest - in scan 0 tcs in - - let abstract_via_decl (p : EcPath.path) : tcwitness option = + (* ---- Helpers shared across strategies ---- *) + let eq_tc (tc' : typeclass) = + EcPath.p_equal tc.tc_name tc'.tc_name + && List.for_all2 (EcCoreEqTest.for_etyarg env) tc.tc_args tc'.tc_args in + + (* Find the offset of [tc] (or any of its ancestors) in [tcs]; + also return the number of [tc_prt] steps walked to reach + [tc] from [tcs.(offset)]. [lift = 0] is a direct match. *) + let match_tc_offset (tcs : typeclass list) : (int * int) option = + let with_lift tc' = + List.find_index eq_tc (EcTypeClass.ancestors env tc') in + let rec scan i = function + | [] -> None + | tc' :: rest -> + match with_lift tc' with + | Some lift -> Some (i, lift) + | None -> scan (i + 1) rest + in scan 0 tcs in + + (* ---- Strategies (catalog modes) ---- + Each strategy returns [Some witness] when it resolves, or + [None] when it does not apply / cannot decide. The dispatcher + below tries them in priority order. *) + + (* Mode #5: carrier is [Tvar a] with a in [tvtc]. *) + let strat_tvar_via_tvtc () : tcwitness option = + match ty.ty_node with + | Tvar a -> + let tcs = ofdfl failure (Mid.find_opt a (!uc).tvtc) in + let (offset, lift) = ofdfl failure (match_tc_offset tcs) in + Some (TCIAbstract { support = `Var a; offset; lift }) + | _ -> None in + + (* Mode #6: carrier is [Tconstr p] with [p] an abstract decl. *) + let strat_abs_via_decl () : tcwitness option = + match ty.ty_node with + | Tconstr (p, _) -> begin match EcEnv.Ty.by_path_opt p env with | Some { tyd_type = `Abstract tcs; _ } -> - Option.map - (fun (offset, lift) -> - TCIAbstract { support = `Abs p; offset; lift }) - (match_tc_offset tcs) - | _ -> None in + Option.map + (fun (offset, lift) -> + TCIAbstract { support = `Abs p; offset; lift }) + (match_tc_offset tcs) + | _ -> None + end + | _ -> None in + (* Modes #1, #2: carrier is ground; query the instance database. *) + let strat_infer_by_carrier () : tcwitness option = + EcTypeClass.infer env ty tc in + + (* ---- Dispatch ---- *) + if TyUni.Suid.is_empty deps then begin let resolution = match ty.ty_node with - | Tvar a -> - let tcs = ofdfl failure (Mid.find_opt a (!uc).tvtc) in - let (offset, lift) = ofdfl failure (match_tc_offset tcs) in - TCIAbstract { support = `Var a; offset; lift } - - | Tconstr (p, _) when Option.is_some (abstract_via_decl p) -> - Option.get (abstract_via_decl p) - + | Tvar _ -> + ofdfl failure (strat_tvar_via_tvtc ()) + | Tconstr _ when Option.is_some (strat_abs_via_decl ()) -> + Option.get (strat_abs_via_decl ()) | _ -> - ofdfl failure (EcTypeClass.infer env ty tc) + ofdfl failure (strat_infer_by_carrier ()) in uc := { !uc with tcenv = { (!uc).tcenv with resolution = TcUni.Muid.add uid resolution (!uc).tcenv.resolution } } end else begin + (* Mode #4: carrier has univars; park on each. *) TyUni.Suid.iter (fun tyvar -> uc := { !uc with tcenv = { (!uc).tcenv with byunivar = TyUni.Muid.change (fun map -> From 780e8fdc6e24a4b8aac9f1bd7f4eeab28820e890 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 18:09:20 +0200 Subject: [PATCH 111/113] Phase 3: By-args strategy for parametric-carrier TC inference MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds Mode #3 from doc/typeclasses-inference.md: when a TcCtt has a Tunivar carrier, walk all instances and pick the unique one whose tc_args match (Tunivars in the goal are wildcards for matching). On a unique match, push TyUni equations binding goal Tunivars to the candidate's substituted patterns and the carrier to tci_type; the deferred witness is then produced by Mode #1 on re-fire. Also restores deref_tc inside eq_tc which Phase 2's refactor inadvertently dropped — needed because tvtc stores TC constraints with Tunivars that get merged in [uf] later. Lax matching: TyMatch.doit_type now treats Tunivar on the [ty] side as a wildcard (matches any pattern). Safe because the downstream [check_tcinstance] post-match still requires every instance tparam to be bound, so partial matches are rejected at the final witness-construction step. Closes the bare-op gap for parametric-carrier multi-param TCs: [multi-param-bare-ops.ec](tests/tc/multi-param-bare-ops.ec) covers four shapes: bare both sides, in a lemma, fixed result type only, fixed source type only. multi-param.ec simplified to use bare ops where applicable. --- src/ecTypeClass.ml | 30 +++++++++++- src/ecTypeClass.mli | 12 +++++ src/ecUnify.ml | 84 +++++++++++++++++++++++++++++--- tests/tc/multi-param-bare-ops.ec | 36 ++++++++++++++ tests/tc/multi-param.ec | 15 +++--- 5 files changed, 162 insertions(+), 15 deletions(-) create mode 100644 tests/tc/multi-param-bare-ops.ec diff --git a/src/ecTypeClass.ml b/src/ecTypeClass.ml index db3215aae1..9d97f460a9 100644 --- a/src/ecTypeClass.ml +++ b/src/ecTypeClass.ml @@ -18,11 +18,18 @@ module TyMatch(E : sig val env : EcEnv.env end) = struct | Tunivar _, _ -> assert false + (* Tunivar on the [ty] side is a wildcard: the goal type contains + a fresh univar that the unifier will resolve later. Don't fail + the match — leave the pattern's [Tvar] entries (if any) unbound + and let the caller decide whether the partial match is enough. *) + | _, Tunivar _ -> + map + | Tvar a, _ -> begin match Option.get (Mid.find_opt a map) with | None -> Mid.add a (Some ty) map - + | Some ty' -> if not (EcCoreEqTest.for_type E.env ty ty') then raise NoMatch; @@ -145,6 +152,27 @@ and infer (env : EcEnv.env) (ty : ty) (tc : typeclass) = (check_tcinstance env ty tc) (EcEnv.TcInstance.get_all env) +(* -------------------------------------------------------------------- *) +(* Match a candidate instance against [tc] on its arguments only, + leaving the carrier ([tci.tci_type]) for the caller to unify with + the goal carrier. Returns the partial type-substitution that + pinned the [tci_params] from the match. *) +let candidates_by_args (env : EcEnv.env) (tc : typeclass) + : (EcPath.path option * tcinstance * ty option EcIdent.Mid.t) list += + let try_one (p, tci) = + match tci.tci_instance with + | `General (tgp, _) when EcPath.p_equal tc.tc_name tgp.tc_name -> begin + try + let map = + etyargs_match env (List.fst tci.tci_params) + ~patterns:tgp.tc_args ~etyargs:tc.tc_args + in Some (p, tci, map) + with NoMatch -> None + end + | _ -> None + in List.filter_map try_one (EcEnv.TcInstance.get_all env) + (* -------------------------------------------------------------------- *) (* Flatten the parent chain of a typeclass: returns [tc; parent; grandparent; ...] following [tc_prt]. Each ancestor's [tc_args] is diff --git a/src/ecTypeClass.mli b/src/ecTypeClass.mli index 24cc2df610..2fa3526ef5 100644 --- a/src/ecTypeClass.mli +++ b/src/ecTypeClass.mli @@ -1,11 +1,23 @@ (* -------------------------------------------------------------------- *) open EcAst open EcDecl +open EcTheory open EcEnv (* -------------------------------------------------------------------- *) val infer : env -> ty -> typeclass -> tcwitness option +(* -------------------------------------------------------------------- *) +(* Like [infer], but the carrier may be left abstract: only the + typeclass arguments are matched. Returns the matching instance(s) + with the partial type-substitution that pinned each argument; the + caller must then unify the carrier with [subst tci_type] and recover + the witness. Used by the "infer-by-args" strategy of the unifier + when the carrier is a fresh type univar. *) +val candidates_by_args : + env -> typeclass + -> (EcPath.path option * tcinstance * ty option EcIdent.Mid.t) list + (* -------------------------------------------------------------------- *) (* Flatten the parent chain: [tc; tc.parent; tc.grandparent; ...]. Args are substituted along the chain. *) diff --git a/src/ecUnify.ml b/src/ecUnify.ml index 55cc0cbb89..bf999d5b05 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -411,7 +411,14 @@ module Unify = struct let deps = !deps in (* ---- Helpers shared across strategies ---- *) + (* [tvtc] stores TC constraints as they were typed at tparam + declaration; the args may still mention Tunivars that were + since merged in [uf]. Dereference via [check_etyarg] before + structural comparison. *) + let deref_tc (tc' : typeclass) = + { tc' with tc_args = List.map check_etyarg tc'.tc_args } in let eq_tc (tc' : typeclass) = + let tc' = deref_tc tc' in EcPath.p_equal tc.tc_name tc'.tc_name && List.for_all2 (EcCoreEqTest.for_etyarg env) tc.tc_args tc'.tc_args in @@ -461,6 +468,59 @@ module Unify = struct let strat_infer_by_carrier () : tcwitness option = EcTypeClass.infer env ty tc in + (* Univars appearing in [tc.tc_args] (types and witnesses). + Used both for the Mode-#3 strategy gating and to register + extra parking edges so the problem re-fires when one of + them is resolved later. *) + let etyarg_univars (a, ws) = + let from_ty = Tuni.univars a in + List.fold_left (fun s w -> + TyUni.Suid.union s + (EcTypes.tcw_fold + (fun s t -> TyUni.Suid.union s (Tuni.univars t)) + TyUni.Suid.empty w)) + from_ty ws in + let arg_deps = + List.fold_left (fun s a -> TyUni.Suid.union s (etyarg_univars a)) + TyUni.Suid.empty tc.tc_args in + + (* Mode #3: carrier is a univar; identify a unique matching + instance by [tc.tc_args] (Tunivars on the goal side act + as wildcards), then push a [`TyUni (ty, tci_type)] + equation. The carrier resolution will then re-fire this + TcCtt under Mode #1 and produce the concrete witness. *) + let strat_infer_by_args () : tcwitness option = + match EcTypeClass.candidates_by_args env tc with + | [(Some _, tci, _map)] -> begin + (* Recover the candidate's [tgp.tc_args] (the patterns). *) + let tgargs = + match tci.tci_instance with + | `General (tgp, _) -> tgp.tc_args + | _ -> assert false in + (* Open the candidate's tparams as fresh univars. *) + let inst_subst = + List.fold_left (fun subst (a, _) -> + let (uc', (fresh_ty, _)) = fresh (!uc) in + uc := uc' ; + Mid.add a (fresh_ty, []) subst + ) Mid.empty tci.tci_params in + let tgargs = + List.map (EcCoreSubst.Tvar.subst_etyarg inst_subst) tgargs in + let inst_carrier = + EcCoreSubst.Tvar.subst inst_subst tci.tci_type in + (* Push TyUni equations: each goal arg unifies with the + candidate's substituted arg, and the carrier with + [tci_type]. The unifier binds goal Tunivars to the + corresponding patterns and triggers Mode #1 re-firing + once the carrier is concrete. *) + List.iter2 (fun (gty, _) (pty, _) -> + Queue.push (`TyUni (gty, pty)) pb) + tc.tc_args tgargs; + Queue.push (`TyUni (ty, inst_carrier)) pb; + None (* Defer witness construction; Mode #1 will fire. *) + end + | _ -> None in + (* ---- Dispatch ---- *) if TyUni.Suid.is_empty deps then begin let resolution = @@ -476,15 +536,23 @@ module Unify = struct TcUni.Muid.add uid resolution (!uc).tcenv.resolution } } end else begin - (* Mode #4: carrier has univars; park on each. *) - TyUni.Suid.iter (fun tyvar -> - uc := { !uc with tcenv = { (!uc).tcenv with byunivar = - TyUni.Muid.change (fun map -> - let map = Option.value ~default:TcUni.Suid.empty map in - Some (TcUni.Suid.add uid map) - ) tyvar (!uc).tcenv.byunivar + match strat_infer_by_args () with + | Some witness -> + uc := { !uc with tcenv = { (!uc).tcenv with resolution = + TcUni.Muid.add uid witness (!uc).tcenv.resolution } } - ) deps + | None -> + (* Mode #4: carrier still has univars; park on each. + Also park on [arg_deps] so a later binding of a + typeclass argument re-fires Mode #3. *) + TyUni.Suid.iter (fun tyvar -> + uc := { !uc with tcenv = { (!uc).tcenv with byunivar = + TyUni.Muid.change (fun map -> + let map = Option.value ~default:TcUni.Suid.empty map in + Some (TcUni.Suid.add uid map) + ) tyvar (!uc).tcenv.byunivar + } } + ) (TyUni.Suid.union deps arg_deps) end | `TcTw (w1, w2) -> diff --git a/tests/tc/multi-param-bare-ops.ec b/tests/tc/multi-param-bare-ops.ec new file mode 100644 index 0000000000..ede6843540 --- /dev/null +++ b/tests/tc/multi-param-bare-ops.ec @@ -0,0 +1,36 @@ +require import AllCore. + +(* Mode #3: bare ops on a parametric-carrier multi-parameter typeclass. + The unifier's By-args strategy infers the carrier from the (ground) + type-class arguments when there is a unique matching instance. *) +type class ['a, 'b] embed = { + op proj : embed -> 'a + op inj : 'b -> embed + axiom dummy : true +}. + +(* Concrete instance: pair (int, bool). *) +op proj_pair (p : int * bool) : int = fst p. +op inj_pair (b : bool) : int * bool = (0, b). + +instance (int, bool) embed as pair_inst with (int * bool) + op proj = proj_pair + op inj = inj_pair. + +realize dummy by trivial. + +(* Bare ops: the carrier (int * bool) is inferred from the (int, bool) + embed instance — no explicit tvi needed. *) +op test_bare : int = proj (inj true). + +(* Same shape inside a lemma. *) +lemma round_trip (b : bool) : proj (inj b) = (0, b).`1. +proof. by rewrite /inj_pair /proj_pair. qed. + +(* Even when the user only constrains the result type, the args of the + typeclass propagate from the unique matching instance. *) +op test_proj_only (s : int * bool) : int = proj s. + +(* And when only the source type is fixed: the carrier and target are + inferred from the unique embed instance. *) +op test_inj_only (b : bool) : int * bool = inj b. diff --git a/tests/tc/multi-param.ec b/tests/tc/multi-param.ec index 9ff5d30993..29cb5f50e7 100644 --- a/tests/tc/multi-param.ec +++ b/tests/tc/multi-param.ec @@ -10,7 +10,9 @@ type class ['a, 'b] embed = { forall (x : 'a) (y : 'b), proj (inj y) = x => proj (inj y) = x }. -(* Polymorphic-over-multi-param lemma. *) +(* Polymorphic-over-multi-param lemma. The polymorphic body still needs + an explicit tvi: the carrier is a type parameter ['c], so there is + no concrete instance to drive By-args inference. *) lemma round_trip ['a, 'b, 'c <: ('a, 'b) embed] (x : 'a) (y : 'b) : @@ -28,13 +30,14 @@ instance (int, bool) embed as pair_inst with (int * bool) realize proj_inj by trivial. -(* The instance specializes both type parameters; bare ops require - explicit tvi because the parametric carrier 'self cannot be inferred - from the source/target alone. *) +(* The instance specializes both type parameters. Both forms work: + the helper-op form and the bare TC op form. *) op test_proj : int = proj_pair (inj_pair true). -op test_via_tc : int = proj<:int, bool, (int * bool)> (inj<:int, bool, (int * bool)> true). +op test_via_tc : int = proj (inj true). -(* Polymorphic lemma applied at the concrete instance. *) +(* Polymorphic lemma applied at the concrete instance. The body uses + explicit tvi because the apply target is the polymorphic + [round_trip], not a TC op directly. *) lemma round_trip_int (x : int) (y : bool) : proj<:int, bool, (int * bool)> (inj<:int, bool, (int * bool)> y) = x => proj<:int, bool, (int * bool)> (inj<:int, bool, (int * bool)> y) = x. From 70af95e5199b2a18cae67ad9d21315e81817dac2 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 18:09:57 +0200 Subject: [PATCH 112/113] doc: update typeclasses.md after Phase 3 (bare-op inference now works) Replaces the 'bare-op parametric-carrier inference fails' limitation with the narrower 'polymorphic-body still needs explicit tvi' note. Adds tests/tc/multi-param-bare-ops.ec to the test inventory. --- doc/typeclasses.md | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/doc/typeclasses.md b/doc/typeclasses.md index fa026a508d..454b140c3d 100644 --- a/doc/typeclasses.md +++ b/doc/typeclasses.md @@ -233,14 +233,15 @@ placeholders, abstract carriers, parametric instances). ## Known limitations -### Bare ops on parametric-carrier typeclasses +### Polymorphic-body bare ops on parametric-carrier typeclasses -For `proj : embed -> 'a` and `inj : 'b -> embed` declared on -`('a, 'b) embed`, a bare-op call `proj (inj true)` does not infer the -carrier `'self` automatically because each call generates its own -TcCtt problem with disjoint witness uids; the unifier does not (yet) -share carrier inference across them. Workaround: explicit positional -instantiation, `proj<:int, bool, (int * bool)> ...`. +Inside a polymorphic body — say a lemma `['a, 'b, 'c <: ('a, 'b) embed] +... proj (inj y) ...` — bare ops still need explicit tvi +(`proj<:'a, 'b, 'c>`). The carrier is a type parameter, not a concrete +type, so the By-args strategy (which picks an instance from the +database) does not fire. At ground call sites the carrier is inferred +automatically; see [tests/tc/multi-param-bare-ops.ec](../tests/tc/multi-param-bare-ops.ec) +and [doc/typeclasses-inference.md](typeclasses-inference.md). ### Tuple/function carriers in instance declarations @@ -307,6 +308,7 @@ scenario (`./scripts/testing/runtest --bin=./ec.native config/tests.config unit` | `instance.ec` | Multiple ops/axioms in an instance | | `multi-instance.ec` | Two named instances for one TC at different types | | `multi-param.ec` | `('a, 'b) embed` + polymorphic lemma + instance | +| `multi-param-bare-ops.ec` | Bare-op carrier inference for multi-param TCs | | `parametric.ec` | Parametric TC `['a <: tc] action` | | `print.ec` | `print` does not crash on TC entities | | `section.ec` | Typeclass declared inside a section | From 90f9be794a81d562097e873fe42f9c05d51c6e71 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 30 Apr 2026 20:54:46 +0200 Subject: [PATCH 113/113] Negative TC test infrastructure + ambiguity diagnostic MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - config/tests.config: new test-tc-ko scenario backed by tests/tc-ko/, files there must fail to compile. test-unit excludes the directory. - ecUnify: new exception AmbiguousTcInstance; the By-args strategy raises it when multiple candidate instances disagree on the carrier ([tci_type] differs across candidates). - ecTyping: TypeClassAmbiguous tyerror variant; unify_or_fail catches AmbiguousTcInstance and converts. - ecUserMessages: top-level printer for AmbiguousTcInstance and the typed TypeClassAmbiguous variant. Replaces the previous generic 'free type/typeclass variables' close-time message with a clear list of candidate instance paths. - tests/tc-ko/: three regression tests for negative-typing diagnostics: - bad-tvi.ec — pf_check_tvi rejects [<:int>] for a 'a <: addmonoid tparam - underconstrained-axiom.ec — typeclass body axiom with a free carrier - ambiguous-instance.ec — two distinct instances of (int, bool) embed All 113/113 stdlib + 32/32 unit + 3/3 tc-ko pass. --- config/tests.config | 4 +++ doc/typeclasses.md | 14 +++++++++-- src/ecTyping.ml | 6 ++++- src/ecTyping.mli | 1 + src/ecUnify.ml | 23 +++++++++++++++++- src/ecUnify.mli | 6 +++++ src/ecUserMessages.ml | 16 ++++++++++++ tests/tc-ko/ambiguous-instance.ec | 35 +++++++++++++++++++++++++++ tests/tc-ko/bad-tvi.ec | 23 ++++++++++++++++++ tests/tc-ko/underconstrained-axiom.ec | 19 +++++++++++++++ 10 files changed, 143 insertions(+), 4 deletions(-) create mode 100644 tests/tc-ko/ambiguous-instance.ec create mode 100644 tests/tc-ko/bad-tvi.ec create mode 100644 tests/tc-ko/underconstrained-axiom.ec diff --git a/config/tests.config b/config/tests.config index a530870cdb..2a23f58776 100644 --- a/config/tests.config +++ b/config/tests.config @@ -15,3 +15,7 @@ okdirs = examples/MEE-CBC [test-unit] okdirs = !tests +exclude = tests/tc-ko + +[test-tc-ko] +kodirs = !tests/tc-ko diff --git a/doc/typeclasses.md b/doc/typeclasses.md index 454b140c3d..4c0d5c131c 100644 --- a/doc/typeclasses.md +++ b/doc/typeclasses.md @@ -292,8 +292,10 @@ typeclasses); fix would touch the rewrite engine more broadly. ## Test suite -All under [`tests/tc/`](../tests/tc/). Each is included in the unit-test -scenario (`./scripts/testing/runtest --bin=./ec.native config/tests.config unit`). +Positive tests are under [`tests/tc/`](../tests/tc/) (scenario `unit`); +negative regression tests — files that must fail compilation with a +specific diagnostic — are under [`tests/tc-ko/`](../tests/tc-ko/) +(scenario `tc-ko`). | File | What it covers | |----------------------------|-------------------------------------------------| @@ -309,6 +311,14 @@ scenario (`./scripts/testing/runtest --bin=./ec.native config/tests.config unit` | `multi-instance.ec` | Two named instances for one TC at different types | | `multi-param.ec` | `('a, 'b) embed` + polymorphic lemma + instance | | `multi-param-bare-ops.ec` | Bare-op carrier inference for multi-param TCs | + +Negative tests under `tests/tc-ko/`: + +| File | Asserted error message | +|------------------------------|-------------------------------------------------| +| `bad-tvi.ec` | `type int does not satisfy typeclass constraint addmonoid` | +| `underconstrained-axiom.ec` | `axiom 'tc3_extra' is type-ambiguous: ...` | +| `ambiguous-instance.ec` | `ambiguous typeclass instance for embed; candidates: ...` | | `parametric.ec` | Parametric TC `['a <: tc] action` | | `print.ec` | `print` does not crash on TC entities | | `section.ec` | Typeclass declared inside a section | diff --git a/src/ecTyping.ml b/src/ecTyping.ml index b732685a55..37536915bc 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -139,6 +139,7 @@ type tyerror = | NonUnitFunWithoutReturn | TypeMismatch of (ty * ty) * (ty * ty) | TypeClassMismatch +| TypeClassAmbiguous of typeclass * EcPath.path list | TypeModMismatch of mpath * module_type * tymod_cnv_failure | NotAFunction | NotAnInductive @@ -195,7 +196,10 @@ module UE = EcUnify.UniEnv let unify_or_fail (env : EcEnv.env) ue loc ~expct:ty1 ty2 = try EcUnify.unify env ue ty1 ty2 - with EcUnify.UnificationFailure pb -> + with + | EcUnify.AmbiguousTcInstance (tc, paths) -> + tyerror loc env (TypeClassAmbiguous (tc, paths)) + | EcUnify.UnificationFailure pb -> match pb with | `TyUni (t1, t2)-> let uidmap = UE.assubst ue in diff --git a/src/ecTyping.mli b/src/ecTyping.mli index da425bf7a8..0e0069d6b3 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -132,6 +132,7 @@ type tyerror = | NonUnitFunWithoutReturn | TypeMismatch of (ty * ty) * (ty * ty) | TypeClassMismatch +| TypeClassAmbiguous of typeclass * EcPath.path list | TypeModMismatch of mpath * module_type * tymod_cnv_failure | NotAFunction | NotAnInductive diff --git a/src/ecUnify.ml b/src/ecUnify.ml index bf999d5b05..4dfef47d94 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -7,6 +7,7 @@ open EcAst open EcTypes open EcCoreSubst open EcDecl +open EcTheory module Sp = EcPath.Sp @@ -22,6 +23,7 @@ type uniflags = { tyvars: bool; tcvars: bool; } exception UnificationFailure of problem exception UninstanciateUni of uniflags +exception AmbiguousTcInstance of typeclass * EcPath.path list (* ==================================================================== *) module Unify = struct @@ -490,7 +492,26 @@ module Unify = struct equation. The carrier resolution will then re-fire this TcCtt under Mode #1 and produce the concrete witness. *) let strat_infer_by_args () : tcwitness option = - match EcTypeClass.candidates_by_args env tc with + let cands = EcTypeClass.candidates_by_args env tc in + (* Multiple matches: check whether they agree on the + carrier ([tci_type]). If they do, any of them works; if + they don't, the goal is genuinely ambiguous and no + further unification can decide between them. *) + if List.length cands >= 2 then begin + let carriers = + List.map (fun (_, tci, _) -> tci.tci_type) cands in + let same = + match carriers with + | [] | [_] -> true + | t :: rest -> + List.for_all (fun t' -> + EcCoreEqTest.for_type env t t') rest in + if not same then begin + let paths = List.filter_map (fun (p, _, _) -> p) cands in + raise (AmbiguousTcInstance (tc, paths)) + end + end; + match cands with | [(Some _, tci, _map)] -> begin (* Recover the candidate's [tgp.tc_args] (the patterns). *) let tgargs = diff --git a/src/ecUnify.mli b/src/ecUnify.mli index e205485084..8c83dd8645 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -17,6 +17,12 @@ type uniflags = { tyvars: bool; tcvars: bool; } exception UnificationFailure of problem exception UninstanciateUni of uniflags +(* Raised by the unifier's By-args strategy when a typeclass with + ground arguments has multiple matching instances and no further + unification can disambiguate. The first field is the offending + typeclass; the second is the list of candidate instance paths. *) +exception AmbiguousTcInstance of typeclass * EcPath.path list + type unienv type petyarg = ty option * tcwitness option list option diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 2cee8c036f..9a52f2c484 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -332,6 +332,14 @@ end = struct | TypeClassMismatch -> msg "Type-class unification failure" + | TypeClassAmbiguous (tc, paths) -> + msg "ambiguous typeclass instance for @[%a@]@\n" + (EcPrinting.pp_typeclass env) tc; + msg " candidates:@\n"; + List.iter (fun p -> + msg " %a@\n" (EcPrinting.pp_axname env) p) + paths + | TypeModMismatch(mp, mt, err) -> msg "the module %a does not have the module type %a:@\n" (EcPrinting.pp_topmod env) mp @@ -980,6 +988,14 @@ let pp fmt exn = | EcLowGoal.Apply.NoInstance e -> pp_apply_error fmt e + | EcUnify.AmbiguousTcInstance (tc, paths) -> + Format.fprintf fmt "ambiguous typeclass instance for "; + Format.fprintf fmt "@[%s@]@\n" (EcPath.tostring tc.tc_name); + Format.fprintf fmt " candidates:@\n"; + List.iter (fun p -> + Format.fprintf fmt " %s@\n" (EcPath.tostring p)) + paths + | _ -> raise exn (* -------------------------------------------------------------------- *) diff --git a/tests/tc-ko/ambiguous-instance.ec b/tests/tc-ko/ambiguous-instance.ec new file mode 100644 index 0000000000..6b170a94df --- /dev/null +++ b/tests/tc-ko/ambiguous-instance.ec @@ -0,0 +1,35 @@ +require import AllCore. + +(* Negative: two distinct instances of the same parametric typeclass + match the goal's args. The By-args strategy must report + "ambiguous typeclass instance" rather than degrading to a generic + "free variables" error at close time. *) +type class ['a, 'b] embed = { + op proj : embed -> 'a + op inj : 'b -> embed + axiom dummy : true +}. + +(* First instance: int * bool, with the natural projections. *) +op proj_pair_l (p : int * bool) : int = fst p. +op inj_pair_l (b : bool) : int * bool = (0, b). + +instance (int, bool) embed as pair_inst_l with (int * bool) + op proj = proj_pair_l + op inj = inj_pair_l. + +realize dummy by trivial. + +(* Second instance: bool * int, with swapped projections. Both match + (int, bool) embed. *) +op proj_pair_r (p : bool * int) : int = snd p. +op inj_pair_r (b : bool) : bool * int = (b, 0). + +instance (int, bool) embed as pair_inst_r with (bool * int) + op proj = proj_pair_r + op inj = inj_pair_r. + +realize dummy by trivial. + +(* Bare op: ambiguous, since both instances of (int, bool) embed match. *) +op test_ambiguous : int = proj (inj true). diff --git a/tests/tc-ko/bad-tvi.ec b/tests/tc-ko/bad-tvi.ec new file mode 100644 index 0000000000..d1a3159039 --- /dev/null +++ b/tests/tc-ko/bad-tvi.ec @@ -0,0 +1,23 @@ +require import AllCore. + +(* Negative: a TC-polymorphic lemma is instantiated at a type with no + matching instance. pf_check_tvi must reject this with the typed + error "type int does not satisfy typeclass constraint addmonoid". *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +lemma idm_idem ['a <: addmonoid] (x : 'a) : idm + x = x. +proof. by apply add0m. qed. + +(* No instance for [int]. *) +lemma test : true. +proof. +have := idm_idem<:int> 0. +trivial. +qed. diff --git a/tests/tc-ko/underconstrained-axiom.ec b/tests/tc-ko/underconstrained-axiom.ec new file mode 100644 index 0000000000..5c5d90b714 --- /dev/null +++ b/tests/tc-ko/underconstrained-axiom.ec @@ -0,0 +1,19 @@ +require import AllCore. + +(* Negative: a typeclass body axiom uses a grandparent's TC operator + without pinning the carrier. The typer must reject with the typed + "axiom is type-ambiguous" message rather than the raw + UninstanciateUni anomaly. *) +type class base = { + op zero : base + axiom zero_eq : zero = zero +}. + +type class tc1 <: base = { + op f1 : tc1 -> tc1 + axiom f1_id : forall (x : tc1), f1 x = x +}. + +type class tc3 <: tc1 = { + axiom tc3_extra : zero = zero +}.