From a8975fc4ca6f8457c19dee40ebd3fa5d5d736649 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 6 Jul 2021 16:16:22 +0200 Subject: [PATCH 01/70] 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 02/70] 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 03/70] 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 04/70] 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 05/70] 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 06/70] 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 07/70] 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 08/70] 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 09/70] 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 10/70] --- 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 11/70] --- 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 12/70] 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 13/70] 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 14/70] 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 15/70] 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 16/70] 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 17/70] 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 18/70] 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 19/70] 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 20/70] 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 21/70] 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 22/70] 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 23/70] 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 24/70] 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 25/70] --- 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 26/70] 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 27/70] 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 28/70] 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 29/70] 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 30/70] 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 31/70] 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 32/70] 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 33/70] 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 34/70] 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 35/70] 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 36/70] 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 37/70] 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 38/70] 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 39/70] 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 40/70] 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 41/70] 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 42/70] 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 43/70] 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 44/70] 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 45/70] 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 46/70] 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 47/70] 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 48/70] 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 49/70] 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 50/70] 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 51/70] 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 52/70] 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 53/70] 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 54/70] 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 55/70] 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 56/70] [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 57/70] [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 58/70] 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 59/70] 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 60/70] 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 61/70] 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 62/70] 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 63/70] 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 64/70] 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 65/70] 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 66/70] 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 67/70] 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 68/70] 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 69/70] 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 70/70] 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