From 6f1dee653303245814417c863535dfbe4ef1ada5 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 2 Jun 2023 15:15:44 +0200 Subject: [PATCH 01/63] test for step 0 of CoREACT --- _CoqProject.test-suite | 1 + tests/monoid_law_structure.v | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+) create mode 100644 tests/monoid_law_structure.v diff --git a/_CoqProject.test-suite b/_CoqProject.test-suite index 98c20167e..80c32c4af 100644 --- a/_CoqProject.test-suite +++ b/_CoqProject.test-suite @@ -80,6 +80,7 @@ tests/hnf.v tests/fun_instance.v tests/issue284.v tests/issue287.v +tests/monoid_law_structure.v -R tests HB.tests -R examples HB.examples diff --git a/tests/monoid_law_structure.v b/tests/monoid_law_structure.v new file mode 100644 index 000000000..e43439164 --- /dev/null +++ b/tests/monoid_law_structure.v @@ -0,0 +1,18 @@ +From HB Require Import structures. + +HB.mixin Record isMonLaw T (e : T) (op : T -> T -> T) := { + opmA : forall a b c, op (op a b) c = op a (op b c); + op1m : forall x, op e x = x; + opm1 : forall x, op x e = x; +}. + +HB.structure Definition MonLaw T e := { op of isMonLaw T e op }. + +HB.mixin Record isPreMonoid T := { + zero : T; + add : T -> T -> T; +}. +HB.structure Definition PreMonoid := { T of isPreMonoid T }. + +HB.structure Definition Monoid := + { T of isPreMonoid T & isMonLaw T zero add }. From 1ceb6ea4c9e46836f37f712aaa1918db485309e2 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 2 Jun 2023 15:38:25 +0200 Subject: [PATCH 02/63] update --- tests/monoid_law_structure.v | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/monoid_law_structure.v b/tests/monoid_law_structure.v index e43439164..3d6f8e0d5 100644 --- a/tests/monoid_law_structure.v +++ b/tests/monoid_law_structure.v @@ -15,4 +15,6 @@ HB.mixin Record isPreMonoid T := { HB.structure Definition PreMonoid := { T of isPreMonoid T }. HB.structure Definition Monoid := - { T of isPreMonoid T & isMonLaw T zero add }. + { T of isPreMonoid T & + isMonLaw T zero add }. + (* isMonLaw T (@zero (PreMonoid.clone T _)) (@add (PreMonoid.clone T _))*) From f6c1970f4748fcff2fe4b1234ef3fb158d72e173 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 2 Jun 2023 15:52:10 +0200 Subject: [PATCH 03/63] more --- _CoqProject.test-suite | 1 + tests/monoid_law_structure.v | 4 +--- tests/monoid_law_structure_clone.v | 19 +++++++++++++++++++ 3 files changed, 21 insertions(+), 3 deletions(-) create mode 100644 tests/monoid_law_structure_clone.v diff --git a/_CoqProject.test-suite b/_CoqProject.test-suite index 80c32c4af..9661f9ac8 100644 --- a/_CoqProject.test-suite +++ b/_CoqProject.test-suite @@ -81,6 +81,7 @@ tests/fun_instance.v tests/issue284.v tests/issue287.v tests/monoid_law_structure.v +tests/monoid_law_structure_clone.v -R tests HB.tests -R examples HB.examples diff --git a/tests/monoid_law_structure.v b/tests/monoid_law_structure.v index 3d6f8e0d5..b78f06c69 100644 --- a/tests/monoid_law_structure.v +++ b/tests/monoid_law_structure.v @@ -15,6 +15,4 @@ HB.mixin Record isPreMonoid T := { HB.structure Definition PreMonoid := { T of isPreMonoid T }. HB.structure Definition Monoid := - { T of isPreMonoid T & - isMonLaw T zero add }. - (* isMonLaw T (@zero (PreMonoid.clone T _)) (@add (PreMonoid.clone T _))*) + { T of isPreMonoid T & isMonLaw T zero add }. diff --git a/tests/monoid_law_structure_clone.v b/tests/monoid_law_structure_clone.v new file mode 100644 index 000000000..5df341567 --- /dev/null +++ b/tests/monoid_law_structure_clone.v @@ -0,0 +1,19 @@ +From HB Require Import structures. + +HB.mixin Record isMonLaw T (e : T) (op : T -> T -> T) := { + opmA : forall a b c, op (op a b) c = op a (op b c); + op1m : forall x, op e x = x; + opm1 : forall x, op x e = x; +}. + +HB.structure Definition MonLaw T e := { op of isMonLaw T e op }. + +HB.mixin Record isPreMonoid T := { + zero : T; + add : T -> T -> T; +}. +HB.structure Definition PreMonoid := { T of isPreMonoid T }. + +HB.structure Definition Monoid := + { T of isPreMonoid T & + isMonLaw T (@zero (PreMonoid.clone T _)) (@add (PreMonoid.clone T _)) }. From 17d6561596115b759fa5c317a7e03cbca9342a33 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 2 Jun 2023 16:18:01 +0200 Subject: [PATCH 04/63] more --- tests/monoid_enriched_cat.v | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 tests/monoid_enriched_cat.v diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v new file mode 100644 index 000000000..f0552a4e9 --- /dev/null +++ b/tests/monoid_enriched_cat.v @@ -0,0 +1,37 @@ +From HB Require Import structures. +From Coq Require Import ssreflect ssrfun. + +HB.mixin Record isQuiver Obj := { hom : Obj -> Obj -> Type }. + +HB.structure Definition Quiver := { Obj of isQuiver Obj }. + +HB.mixin Record isMon A := { + zero : A; + add : A -> A -> A; + addrA : associative add; + add0r : left_id zero add; + addr0 : right_id zero add; + }. + +HB.structure + Definition Monoid := { A of isMon A }. + +Fail HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & + (forall A B : Obj, isMon (@hom (Quiver.clone Obj _) A B)) }. + + +HB.mixin Record hom_isMon T of Quiver T := + { private : forall A B, isMon (@hom T A B) }. + +HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon Obj }. + +HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := + @private T A B. + + (* each instance of isMon should be tried as an instance of hom_isMon *) + + From d2bc00fb29bec805195af4123a8c44594cc09d19 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Mon, 19 Jun 2023 16:07:25 +0200 Subject: [PATCH 05/63] Update tests/monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index f0552a4e9..4aa63cd87 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -34,4 +34,9 @@ HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@h (* each instance of isMon should be tried as an instance of hom_isMon *) - +HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). +Fail HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). +(* This last command should create a `Monoid_enriched_quiver`, in order to do so it should + automatically instanciate the wrapper `hom_isMon`: + HB.instance Definition _ := hom_isMon.Build Type homTypeMon. + *) From 6726472407ef61191d663e32f08a625ed8de3564 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Mon, 19 Jun 2023 16:10:12 +0200 Subject: [PATCH 06/63] Update tests/monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 4aa63cd87..2a380990d 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -25,6 +25,9 @@ Fail HB.structure HB.mixin Record hom_isMon T of Quiver T := { private : forall A B, isMon (@hom T A B) }. +(* Step 2: at structure declaration, export the main and only projection + of each declared wrapper as an instance of the wrapped structure on + its subject *) HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & hom_isMon Obj }. From 0821793a406d2d5a725622c5cd1b381ad950a0f3 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Mon, 19 Jun 2023 16:10:18 +0200 Subject: [PATCH 07/63] Update tests/monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 2a380990d..7b00b8913 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -22,6 +22,14 @@ Fail HB.structure (forall A B : Obj, isMon (@hom (Quiver.clone Obj _) A B)) }. +(* Step 0: define a wrapper predicate in coq-elpi *) +(* Step 1: add a wrapper attribute to declare wrappers, + they should index: + - the wrapped mixin (`isMon`) + - the wrapper mixin (`hom_isMon`) + - the new subject (`hom`) + *) +#[wrapper] HB.mixin Record hom_isMon T of Quiver T := { private : forall A B, isMon (@hom T A B) }. From 234e3f5d3b354ec0e849600f8507adccf06e59d6 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Mon, 19 Jun 2023 16:11:38 +0200 Subject: [PATCH 08/63] Update tests/monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 7b00b8913..16dc0091b 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -45,6 +45,8 @@ HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@h (* each instance of isMon should be tried as an instance of hom_isMon *) +(* Step 3: for each instance of a wrapped mixin on a subject known + to be wrapped, automatically produce an instance of the wrapper mixin too. *) HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). Fail HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). (* This last command should create a `Monoid_enriched_quiver`, in order to do so it should From 92e1f685272a9817754121a719cf1b8816722d28 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Mon, 19 Jun 2023 16:24:58 +0200 Subject: [PATCH 09/63] Update tests/monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 16dc0091b..20e2dd2e3 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -23,6 +23,9 @@ Fail HB.structure (* Step 0: define a wrapper predicate in coq-elpi *) +(* 5 lines of documentation + 1 line of elpi code in structure.v + `pred wrapper-mixin o:mixinname, o:gref, o:mixinname` +*) (* Step 1: add a wrapper attribute to declare wrappers, they should index: - the wrapped mixin (`isMon`) From b7f37892933bdc1f959beea4c4b3670875f9025d Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Mon, 19 Jun 2023 16:27:52 +0200 Subject: [PATCH 10/63] Update tests/monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 20e2dd2e3..002d1f506 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -31,6 +31,9 @@ Fail HB.structure - the wrapped mixin (`isMon`) - the wrapper mixin (`hom_isMon`) - the new subject (`hom`) + This attribute will add an entry in the `wrapper-mixin` database. + As an addition substep, we should check that the wrapper has + exactly one field, which is the wrapped mixin. *) #[wrapper] HB.mixin Record hom_isMon T of Quiver T := From 80e17f226da5286ecc8bd85992fbbbf7ce9da262 Mon Sep 17 00:00:00 2001 From: ptorrini Date: Mon, 19 Jun 2023 17:11:00 +0200 Subject: [PATCH 11/63] added enriched_cat.v --- tests/enriched_cat.v | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 tests/enriched_cat.v diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v new file mode 100644 index 000000000..c909e155e --- /dev/null +++ b/tests/enriched_cat.v @@ -0,0 +1,3 @@ +(* testing enriched categories *) + + From 314c6b993134301e7fe9a6313fb16f93ad88bcc3 Mon Sep 17 00:00:00 2001 From: ptorrini Date: Mon, 19 Jun 2023 20:52:14 +0200 Subject: [PATCH 12/63] copied Cyril's monoid_enriched_cat.v to enriched_cat.v --- tests/enriched_cat.v | 71 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index c909e155e..80f6d38a6 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -1,3 +1,74 @@ (* testing enriched categories *) +From HB Require Import structures. +From Coq Require Import ssreflect ssrfun. + +HB.mixin Record isQuiver Obj := { hom : Obj -> Obj -> Type }. + +HB.structure Definition Quiver := { Obj of isQuiver Obj }. + +HB.mixin Record isMon A := { + zero : A; + add : A -> A -> A; + addrA : associative add; + add0r : left_id zero add; + addr0 : right_id zero add; + }. + +HB.structure + Definition Monoid := { A of isMon A }. + +(**) +HB.mixin Record hom_isMonT T of Quiver T := + { private : forall A B, isMon (@hom T A B) }. + +HB.structure + Definition Monoid_enriched_quiverT := + { Obj of isQuiver Obj & hom_isMonT Obj }. + +(**) + + +Fail HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & + (forall A B : Obj, isMon (@hom (Quiver.clone Obj _) A B)) }. + +(* Step 0: define a wrapper predicate in coq-elpi *) +(* 5 lines of documentation + 1 line of elpi code in structure.v + `pred wrapper-mixin o:mixinname, o:gref, o:mixinname` +*) +(* Step 1: add a wrapper attribute to declare wrappers, + they should index: + - the wrapped mixin (`isMon`) + - the wrapper mixin (`hom_isMon`) + - the new subject (`hom`) + This attribute will add an entry in the `wrapper-mixin` database. + As an addition substep, we should check that the wrapper has + exactly one field, which is the wrapped mixin. + *) +#[wrapper] +HB.mixin Record hom_isMon T of Quiver T := + { private : forall A B, isMon (@hom T A B) }. + +(* Step 2: at structure declaration, export the main and only projection + of each declared wrapper as an instance of the wrapped structure on + its subject *) +HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon Obj }. + +HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : + isMon (@hom T A B) := @private T A B. + + (* each instance of isMon should be tried as an instance of hom_isMon *) + +(* Step 3: for each instance of a wrapped mixin on a subject known + to be wrapped, automatically produce an instance of the wrapper mixin too. *) +HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). +Fail HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). +(* This last command should create a `Monoid_enriched_quiver`, in order to do so it should + automatically instanciate the wrapper `hom_isMon`: + HB.instance Definition _ := hom_isMon.Build Type homTypeMon. + *) From 67526eb2073232ee21562d866a40f570bca175b4 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 20 Jun 2023 20:05:37 +0200 Subject: [PATCH 13/63] added monoid_enriched_cat.v as the original pull request by Cyril, inconclusively modified enriched_cat.v (the version I'm working on) --- tests/enriched_cat.v | 94 +++++++++++++++++++++++++++++++++++++++----- 1 file changed, 84 insertions(+), 10 deletions(-) diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index 80f6d38a6..bd61296e2 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -3,11 +3,11 @@ From HB Require Import structures. From Coq Require Import ssreflect ssrfun. -HB.mixin Record isQuiver Obj := { hom : Obj -> Obj -> Type }. +HB.mixin Record isQuiver (Obj: Type) : Type := { hom : Obj -> Obj -> Type }. -HB.structure Definition Quiver := { Obj of isQuiver Obj }. +HB.structure Definition Quiver : Type := { Obj of isQuiver Obj }. -HB.mixin Record isMon A := { +HB.mixin Record isMon (A: Type) : Type := { zero : A; add : A -> A -> A; addrA : associative add; @@ -16,20 +16,94 @@ HB.mixin Record isMon A := { }. HB.structure - Definition Monoid := { A of isMon A }. + Definition Monoid : Type := { A of isMon A }. -(**) -HB.mixin Record hom_isMonT T of Quiver T := +HB.mixin Record hom_isMon T of Quiver T := { private : forall A B, isMon (@hom T A B) }. HB.structure - Definition Monoid_enriched_quiverT := - { Obj of isQuiver Obj & hom_isMonT Obj }. + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon Obj }. + +(* unique projection from the axiom of Monoid_enriched_quiver *) +HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := + @private T A B. + +HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). + + +(*********) + +HB.mixin Record hom_isMonX T of Quiver T : Type := + { private : forall A B, isMon (@hom T A B) }. + +HB.structure + Definition Monoid_enriched_quiverX := + { Obj of isQuiver Obj & hom_isMonX Obj }. + +Record isQuiverS (Obj: Type) : Type := { homS : Obj -> Obj -> Type }. + +Structure QuiverS := { ObjS: Type; AxS: isQuiverS ObjS }. + +Definition hom_isMon_type T (X: isQuiverS T) (A B: T) : Type := + isMon (@homS T X A B). + +Record hom_isMonQ T (X: isQuiverS T) : Type := + hiMQ { privateQ : forall (A B: T), hom_isMon_type T X A B }. + +Definition my_hom_isMonQ T (X: isQuiverS T) (F: forall A B, hom_isMon_type T X A B) : + hom_isMonQ T X := hiMQ T X F. + +Record Monoid_enriched_quiverQ := { ObjQ: Type; iQQ: isQuiverS ObjQ; hsM: hom_isMonQ ObjQ iQQ }. + +Record hom_wrapper T (X: isQuiverS T) (Str: Type -> Type) : Type := + { privateW : forall (A B: T), Str (@homS T X A B) }. -(**) +Record hom_wrapperA T (Qv: Type -> Type) (hm: Qv T -> T -> T -> Type) (Str: Type -> Type) (x: Qv T) : Type := + { privateWA : forall (A B: T), Str (hm x A B) }. +Definition my_quiver (T: Type) : isQuiverS T. +Admitted. -Fail HB.structure +Lemma my_quiver_mon (T: Type) : forall (A B: T), isMon (@homS T (my_quiver T) A B). +Admitted. + +Definition my_hom_isMon (T: Type) : hom_isMonQ T (my_quiver T) := + my_hom_isMonQ T (my_quiver T) (my_quiver_mon T). + +Definition Mixin : Type := Type -> Type. + +(* write two versions of Monoid_enriched_quiver: one using hom_isMon +(a mixin, hence a record), the other one using hom_isMon_type as naked +field type. The former corresponds to the wrapped version, the latter +to the intuitive, wrapper-less version. Now the latter should agree +with the former... (broadly corresponding to 2?) *) + + + +Lemma quiver_ok (T: Type) (Str: Type -> Type) : + forall (A B: T), @homS (my_quiver T) A B + + +Class wrapper (T: Type) () (P: T -> T -> Prop) { prop: forall A B: T, P A B }. + +Definition wrapped_hom (T: Type) (F: isMon (@hom T A B)) := wrapper T (isMon (@hom T)) + + +Elpi Accumulate lp:{{ + + pred wrapper-mixin o:mixinname, o:gref, o:mixinname. + +}}. + + + +HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). + +(*********) + + +HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & (forall A B : Obj, isMon (@hom (Quiver.clone Obj _) A B)) }. From a3bcee5fe039ced428bf112723accfd1aa639c4d Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 21 Jun 2023 13:42:39 +0200 Subject: [PATCH 14/63] add enriched_cat to _CoqProject --- _CoqProject.test-suite | 1 + 1 file changed, 1 insertion(+) diff --git a/_CoqProject.test-suite b/_CoqProject.test-suite index 9661f9ac8..baea129a3 100644 --- a/_CoqProject.test-suite +++ b/_CoqProject.test-suite @@ -82,6 +82,7 @@ tests/issue284.v tests/issue287.v tests/monoid_law_structure.v tests/monoid_law_structure_clone.v +tests/enriched_cat.v -R tests HB.tests -R examples HB.examples From f472ce6e5922e607a81066aa7a464d79b512d3db Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 21 Jun 2023 13:46:37 +0200 Subject: [PATCH 15/63] changes to enriched_cat.v --- tests/enriched_cat.v | 84 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 83 insertions(+), 1 deletion(-) diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index bd61296e2..429843226 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -18,13 +18,95 @@ HB.mixin Record isMon (A: Type) : Type := { HB.structure Definition Monoid : Type := { A of isMon A }. -HB.mixin Record hom_isMon T of Quiver T := +HB.mixin Record hom_isMon0 T of Quiver T := { private : forall A B, isMon (@hom T A B) }. +Definition hom_isMon_ty {T} (H: T -> T -> Type) (A B: T) : + Type := isMon (H A B). + +HB.mixin Record hom_isMon1 T of Quiver T := + { private : forall A B, hom_isMon_ty (@hom (Quiver.clone T _)) A B }. + +(* related to the wrapper attribute? *) +Definition hom_isM_ty {T} (H: T -> T -> Type) (M: Type -> Type) (A B: T) : + Type := M (H A B). + +(* three parameter version *) +Definition wrapper_spec {T} (H: T -> T -> Type) (M HM: Type -> Type) : + Prop := HM T = forall A B, hom_isM_ty H M A B. + + +HB.mixin Record hom_isMon2 T of Quiver T := + { private : forall A B, hom_isM_ty (@hom (Quiver.clone T _)) + (fun X => isMon X) + A B }. + +Fail HB.mixin Record hom_isM T (M: Type -> Type) of Quiver T := + { private : forall (A B: T), @hom_isM_ty T (@hom (Quiver.clone T _)) + M + A B }. + +HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon2 Obj }. + +(******************) + +HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : + isMon (@hom T A B) := + @private T A B. + +HB.instance Definition funQ := isQuiver.Build Type (fun A B => A -> B). + +Definition funQ_isMonF (A B: Type) : isMon (A -> B). +Admitted. + +HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> B) := + funQ_isMonF A B. + +HB.instance Definition _ := hom_isMon2.Build Type (fun A B => funQ_isMon A B). + +(********************) + +(* without HB *) +Record isQuiverS (Obj: Type) : Type := { homS : Obj -> Obj -> Type }. + +(* without HB: trype-checks, trivially... *) +Structure Monoid_enriched_quiverN := { + ObjN: Type; + iQ: isQuiverS ObjN; + hsM: forall A B, hom_isM_ty (homS ObjN iQ) + (fun X => isMon X) A B }. + +(* mixing with HB doesn't work *) +Fail Record Monoid_enriched_quiverN1 := { + ObjN: Type; + iQ: isQuiver ObjN; + hsM: forall A B, hom_isM_ty (@hom iQ) + (fun X => isMon X) A B }. + + +(*************************************) +(** GARBAGE FOLLOWS ************************) + + +HB.mixin Record hom_isM T (M: Type -> Type) of Quiver T := + { private : forall (A B: T), @hom_isM_ty T (@hom (Quiver.clone T _)) + M + A B }. + + + HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & hom_isMon Obj }. + +Definition hom_isMon_ty2 {T} (F: T -> T -> Type) := hom_isP_ty F + (fun X => isMon X). + + + (* unique projection from the axiom of Monoid_enriched_quiver *) HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := @private T A B. From b3ba8c19cf0ea09415889dd16c8881602c3805f1 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 21 Jun 2023 21:08:33 +0200 Subject: [PATCH 16/63] changes related to monoid_enriched_cat.v and wrappers in various files. changes in enriched_cat.v --- HB/common/utils.elpi | 1 + HB/factory.elpi | 23 ++++- _CoqProject.test-suite | 1 + structures.v | 7 ++ tests/enriched_cat.v | 187 ++++++------------------------------ tests/monoid_enriched_cat.v | 15 ++- 6 files changed, 75 insertions(+), 159 deletions(-) diff --git a/HB/common/utils.elpi b/HB/common/utils.elpi index 000826a2a..4b2a6816a 100644 --- a/HB/common/utils.elpi +++ b/HB/common/utils.elpi @@ -44,6 +44,7 @@ with-attributes P :- att "primitive" bool, att "non_forgetful_inheritance" bool, att "hnf" bool, + att "wrapper" bool, ] Opts, !, Opts => (save-docstring, P). diff --git a/HB/factory.elpi b/HB/factory.elpi index 2b599df10..79b93af85 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -192,6 +192,7 @@ mk-factory-abbrev Str GR Aliases FactAbbrev :- !, std.do! [ pred declare-asset i:argument, i:asset. declare-asset Arg AssetKind :- std.do! [ argument-name Arg Module, + if-verbose (coq.say {header} "start module and section" Module), log.coq.env.begin-module Module none, log.coq.env.begin-section Module, @@ -232,6 +233,7 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance % coq.say RDecl RDeclClosed, + if (get-option "primitive" tt) (@primitive! => log.coq.env.add-indt RDeclClosed R) (log.coq.env.add-indt RDeclClosed R), @@ -250,6 +252,25 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance build-deps-for-projections R MLwP GRDepsClausesProjs, GRDepsClauses = [gref-deps (indt R) MLwP, gref-deps (indc K) MLwP|GRDepsClausesProjs], + coq.say "TODO: extract useful info:" RDecl, + % record-decl in https://github.com/LPCIC/coq-elpi/blob/master/coq-builtin.elpi#L429 + % per trovare il vero nome del mixin database.elpi:factory-alias->gref + % per sapere quanti argomenti skippare prima del soggetto del mixin + % factory-nparams + % + % in generale hai: + % forall ....., app[mixin_alias, p1 ... pn | [ app[subject, ...] , extra]] + % mixin_alias -> mixin via factory-alias->gref + % factory-nparams mixin -> n + % + + if (get-option "wrapper" tt) + ((factory-alias->gref (indt R) X), + (WrapperClauses = [wrapper-mixin X (indt R) (indt R)])) + (WrapperClauses = []), + + coq.say "aggiungiamo " WrapperClauses, + % GRDepsClauses => mk-factory-sort MLwP (indt R) _ FactorySortCoe, % FactorySortCoe = coercion GRFSort _ _ _, @@ -271,7 +292,7 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance if-verbose (coq.say {header} "start module Exports"), log.coq.env.begin-module "Exports" none, - std.flatten [Clauses, GRDepsClauses, [ + std.flatten [Clauses, GRDepsClauses, WrapperClauses, [ factory-constructor (indt R) GRK, factory-nparams (indt R) NParams, factory-builder-nparams BuildConst NParams, diff --git a/_CoqProject.test-suite b/_CoqProject.test-suite index baea129a3..4eae43b8b 100644 --- a/_CoqProject.test-suite +++ b/_CoqProject.test-suite @@ -83,6 +83,7 @@ tests/issue287.v tests/monoid_law_structure.v tests/monoid_law_structure_clone.v tests/enriched_cat.v +tests/monoid_enriched_cat.v -R tests HB.tests -R examples HB.examples diff --git a/structures.v b/structures.v index 30c9015f4..cefe521d4 100644 --- a/structures.v +++ b/structures.v @@ -159,6 +159,13 @@ pred join o:classname, o:classname, o:classname. % in order to discover two mixins are the same) pred mixin-mem i:term, o:gref. +% [wrapper-mixin Wrapper NewSubject WrappedMixin] +% #[wrapper] HB.mixin Record hom_isMon T of Quiver T := +% { private : forall A B, isMon (@hom T A B) }. +% --> +% wrapper-mixin (indt "hom_isMon") (const "hom") (indt "isMon"). +pred wrapper-mixin o:mixinname, o:gref, o:mixinname. + %%%%%% Memory of exported mixins (HB.structure) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Operations (named mixin fields) need to be exported exactly once, % but the same mixin can be used in many structure, hence this memory diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index 429843226..f8fe6c85e 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -18,67 +18,84 @@ HB.mixin Record isMon (A: Type) : Type := { HB.structure Definition Monoid : Type := { A of isMon A }. -HB.mixin Record hom_isMon0 T of Quiver T := +(* original wrapper *) +HB.mixin Record hom_isMon T of Quiver T := { private : forall A B, isMon (@hom T A B) }. +(* just an abbreviation with a parameter for homset *) Definition hom_isMon_ty {T} (H: T -> T -> Type) (A B: T) : Type := isMon (H A B). +(* write two versions of Monoid_enriched_quiver: one using hom_isMon +(a mixin, hence a record), the other one using hom_isMon_ty as naked +field type. The former corresponds to the wrapped version, the latter +to the intuitive, wrapper-less version. Now the latter should agree +with the former... (broadly corresponding to 2?) *) + +(* alternative wrapper definition *) HB.mixin Record hom_isMon1 T of Quiver T := { private : forall A B, hom_isMon_ty (@hom (Quiver.clone T _)) A B }. -(* related to the wrapper attribute? *) +(* abbreviation with parameters for homset and monoid *) Definition hom_isM_ty {T} (H: T -> T -> Type) (M: Type -> Type) (A B: T) : Type := M (H A B). -(* three parameter version *) +(* three parameter relation *) Definition wrapper_spec {T} (H: T -> T -> Type) (M HM: Type -> Type) : Prop := HM T = forall A B, hom_isM_ty H M A B. - +(* one more wrapper definition (no real change) *) HB.mixin Record hom_isMon2 T of Quiver T := { private : forall A B, hom_isM_ty (@hom (Quiver.clone T _)) (fun X => isMon X) A B }. -Fail HB.mixin Record hom_isM T (M: Type -> Type) of Quiver T := +(* trying parametric definition however doesn't work *) +Fail HB.mixin Record hom_isM2 T (M: Type -> Type) of Quiver T := { private : forall (A B: T), @hom_isM_ty T (@hom (Quiver.clone T _)) M A B }. -HB.structure - Definition Monoid_enriched_quiver := +(* structure based on one of the wrappers *) +HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & hom_isMon2 Obj }. (******************) +(* unique projection from the wrapper *) HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : - isMon (@hom T A B) := - @private T A B. + isMon (@hom T A B) := @private T A B. +(* quiver instance (simply typed functions between two types) *) HB.instance Definition funQ := isQuiver.Build Type (fun A B => A -> B). -Definition funQ_isMonF (A B: Type) : isMon (A -> B). +(* prove that for every two types the quiver is a monoid *) +Lemma funQ_isMonF (A B: Type) : isMon (A -> B). Admitted. - + +(* use the lemma to instantiate isMon *) HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> B) := funQ_isMonF A B. -HB.instance Definition _ := hom_isMon2.Build Type (fun A B => funQ_isMon A B). +(* use the generic isMon instance to instantiate 'private' *) +HB.instance Definition funQ_hom_isMon := + hom_isMon2.Build Type (fun A B => funQ_isMon A B). + +(* HB.instance Definition _ := Monoid_enriched_quiver.Build ... *) (********************) (* without HB *) Record isQuiverS (Obj: Type) : Type := { homS : Obj -> Obj -> Type }. -(* without HB: trype-checks, trivially... *) +(* structure without wrapper and out of HB, trivially type-checks *) Structure Monoid_enriched_quiverN := { ObjN: Type; iQ: isQuiverS ObjN; hsM: forall A B, hom_isM_ty (homS ObjN iQ) (fun X => isMon X) A B }. -(* mixing with HB doesn't work *) +(* but mixing with HB doesn't work *) Fail Record Monoid_enriched_quiverN1 := { ObjN: Type; iQ: isQuiver ObjN; @@ -86,145 +103,3 @@ Fail Record Monoid_enriched_quiverN1 := { (fun X => isMon X) A B }. -(*************************************) -(** GARBAGE FOLLOWS ************************) - - -HB.mixin Record hom_isM T (M: Type -> Type) of Quiver T := - { private : forall (A B: T), @hom_isM_ty T (@hom (Quiver.clone T _)) - M - A B }. - - - -HB.structure - Definition Monoid_enriched_quiver := - { Obj of isQuiver Obj & hom_isMon Obj }. - - -Definition hom_isMon_ty2 {T} (F: T -> T -> Type) := hom_isP_ty F - (fun X => isMon X). - - - -(* unique projection from the axiom of Monoid_enriched_quiver *) -HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := - @private T A B. - -HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). - - -(*********) - -HB.mixin Record hom_isMonX T of Quiver T : Type := - { private : forall A B, isMon (@hom T A B) }. - -HB.structure - Definition Monoid_enriched_quiverX := - { Obj of isQuiver Obj & hom_isMonX Obj }. - -Record isQuiverS (Obj: Type) : Type := { homS : Obj -> Obj -> Type }. - -Structure QuiverS := { ObjS: Type; AxS: isQuiverS ObjS }. - -Definition hom_isMon_type T (X: isQuiverS T) (A B: T) : Type := - isMon (@homS T X A B). - -Record hom_isMonQ T (X: isQuiverS T) : Type := - hiMQ { privateQ : forall (A B: T), hom_isMon_type T X A B }. - -Definition my_hom_isMonQ T (X: isQuiverS T) (F: forall A B, hom_isMon_type T X A B) : - hom_isMonQ T X := hiMQ T X F. - -Record Monoid_enriched_quiverQ := { ObjQ: Type; iQQ: isQuiverS ObjQ; hsM: hom_isMonQ ObjQ iQQ }. - -Record hom_wrapper T (X: isQuiverS T) (Str: Type -> Type) : Type := - { privateW : forall (A B: T), Str (@homS T X A B) }. - -Record hom_wrapperA T (Qv: Type -> Type) (hm: Qv T -> T -> T -> Type) (Str: Type -> Type) (x: Qv T) : Type := - { privateWA : forall (A B: T), Str (hm x A B) }. - -Definition my_quiver (T: Type) : isQuiverS T. -Admitted. - -Lemma my_quiver_mon (T: Type) : forall (A B: T), isMon (@homS T (my_quiver T) A B). -Admitted. - -Definition my_hom_isMon (T: Type) : hom_isMonQ T (my_quiver T) := - my_hom_isMonQ T (my_quiver T) (my_quiver_mon T). - -Definition Mixin : Type := Type -> Type. - -(* write two versions of Monoid_enriched_quiver: one using hom_isMon -(a mixin, hence a record), the other one using hom_isMon_type as naked -field type. The former corresponds to the wrapped version, the latter -to the intuitive, wrapper-less version. Now the latter should agree -with the former... (broadly corresponding to 2?) *) - - - -Lemma quiver_ok (T: Type) (Str: Type -> Type) : - forall (A B: T), @homS (my_quiver T) A B - - -Class wrapper (T: Type) () (P: T -> T -> Prop) { prop: forall A B: T, P A B }. - -Definition wrapped_hom (T: Type) (F: isMon (@hom T A B)) := wrapper T (isMon (@hom T)) - - -Elpi Accumulate lp:{{ - - pred wrapper-mixin o:mixinname, o:gref, o:mixinname. - -}}. - - - -HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). - -(*********) - - -HB.structure - Definition Monoid_enriched_quiver := - { Obj of isQuiver Obj & - (forall A B : Obj, isMon (@hom (Quiver.clone Obj _) A B)) }. - -(* Step 0: define a wrapper predicate in coq-elpi *) -(* 5 lines of documentation + 1 line of elpi code in structure.v - `pred wrapper-mixin o:mixinname, o:gref, o:mixinname` -*) -(* Step 1: add a wrapper attribute to declare wrappers, - they should index: - - the wrapped mixin (`isMon`) - - the wrapper mixin (`hom_isMon`) - - the new subject (`hom`) - This attribute will add an entry in the `wrapper-mixin` database. - As an addition substep, we should check that the wrapper has - exactly one field, which is the wrapped mixin. - *) -#[wrapper] -HB.mixin Record hom_isMon T of Quiver T := - { private : forall A B, isMon (@hom T A B) }. - -(* Step 2: at structure declaration, export the main and only projection - of each declared wrapper as an instance of the wrapped structure on - its subject *) -HB.structure - Definition Monoid_enriched_quiver := - { Obj of isQuiver Obj & hom_isMon Obj }. - -HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : - isMon (@hom T A B) := @private T A B. - - (* each instance of isMon should be tried as an instance of hom_isMon *) - -(* Step 3: for each instance of a wrapped mixin on a subject known - to be wrapped, automatically produce an instance of the wrapper mixin too. *) -HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). -Fail HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). -(* This last command should create a `Monoid_enriched_quiver`, in order to do so it should - automatically instanciate the wrapper `hom_isMon`: - HB.instance Definition _ := hom_isMon.Build Type homTypeMon. - *) - diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 002d1f506..10fefecb9 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -34,11 +34,22 @@ Fail HB.structure This attribute will add an entry in the `wrapper-mixin` database. As an addition substep, we should check that the wrapper has exactly one field, which is the wrapped mixin. - *) + *) + +(* added wrapper attribute in coq-builtin.elpi. + added pred wrapper-mixin in structures.v. + added conditional rule for wrapper-mixin in factory.elpi. + tentative use of factory-alias->gref, but the parameters + aren't right yet -- see HB.structure.html. +*) #[wrapper] HB.mixin Record hom_isMon T of Quiver T := { private : forall A B, isMon (@hom T A B) }. - + +Elpi Print HB.structure. + +stop. + (* Step 2: at structure declaration, export the main and only projection of each declared wrapper as an instance of the wrapped structure on its subject *) From 9f0bde57a39860fb0c5b8a4933f72796151a181b Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 22 Jun 2023 09:55:29 +0200 Subject: [PATCH 17/63] change to enriched_cat.v --- HB/factory.elpi | 4 ++-- tests/enriched_cat.v | 10 ++++++---- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/HB/factory.elpi b/HB/factory.elpi index 79b93af85..02287e972 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -265,8 +265,8 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance % if (get-option "wrapper" tt) - ((factory-alias->gref (indt R) X), - (WrapperClauses = [wrapper-mixin X (indt R) (indt R)])) +% ((factory-alias->gref (indt R) X), + (WrapperClauses = [wrapper-mixin (indt R) (indt R) (indt R)]) (WrapperClauses = []), coq.say "aggiungiamo " WrapperClauses, diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index f8fe6c85e..bceefd718 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -95,11 +95,13 @@ Structure Monoid_enriched_quiverN := { hsM: forall A B, hom_isM_ty (homS ObjN iQ) (fun X => isMon X) A B }. +About hom. + (* but mixing with HB doesn't work *) -Fail Record Monoid_enriched_quiverN1 := { - ObjN: Type; - iQ: isQuiver ObjN; - hsM: forall A B, hom_isM_ty (@hom iQ) +Record Monoid_enriched_quiverN1 := { + ObjN1: Type; + iQ1: isQuiver ObjN1; + hsM1: forall A B, hom_isM_ty (@hom (HB.pack ObjN1 iQ1)) (fun X => isMon X) A B }. From 056f6e09d073fb9135bc185681702414d60720e8 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 22 Jun 2023 20:58:59 +0200 Subject: [PATCH 18/63] minor changes --- HB/factory.elpi | 7 +++++-- tests/enriched_cat.v | 22 +++++++++++++++++++--- 2 files changed, 24 insertions(+), 5 deletions(-) diff --git a/HB/factory.elpi b/HB/factory.elpi index 02287e972..2aab28df2 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -231,8 +231,9 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance abstract-over-section TheParams TheType MixinSrcClauses SectionCanonicalInstance coq.abstract-indt-decl RDecl RDeclClosed _, - % coq.say RDecl RDeclClosed, - +% coq.say "TEST" RDecl RDeclClosed, +% coq.say "TEST" RDecl, + coq.say "TEST" (indt R), if (get-option "primitive" tt) (@primitive! => log.coq.env.add-indt RDeclClosed R) @@ -264,6 +265,8 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance % factory-nparams mixin -> n % + coq.say "TEST 2" (indt R), + if (get-option "wrapper" tt) % ((factory-alias->gref (indt R) X), (WrapperClauses = [wrapper-mixin (indt R) (indt R) (indt R)]) diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index bceefd718..a12c99caa 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -50,8 +50,14 @@ HB.mixin Record hom_isMon2 T of Quiver T := (fun X => isMon X) A B }. -(* trying parametric definition however doesn't work *) -Fail HB.mixin Record hom_isM2 T (M: Type -> Type) of Quiver T := +(* the parametric definition works, though it is problematic *) +HB.mixin Record hom_isM2 (M: Type -> Type) T of Quiver T := + { private : forall (A B: T), @hom_isM_ty T (@hom (Quiver.clone T _)) + M + A B }. + +(* just a copy of hom_isM2 *) +HB.mixin Record hom_isM3 (M: Type -> Type) T of Quiver T := { private : forall (A B: T), @hom_isM_ty T (@hom (Quiver.clone T _)) M A B }. @@ -60,6 +66,16 @@ Fail HB.mixin Record hom_isM2 T (M: Type -> Type) of Quiver T := HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & hom_isMon2 Obj }. +(* structure based on the parametric wrappers *) +HB.structure Definition Monoid_enriched_quiver2 := + { Obj of isQuiver Obj & hom_isM2 (fun X => isMon X) Obj }. + +(* parametric stucture, cannot use hom_isM2 as it has been already used, + but works with a copy (hom_isM3) *) +HB.structure Definition M_enriched_quiver3 (M: Type -> Type) := + { Obj of isQuiver Obj & hom_isM3 M Obj }. + + (******************) (* unique projection from the wrapper *) @@ -97,7 +113,7 @@ Structure Monoid_enriched_quiverN := { About hom. -(* but mixing with HB doesn't work *) +(* making it work with HB *) Record Monoid_enriched_quiverN1 := { ObjN1: Type; iQ1: isQuiver ObjN1; From b78c77c6c6be177c6a6e9f56c97aca6a6783774d Mon Sep 17 00:00:00 2001 From: ptorrx Date: Fri, 23 Jun 2023 18:25:40 +0200 Subject: [PATCH 19/63] added Elpi code in monoid_enriched_cat.v --- HB/factory.elpi | 4 +- structures.v | 29 ++++++++++ tests/monoid_enriched_cat.v | 107 ++++++++++++++++++++++++++++++++++++ 3 files changed, 138 insertions(+), 2 deletions(-) diff --git a/HB/factory.elpi b/HB/factory.elpi index 2aab28df2..1780eb99c 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -233,7 +233,7 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance % coq.say "TEST" RDecl RDeclClosed, % coq.say "TEST" RDecl, - coq.say "TEST" (indt R), +% coq.say "TEST" (indt R), if (get-option "primitive" tt) (@primitive! => log.coq.env.add-indt RDeclClosed R) @@ -253,7 +253,7 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance build-deps-for-projections R MLwP GRDepsClausesProjs, GRDepsClauses = [gref-deps (indt R) MLwP, gref-deps (indc K) MLwP|GRDepsClausesProjs], - coq.say "TODO: extract useful info:" RDecl, + coq.say "TODO: extract useful info:" RDecl "AND THEN:" RDeclClosed, % record-decl in https://github.com/LPCIC/coq-elpi/blob/master/coq-builtin.elpi#L429 % per trovare il vero nome del mixin database.elpi:factory-alias->gref % per sapere quanti argomenti skippare prima del soggetto del mixin diff --git a/structures.v b/structures.v index cefe521d4..6f57b29ca 100644 --- a/structures.v +++ b/structures.v @@ -17,6 +17,35 @@ Definition ignore_disabled {T T'} (x : T) (x' : T') := x'. (* ********************* structures ****************************** *) From elpi Require Import elpi. +Axiom m : Type -> Type. +Record r (P : Type) := { private : m P }. + +Elpi Command x. +Elpi Accumulate lp:{{ + +pred extract i:indt-decl, o:gref. +extract (parameter ID _ _ R) Out :- + pi p\ + extract (R p) Out. +extract (record ID _ KID (field _ _ Ty (x\end-record))) GR :- + Ty = app [global GR| _]. + +}}. +Elpi Typecheck. + + +Elpi Query lp:{{ + + coq.locate "r" (indt I), + coq.env.indt-decl I D, + extract D GR. + +}}. + + + + + Register unify as hb.unify. Register id_phant as hb.id. Register id_phant_disabled as hb.id_disabled. diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 10fefecb9..035750531 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -5,6 +5,21 @@ HB.mixin Record isQuiver Obj := { hom : Obj -> Obj -> Type }. HB.structure Definition Quiver := { Obj of isQuiver Obj }. +(* +parameter Obj explicit (sort (typ «HB.tests.monoid_enriched_cat.2»)) c0 \ + record axioms_ (sort (typ «HB.tests.monoid_enriched_cat.5»)) Axioms_ + (field [coercion off, canonical tt] hom + (prod `_` c0 c1 \ + prod `_` c0 c2 \ sort (typ «HB.tests.monoid_enriched_cat.7»)) c1 \ + end-record) + +record axioms_ (sort (typ «HB.tests.monoid_enriched_cat.5»)) Axioms_ + (field [coercion off, canonical tt] hom + (prod `_` (global (const «Obj»)) c0 \ + prod `_` (global (const «Obj»)) c1 \ + sort (typ «HB.tests.monoid_enriched_cat.7»)) c0 \ end-record) +*) + HB.mixin Record isMon A := { zero : A; add : A -> A -> A; @@ -46,6 +61,98 @@ Fail HB.structure HB.mixin Record hom_isMon T of Quiver T := { private : forall A B, isMon (@hom T A B) }. +(* Elpi code to be moved to an Elpi file such as factory.elpi *) + +Elpi Command x. +Elpi Accumulate File "HB/common/stdpp.elpi". +Elpi Accumulate File "HB/common/database.elpi". +Elpi Accumulate File "HB/common/utils.elpi". +Elpi Accumulate File "HB/status.elpi". +Elpi Accumulate Db hb.db. + +(* extracts isMon *) +Elpi Accumulate lp:{{ + +pred extract_head_type_name i:term o:gref. +extract_head_type_name (prod _ _ TF) Out1 :- + pi p\ + extract_head_type_name (TF p) Out1. +extract_head_type_name Ty GR :- + Ty = app [global GR| _]. + +pred extract_wrapped i:indt-decl, o:gref. +extract_wrapped (parameter ID _ _ R) Out :- + pi p\ + extract_wrapped (R p) Out. +extract_wrapped (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + extract_head_type_name Ty GR0. + +}}. +Elpi Typecheck. + +(* OK *) +Elpi Query lp:{{ + + std.spy!(coq.locate "hom_isMon.axioms_" XX), + XX = (indt I), + coq.env.indt-decl I D, + extract_wrapped D GR0. + +}}. + +(* should extract hom *) +Elpi Accumulate lp:{{ + +pred extract_inner_type_name i:term o:gref. +extract_inner_type_name (prod _ _ TF) Out1 :- + pi p\ + extract_inner_type_name (TF p) Out1. +extract_inner_type_name Ty Gr :- + Ty = (app [global _, app [global GR]]). + +pred extract_subject i:indt-decl, o:gref. +extract_subject (parameter ID _ _ R) Out :- + pi p\ + extract_subject (R p) Out. +extract_subject (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + extract_inner_type_name Ty GR0. + +}}. +Elpi Typecheck. + +(* not working *) +Elpi Query lp:{{ + + std.spy!(coq.locate "hom_isMon.axioms_" XX), + XX = (indt I), + coq.env.indt-decl I D, + extract_subject D GR. + +}}. + +(* +Elpi Accumulate lp:{{ + +pred extract_head_type i:term o:term. +extract_head_type (prod _ _ TF) Out1 :- + pi p\ + extract_head_type (TF p) Out1. +extract_head_type Ty Ty :- + Ty = app [global _| _]. + +pred extract_wrapped i:indt-decl, o:gref. +extract_wrapped (parameter ID _ _ R) Out :- + pi p\ + extract_wrapped (R p) Out. +extract_wrapped (record ID _ KID (field _ _ Ty (x\end-record))) GR :- + extract_head_type Ty Ty1, + Ty1 = app [global GR| _]. + +}}. +Elpi Typecheck. + +*) + Elpi Print HB.structure. stop. From 0d0e9b79295a417c0deebb0a42a8dcbb5f83e651 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Mon, 26 Jun 2023 13:57:10 +0200 Subject: [PATCH 20/63] changes in monoid_enriched_cat.v --- HB/factory.elpi | 3 ++- structures.v | 12 ++++++------ tests/monoid_enriched_cat.v | 24 ++++++++++++++++++------ 3 files changed, 26 insertions(+), 13 deletions(-) diff --git a/HB/factory.elpi b/HB/factory.elpi index 1780eb99c..67a642889 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -253,7 +253,8 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance build-deps-for-projections R MLwP GRDepsClausesProjs, GRDepsClauses = [gref-deps (indt R) MLwP, gref-deps (indc K) MLwP|GRDepsClausesProjs], - coq.say "TODO: extract useful info:" RDecl "AND THEN:" RDeclClosed, + coq.say "TODO: extract useful info:" RDecl, + % coq.say "TODO: extract useful info:" RDecl "AND THEN:" RDeclClosed, % record-decl in https://github.com/LPCIC/coq-elpi/blob/master/coq-builtin.elpi#L429 % per trovare il vero nome del mixin database.elpi:factory-alias->gref % per sapere quanti argomenti skippare prima del soggetto del mixin diff --git a/structures.v b/structures.v index 6f57b29ca..b4d1cad8c 100644 --- a/structures.v +++ b/structures.v @@ -17,10 +17,13 @@ Definition ignore_disabled {T T'} (x : T) (x' : T') := x'. (* ********************* structures ****************************** *) From elpi Require Import elpi. +(******* simple example of Elpi command *) Axiom m : Type -> Type. Record r (P : Type) := { private : m P }. -Elpi Command x. +(* command name *) +Elpi Command foo_example_command. +(* predicate definition *) Elpi Accumulate lp:{{ pred extract i:indt-decl, o:gref. @@ -33,7 +36,7 @@ extract (record ID _ KID (field _ _ Ty (x\end-record))) GR :- }}. Elpi Typecheck. - +(* predicate query *) Elpi Query lp:{{ coq.locate "r" (indt I), @@ -41,10 +44,7 @@ Elpi Query lp:{{ extract D GR. }}. - - - - +(******* end simple example *) Register unify as hb.unify. Register id_phant as hb.id. diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 035750531..33aa520db 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -108,7 +108,7 @@ extract_inner_type_name (prod _ _ TF) Out1 :- pi p\ extract_inner_type_name (TF p) Out1. extract_inner_type_name Ty Gr :- - Ty = (app [global _, app [global GR]]). + Ty = (app [global _, app [global Gr| _]]). pred extract_subject i:indt-decl, o:gref. extract_subject (parameter ID _ _ R) Out :- @@ -120,7 +120,10 @@ extract_subject (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- }}. Elpi Typecheck. -(* not working *) +(*for debugging - check tmp/trace... with Elpi Tracer *) +(* Elpi Trace Browser. *) + +(* OK *) Elpi Query lp:{{ std.spy!(coq.locate "hom_isMon.axioms_" XX), @@ -140,19 +143,28 @@ extract_head_type (prod _ _ TF) Out1 :- extract_head_type Ty Ty :- Ty = app [global _| _]. -pred extract_wrapped i:indt-decl, o:gref. -extract_wrapped (parameter ID _ _ R) Out :- +pred extract_wrapped2 i:indt-decl, o:gref. +extract_wrapped2 (parameter ID _ _ R) Out :- pi p\ - extract_wrapped (R p) Out. -extract_wrapped (record ID _ KID (field _ _ Ty (x\end-record))) GR :- + extract_wrapped2 (R p) Out. +extract_wrapped2 (record ID _ KID (field _ _ Ty (x\end-record))) GR :- extract_head_type Ty Ty1, Ty1 = app [global GR| _]. }}. Elpi Typecheck. +Elpi Query lp:{{ + + std.spy!(coq.locate "hom_isMon.axioms_" XX), + XX = (indt I), + coq.env.indt-decl I D, + extract_head_type D GR. + +}}. *) + Elpi Print HB.structure. stop. From b6b827883dfbcad8c4c496b64b5926aee8a5fcc1 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 27 Jun 2023 15:01:13 +0200 Subject: [PATCH 21/63] added improved version of extraction predicates in monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 121 +++++++++++++++++++----------------- 1 file changed, 65 insertions(+), 56 deletions(-) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 33aa520db..3badb8b79 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -73,98 +73,107 @@ Elpi Accumulate Db hb.db. (* extracts isMon *) Elpi Accumulate lp:{{ -pred extract_head_type_name i:term o:gref. -extract_head_type_name (prod _ _ TF) Out1 :- +pred extract_ret_type_name i:term, o:gref. +extract_ret_type_name (prod _ _ TF) Out1 :- pi p\ - extract_head_type_name (TF p) Out1. -extract_head_type_name Ty GR :- - Ty = app [global GR| _]. - -pred extract_wrapped i:indt-decl, o:gref. -extract_wrapped (parameter ID _ _ R) Out :- + extract_ret_type_name (TF p) Out1. +extract_ret_type_name Ty GR1 :- + Ty = app [global GR0| _], + factory-alias->gref GR0 GR1. + +pred extract_wrapped1 i:indt-decl, o:gref. +extract_wrapped1 (parameter ID _ _ R) Out :- pi p\ - extract_wrapped (R p) Out. -extract_wrapped (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- - extract_head_type_name Ty GR0. + extract_wrapped1 (R p) Out. +extract_wrapped1 (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + extract_ret_type_name Ty GR0. }}. Elpi Typecheck. -(* OK *) -Elpi Query lp:{{ - - std.spy!(coq.locate "hom_isMon.axioms_" XX), - XX = (indt I), - coq.env.indt-decl I D, - extract_wrapped D GR0. - -}}. - -(* should extract hom *) +(* extracts hom *) Elpi Accumulate lp:{{ -pred extract_inner_type_name i:term o:gref. +pred extract_inner_type_name i:term, o:gref. extract_inner_type_name (prod _ _ TF) Out1 :- pi p\ extract_inner_type_name (TF p) Out1. extract_inner_type_name Ty Gr :- Ty = (app [global _, app [global Gr| _]]). -pred extract_subject i:indt-decl, o:gref. -extract_subject (parameter ID _ _ R) Out :- +pred extract_subject1 i:indt-decl, o:gref. +extract_subject1 (parameter ID _ _ R) Out :- pi p\ - extract_subject (R p) Out. -extract_subject (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + extract_subject1 (R p) Out. +extract_subject1 (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- extract_inner_type_name Ty GR0. }}. Elpi Typecheck. -(*for debugging - check tmp/trace... with Elpi Tracer *) -(* Elpi Trace Browser. *) +(* better version, with predicate parameters *) +Elpi Accumulate lp:{{ -(* OK *) -Elpi Query lp:{{ +pred extract_from_record_decl i: (term -> gref -> prop), i:indt-decl, o:gref. +extract_from_record_decl P (parameter ID _ _ R) Out :- + pi p\ + extract_from_record_decl P (R p) Out. +extract_from_record_decl P (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + P Ty GR0. - std.spy!(coq.locate "hom_isMon.axioms_" XX), - XX = (indt I), - coq.env.indt-decl I D, - extract_subject D GR. +pred extract_from_rtty i: (term -> gref -> prop), i: term, o:gref. +extract_from_rtty P (prod _ _ TF) Out1 :- + pi p\ + extract_from_rtty P (TF p) Out1. +extract_from_rtty P Ty Gr :- P Ty Gr. -}}. +pred xtr_fst_op i:term, o:gref. +xtr_fst_op Ty Gr1 :- + Ty = (app [global Gr0| _]), + factory-alias->gref Gr0 Gr1. -(* -Elpi Accumulate lp:{{ +pred xtr_snd_op i:term, o:gref. +xtr_snd_op Ty Gr :- + Ty = (app [global _, app [global Gr| _]]). -pred extract_head_type i:term o:term. -extract_head_type (prod _ _ TF) Out1 :- - pi p\ - extract_head_type (TF p) Out1. -extract_head_type Ty Ty :- - Ty = app [global _| _]. - -pred extract_wrapped2 i:indt-decl, o:gref. -extract_wrapped2 (parameter ID _ _ R) Out :- - pi p\ - extract_wrapped2 (R p) Out. -extract_wrapped2 (record ID _ KID (field _ _ Ty (x\end-record))) GR :- - extract_head_type Ty Ty1, - Ty1 = app [global GR| _]. +pred extract_wrapped i:indt-decl, o:gref. +extract_wrapped In Out :- + extract_from_record_decl (extract_from_rtty xtr_fst_op) In Out. + +pred extract_subject i:indt-decl, o:gref. +extract_subject In Out :- + extract_from_record_decl (extract_from_rtty xtr_snd_op) In Out. }}. Elpi Typecheck. +(*for debugging - check /tmp/traced.tmp.json with Elpi Tracer *) +(* Elpi Trace Browser. *) +(* Elpi Bound Steps 1000. *) + +(* OK *) Elpi Query lp:{{ - std.spy!(coq.locate "hom_isMon.axioms_" XX), + coq.locate "hom_isMon.axioms_" XX, XX = (indt I), coq.env.indt-decl I D, - extract_head_type D GR. - + extract_wrapped D GR1, + extract_subject D GR2. + }}. -*) +(* also OK *) +Elpi Query lp:{{ + + coq.locate "hom_isMon.axioms_" XX, + XX = (indt I), + coq.env.indt-decl I D, + extract_wrapped1 D GR11, + extract_subject1 D GR12. + +}}. + Elpi Print HB.structure. stop. From 145aa0dfb7ee73f2083dec1a0fbedda11f1311f5 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 27 Jun 2023 17:24:21 +0200 Subject: [PATCH 22/63] minor changes in monoid_enriched_cat.v --- HB/factory.elpi | 4 ++-- tests/monoid_enriched_cat.v | 13 ++++++++----- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/HB/factory.elpi b/HB/factory.elpi index 67a642889..e881299dc 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -266,14 +266,14 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance % factory-nparams mixin -> n % - coq.say "TEST 2" (indt R), + % coq.say "TEST 2" (indt R), if (get-option "wrapper" tt) % ((factory-alias->gref (indt R) X), (WrapperClauses = [wrapper-mixin (indt R) (indt R) (indt R)]) (WrapperClauses = []), - coq.say "aggiungiamo " WrapperClauses, + % coq.say "aggiungiamo " WrapperClauses, % GRDepsClauses => mk-factory-sort MLwP (indt R) _ FactorySortCoe, % FactorySortCoe = coercion GRFSort _ _ _, diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 3badb8b79..e7db6f337 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -144,6 +144,13 @@ pred extract_subject i:indt-decl, o:gref. extract_subject In Out :- extract_from_record_decl (extract_from_rtty xtr_snd_op) In Out. +pred wrapper_mixin_aux i:gref, o:gref, o:gref. +wrapper_mixin_aux XX Gr1 Gr2 :- + XX = (indt I), + coq.env.indt-decl I D, + extract_subject D Gr1, + extract_wrapped D Gr2. + }}. Elpi Typecheck. @@ -155,14 +162,10 @@ Elpi Typecheck. Elpi Query lp:{{ coq.locate "hom_isMon.axioms_" XX, - XX = (indt I), - coq.env.indt-decl I D, - extract_wrapped D GR1, - extract_subject D GR2. + wrapper_mixin_aux XX Gr1 Gr2. }}. - (* also OK *) Elpi Query lp:{{ From 8d0310e3441f061726be537fcb4c6f5299f9a1d3 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 27 Jun 2023 20:52:55 +0200 Subject: [PATCH 23/63] moved Elpi code from monoid_enriched_cat.v to factory.v. monoid-enriched_cat.v compiles --- HB/factory.elpi | 47 ++++++++++++++++++++- tests/monoid_enriched_cat.v | 81 +++++++++++++++++++------------------ 2 files changed, 87 insertions(+), 41 deletions(-) diff --git a/HB/factory.elpi b/HB/factory.elpi index e881299dc..158060f07 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -219,6 +219,49 @@ declare-asset Arg AssetKind :- std.do! [ ) ]. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% auxiliary code for wrapper-mixin + +pred extract_from_record_decl i: (term -> gref -> prop), i:indt-decl, o:gref. +extract_from_record_decl P (parameter ID _ _ R) Out :- + pi p\ + extract_from_record_decl P (R p) Out. +extract_from_record_decl P (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + P Ty GR0. + +pred extract_from_rtty i: (term -> gref -> prop), i: term, o:gref. +extract_from_rtty P (prod _ _ TF) Out1 :- + pi p\ + extract_from_rtty P (TF p) Out1. +extract_from_rtty P Ty Gr :- P Ty Gr. + +pred xtr_fst_op i:term, o:gref. +xtr_fst_op Ty Gr1 :- + Ty = (app [global Gr0| _]), + factory-alias->gref Gr0 Gr1. + +pred xtr_snd_op i:term, o:gref. +xtr_snd_op Ty Gr :- + Ty = (app [global _, app [global Gr| _]]). + +pred extract_wrapped i:indt-decl, o:gref. +extract_wrapped In Out :- + extract_from_record_decl (extract_from_rtty xtr_fst_op) In Out. + +pred extract_subject i:indt-decl, o:gref. +extract_subject In Out :- + extract_from_record_decl (extract_from_rtty xtr_snd_op) In Out. + +pred wrapper_mixin_aux i:gref, o:gref, o:gref. +wrapper_mixin_aux XX Gr1 Gr2 :- + XX = (indt I), + coq.env.indt-decl I D, + extract_subject D Gr1, + extract_wrapped D Gr2. + +%%% end auxiliary code for wrapper-mixin +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + pred declare-mixin-or-factory i:list prop, i:list constant, i:list term, i:term, i:term, i:record-decl, i:list-w-params factoryname, i:id, i:asset. declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance @@ -269,8 +312,8 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance % coq.say "TEST 2" (indt R), if (get-option "wrapper" tt) -% ((factory-alias->gref (indt R) X), - (WrapperClauses = [wrapper-mixin (indt R) (indt R) (indt R)]) + ((wrapper_mixin_aux (indt R) NSbj WMxn), + (WrapperClauses = [wrapper-mixin (indt R) NSbj WMxn])) (WrapperClauses = []), % coq.say "aggiungiamo " WrapperClauses, diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index e7db6f337..64b9f24d2 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -5,21 +5,6 @@ HB.mixin Record isQuiver Obj := { hom : Obj -> Obj -> Type }. HB.structure Definition Quiver := { Obj of isQuiver Obj }. -(* -parameter Obj explicit (sort (typ «HB.tests.monoid_enriched_cat.2»)) c0 \ - record axioms_ (sort (typ «HB.tests.monoid_enriched_cat.5»)) Axioms_ - (field [coercion off, canonical tt] hom - (prod `_` c0 c1 \ - prod `_` c0 c2 \ sort (typ «HB.tests.monoid_enriched_cat.7»)) c1 \ - end-record) - -record axioms_ (sort (typ «HB.tests.monoid_enriched_cat.5»)) Axioms_ - (field [coercion off, canonical tt] hom - (prod `_` (global (const «Obj»)) c0 \ - prod `_` (global (const «Obj»)) c1 \ - sort (typ «HB.tests.monoid_enriched_cat.7»)) c0 \ end-record) -*) - HB.mixin Record isMon A := { zero : A; add : A -> A -> A; @@ -31,6 +16,7 @@ HB.mixin Record isMon A := { HB.structure Definition Monoid := { A of isMon A }. +(* This is expected to fail, as it isn't a mixin *) Fail HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & @@ -50,19 +36,55 @@ Fail HB.structure As an addition substep, we should check that the wrapper has exactly one field, which is the wrapped mixin. *) - (* added wrapper attribute in coq-builtin.elpi. added pred wrapper-mixin in structures.v. added conditional rule for wrapper-mixin in factory.elpi. - tentative use of factory-alias->gref, but the parameters - aren't right yet -- see HB.structure.html. *) #[wrapper] HB.mixin Record hom_isMon T of Quiver T := { private : forall A B, isMon (@hom T A B) }. -(* Elpi code to be moved to an Elpi file such as factory.elpi *) +(* Step 2: at structure declaration, export the main and only projection + of each declared wrapper as an instance of the wrapped structure on + its subject *) + HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon Obj }. + + HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := + @private T A B. + +(* each instance of isMon should be tried as an instance of hom_isMon *) +(* + (* Step 3: for each instance of a wrapped mixin on a subject known + to be wrapped, automatically produce an instance of the wrapper mixin too. *) + HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). + Fail HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). + (* This last command should create a `Monoid_enriched_quiver`, in order to do so it should + automatically instanciate the wrapper `hom_isMon`: + HB.instance Definition _ := hom_isMon.Build Type homTypeMon. + *) +*) + +(* quiver instance (simply typed functions between two types) *) +HB.instance Definition funQ := isQuiver.Build Type (fun A B => A -> B). + +(* prove that for every two types the quiver is a monoid *) +Lemma funQ_isMonF (A B: Type) : isMon (A -> B). +Admitted. + +(* use the lemma to instantiate isMon *) +HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> B) := + funQ_isMonF A B. + +(* use the generic isMon instance to instantiate 'private' *) +HB.instance Definition funQ_hom_isMon := + hom_isMon.Build Type (fun A B => funQ_isMon A B). + +(**************************************************************) +(* Elpi code moved to factory.elpi *) +(* Elpi Command x. Elpi Accumulate File "HB/common/stdpp.elpi". Elpi Accumulate File "HB/common/database.elpi". @@ -180,24 +202,5 @@ Elpi Query lp:{{ Elpi Print HB.structure. stop. +*) -(* Step 2: at structure declaration, export the main and only projection - of each declared wrapper as an instance of the wrapped structure on - its subject *) -HB.structure - Definition Monoid_enriched_quiver := - { Obj of isQuiver Obj & hom_isMon Obj }. - -HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := - @private T A B. - - (* each instance of isMon should be tried as an instance of hom_isMon *) - -(* Step 3: for each instance of a wrapped mixin on a subject known - to be wrapped, automatically produce an instance of the wrapper mixin too. *) -HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). -Fail HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). -(* This last command should create a `Monoid_enriched_quiver`, in order to do so it should - automatically instanciate the wrapper `hom_isMon`: - HB.instance Definition _ := hom_isMon.Build Type homTypeMon. - *) From 0b2b79ff9170cfd8ddd2c39d47493f0ea68d0510 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 28 Jun 2023 11:13:12 +0200 Subject: [PATCH 24/63] minor changes in monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 64b9f24d2..8646a1d8a 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -36,7 +36,7 @@ Fail HB.structure As an addition substep, we should check that the wrapper has exactly one field, which is the wrapped mixin. *) -(* added wrapper attribute in coq-builtin.elpi. +(* added wrapper attribute in utils.elpi. added pred wrapper-mixin in structures.v. added conditional rule for wrapper-mixin in factory.elpi. *) From 7fbd129d48226d43a8f66b0e7e72e81fb0262dc0 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 28 Jun 2023 14:20:13 +0200 Subject: [PATCH 25/63] added instance in monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 36 ++++++++++++++++++++++++++++++++---- 1 file changed, 32 insertions(+), 4 deletions(-) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 8646a1d8a..31c94b5e9 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -67,14 +67,42 @@ HB.mixin Record hom_isMon T of Quiver T := *) (* quiver instance (simply typed functions between two types) *) -HB.instance Definition funQ := isQuiver.Build Type (fun A B => A -> B). +HB.instance Definition funQ := isQuiver.Build Type + (fun A B => A -> option B). (* prove that for every two types the quiver is a monoid *) -Lemma funQ_isMonF (A B: Type) : isMon (A -> B). -Admitted. + +Require Import FunctionalExtensionality. + +Definition funQ_comp {A B} (f g: A -> option B) (x: A) : option B := + match f x with + | Some _ => f x + | _ => g x end. + +Program Definition funQ_isMonF (A B: Type) : isMon (A -> option B) := + isMon.Build (A -> option B) (fun (_:A) => None) funQ_comp _ _ _. +Obligations. +Obligation 1. +unfold associative; intros. +eapply functional_extensionality; intro a. +unfold funQ_comp. +destruct (x a) eqn:K1. +simpl; auto. +destruct (y a); auto. +Qed. +Obligation 2. +unfold left_id; intros. +unfold funQ_comp; auto. +Qed. +Obligation 3. +unfold right_id; intros. +eapply functional_extensionality; intro a. +unfold funQ_comp. +destruct (x a); auto. +Qed. (* use the lemma to instantiate isMon *) -HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> B) := +HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> option B) := funQ_isMonF A B. (* use the generic isMon instance to instantiate 'private' *) From 5ded009628617ddc4f297a3a11a4a983aebf68b8 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 28 Jun 2023 15:41:41 +0200 Subject: [PATCH 26/63] added some tests to monoid_enriched_cat.v --- tests/monoid_enriched_cat.v | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 31c94b5e9..7f6e122d6 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -101,6 +101,9 @@ unfold funQ_comp. destruct (x a); auto. Qed. +Print Canonical Projections. +Fail Check (nat -> option nat) : Monoid.type. + (* use the lemma to instantiate isMon *) HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> option B) := funQ_isMonF A B. @@ -109,7 +112,16 @@ HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> option B) := HB.instance Definition funQ_hom_isMon := hom_isMon.Build Type (fun A B => funQ_isMon A B). - +HB.about private. +Print Canonical Projections. +Check (nat -> option nat) : Monoid.type. +HB.about funQ_isMon. +Fail HB.about funQ_hom_isMon. +About funQ_hom_isMon. + +Elpi Print HB.structure. + + (**************************************************************) (* Elpi code moved to factory.elpi *) (* From 2ea2be6c9eb07d12930eb04d4a0619e4983eb23f Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Wed, 28 Jun 2023 18:17:59 +0200 Subject: [PATCH 27/63] pseudo-code to add new instances for each wrapper mixin --- HB/structure.elpi | 10 ++++++++++ tests/monoid_enriched_cat.v | 15 +++++++++++---- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/HB/structure.elpi b/HB/structure.elpi index addf308a4..f58ab76d4 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -205,6 +205,16 @@ declare Module BSkel Sort :- std.do! [ log.coq.env.end-module-name ElpiOperationModName ElpiOperations, export.module ElpiOperationModName ElpiOperations, + %% tentative pseudo-code:: + % std.filter ML (x\ wrapper-mixin x _ _) WrapperML, + % std.forall WrapperML private.rexport-wrapper-as-instance, + + %% write private code below: + % pred rexport-wrapper-as-instance i:mixinname. + % reexport-wrapper-as-instance M :- + % exported-op M _ C, + % declare-existing-instance C %fixme. + if-verbose (coq.say {header} "abbreviation factory-by-classname"), NewClauses => factory.declare-abbrev Module (factory.by-classname ClassName), diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 7f6e122d6..2489a2786 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -42,17 +42,24 @@ Fail HB.structure *) #[wrapper] HB.mixin Record hom_isMon T of Quiver T := - { private : forall A B, isMon (@hom T A B) }. + { hom_isMon_private : forall A B, isMon (@hom T A B) }. +About hom_isMon_private. +About hom_isMon.hom_isMon_private. + (* Step 2: at structure declaration, export the main and only projection of each declared wrapper as an instance of the wrapped structure on its subject *) - HB.structure +HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & hom_isMon Obj }. - + +About hom_isMon.hom_isMon_private. +About hom_isMon_private. + + HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := - @private T A B. + @hom_isMon_private T A B. (* each instance of isMon should be tried as an instance of hom_isMon *) (* From 2fccea4a29d0095887dc0f397e88fc0d717a8ff0 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 29 Jun 2023 17:27:56 +0200 Subject: [PATCH 28/63] added some comment --- HB/structure.elpi | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/HB/structure.elpi b/HB/structure.elpi index f58ab76d4..1e56411c3 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -205,6 +205,12 @@ declare Module BSkel Sort :- std.do! [ log.coq.env.end-module-name ElpiOperationModName ElpiOperations, export.module ElpiOperationModName ElpiOperations, + % factories-provide (line 16) gives the mixins provided from a factory. + % line 23 (list-w-params_list) associates these mixins with their names (ML). + % we need to filter the wrappers out of ML. + % then export the projection of each mixin wrapper. + % can use exported-op to this purpose + %% tentative pseudo-code:: % std.filter ML (x\ wrapper-mixin x _ _) WrapperML, % std.forall WrapperML private.rexport-wrapper-as-instance, From 1ffc93dcd43875ba0786c2942294d4f207691830 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 29 Jun 2023 18:44:44 +0200 Subject: [PATCH 29/63] tentative changes in structure.elpi (reexport-wrapper-as-instance is not right, it is just meant to compile) - anyway it makes compilation of HB.structure Monoid_enriched_quiver fail --- HB/structure.elpi | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/HB/structure.elpi b/HB/structure.elpi index 1e56411c3..9389d91fe 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -221,6 +221,9 @@ declare Module BSkel Sort :- std.do! [ % exported-op M _ C, % declare-existing-instance C %fixme. + std.filter ML (x\ wrapper-mixin x _ _) WrapperML, + std.forall WrapperML private.reexport-wrapper-as-instance, + if-verbose (coq.say {header} "abbreviation factory-by-classname"), NewClauses => factory.declare-abbrev Module (factory.by-classname ClassName), @@ -754,4 +757,9 @@ mk-hb-eta.arity Structure ClassName SortProjection Out = parameter {coq.name->id NT} explicit Ty s\ arity (Concl s) ]. +pred reexport-wrapper-as-instance i:mixinname. +reexport-wrapper-as-instance M :- + exported-op M _ C, + declare-existing C _. %fixme. + }} From d9c798011ba8c3aef7a9ee4497e1b998eab44ba2 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Fri, 30 Jun 2023 15:10:59 +0200 Subject: [PATCH 30/63] changes in structure.elpi and monoid_enriched_cat.v - compiles --- HB/structure.elpi | 13 ++++++++++--- tests/monoid_enriched_cat.v | 9 +++++---- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/HB/structure.elpi b/HB/structure.elpi index 9389d91fe..4d7bd4c9a 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -222,7 +222,8 @@ declare Module BSkel Sort :- std.do! [ % declare-existing-instance C %fixme. std.filter ML (x\ wrapper-mixin x _ _) WrapperML, - std.forall WrapperML private.reexport-wrapper-as-instance, + coq.say "????" EX, + EX => std.forall WrapperML private.reexport-wrapper-as-instance, if-verbose (coq.say {header} "abbreviation factory-by-classname"), @@ -758,8 +759,14 @@ mk-hb-eta.arity Structure ClassName SortProjection ]. pred reexport-wrapper-as-instance i:mixinname. -reexport-wrapper-as-instance M :- +reexport-wrapper-as-instance M :- std.spy-do! [ exported-op M _ C, - declare-existing C _. %fixme. + coq.say "C=" C, + B = (global (const C)), + coq.env.typeof (const C) Ty, + coq.count-prods Ty N0, + instance.declare-const "xx" B {coq.term->arity Ty N0} _, + % declare-existing C _, + ]. %fixme. }} diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 2489a2786..e91c2c0bf 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -22,7 +22,8 @@ Fail HB.structure { Obj of isQuiver Obj & (forall A B : Obj, isMon (@hom (Quiver.clone Obj _) A B)) }. - +About zero. +Print zero. (* Step 0: define a wrapper predicate in coq-elpi *) (* 5 lines of documentation + 1 line of elpi code in structure.v `pred wrapper-mixin o:mixinname, o:gref, o:mixinname` @@ -57,10 +58,10 @@ HB.structure About hom_isMon.hom_isMon_private. About hom_isMon_private. - +(* HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := @hom_isMon_private T A B. - + *) (* each instance of isMon should be tried as an instance of hom_isMon *) (* (* Step 3: for each instance of a wrapped mixin on a subject known @@ -119,7 +120,7 @@ HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> option B) := HB.instance Definition funQ_hom_isMon := hom_isMon.Build Type (fun A B => funQ_isMon A B). -HB.about private. +(* HB.about private. *) Print Canonical Projections. Check (nat -> option nat) : Monoid.type. HB.about funQ_isMon. From 7158c5456c6a05198e4ce0c91774dc95b658c845 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Fri, 30 Jun 2023 18:27:57 +0200 Subject: [PATCH 31/63] added comments in structure.elpi --- HB/structure.elpi | 27 ++++++++++++++++++++++----- tests/monoid_enriched_cat.v | 1 + 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/HB/structure.elpi b/HB/structure.elpi index 4d7bd4c9a..4614acdd8 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -222,7 +222,19 @@ declare Module BSkel Sort :- std.do! [ % declare-existing-instance C %fixme. std.filter ML (x\ wrapper-mixin x _ _) WrapperML, - coq.say "????" EX, + % we need to assert locally the clauses in EX, which is + % [exported-op (indt «hom_isMon.axioms_») «hom_isMon.hom_isMon_private» + % «hom_isMon_private»] + % crucially containing hom_isMon_private. + % In fact, these clauses get added to the global database by Accumulate, + % but this makes them available only at the end of the program run, and + % this is too late. + % Then given WrapperML (the list of the wrapper mixins as grefs) + % i.e. [indt «hom_isMon.axioms_»] + % we can use reexport-wrapper-as-instance to get the projection and build + % the instances. + coq.say "???? WrapperML " WrapperML, + coq.say "???? EX " EX, EX => std.forall WrapperML private.reexport-wrapper-as-instance, if-verbose (coq.say {header} "abbreviation factory-by-classname"), @@ -758,15 +770,20 @@ mk-hb-eta.arity Structure ClassName SortProjection Out = parameter {coq.name->id NT} explicit Ty s\ arity (Concl s) ]. +% M is the gref of the wrapper mixin +% C gets now instantiated to the projection, i.e. hom_isMon_private +% we need to count the parameters, that we get from the type +% we then can construct the instance, using +% instance.declare-const (notably used in the API, i.e. in structures.v, +% HB.instance) pred reexport-wrapper-as-instance i:mixinname. reexport-wrapper-as-instance M :- std.spy-do! [ exported-op M _ C, - coq.say "C=" C, + coq.say "???? C=" C, B = (global (const C)), coq.env.typeof (const C) Ty, coq.count-prods Ty N0, - instance.declare-const "xx" B {coq.term->arity Ty N0} _, - % declare-existing C _, - ]. %fixme. + instance.declare-const "xx" B {coq.term->arity Ty N0} _ + ]. }} diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index e91c2c0bf..a9a13d1b6 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -58,6 +58,7 @@ HB.structure About hom_isMon.hom_isMon_private. About hom_isMon_private. +(* as expected from step 2, now this instance declaration is no more necessary *) (* HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := @hom_isMon_private T A B. From 7ec530a9c138250a392027d6eeee10e7e2a9abe1 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Mon, 3 Jul 2023 14:53:45 +0200 Subject: [PATCH 32/63] changes in structure.elpi, to prepare the derivation of the wrapper instance --- HB/structure.elpi | 30 ++++++++++++++++++++++++++++++ tests/monoid_enriched_cat.v | 31 ++++++++++++++++++++++++++++--- 2 files changed, 58 insertions(+), 3 deletions(-) diff --git a/HB/structure.elpi b/HB/structure.elpi index 4614acdd8..e9e5a7c72 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -786,4 +786,34 @@ reexport-wrapper-as-instance M :- std.spy-do! [ instance.declare-const "xx" B {coq.term->arity Ty N0} _ ]. +%hom_isMon.hom_isMon_private : +%forall (T : Type) +% (local_mixin_monoid_enriched_cat_isQuiver : isQuiver.axioms_ T), +%hom_isMon.axioms_ T local_mixin_monoid_enriched_cat_isQuiver -> +%forall +% A +% B : {| +% Quiver.sort := T; +% Quiver.class := +% {| +% Quiver.monoid_enriched_cat_isQuiver_mixin := +% local_mixin_monoid_enriched_cat_isQuiver +% |} +% |}, isMon.phant_axioms (hom A B) + +pred derive_wrapper_instance i:mixinname. +derive_wrapper_instance M :- std.spy-do! [ +% 1) from M, the wrapper gref, +% we need to recover the wrapped mixin and the new subject. +% these could also be extracted e.g. from the type Ty of the wrapper projection. + exported-op M _ C, + coq.say "???? C=" C, + B = (global (const C)), + coq.env.typeof (const C) Ty, +% 2) we need to find a definition D for the projection: something that has the same type. +% this is indeed the type of a function that produces instances of the wrapped mixin. +% 3) then we can define the wrapper instance, using D. + instance.declare-const _ _ _ _ +]. + }} diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index a9a13d1b6..cf43b0a78 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -75,6 +75,8 @@ About hom_isMon_private. *) *) +(* Essentially, step 2 is the elimination rule for the wrapper, step 3 is the introduction one *) + (* quiver instance (simply typed functions between two types) *) HB.instance Definition funQ := isQuiver.Build Type (fun A B => A -> option B). @@ -88,6 +90,28 @@ Definition funQ_comp {A B} (f g: A -> option B) (x: A) : option B := | Some _ => f x | _ => g x end. + Program Definition funQ_isMonF_alt (A B: Type) : isMon (hom A B) := + isMon.Build (A -> option B) (fun (_:A) => None) funQ_comp _ _ _. + Obligations. + Obligation 1. + unfold associative; intros. + eapply functional_extensionality; intro a. + unfold funQ_comp. + destruct (x a) eqn:K1. + simpl; auto. + destruct (y a); auto. + Qed. + Obligation 2. + unfold left_id; intros. + unfold funQ_comp; auto. + Qed. + Obligation 3. + unfold right_id; intros. + eapply functional_extensionality; intro a. + unfold funQ_comp. + destruct (x a); auto. + Qed. + Program Definition funQ_isMonF (A B: Type) : isMon (A -> option B) := isMon.Build (A -> option B) (fun (_:A) => None) funQ_comp _ _ _. Obligations. @@ -114,16 +138,17 @@ Print Canonical Projections. Fail Check (nat -> option nat) : Monoid.type. (* use the lemma to instantiate isMon *) -HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> option B) := +HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := funQ_isMonF A B. -(* use the generic isMon instance to instantiate 'private' *) +(* instantiate hom_isMon by using the generic isMon instance to define 'private' *) HB.instance Definition funQ_hom_isMon := hom_isMon.Build Type (fun A B => funQ_isMon A B). (* HB.about private. *) Print Canonical Projections. -Check (nat -> option nat) : Monoid.type. +(* this has to be changed, it should be something like (hom nat nat): + Check (nat -> option nat) : Monoid.type. *) HB.about funQ_isMon. Fail HB.about funQ_hom_isMon. About funQ_hom_isMon. From 7e83bd9b98a1443756ddf2473e1ec9e82e0804fb Mon Sep 17 00:00:00 2001 From: ptorrx Date: Mon, 3 Jul 2023 15:44:01 +0200 Subject: [PATCH 33/63] added comments in structure.elpi --- HB/structure.elpi | 12 ++++++++++-- tests/monoid_enriched_cat.v | 2 +- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/HB/structure.elpi b/HB/structure.elpi index e9e5a7c72..2feffffbd 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -810,8 +810,16 @@ derive_wrapper_instance M :- std.spy-do! [ coq.say "???? C=" C, B = (global (const C)), coq.env.typeof (const C) Ty, -% 2) we need to find a definition D for the projection: something that has the same type. -% this is indeed the type of a function that produces instances of the wrapped mixin. +% 2) we need to find a definition D for the projection. This can only be a function that +% has the same type. +% This is indeed the type of a function that constructs instances of the wrapped mixin +% on a given subject. +% Crucially, the type does not depend syntatically on the particular subject, becase it is +% generally +% forall A B, isMon (hom A B) +% Nonetheelss, if such a function is available, it is going to be defined +% on a specific subject that happens to give monoids, for example +% A -> option B. % 3) then we can define the wrapper instance, using D. instance.declare-const _ _ _ _ ]. diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index cf43b0a78..5c09ed50a 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -137,7 +137,7 @@ Qed. Print Canonical Projections. Fail Check (nat -> option nat) : Monoid.type. -(* use the lemma to instantiate isMon *) +(* use the lemma to instantiate isMon. Notice the genericity of the type. *) HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := funQ_isMonF A B. From 40eef02edc53a84c6088d3d91328c2a9b9fdf572 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Mon, 3 Jul 2023 21:11:04 +0200 Subject: [PATCH 34/63] tentative changes to structure.elpi --- HB/structure.elpi | 72 ++++++++++++++++++++++++++++++----------------- 1 file changed, 46 insertions(+), 26 deletions(-) diff --git a/HB/structure.elpi b/HB/structure.elpi index 2feffffbd..2ac22954f 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -237,6 +237,9 @@ declare Module BSkel Sort :- std.do! [ coq.say "???? EX " EX, EX => std.forall WrapperML private.reexport-wrapper-as-instance, + % tentative: generating wrapper instances from the available definitions. + NewClauses => std.forall WrapperML private.derive_wrapper_instances, + if-verbose (coq.say {header} "abbreviation factory-by-classname"), NewClauses => factory.declare-abbrev Module (factory.by-classname ClassName), @@ -770,9 +773,9 @@ mk-hb-eta.arity Structure ClassName SortProjection Out = parameter {coq.name->id NT} explicit Ty s\ arity (Concl s) ]. -% M is the gref of the wrapper mixin -% C gets now instantiated to the projection, i.e. hom_isMon_private -% we need to count the parameters, that we get from the type +% M is the gref of the wrapper mixin. +% C gets now instantiated to the projection, i.e. hom_isMon_private. +% we need to count the parameters, we can get that from the type. % we then can construct the instance, using % instance.declare-const (notably used in the API, i.e. in structures.v, % HB.instance) @@ -786,11 +789,12 @@ reexport-wrapper-as-instance M :- std.spy-do! [ instance.declare-const "xx" B {coq.term->arity Ty N0} _ ]. -%hom_isMon.hom_isMon_private : -%forall (T : Type) +% The type of the wrapper projection is... +% hom_isMon.hom_isMon_private : +% forall (T : Type) % (local_mixin_monoid_enriched_cat_isQuiver : isQuiver.axioms_ T), -%hom_isMon.axioms_ T local_mixin_monoid_enriched_cat_isQuiver -> -%forall +% hom_isMon.axioms_ T local_mixin_monoid_enriched_cat_isQuiver -> +% forall % A % B : {| % Quiver.sort := T; @@ -801,27 +805,43 @@ reexport-wrapper-as-instance M :- std.spy-do! [ % |} % |}, isMon.phant_axioms (hom A B) -pred derive_wrapper_instance i:mixinname. -derive_wrapper_instance M :- std.spy-do! [ -% 1) from M, the wrapper gref, -% we need to recover the wrapped mixin and the new subject. -% these could also be extracted e.g. from the type Ty of the wrapper projection. +pred filter_out_unique_defs_of_type i:term i:list term o:list term. +filter_out_unique_defs_of_type Ty InDcs OutDcs. + +pred infer_type i:term i:term o:term. +infer_type Trm ATyp Typ. + +pred extract_string_name i: term o:string. +extract_string_name Trm Str. + +pred export-wrapper-instance i: term i:term. +export-wrapper_instance Ty I :- std.spy-do! [ + infer_type I Ty Ty1, + extract_string_name I S, + coq.count-prods Ty0 N0, + instance.declare-const S I {coq.term->arity Ty0 N0} _ +]. + +% Based on the existing definitions, we want to add wrapper instances +% for all the original subjects that are covered. +pred derive_wrapper_instances i:mixinname. +derive_wrapper_instances M :- std.spy-do! [ +% 1) M is the wrapper mixin gref. +% The wrapped mixin and the new subject can be extracted from the type Ty +% of the wrapper projection dependent on the original subject T +% i.e. (forall (A B:T), isMon (hom A B)), +% which we need anyway. exported-op M _ C, - coq.say "???? C=" C, - B = (global (const C)), coq.env.typeof (const C) Ty, -% 2) we need to find a definition D for the projection. This can only be a function that -% has the same type. -% This is indeed the type of a function that constructs instances of the wrapped mixin -% on a given subject. -% Crucially, the type does not depend syntatically on the particular subject, becase it is -% generally -% forall A B, isMon (hom A B) -% Nonetheelss, if such a function is available, it is going to be defined -% on a specific subject that happens to give monoids, for example -% A -> option B. -% 3) then we can define the wrapper instance, using D. - instance.declare-const _ _ _ _ +% 2) The existing possible instances of M correspond to the functions of type (Ty _) +% that are already defined for different original subjects in the Coq code. +% We should consider only one function for each T, in order to be able to ensure +% canonicity. +% Notice the importance of assuming that all relevant functions have been +% defined using generic type syntax (otherwise recovering them would be much harder). + filter_out_unique_defs_of_type Ty FunctionDefinitions WrapperProjections, +% 3) We can define the wrapper instances based on Ty, using the projection definitions. + std.forall WrapperProjections (export-wrapper-instance Ty) ]. }} From a26cf4bad4c332e6b03e780d989c749abf911c4e Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 4 Jul 2023 11:48:35 +0200 Subject: [PATCH 35/63] changes in structure.elpi - mainly comments --- HB/structure.elpi | 57 ++++++++++++++++++++++++++++------------------- 1 file changed, 34 insertions(+), 23 deletions(-) diff --git a/HB/structure.elpi b/HB/structure.elpi index 2ac22954f..a04183b81 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -237,8 +237,10 @@ declare Module BSkel Sort :- std.do! [ coq.say "???? EX " EX, EX => std.forall WrapperML private.reexport-wrapper-as-instance, + coq.say "???? NewClauses " NewClauses, % tentative: generating wrapper instances from the available definitions. - NewClauses => std.forall WrapperML private.derive_wrapper_instances, + % EX => std.forall WrapperML private.derive_wrapper_instances, + % NewClauses => std.forall WrapperML private.derive_wrapper_instances, if-verbose (coq.say {header} "abbreviation factory-by-classname"), @@ -811,37 +813,46 @@ filter_out_unique_defs_of_type Ty InDcs OutDcs. pred infer_type i:term i:term o:term. infer_type Trm ATyp Typ. -pred extract_string_name i: term o:string. -extract_string_name Trm Str. - -pred export-wrapper-instance i: term i:term. -export-wrapper_instance Ty I :- std.spy-do! [ - infer_type I Ty Ty1, - extract_string_name I S, - coq.count-prods Ty0 N0, - instance.declare-const S I {coq.term->arity Ty0 N0} _ +pred extract_string_name i:mixinname i:term o:string. +extract_string_name W Trm Str. + +% build the wrapper instance that uses I as definition of the projection +pred export-wrapper-instance i:mixinname i:term. +export-wrapper_instance W I :- std.spy-do! [ + exported-op W _ C, + coq.env.typeof (const C) Ty, + % the Ty0 of I should be (Ty T), i.e. the wrapper instance type applied to the + % original subject of I + infer_type I Ty Ty0, + % maybe we need to generate a string from W and I to name the wrapper instance + extract_string_name W I S, + % then we build the wrapped instance from the generic wrapped one + % coq.count-prods Ty0 N0, + % instance.declare-const S I {coq.term->arity Ty0 N0} _ ]. % Based on the existing definitions, we want to add wrapper instances % for all the original subjects that are covered. pred derive_wrapper_instances i:mixinname. -derive_wrapper_instances M :- std.spy-do! [ -% 1) M is the wrapper mixin gref. -% The wrapped mixin and the new subject can be extracted from the type Ty -% of the wrapper projection dependent on the original subject T -% i.e. (forall (A B:T), isMon (hom A B)), -% which we need anyway. - exported-op M _ C, +derive_wrapper_instances W :- std.spy-do! [ +% 1) W is the wrapper mixin gref. +% We need the type of the wrapper projection, which depends on the original subject T +% i.e. (forall (A B:T), isMon (hom A B)) + exported-op W _ C, coq.env.typeof (const C) Ty, -% 2) The existing possible instances of M correspond to the functions of type (Ty _) -% that are already defined for different original subjects in the Coq code. -% We should consider only one function for each T, in order to be able to ensure -% canonicity. -% Notice the importance of assuming that all relevant functions have been +% 2) The existing instances of W correspond to the functions of type (Ty _) +% that are already defined for different original subjects; +% or in other words, they correspond to wrapped instances, +% given a specific original subject T and two generic objects of that type. +% Should we consider only one function for each T? +% This means that e.g. there is only one way a homset can be instance of the wrapped +% (here, a monoid). +% Notice that it's good to assume all relevant functions have been % defined using generic type syntax (otherwise recovering them would be much harder). +% This means for a carrier there is only a quiver. filter_out_unique_defs_of_type Ty FunctionDefinitions WrapperProjections, % 3) We can define the wrapper instances based on Ty, using the projection definitions. - std.forall WrapperProjections (export-wrapper-instance Ty) + std.forall WrapperProjections (export-wrapper-instance W) ]. }} From 09b022210f58daf060e68ee66afb39b486b617f7 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 4 Jul 2023 13:46:50 +0200 Subject: [PATCH 36/63] changes in structure.elpi - mainly comments --- HB/structure.elpi | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/HB/structure.elpi b/HB/structure.elpi index a04183b81..386aea58d 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -850,7 +850,9 @@ derive_wrapper_instances W :- std.spy-do! [ % Notice that it's good to assume all relevant functions have been % defined using generic type syntax (otherwise recovering them would be much harder). % This means for a carrier there is only a quiver. - filter_out_unique_defs_of_type Ty FunctionDefinitions WrapperProjections, +% The instances whould be filtered out from the current context, maybe EX? + filter_out_unique_defs_of_type Ty WrapperProjections, +% filter_out_unique_defs_of_type Ty AllInstances WrapperProjections, % 3) We can define the wrapper instances based on Ty, using the projection definitions. std.forall WrapperProjections (export-wrapper-instance W) ]. From e5f56a13c6c542b93b3ed4aff7a4cfffcf122517 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 4 Jul 2023 15:34:04 +0200 Subject: [PATCH 37/63] main changes in instance.elpi --- HB/instance.elpi | 114 +++++++++++++++++++++++++++++++++++- HB/structure.elpi | 71 ++-------------------- tests/monoid_enriched_cat.v | 15 ++++- 3 files changed, 130 insertions(+), 70 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 0b793248c..81a2654fd 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -68,6 +68,17 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ private.declare-instance Factory TheType TheFactory Clauses CSL, +% HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := +% funQ_isMonF A B. +% +% Factory = isMon +% TheFactory = funQ_isMon +% TheType = hom A B + + coq.say "inizio wrapper" Factory TheFactory TheType, + coq.safe-dest-app TheType TheTypeKey _, + + % handle parameters via a section -- end if (TyWP = arity _) true ( if-verbose (coq.say {header} "closing instance section"), @@ -75,7 +86,17 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ ), % we accumulate clauses now that the section is over - acc-clauses current Clauses + acc-clauses current Clauses, + + if (TheTypeKey = global TheTypeKeyGR) + (std.do! [ + std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, + coq.say "WRAPPERS:" Wrappers, + std.forall Wrappers (private.derive_wrapper_instances TheFactory) + ] + %derive_wrapper_instances Wrapper, + ) + true, ]. % [declare-all T CL MCSTL] given a type T and a list of class definition @@ -375,4 +396,95 @@ check-non-forgetful-inheritance T Factory :- std.do! [ ) true ]. +% The type of the wrapper projection is... +% hom_isMon.hom_isMon_private : +% forall (T : Type) +% (local_mixin_monoid_enriched_cat_isQuiver : isQuiver.axioms_ T), +% hom_isMon.axioms_ T local_mixin_monoid_enriched_cat_isQuiver -> +% forall +% A +% B : {| +% Quiver.sort := T; +% Quiver.class := +% {| +% Quiver.monoid_enriched_cat_isQuiver_mixin := +% local_mixin_monoid_enriched_cat_isQuiver +% |} +% |}, isMon.phant_axioms (hom A B) + +pred filter_out_unique_defs_of_type i:term o:list term. +filter_out_unique_defs_of_type Ty OutDcs. + +pred infer_type i:term i:term o:term. +infer_type Trm ATyp Typ. + +pred extract_string_name i:mixinname i:term o:string. +extract_string_name W Trm Str. + +% build the wrapper instance that uses I as definition of the projection +pred export-wrapper-instance i:mixinname i:term. +export-wrapper_instance W I :- std.do! [ + exported-op W _ C, + coq.env.typeof (const C) Ty, + % the Ty0 of I should be (Ty T), i.e. the wrapper instance type applied to the + % original subject of I + infer_type I Ty Ty0, + % maybe we need to generate a string from W and I to name the wrapper instance + extract_string_name W I S, + % then we build the wrapped instance from the generic wrapped one + % coq.count-prods Ty0 N0, + % instance.declare-const S I {coq.term->arity Ty0 N0} _ +]. + +% Based on the existing definitions, we want to add wrapper instances +% for all the original subjects that are covered. +% Instance has morally type Mixin Subject +pred derive_wrapper_instances i:term, i:prop. +derive_wrapper_instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.do! [ +% 1) W is the wrapper mixin gref. +% We need the type of the wrapper projection, which depends on the original subject T +% i.e. (forall (A B:T), isMon (hom A B)) + factory-constructor WrapperMixin K, + factory-nparams WrapperMixin NParams, + std.assert! (NParams = 0) "TODO support parameters", + + coq.env.typeof K KTy, + coq.count-prods KTy KN, + KN0 = KN - 1, + coq.mk-n-holes KN0 Holes, + + std.append Holes [Instance] Args, + NewInstance = app[global K| Args], + + coq.say "NewInstance=" {coq.term->string NewInstance}, + + coq.typecheck NewInstance Ty Dgn, + if (Dgn = error S) (coq.say "errore" S) + (coq.count-prods Ty N0, + instance.declare-const "_" NewInstance {coq.term->arity Ty N0} _ + ) + + +/* + exported-op W _ C, + coq.env.typeof (const C) Ty, +% 2) The existing instances of W correspond to the functions of type (Ty _) +% that are already defined for different original subjects; +% or in other words, they correspond to wrapped instances, +% given a specific original subject T and two generic objects of that type. +% Should we consider only one function for each T? +% This means that e.g. there is only one way a homset can be instance of the wrapped +% (here, a monoid). +% Notice that it's good to assume all relevant functions have been +% defined using generic type syntax (otherwise recovering them would be much harder). +% This means for a carrier there is only a quiver. +% The instances whould be filtered out from the current context, maybe EX? + filter_out_unique_defs_of_type Ty WrapperProjections, +% filter_out_unique_defs_of_type Ty AllInstances WrapperProjections, +% 3) We can define the wrapper instances based on Ty, using the projection definitions. + std.forall WrapperProjections (export-wrapper-instance W) + */ +]. +derive_wrapper_instances _ _. + }} diff --git a/HB/structure.elpi b/HB/structure.elpi index 386aea58d..24ba19e05 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -787,74 +787,11 @@ reexport-wrapper-as-instance M :- std.spy-do! [ coq.say "???? C=" C, B = (global (const C)), coq.env.typeof (const C) Ty, - coq.count-prods Ty N0, - instance.declare-const "xx" B {coq.term->arity Ty N0} _ + coq.count-prods Ty N0, + coq.term->arity Ty N0 Arity, + instance.declare-const "xx" B Arity _ ]. -% The type of the wrapper projection is... -% hom_isMon.hom_isMon_private : -% forall (T : Type) -% (local_mixin_monoid_enriched_cat_isQuiver : isQuiver.axioms_ T), -% hom_isMon.axioms_ T local_mixin_monoid_enriched_cat_isQuiver -> -% forall -% A -% B : {| -% Quiver.sort := T; -% Quiver.class := -% {| -% Quiver.monoid_enriched_cat_isQuiver_mixin := -% local_mixin_monoid_enriched_cat_isQuiver -% |} -% |}, isMon.phant_axioms (hom A B) - -pred filter_out_unique_defs_of_type i:term i:list term o:list term. -filter_out_unique_defs_of_type Ty InDcs OutDcs. - -pred infer_type i:term i:term o:term. -infer_type Trm ATyp Typ. - -pred extract_string_name i:mixinname i:term o:string. -extract_string_name W Trm Str. - -% build the wrapper instance that uses I as definition of the projection -pred export-wrapper-instance i:mixinname i:term. -export-wrapper_instance W I :- std.spy-do! [ - exported-op W _ C, - coq.env.typeof (const C) Ty, - % the Ty0 of I should be (Ty T), i.e. the wrapper instance type applied to the - % original subject of I - infer_type I Ty Ty0, - % maybe we need to generate a string from W and I to name the wrapper instance - extract_string_name W I S, - % then we build the wrapped instance from the generic wrapped one - % coq.count-prods Ty0 N0, - % instance.declare-const S I {coq.term->arity Ty0 N0} _ -]. - -% Based on the existing definitions, we want to add wrapper instances -% for all the original subjects that are covered. -pred derive_wrapper_instances i:mixinname. -derive_wrapper_instances W :- std.spy-do! [ -% 1) W is the wrapper mixin gref. -% We need the type of the wrapper projection, which depends on the original subject T -% i.e. (forall (A B:T), isMon (hom A B)) - exported-op W _ C, - coq.env.typeof (const C) Ty, -% 2) The existing instances of W correspond to the functions of type (Ty _) -% that are already defined for different original subjects; -% or in other words, they correspond to wrapped instances, -% given a specific original subject T and two generic objects of that type. -% Should we consider only one function for each T? -% This means that e.g. there is only one way a homset can be instance of the wrapped -% (here, a monoid). -% Notice that it's good to assume all relevant functions have been -% defined using generic type syntax (otherwise recovering them would be much harder). -% This means for a carrier there is only a quiver. -% The instances whould be filtered out from the current context, maybe EX? - filter_out_unique_defs_of_type Ty WrapperProjections, -% filter_out_unique_defs_of_type Ty AllInstances WrapperProjections, -% 3) We can define the wrapper instances based on Ty, using the projection definitions. - std.forall WrapperProjections (export-wrapper-instance W) -]. + }} diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 5c09ed50a..35b8a5ba7 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -137,14 +137,25 @@ Qed. Print Canonical Projections. Fail Check (nat -> option nat) : Monoid.type. +Check 1. + +Print Canonical Projections. + +Check 2. +Set Printing All. (* use the lemma to instantiate isMon. Notice the genericity of the type. *) HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := funQ_isMonF A B. +Print Canonical Projections. + +Check 3. + stop + + (* instantiate hom_isMon by using the generic isMon instance to define 'private' *) HB.instance Definition funQ_hom_isMon := - hom_isMon.Build Type (fun A B => funQ_isMon A B). - + hom_isMon.Axioms_ Type _ funQ_isMon. (* HB.about private. *) Print Canonical Projections. (* this has to be changed, it should be something like (hom nat nat): From 36dc631068fff3ba55acdc731e4adc224d6346c6 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 4 Jul 2023 21:23:18 +0200 Subject: [PATCH 38/63] added commments in instance.elpi --- HB/instance.elpi | 85 +++++++++++++++++++++---------------- HB/structure.elpi | 5 ++- tests/monoid_enriched_cat.v | 4 +- 3 files changed, 53 insertions(+), 41 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 81a2654fd..4f74821a6 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -68,6 +68,12 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ private.declare-instance Factory TheType TheFactory Clauses CSL, +% In a WRAPPING-RELEVANT INSTANCE, +% Factory is the wrapped mixin, TheType is the new subject, +% TheFactory is the wrapped instance for the new subject (in fact, +% it is the term for the instance that is being processed). +% E.g. in connection with our example in monoid_enriched_cat.v: +% % HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := % funQ_isMonF A B. % @@ -75,9 +81,15 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ % TheFactory = funQ_isMon % TheType = hom A B - coq.say "inizio wrapper" Factory TheFactory TheType, + coq.say "wrapping instance ???", + coq.say "Factory = " Factory, + coq.say "TheFactory = " TheFactory, + coq.say "TheType = " TheType, + + % extracts the head subterm (e.g. hom) coq.safe-dest-app TheType TheTypeKey _, + coq.say "TheTypeKey = " TheTypeKey, % handle parameters via a section -- end if (TyWP = arity _) true ( @@ -88,13 +100,23 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ % we accumulate clauses now that the section is over acc-clauses current Clauses, + % As a general idea, we want to add wrapper instances + % for the original subjects that are covered by the current instances. + % Here we are processing a specific instance. We want to check + % whether it corresponds to a wrapper with respect to the new subject + % (associated with TheTypeKey and the Factory mixin). + % To this purpose, + % 1) we find all the wrappers that agree with the given parameters, + % using the wrapper-mixin predicate. + % 2) we then apply derive_wrapper_instances to each wrapper, together + % with the current instance, to create the derived wrapper instances. + % Notice that derive_wrapper_instances calls declare-const. if (TheTypeKey = global TheTypeKeyGR) (std.do! [ - std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, - coq.say "WRAPPERS:" Wrappers, - std.forall Wrappers (private.derive_wrapper_instances TheFactory) - ] - %derive_wrapper_instances Wrapper, + std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, + coq.say "WRAPPERS:" Wrappers, + std.forall Wrappers (private.derive_wrapper_instances TheFactory) + ] ) true, ]. @@ -411,49 +433,39 @@ check-non-forgetful-inheritance T Factory :- std.do! [ % local_mixin_monoid_enriched_cat_isQuiver % |} % |}, isMon.phant_axioms (hom A B) - -pred filter_out_unique_defs_of_type i:term o:list term. -filter_out_unique_defs_of_type Ty OutDcs. -pred infer_type i:term i:term o:term. -infer_type Trm ATyp Typ. - +% Not used, but possible useful pred extract_string_name i:mixinname i:term o:string. extract_string_name W Trm Str. -% build the wrapper instance that uses I as definition of the projection -pred export-wrapper-instance i:mixinname i:term. -export-wrapper_instance W I :- std.do! [ - exported-op W _ C, - coq.env.typeof (const C) Ty, - % the Ty0 of I should be (Ty T), i.e. the wrapper instance type applied to the - % original subject of I - infer_type I Ty Ty0, - % maybe we need to generate a string from W and I to name the wrapper instance - extract_string_name W I S, - % then we build the wrapped instance from the generic wrapped one - % coq.count-prods Ty0 N0, - % instance.declare-const S I {coq.term->arity Ty0 N0} _ -]. - -% Based on the existing definitions, we want to add wrapper instances -% for all the original subjects that are covered. -% Instance has morally type Mixin Subject +% Instance has morally type 'Mixin Subject' pred derive_wrapper_instances i:term, i:prop. derive_wrapper_instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.do! [ -% 1) W is the wrapper mixin gref. -% We need the type of the wrapper projection, which depends on the original subject T -% i.e. (forall (A B:T), isMon (hom A B)) + % K is the mixin constructor (Build) for WrapperMixin factory-constructor WrapperMixin K, factory-nparams WrapperMixin NParams, std.assert! (NParams = 0) "TODO support parameters", + % We are only interested in the last parameter of the constructor + % type, which is the current instance + % (which is a Mixin instance on the new Subject). + % In monoid_enriched_cat.v, we are targeting the code + % + % HB.instance Definition funQ_hom_isMon := + % hom_isMon.Axioms_ _ _ funQ_isMon. + % which Coq can compute to stand for + % hom_isMon.Axioms_ Type funQ funQ_isMon. + % + % We compute the number of the underscores and we pass + % them as arguments followed by Instance. coq.env.typeof K KTy, coq.count-prods KTy KN, KN0 = KN - 1, coq.mk-n-holes KN0 Holes, std.append Holes [Instance] Args, + + % the body of the new wrapper instance NewInstance = app[global K| Args], coq.say "NewInstance=" {coq.term->string NewInstance}, @@ -461,13 +473,12 @@ derive_wrapper_instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- coq.typecheck NewInstance Ty Dgn, if (Dgn = error S) (coq.say "errore" S) (coq.count-prods Ty N0, + % we then call declare-const to add the new instance. + % the name needs to be fixed. instance.declare-const "_" NewInstance {coq.term->arity Ty N0} _ ) - /* - exported-op W _ C, - coq.env.typeof (const C) Ty, % 2) The existing instances of W correspond to the functions of type (Ty _) % that are already defined for different original subjects; % or in other words, they correspond to wrapped instances, @@ -483,7 +494,7 @@ derive_wrapper_instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- % filter_out_unique_defs_of_type Ty AllInstances WrapperProjections, % 3) We can define the wrapper instances based on Ty, using the projection definitions. std.forall WrapperProjections (export-wrapper-instance W) - */ +*/ ]. derive_wrapper_instances _ _. diff --git a/HB/structure.elpi b/HB/structure.elpi index 24ba19e05..324e9742a 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -238,7 +238,10 @@ declare Module BSkel Sort :- std.do! [ EX => std.forall WrapperML private.reexport-wrapper-as-instance, coq.say "???? NewClauses " NewClauses, + % tentative: generating wrapper instances from the available definitions. + % Wrong approach: we actually need to check each new defined instance to + % see if it triggers a wrapper instance too. We do this in instance.elpi. % EX => std.forall WrapperML private.derive_wrapper_instances, % NewClauses => std.forall WrapperML private.derive_wrapper_instances, @@ -792,6 +795,4 @@ reexport-wrapper-as-instance M :- std.spy-do! [ instance.declare-const "xx" B Arity _ ]. - - }} diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 35b8a5ba7..49a314f59 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -150,9 +150,9 @@ HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := Print Canonical Projections. Check 3. - stop - +stop + (* instantiate hom_isMon by using the generic isMon instance to define 'private' *) HB.instance Definition funQ_hom_isMon := hom_isMon.Axioms_ Type _ funQ_isMon. From b46a369eb0fec48cf2192a58957f55a1aef4aecb Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 4 Jul 2023 21:31:15 +0200 Subject: [PATCH 39/63] minor changes in monoid_enriched_cat.v (wrapper instance definition not commented out yet) --- tests/monoid_enriched_cat.v | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 49a314f59..42bbc7f9f 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -151,11 +151,10 @@ Print Canonical Projections. Check 3. -stop - (* instantiate hom_isMon by using the generic isMon instance to define 'private' *) -HB.instance Definition funQ_hom_isMon := - hom_isMon.Axioms_ Type _ funQ_isMon. + HB.instance Definition funQ_hom_isMon := + hom_isMon.Build Type funQ_isMon. + (* HB.about private. *) Print Canonical Projections. (* this has to be changed, it should be something like (hom nat nat): From d93a11d3010d53740a962256e4ec996c865a1492 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 5 Jul 2023 17:22:55 +0200 Subject: [PATCH 40/63] Update tests/monoid_enriched_cat.v Co-authored-by: Cyril Cohen --- tests/monoid_enriched_cat.v | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 42bbc7f9f..493e6db0d 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -148,6 +148,7 @@ HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := funQ_isMonF A B. Print Canonical Projections. +Check (fun A B : Type => hom A B : Monoid.type). Check 3. From e4c37329bb88bf8d366ff3073cdbd36a597ccb99 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 5 Jul 2023 17:24:44 +0200 Subject: [PATCH 41/63] added summary of today's discussion at the bottom of instance.elpi --- HB/instance.elpi | 68 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) diff --git a/HB/instance.elpi b/HB/instance.elpi index 4f74821a6..7176f8336 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -498,4 +498,72 @@ derive_wrapper_instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- ]. derive_wrapper_instances _ _. +/* +GENERAL COMMENT 05/07/2023. +We have already implemented the elimination rule for wrapper +instances (adding the projection means that given a wrapper instance +we can get a base mixin one). +We are now implementing the introduction rule for wrapper mixins, +that is, given a function definition (prospected instance) that has +the type of the wrapper projection specialized to the base mixin +(base = wrapped), we can derive a wrapper instance. +The current proposed solution assumes that the prospected instance +has already been lifted to a base mixin instance, and additionally +introduces the wrapper instance. +This is undesirable, as in fact, given the wrapper projection, the +base mixin instance can be derived from the wrapper instance. +So we actually want to use the prospected instance to introduce +the wrapper instance directly. +Moreover, the current solution involves iterating over all the wrappers, +given an instance, in order to check whether it is a base mixin instance +for some wrapper. +So it is not good to call 'derive_wrapper_instances' in 'declare-const'. + +Instead, we consider 'declare-existing' (line 8) which is used to +collect each Coq definition (I guess), therefore also a prospective +instance. +Our real entry point should be 'declare-instance' (line 243). +There are two clauses for this predicate (some refactoring needed?) +We will focus on the latter (line 253), which calls +'declare-canonical-instances-from-factory' (defined at line 337). + +At line 339, Factory is the mixin (base mixin?), + T is the type (new subject (@hom T0 A B) ?), + F is the prospective instance (crucially!), + CSL are the clauses so far. +Notably: + Line 344, 'synthesis.under-mixin-src-from-factory.do!'. + Line 347, 'add-all-mixins'. + Line 348, 'declare-all'. + +In the implemention of 'under-mixin-src-from-factory.do!' +(line 99, synthesis.elpi), +- the first two arguments of 'mixin-src', i.e 'TheType' and 'm', + should be related by 'wrapper-mixin' + (with 'hom' extracted from 'TheType' ??) + (with 'm' as base mixin ??) +- 'std.map' ranges over 'ML' (the mixins) and produces clauses + collected in MLClauses +- the third argument is the continuation (executed after locally + adding MLClauses to the context). + Here 'add-all-mixins' is called (line 347, instance.elpi). + +'add-all-mixins' (defined line 291) calls +'add-mixin' (defined line 262). +In 'add-mixin' we should check when 'MissingMixin' is a wrapped one. +Change then will affect 'C'. +Also check 'assert!-infer-mixin' (synthesis.elpi, line 81) which +calls 'mixin-for' (synthesis.elpi, line 176). +'mixin-for' actually produces a mixin instance for a mixin and a type, +given a database. + +Main targets for change: +- 'under-mixin-src-from-factory.do!' : change of subject +- 'add-mixin': check 'MissingMixin', change 'C'. +- discussion about overloading of 'mixin-src': used in different predicates, + not really understood (??) +- possible refactoring of 'declare-instance' + +*/ + }} From 911ede106cd49d395143f3f035220e49c8d675f1 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Mon, 3 Jul 2023 10:11:11 +0200 Subject: [PATCH 42/63] setup nix --- .nix/config.nix | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.nix/config.nix b/.nix/config.nix index bd392b3cb..e340153a2 100644 --- a/.nix/config.nix +++ b/.nix/config.nix @@ -1,7 +1,7 @@ { format = "1.0.0"; attribute = "hierarchy-builder"; - default-bundle = "coq-8.15"; + default-bundle = "coq-8.16"; bundles = let mcHBcommon = { mathcomp.override.version = "hierarchy-builder"; @@ -26,6 +26,9 @@ coq.override.version = "8.15"; } // mcHBcommon; + "coq-8.17".coqPackages = { + coq.override.version = "8.17"; + }; "coq-8.16".coqPackages = { coq.override.version = "8.16"; mathcomp.override.version = "mathcomp-1.15.0"; From 4e47908d7e41f2094332839d7f6fe5f71ad4d651 Mon Sep 17 00:00:00 2001 From: Cyril Cohen Date: Thu, 6 Jul 2023 14:31:13 +0200 Subject: [PATCH 43/63] blind attempt --- HB/instance.elpi | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 7176f8336..df6b8761d 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -344,10 +344,12 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ synthesis.under-mixin-src-from-factory.do! T F [ synthesis.under-local-canonical-mixins-of.do! T [ list-w-params_list {factory-provides Factory} ML, - add-all-mixins T Factory ML tt _ MCSL, - instance.declare-all T {findall-classes-for ML} CCSL, + add-all-mixins T Factory ML tt Clauses MCSL, % this should output all the candidate subjects too, as a new output argument. ] ], + AllSubjects = [T], % change this + Clauses => std.forall AllSubjects + (s\ instance.declare-all s {findall-classes-for ML} CCSL), std.append MCSL CCSL CSL ]. From 3d0961c1ea89e7a30dcb7c10b77f6768be30be3e Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 6 Jul 2023 15:37:41 +0200 Subject: [PATCH 44/63] minor changes to comments in instance.elpi --- HB/instance.elpi | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index df6b8761d..5e7030375 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -344,12 +344,25 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ synthesis.under-mixin-src-from-factory.do! T F [ synthesis.under-local-canonical-mixins-of.do! T [ list-w-params_list {factory-provides Factory} ML, - add-all-mixins T Factory ML tt Clauses MCSL, % this should output all the candidate subjects too, as a new output argument. + +%% + % Old code: + % notice the underscore in add-all-mixins, output clauses are not used + % add-all-mixins T Factory ML tt _ MCSL, + % instance.declare-all T {findall-classes-for ML} CCSL, ] ], + + % New code: + % this should output all the candidate subjects too, as a new output argument. + add-all-mixins T Factory ML tt Clauses MCSL, ] ], - AllSubjects = [T], % change this + AllSubjects = [T], % change this using the additional output in add-all-mixins + % declare-all now is mapped on all the subjects, while Clauses is added to the context. Clauses => std.forall AllSubjects (s\ instance.declare-all s {findall-classes-for ML} CCSL), + +%% + std.append MCSL CCSL CSL ]. @@ -521,10 +534,8 @@ given an instance, in order to check whether it is a base mixin instance for some wrapper. So it is not good to call 'derive_wrapper_instances' in 'declare-const'. -Instead, we consider 'declare-existing' (line 8) which is used to -collect each Coq definition (I guess), therefore also a prospective -instance. -Our real entry point should be 'declare-instance' (line 243). +Our real entry point should be 'declare-instance' (line 243) +(ignore 'declare-existing', deprecated). There are two clauses for this predicate (some refactoring needed?) We will focus on the latter (line 253), which calls 'declare-canonical-instances-from-factory' (defined at line 337). @@ -560,11 +571,12 @@ calls 'mixin-for' (synthesis.elpi, line 176). given a database. Main targets for change: -- 'under-mixin-src-from-factory.do!' : change of subject -- 'add-mixin': check 'MissingMixin', change 'C'. -- discussion about overloading of 'mixin-src': used in different predicates, +- add-all-mixins: see the proposed change +- ? 'add-mixin': check 'MissingMixin', change 'C'. +- ? discussion about overloading of 'mixin-src': used in different predicates, not really understood (??) -- possible refactoring of 'declare-instance' +- ? possible refactoring of 'declare-instance' +- ? 'under-mixin-src-from-factory.do!' : actually no need to change the subject */ From 314dadc79ef5667e58608db592c278fcbd08b981 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 13 Jul 2023 16:43:07 +0200 Subject: [PATCH 45/63] added debug printouts --- HB/factory.elpi | 19 +++++- HB/instance.elpi | 125 ++++++++++++++++++++++++++++-------- HB/structure.elpi | 16 +++-- tests/monoid_enriched_cat.v | 2 + 4 files changed, 127 insertions(+), 35 deletions(-) diff --git a/HB/factory.elpi b/HB/factory.elpi index 158060f07..bceb4a710 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -15,9 +15,13 @@ type by-phantabbrev abbreviation -> factory-abbrev. pred declare-abbrev i:id, i:factory-abbrev. declare-abbrev Name (by-classname GR) :- + + coq.say "DA!!!!!!&&& NOW RUNNING declare-abbrev", + % looks fishy (the parameters are not taken into account) @global! => log.coq.notation.add-abbreviation Name 1 (fun _ _ t\ app[global GR,t]) tt _. declare-abbrev Name (by-phantabbrev Abbr) :- std.do! [ + coq.say "DA!!!!!!&&& NOW RUNNING declare-abbrev", coq.notation.abbreviation-body Abbr Nargs AbbrTrm, @global! => log.coq.notation.add-abbreviation Name Nargs AbbrTrm tt _, ]. @@ -267,6 +271,17 @@ pred declare-mixin-or-factory i:list prop, i:list constant, i:list term, i:term, declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance TheParams TheType Sort1 Fields GRFSwP Module D :- std.do! [ + coq.say "DMOF!!!!!!!!!!!!!!!!!!!! NOW RUNNING declare-mixin-or-factory", + coq.say "DMOF!!!!!!!! MixinSrcClauses" MixinSrcCaluses, + coq.say "DMOF!!!!!!!! SectionCanonicalInstance" SectionCanonicalInstance, + coq.say "DMOF!!!!!!!! TheParams" TheParams, + coq.say "DMOF!!!!!!!! TheType" TheType, + coq.say "DMOF!!!!!!!! Sort1" Sort1, + coq.say "DMOF!!!!!!!! Fields" Fields, + coq.say "DMOF!!!!!!!! GRFSwP" GRFSwP, + coq.say "DMOF!!!!!!!! Module" Module, + coq.say "DMOF!!!!!!!! D" D, + if-verbose (coq.say {header} "declare record axioms_"), Kname = "Axioms_", RDeclSkel = record "axioms_" Sort1 Kname Fields, @@ -296,7 +311,7 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance build-deps-for-projections R MLwP GRDepsClausesProjs, GRDepsClauses = [gref-deps (indt R) MLwP, gref-deps (indc K) MLwP|GRDepsClausesProjs], - coq.say "TODO: extract useful info:" RDecl, + % coq.say "TODO: extract useful info:" RDecl, % coq.say "TODO: extract useful info:" RDecl "AND THEN:" RDeclClosed, % record-decl in https://github.com/LPCIC/coq-elpi/blob/master/coq-builtin.elpi#L429 % per trovare il vero nome del mixin database.elpi:factory-alias->gref @@ -316,7 +331,7 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance (WrapperClauses = [wrapper-mixin (indt R) NSbj WMxn])) (WrapperClauses = []), - % coq.say "aggiungiamo " WrapperClauses, + coq.say "DMOF!!!!!!!! adding WrapperClauses " WrapperClauses, % GRDepsClauses => mk-factory-sort MLwP (indt R) _ FactorySortCoe, % FactorySortCoe = coercion GRFSort _ _ _, diff --git a/HB/instance.elpi b/HB/instance.elpi index 5e7030375..ebb7d5eca 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -23,6 +23,12 @@ declare-existing T0 F0 :- std.do! [ % that can be built using factory instance B pred declare-const i:id, i:term, i:arity, o:list (pair id constant). declare-const Name BodySkel TyWPSkel CSL :- std.do! [ + + coq.say "DC!!!!!!!!!!!!! NOW RUNNING (entry point) declare-const Name BodySkel TyWPSkel CSL", + coq.say "DC!!!!!!!!!!!!! Name = " Name, + coq.say "DC!!!!!!!!!!!!! BodySkel = " BodySkel, + coq.say "DC!!!!!!!!!!!!! TyWPSkel = " TyWPSkel, + std.assert-ok! (coq.elaborate-arity-skeleton TyWPSkel _ TyWP) "Definition type illtyped", coq.arity->term TyWP Ty, std.assert-ok! (coq.elaborate-skeleton BodySkel Ty Body) "Definition illtyped", @@ -81,15 +87,17 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ % TheFactory = funQ_isMon % TheType = hom A B - coq.say "wrapping instance ???", - coq.say "Factory = " Factory, - coq.say "TheFactory = " TheFactory, - coq.say "TheType = " TheType, + coq.say "DC!!!!!! Aft DI: wrapping instance", + coq.say "DC!!!!!! Aft DI: Factory = " Factory, + coq.say "DC!!!!!! Aft DI: TheType = " TheType, + coq.say "DC!!!!! Aft DI: TheFactory = " TheFactory, + coq.say "DC!!!!!! Aft DI: Clauses = " Clauses, + coq.say "DC!!!!! Aft DI: CSL = " CSL, % extracts the head subterm (e.g. hom) coq.safe-dest-app TheType TheTypeKey _, - coq.say "TheTypeKey = " TheTypeKey, + coq.say "DC!!!!!! Aft DI: TheTypeKey = " TheTypeKey, % handle parameters via a section -- end if (TyWP = arity _) true ( @@ -108,17 +116,19 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ % To this purpose, % 1) we find all the wrappers that agree with the given parameters, % using the wrapper-mixin predicate. - % 2) we then apply derive_wrapper_instances to each wrapper, together + % 2) we then apply derive-wrapper-instances to each wrapper, together % with the current instance, to create the derived wrapper instances. - % Notice that derive_wrapper_instances calls declare-const. + % Notice that derive-wrapper-instances calls declare-const. if (TheTypeKey = global TheTypeKeyGR) (std.do! [ std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, - coq.say "WRAPPERS:" Wrappers, - std.forall Wrappers (private.derive_wrapper_instances TheFactory) + coq.say "DC!!!!!! WRAPPERS (used in old implementation, need changes):" Wrappers, + std.forall Wrappers (private.derive-wrapper-instances TheFactory) ] ) true, + + coq.say "DC!!!!!!!!!!!!! (final output) CSL = " CSL, ]. % [declare-all T CL MCSTL] given a type T and a list of class definition @@ -243,6 +253,12 @@ shorten coq.{ term->gref, subst-fun, safe-dest-app, mk-app, mk-eta, subst-prod } pred declare-instance i:factoryname, i:term, i:term, o:list prop, o:list (pair id constant). declare-instance Factory T F Clauses CSL :- + + coq.say "DI??????!!!!!!!!!! NOW RUNNING (1) private.declare-instance Factory T F Clauses CSL", + coq.say "DI?????? Factory " Factory, + coq.say "DI?????? T " T, + coq.say "DI?????? F " F, + current-mode (builder-from T TheFactory FGR _), !, if (get-option "local" tt) (coq.error "HB: declare-instance: cannot make builders local. @@ -251,6 +267,12 @@ declare-instance Factory T F Clauses CSL :- declare-canonical-instances-from-factory-and-local-builders Factory T F TheFactory FGR Clauses CSL. declare-instance Factory T F Clauses CSL :- + + coq.say "DI??????!!!!!!!!!! NOW RUNNING (2) private.declare-instance Factory T F Clauses CSL", + coq.say "DI?????? Factory " Factory, + coq.say "DI?????? T " T, + coq.say "DI?????? F " F, + declare-canonical-instances-from-factory Factory T F CSL, if (get-option "export" tt) (coq.env.current-library File, @@ -262,6 +284,9 @@ declare-instance Factory T F Clauses CSL :- pred add-mixin i:term, i:factoryname, i:bool, i:mixinname, o:list prop, o:list (pair id constant). add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do! [ + + coq.say "AM!!!!!!!!! NOW RUNNING add-mixin", + new_int N, % timestamp synthesis.assert!-infer-mixin T MissingMixin Bo, @@ -291,11 +316,23 @@ add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, o:list prop, o:list (pair id constant). add-all-mixins T FGR ML MakeCanon Clauses CSL :- std.do! [ + + coq.say "AAM!!!!!!!!!!!!!!! NOW RUNNING add-all-mixins", + + coq.say "AAM!!!!!!!!!! Bfr T = " T, + coq.say "AAM!!!!!!!!!! Bfr Factory (FGR) = " FGR, + coq.say "AAM!!!!!!!!!! Bfr ML = " ML, + coq.say "AAM!!!!!!!!!! Bfr MakeCanon" MakeCanon, + std.map ML (m\ o\ sigma ClL CSL\ add-mixin T FGR MakeCanon m ClL CSL, o = pr ClL CSL) ClLxCSL_L, std.unzip ClLxCSL_L ClLL CSLL, std.flatten ClLL Clauses, - std.flatten CSLL CSL + std.flatten CSLL CSL, + + coq.say "AAM!!!!!!!!!! Aft Clauses = " Clauses, + coq.say "AAM!!!!!!!!!! Aft CSL = " CSL, + ]. % [postulate-arity A Acc T TS] postulates section variables @@ -337,6 +374,9 @@ declare-canonical-instances-from-factory-and-local-builders pred declare-canonical-instances-from-factory i:factoryname, i:term, i:term, o:list (pair id constant). declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ + + coq.say "DCIFF!!!!!!!!!!! NOW RUNNING declare-canonical-instances-from-factory", + % The order of the following two "under...do!" is crucial, % priority must be given to canonical mixins % as they are the ones which guarantee forgetful inheritance @@ -346,11 +386,20 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ list-w-params_list {factory-provides Factory} ML, %% + % coq.say "#!!!!!!!!!! Bfr F = " F, + % Old code: % notice the underscore in add-all-mixins, output clauses are not used - % add-all-mixins T Factory ML tt _ MCSL, - % instance.declare-all T {findall-classes-for ML} CCSL, ] ], + add-all-mixins T Factory ML tt _ MCSL, + instance.declare-all T {findall-classes-for ML} CCSL, + + coq.say "DCIFF!!!!!!!!!! Aft MCSL = " MCSL, + coq.say "DCIFF!!!!!!!!!! Aft CCSL = " CCSL, + coq.say "DCIFF!!!!!!!!!! Aft (NOT USED!) CSL = " CSL, + + ] ], +/* % New code: % this should output all the candidate subjects too, as a new output argument. add-all-mixins T Factory ML tt Clauses MCSL, @@ -362,6 +411,7 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ (s\ instance.declare-all s {findall-classes-for ML} CCSL), %% +*/ std.append MCSL CCSL CSL ]. @@ -454,8 +504,12 @@ pred extract_string_name i:mixinname i:term o:string. extract_string_name W Trm Str. % Instance has morally type 'Mixin Subject' -pred derive_wrapper_instances i:term, i:prop. -derive_wrapper_instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.do! [ +pred derive-wrapper-instances i:term, i:prop. +derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.do! [ + + coq.say "OLD!!!!!!!!! NOW RUNNING (old implementation, BAD) derive-wrapper-instances Instance _", + coq.say "OLD!!!!!!! Instance " Instance, + % K is the mixin constructor (Build) for WrapperMixin factory-constructor WrapperMixin K, factory-nparams WrapperMixin NParams, @@ -483,7 +537,7 @@ derive_wrapper_instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- % the body of the new wrapper instance NewInstance = app[global K| Args], - coq.say "NewInstance=" {coq.term->string NewInstance}, + coq.say "!!!!!!!! NewInstance=" {coq.term->string NewInstance}, coq.typecheck NewInstance Ty Dgn, if (Dgn = error S) (coq.say "errore" S) @@ -511,7 +565,7 @@ derive_wrapper_instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.forall WrapperProjections (export-wrapper-instance W) */ ]. -derive_wrapper_instances _ _. +derive-wrapper-instances _ _. /* GENERAL COMMENT 05/07/2023. @@ -529,25 +583,40 @@ This is undesirable, as in fact, given the wrapper projection, the base mixin instance can be derived from the wrapper instance. So we actually want to use the prospected instance to introduce the wrapper instance directly. -Moreover, the current solution involves iterating over all the wrappers, +Moreoever, our solution only works when the base mixin is atomic (note this +is why we need to get down to add-all-mixins). +Finally, the current solution involves iterating over all the wrappers, given an instance, in order to check whether it is a base mixin instance for some wrapper. -So it is not good to call 'derive_wrapper_instances' in 'declare-const'. +So it is not good to call 'derive-wrapper-instances' in 'declare-const'. + +Top-level (called in structures.v): 'instance.declare-const', 'structure.declare'. + +Our real entry point should be 'instance.private.declare-instance' (after line 243) +Notice that 'declare-instance' is only called in 'instance.declare-const' +(ignore 'instance.declare-existing', deprecated). + +'instance.declare-const' is called in 'instance.mk-factory-sort-factory' +(called in instance.declare-factory-sort-deps and + instance.declare-factory-sort-factory), +in 'instance.private.derive-wrapper-instance' (our predicate, + called in instance.declare-const), +in 'structure.declare', +in 'structure.private.reexport-wrapper-as-instance' (our predicate, + called in structure.declare). -Our real entry point should be 'declare-instance' (line 243) -(ignore 'declare-existing', deprecated). There are two clauses for this predicate (some refactoring needed?) -We will focus on the latter (line 253), which calls -'declare-canonical-instances-from-factory' (defined at line 337). +We will focus on the latter (after line 253), which calls +'declare-canonical-instances-from-factory' (defined after line 337). -At line 339, Factory is the mixin (base mixin?), +At line 3**, Factory is the mixin (base mixin?), T is the type (new subject (@hom T0 A B) ?), F is the prospective instance (crucially!), CSL are the clauses so far. Notably: - Line 344, 'synthesis.under-mixin-src-from-factory.do!'. - Line 347, 'add-all-mixins'. - Line 348, 'declare-all'. + Line 3**, 'synthesis.under-mixin-src-from-factory.do!'. + Line 3**, 'add-all-mixins'. + Line 3**, 'declare-all'. In the implemention of 'under-mixin-src-from-factory.do!' (line 99, synthesis.elpi), @@ -561,8 +630,8 @@ In the implemention of 'under-mixin-src-from-factory.do!' adding MLClauses to the context). Here 'add-all-mixins' is called (line 347, instance.elpi). -'add-all-mixins' (defined line 291) calls -'add-mixin' (defined line 262). +'add-all-mixins' (defined after line 291) calls +'add-mixin' (defined after line 262). In 'add-mixin' we should check when 'MissingMixin' is a wrapped one. Change then will affect 'C'. Also check 'assert!-infer-mixin' (synthesis.elpi, line 81) which diff --git a/HB/structure.elpi b/HB/structure.elpi index 324e9742a..bc0461f5d 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -8,6 +8,9 @@ namespace structure { pred declare i:string, i:term, i:sort. pred declare i:string, i:term, i:universe. declare Module BSkel Sort :- std.do! [ + + coq.say "D!!!!!!!!!!!!!!!! NOW RUNNING declare", + disable-id-phant BSkel BSkelNoId, std.assert-ok! (coq.elaborate-skeleton BSkelNoId _ BNoId) "illtyped structure definition", re-enable-id-phant BNoId B, @@ -233,11 +236,11 @@ declare Module BSkel Sort :- std.do! [ % i.e. [indt «hom_isMon.axioms_»] % we can use reexport-wrapper-as-instance to get the projection and build % the instances. - coq.say "???? WrapperML " WrapperML, - coq.say "???? EX " EX, + coq.say "D!!!!????? WrapperML " WrapperML, + coq.say "D!!!!????? EX (local context): " EX, EX => std.forall WrapperML private.reexport-wrapper-as-instance, - coq.say "???? NewClauses " NewClauses, + % coq.say "???? NewClauses " NewClauses, % tentative: generating wrapper instances from the available definitions. % Wrong approach: we actually need to check each new defined instance to @@ -785,9 +788,12 @@ mk-hb-eta.arity Structure ClassName SortProjection % instance.declare-const (notably used in the API, i.e. in structures.v, % HB.instance) pred reexport-wrapper-as-instance i:mixinname. -reexport-wrapper-as-instance M :- std.spy-do! [ +% reexport-wrapper-as-instance M :- std.spy-do! [ +reexport-wrapper-as-instance M :- std.do! [ exported-op M _ C, - coq.say "???? C=" C, + coq.say "RWAI!!!???? NOW RUNNING private.reexport-wrapper-as-instance", + coq.say "RWAI!!!???? M = " M, + coq.say "RWAI!!!???? C = " C, B = (global (const C)), coq.env.typeof (const C) Ty, coq.count-prods Ty N0, diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 493e6db0d..87f542040 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -78,6 +78,8 @@ About hom_isMon_private. (* Essentially, step 2 is the elimination rule for the wrapper, step 3 is the introduction one *) (* quiver instance (simply typed functions between two types) *) +(* Elpi Trace Browser. *) + HB.instance Definition funQ := isQuiver.Build Type (fun A B => A -> option B). From 5f18ee4f63d3e35509c73a7b0ee8853a198d73ca Mon Sep 17 00:00:00 2001 From: ptorrx Date: Mon, 17 Jul 2023 20:14:08 +0200 Subject: [PATCH 46/63] revised comments and printouts, minor change in structure.elpi to name instance --- HB/instance.elpi | 42 +++++++++++++++++++++++---------- HB/structure.elpi | 9 +++++-- structures.v | 4 +++- tests/monoid_enriched_cat.v | 47 +++++++++++++++++++++++++++---------- 4 files changed, 73 insertions(+), 29 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index ebb7d5eca..c2b2f8418 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -385,18 +385,26 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ synthesis.under-local-canonical-mixins-of.do! T [ list-w-params_list {factory-provides Factory} ML, + coq.say "DCIFF!!!!!!! Factory = " Factory, + coq.say "DCIFF!!!!!!! T = " T, + coq.say "DCIFF!!!!!!! F = " F, + coq.say "DCIFF!!!!!!! ML (mixin names) = " ML, + coq.say "DFIFF!!!!!!! run add-all-mixins T Factory ML tt _ MCSL", + %% % coq.say "#!!!!!!!!!! Bfr F = " F, % Old code: % notice the underscore in add-all-mixins, output clauses are not used - add-all-mixins T Factory ML tt _ MCSL, + % pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, + % o:list prop, o:list (pair id constant). + add-all-mixins T Factory ML tt CSL00 MCSL, instance.declare-all T {findall-classes-for ML} CCSL, - coq.say "DCIFF!!!!!!!!!! Aft MCSL = " MCSL, - coq.say "DCIFF!!!!!!!!!! Aft CCSL = " CCSL, - coq.say "DCIFF!!!!!!!!!! Aft (NOT USED!) CSL = " CSL, - + coq.say "DCIFF!!!!!!!!!! Aft MCSL (instance names) = " MCSL, + coq.say "DCIFF!!!!!!!!!! Aft CCSL = " CCSL, + coq.say "DCIFF!!!!!!!!!! Aft (NOT USED!) CSL00 = " CSL00, + ] ], /* @@ -413,7 +421,9 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ %% */ - std.append MCSL CCSL CSL + std.append MCSL CCSL CSL, + coq.say "DCIFF!!!!!!!!!! Aft CSL = " CSL, + ]. % If you don't mention the factory in a builder, then Coq won't make @@ -503,11 +513,16 @@ check-non-forgetful-inheritance T Factory :- std.do! [ pred extract_string_name i:mixinname i:term o:string. extract_string_name W Trm Str. -% Instance has morally type 'Mixin Subject' +% Instance has morally type 'Mixin Subject'. +% Has to change, no instance as input but a definition (like BodySkel in declare_instance, +% still a term, and its type TySkel). +% Morever, in general this may apply to more than a mixin (if the base mixin is not a trivially +% atomic one). +% Important to ensure there is a consistent naming scheme. pred derive-wrapper-instances i:term, i:prop. derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.do! [ - coq.say "OLD!!!!!!!!! NOW RUNNING (old implementation, BAD) derive-wrapper-instances Instance _", + coq.say "OLD!!!!!!!!! NOW RUNNING derive-wrapper-instances Instance _", coq.say "OLD!!!!!!! Instance " Instance, % K is the mixin constructor (Build) for WrapperMixin @@ -537,10 +552,10 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- % the body of the new wrapper instance NewInstance = app[global K| Args], - coq.say "!!!!!!!! NewInstance=" {coq.term->string NewInstance}, + coq.say "OLD!!!!!!!! NewInstance=" {coq.term->string NewInstance}, coq.typecheck NewInstance Ty Dgn, - if (Dgn = error S) (coq.say "errore" S) + if (Dgn = error S) (coq.say "error in NewInstance" S) (coq.count-prods Ty N0, % we then call declare-const to add the new instance. % the name needs to be fixed. @@ -609,9 +624,10 @@ There are two clauses for this predicate (some refactoring needed?) We will focus on the latter (after line 253), which calls 'declare-canonical-instances-from-factory' (defined after line 337). -At line 3**, Factory is the mixin (base mixin?), - T is the type (new subject (@hom T0 A B) ?), - F is the prospective instance (crucially!), +At line 3**, Factory is the mixin (base mixin), + T is actually the subject (a type, e.g. the new subject (@hom T0 A B)), + F is the prospective instance (e.g. funQ, funQ_isMon), + ML are the mixins (the axioms that are needed for the subject...) ???, CSL are the clauses so far. Notably: Line 3**, 'synthesis.under-mixin-src-from-factory.do!'. diff --git a/HB/structure.elpi b/HB/structure.elpi index bc0461f5d..934ec2b86 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -9,7 +9,7 @@ pred declare i:string, i:term, i:sort. pred declare i:string, i:term, i:universe. declare Module BSkel Sort :- std.do! [ - coq.say "D!!!!!!!!!!!!!!!! NOW RUNNING declare", + coq.say "D!!!!!!!!!!!!!!!!! NOW RUNNING declare", disable-id-phant BSkel BSkelNoId, std.assert-ok! (coq.elaborate-skeleton BSkelNoId _ BNoId) "illtyped structure definition", @@ -798,7 +798,12 @@ reexport-wrapper-as-instance M :- std.do! [ coq.env.typeof (const C) Ty, coq.count-prods Ty N0, coq.term->arity Ty N0 Arity, - instance.declare-const "xx" B Arity _ + coq.term->pp B PP0, + coq.pp->string PP0 Str0, +% need to get a valid idenfier out of a term, no @ +% std.string.concat "xx" [Str0, "ELIM"] Str2, + std.string.concat "xx" ["NAME", "ELIM"] Str2, + instance.declare-const Str2 B Arity _ ]. }} diff --git a/structures.v b/structures.v index b4d1cad8c..bbf85195c 100644 --- a/structures.v +++ b/structures.v @@ -697,7 +697,9 @@ Elpi Accumulate Db hb.db. Elpi Accumulate lp:{{ main [const-decl Name (some BodySkel) TyWPSkel] :- !, - with-attributes (with-logging (instance.declare-const Name BodySkel TyWPSkel _)). + coq.say "************************* CALL const-decl", + with-attributes (with-logging (instance.declare-const Name BodySkel TyWPSkel _)), + coq.say "************************* END CALL const-decl". main [T0, F0] :- !, coq.warning "HB" "HB.deprecated" "The syntax \"HB.instance Key FactoryInstance\" is deprecated, use \"HB.instance Definition\" instead", with-attributes (with-logging (instance.declare-existing T0 F0)). diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 87f542040..48348ac7a 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -22,8 +22,9 @@ Fail HB.structure { Obj of isQuiver Obj & (forall A B : Obj, isMon (@hom (Quiver.clone Obj _) A B)) }. -About zero. -Print zero. +(* About zero. + Print zero. +*) (* Step 0: define a wrapper predicate in coq-elpi *) (* 5 lines of documentation + 1 line of elpi code in structure.v `pred wrapper-mixin o:mixinname, o:gref, o:mixinname` @@ -45,9 +46,11 @@ Print zero. HB.mixin Record hom_isMon T of Quiver T := { hom_isMon_private : forall A B, isMon (@hom T A B) }. +(* About hom_isMon_private. About hom_isMon.hom_isMon_private. - +*) + (* Step 2: at structure declaration, export the main and only projection of each declared wrapper as an instance of the wrapped structure on its subject *) @@ -55,8 +58,10 @@ HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & hom_isMon Obj }. +(* About hom_isMon.hom_isMon_private. About hom_isMon_private. +*) (* as expected from step 2, now this instance declaration is no more necessary *) (* @@ -83,6 +88,8 @@ About hom_isMon_private. HB.instance Definition funQ := isQuiver.Build Type (fun A B => A -> option B). +(* Print Canonical Projections. *) + (* prove that for every two types the quiver is a monoid *) Require Import FunctionalExtensionality. @@ -92,6 +99,7 @@ Definition funQ_comp {A B} (f g: A -> option B) (x: A) : option B := | Some _ => f x | _ => g x end. + (* Program Definition funQ_isMonF_alt (A B: Type) : isMon (hom A B) := isMon.Build (A -> option B) (fun (_:A) => None) funQ_comp _ _ _. Obligations. @@ -113,10 +121,11 @@ Definition funQ_comp {A B} (f g: A -> option B) (x: A) : option B := unfold funQ_comp. destruct (x a); auto. Qed. - +*) + Program Definition funQ_isMonF (A B: Type) : isMon (A -> option B) := isMon.Build (A -> option B) (fun (_:A) => None) funQ_comp _ _ _. -Obligations. +(* Obligations. *) Obligation 1. unfold associative; intros. eapply functional_extensionality; intro a. @@ -136,7 +145,11 @@ unfold funQ_comp. destruct (x a); auto. Qed. +(* Print Canonical Projections. +*) + +(* Fail Check (nat -> option nat) : Monoid.type. Check 1. @@ -145,26 +158,34 @@ Print Canonical Projections. Check 2. Set Printing All. +*) + +(* (* use the lemma to instantiate isMon. Notice the genericity of the type. *) HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := funQ_isMonF A B. +*) -Print Canonical Projections. -Check (fun A B : Type => hom A B : Monoid.type). - -Check 3. +(* Print Canonical Projections. *) +(* Check (fun A B : Type => hom A B : Monoid.type). *) (* instantiate hom_isMon by using the generic isMon instance to define 'private' *) HB.instance Definition funQ_hom_isMon := - hom_isMon.Build Type funQ_isMon. - + hom_isMon.Build Type funQ_isMonF. + +(* Print Canonical Projections. *) + +(* Check (fun A B : Type => hom A B : Monoid.type). *) + (* HB.about private. *) -Print Canonical Projections. +(* Print Canonical Projections. *) (* this has to be changed, it should be something like (hom nat nat): Check (nat -> option nat) : Monoid.type. *) -HB.about funQ_isMon. +(* +HB.about funQ_isMonF. Fail HB.about funQ_hom_isMon. About funQ_hom_isMon. +*) Elpi Print HB.structure. From ce51cc4a4ae0e6ad36303efc5de2c0c37630c7ba Mon Sep 17 00:00:00 2001 From: ptorrx Date: Tue, 18 Jul 2023 17:18:13 +0200 Subject: [PATCH 47/63] Switched to tentive version of add-all-mixins with extra parameter. Breaks the compilation of the Coq code. Included call to derive-wrapper-instances in declare-all, but not really sure about it. Commented out funQ_isMon in monoid_enriched_cat.v because it should be derivable, once funQ_hom_isMon is available. But actually I can't see where HB learns about funQ_isMonF, except in the funQ_hom_isMon definition (the one we should actually generate) --- HB/factory.elpi | 1 - HB/instance.elpi | 188 ++++++++++++++++-------------------- HB/structure.elpi | 31 +++--- structures.v | 4 +- tests/monoid_enriched_cat.v | 19 ++-- 5 files changed, 109 insertions(+), 134 deletions(-) diff --git a/HB/factory.elpi b/HB/factory.elpi index bceb4a710..31ce5cfa8 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -323,7 +323,6 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance % mixin_alias -> mixin via factory-alias->gref % factory-nparams mixin -> n % - % coq.say "TEST 2" (indt R), if (get-option "wrapper" tt) diff --git a/HB/instance.elpi b/HB/instance.elpi index c2b2f8418..372df5cb6 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -74,31 +74,6 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ private.declare-instance Factory TheType TheFactory Clauses CSL, -% In a WRAPPING-RELEVANT INSTANCE, -% Factory is the wrapped mixin, TheType is the new subject, -% TheFactory is the wrapped instance for the new subject (in fact, -% it is the term for the instance that is being processed). -% E.g. in connection with our example in monoid_enriched_cat.v: -% -% HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := -% funQ_isMonF A B. -% -% Factory = isMon -% TheFactory = funQ_isMon -% TheType = hom A B - - coq.say "DC!!!!!! Aft DI: wrapping instance", - coq.say "DC!!!!!! Aft DI: Factory = " Factory, - coq.say "DC!!!!!! Aft DI: TheType = " TheType, - coq.say "DC!!!!! Aft DI: TheFactory = " TheFactory, - coq.say "DC!!!!!! Aft DI: Clauses = " Clauses, - coq.say "DC!!!!! Aft DI: CSL = " CSL, - - % extracts the head subterm (e.g. hom) - coq.safe-dest-app TheType TheTypeKey _, - - coq.say "DC!!!!!! Aft DI: TheTypeKey = " TheTypeKey, - % handle parameters via a section -- end if (TyWP = arity _) true ( if-verbose (coq.say {header} "closing instance section"), @@ -106,30 +81,8 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ ), % we accumulate clauses now that the section is over - acc-clauses current Clauses, - - % As a general idea, we want to add wrapper instances - % for the original subjects that are covered by the current instances. - % Here we are processing a specific instance. We want to check - % whether it corresponds to a wrapper with respect to the new subject - % (associated with TheTypeKey and the Factory mixin). - % To this purpose, - % 1) we find all the wrappers that agree with the given parameters, - % using the wrapper-mixin predicate. - % 2) we then apply derive-wrapper-instances to each wrapper, together - % with the current instance, to create the derived wrapper instances. - % Notice that derive-wrapper-instances calls declare-const. - if (TheTypeKey = global TheTypeKeyGR) - (std.do! [ - std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, - coq.say "DC!!!!!! WRAPPERS (used in old implementation, need changes):" Wrappers, - std.forall Wrappers (private.derive-wrapper-instances TheFactory) - ] - ) - true, - - coq.say "DC!!!!!!!!!!!!! (final output) CSL = " CSL, -]. + acc-clauses current Clauses +]. % [declare-all T CL MCSTL] given a type T and a list of class definition % CL in topological order (from least dep to most) looks for classes @@ -175,7 +128,38 @@ declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- if-verbose (coq.say {header} "structure instance" Name "declared"), - Clauses => declare-all T Rest L. + Clauses => declare-all T Rest L, + +/* +% In a WRAPPING-RELEVANT INSTANCE, +% Factory is the wrapped mixin, TheType is the new subject, +% TheFactory is the wrapped instance for the new subject (in fact, +% it is the term for the instance that is being processed). +% E.g. in connection with our example in monoid_enriched_cat.v: +% +% HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := +% funQ_isMonF A B. +% +% Factory = isMon +% TheFactory = funQ_isMon +% TheType = hom A B +*/ + +% Trying to reinsert here the call to derive-wrapper-instances (which was in declare-const). +% Is it still needed? (not clear). +% Apart from other problems, this assumes that CS is the canonical instance generated +% in place of funQ_isMon (not evident at all). +% Probably doesn't make sense. + if (THD = global TheTypeKeyGR) + (std.do! [ + % Name1 is nothing, should find the right mixin + std.findall (wrapper-mixin _ TheTypeKeyGR Name1) Wrappers, + coq.say "WRAPPERS:" Wrappers, + std.forall Wrappers (private.derive-wrapper-instances (local.canonical CS)) + ] + ) + true. +% declare-all T [_|Rest] L :- declare-all T Rest L. declare-all _ [] []. @@ -254,10 +238,10 @@ pred declare-instance i:factoryname, i:term, i:term, o:list prop, o:list (pair id constant). declare-instance Factory T F Clauses CSL :- - coq.say "DI??????!!!!!!!!!! NOW RUNNING (1) private.declare-instance Factory T F Clauses CSL", - coq.say "DI?????? Factory " Factory, - coq.say "DI?????? T " T, - coq.say "DI?????? F " F, + coq.say "DI!!!!!!!!!!!!!!! NOW RUNNING (C1) private.declare-instance Factory T F Clauses CSL", + coq.say "DI!!!!!!!! Factory " Factory, + coq.say "DI!!!!!!!! T " T, + coq.say "DI!!!!!!!! F " F, current-mode (builder-from T TheFactory FGR _), !, if (get-option "local" tt) @@ -268,10 +252,10 @@ declare-instance Factory T F Clauses CSL :- T F TheFactory FGR Clauses CSL. declare-instance Factory T F Clauses CSL :- - coq.say "DI??????!!!!!!!!!! NOW RUNNING (2) private.declare-instance Factory T F Clauses CSL", - coq.say "DI?????? Factory " Factory, - coq.say "DI?????? T " T, - coq.say "DI?????? F " F, + coq.say "DI!!!!!!!!!!!!!!! NOW RUNNING (C2) private.declare-instance Factory T F Clauses CSL", + coq.say "DI!!!!!!!!! Factory " Factory, + coq.say "DI!!!!!!!!! T " T, + coq.say "DI!!!!!!!!! F " F, declare-canonical-instances-from-factory Factory T F CSL, if (get-option "export" tt) @@ -282,8 +266,8 @@ declare-instance Factory T F Clauses CSL :- % [add-mixin T F _ M Cl] adds a constant being the mixin instance for M on type % T built from factory F pred add-mixin i:term, i:factoryname, i:bool, i:mixinname, - o:list prop, o:list (pair id constant). -add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do! [ + o:list prop, o:list (pair id constant), o:list term. +add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL Subj :- std.do! [ coq.say "AM!!!!!!!!! NOW RUNNING add-mixin", @@ -309,30 +293,32 @@ add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do (std.do! [ if-verbose (coq.say {header} "declare canonical mixin instance" C), with-locality (log.coq.CS.declare-instance C), - CSL = [pr "_" C] - ]) (CSL = []), + CSL = [pr "_" C], Subj = [T], + ]) (CSL = []), (Subj = []), ]. pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, - o:list prop, o:list (pair id constant). -add-all-mixins T FGR ML MakeCanon Clauses CSL :- std.do! [ + o:list prop, o:list (pair id constant), o: list term. +add-all-mixins T FGR ML MakeCanon Clauses CSL Sbjs :- std.do! [ coq.say "AAM!!!!!!!!!!!!!!! NOW RUNNING add-all-mixins", - coq.say "AAM!!!!!!!!!! Bfr T = " T, - coq.say "AAM!!!!!!!!!! Bfr Factory (FGR) = " FGR, - coq.say "AAM!!!!!!!!!! Bfr ML = " ML, - coq.say "AAM!!!!!!!!!! Bfr MakeCanon" MakeCanon, + coq.say "AAM!!!!!!!!!! In T = " T, + coq.say "AAM!!!!!!!!!! In Factory (FGR) = " FGR, + coq.say "AAM!!!!!!!!!! In ML = " ML, + coq.say "AAM!!!!!!!!!! In MakeCanon" MakeCanon, std.map ML (m\ o\ sigma ClL CSL\ - add-mixin T FGR MakeCanon m ClL CSL, o = pr ClL CSL) ClLxCSL_L, + add-mixin T FGR MakeCanon m ClL CSL Sbj, o = pr (pr ClL CSL) Sbj) ClLxCSLxSbj_L, + stf.unzip ClLxCSLxSbj ClLxCSL_L Sbj_L, std.unzip ClLxCSL_L ClLL CSLL, std.flatten ClLL Clauses, std.flatten CSLL CSL, + std.flatten Sbj_L Sbjs, - coq.say "AAM!!!!!!!!!! Aft Clauses = " Clauses, - coq.say "AAM!!!!!!!!!! Aft CSL = " CSL, - + coq.say "AAM!!!!!!!!!! Out Clauses = " Clauses, + coq.say "AAM!!!!!!!!!! Out CSL = " CSL, + coq.say "AAM!!!!!!!!!! Out Sbjs = " Sbjs, ]. % [postulate-arity A Acc T TS] postulates section variables @@ -361,7 +347,7 @@ pred declare-canonical-instances-from-factory-and-local-builders declare-canonical-instances-from-factory-and-local-builders Factory T F _TheFactory FGR Clauses CSL :- std.do! [ synthesis.under-new-mixin-src-from-factory.do! T F (NewMixins\ std.do! [ - add-all-mixins T FGR NewMixins ff Clauses MCSL, + add-all-mixins T FGR NewMixins ff Clauses MCSL _, ]), list-w-params_list {factory-provides Factory} ML, Clauses => instance.declare-all T {findall-classes-for ML} CCSL, @@ -385,45 +371,34 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ synthesis.under-local-canonical-mixins-of.do! T [ list-w-params_list {factory-provides Factory} ML, - coq.say "DCIFF!!!!!!! Factory = " Factory, - coq.say "DCIFF!!!!!!! T = " T, - coq.say "DCIFF!!!!!!! F = " F, - coq.say "DCIFF!!!!!!! ML (mixin names) = " ML, - coq.say "DFIFF!!!!!!! run add-all-mixins T Factory ML tt _ MCSL", + coq.say "DCIFF!!!!!!! In Factory = " Factory, + coq.say "DCIFF!!!!!!! In T = " T, + coq.say "DCIFF!!!!!!! In F = " F, + coq.say "DCIFF!!!!!!! In ML (mixin names) = " ML, %% - % coq.say "#!!!!!!!!!! Bfr F = " F, - + /* % Old code: % notice the underscore in add-all-mixins, output clauses are not used % pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, % o:list prop, o:list (pair id constant). - add-all-mixins T Factory ML tt CSL00 MCSL, - instance.declare-all T {findall-classes-for ML} CCSL, - - coq.say "DCIFF!!!!!!!!!! Aft MCSL (instance names) = " MCSL, - coq.say "DCIFF!!!!!!!!!! Aft CCSL = " CCSL, - coq.say "DCIFF!!!!!!!!!! Aft (NOT USED!) CSL00 = " CSL00, - + add-all-mixins T Factory ML tt Clauses MCSL, + instance.declare-all T {findall-classes-for ML} CCSL, ] ], - -/* - % New code: +*/ +%% New code: % this should output all the candidate subjects too, as a new output argument. - add-all-mixins T Factory ML tt Clauses MCSL, + add-all-mixins T Factory ML tt Clauses MCSL AllSubjects, ] ], - AllSubjects = [T], % change this using the additional output in add-all-mixins + % AllSubjects = [T], % change this using the additional output in add-all-mixins % declare-all now is mapped on all the subjects, while Clauses is added to the context. Clauses => std.forall AllSubjects (s\ instance.declare-all s {findall-classes-for ML} CCSL), - %% -*/ std.append MCSL CCSL CSL, - coq.say "DCIFF!!!!!!!!!! Aft CSL = " CSL, - + coq.say "DCIFF!!!!!!!!!! Out CSL = " CSL, ]. % If you don't mention the factory in a builder, then Coq won't make @@ -438,7 +413,8 @@ hack-section-discharging B B. % unfolds the constant used for the phant abbreviation to avoid storing all % the phantom abstrctions and idfun that were used to trigger inference pred optimize-body i:term, o:term. -optimize-body (app[global (const C)| Args]) Red :- (phant-abbrev _ (const C) _ ; (rex_match "phant_" {coq.gref->id (const C)})), !, +optimize-body (app[global (const C)| Args]) Red :- + (phant-abbrev _ (const C) _ ; (rex_match "phant_" {coq.gref->id (const C)})), !, coq.env.const C (some B) _, hd-beta B Args HD Stack, unwind HD Stack Red. @@ -510,8 +486,12 @@ check-non-forgetful-inheritance T Factory :- std.do! [ % |}, isMon.phant_axioms (hom A B) % Not used, but possible useful -pred extract_string_name i:mixinname i:term o:string. -extract_string_name W Trm Str. +pred mk_wrapper_instance_name i:mixinname i:term o:string. +mk_wrapper_instance_name W Ins Str :- + coq.gref->modname W Str0, + coq.term->string Ins Str1, + % coq.term->string (global W) Str0, + std.string.concat "__" [Str1, Str0] Str. % Instance has morally type 'Mixin Subject'. % Has to change, no instance as input but a definition (like BodySkel in declare_instance, @@ -522,8 +502,8 @@ extract_string_name W Trm Str. pred derive-wrapper-instances i:term, i:prop. derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.do! [ - coq.say "OLD!!!!!!!!! NOW RUNNING derive-wrapper-instances Instance _", - coq.say "OLD!!!!!!! Instance " Instance, + coq.say "DWI!!!!!!!!! NOW RUNNING derive-wrapper-instances Instance _", + coq.say "DWI!!!!!!! Instance = " Instance, % K is the mixin constructor (Build) for WrapperMixin factory-constructor WrapperMixin K, @@ -552,14 +532,16 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- % the body of the new wrapper instance NewInstance = app[global K| Args], - coq.say "OLD!!!!!!!! NewInstance=" {coq.term->string NewInstance}, + coq.say "DWI!!!!!!!! NewInstance =" {coq.term->string NewInstance}, coq.typecheck NewInstance Ty Dgn, if (Dgn = error S) (coq.say "error in NewInstance" S) (coq.count-prods Ty N0, % we then call declare-const to add the new instance. % the name needs to be fixed. - instance.declare-const "_" NewInstance {coq.term->arity Ty N0} _ + % name generation doesn't work because of dot occurrences + % mk_wrapper_instance_name Wrapper_Mixin Instance Nm, + instance.declare-const "funq_instance_name" NewInstance {coq.term->arity Ty N0} _ ) /* diff --git a/HB/structure.elpi b/HB/structure.elpi index 934ec2b86..e70915d99 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -9,7 +9,7 @@ pred declare i:string, i:term, i:sort. pred declare i:string, i:term, i:universe. declare Module BSkel Sort :- std.do! [ - coq.say "D!!!!!!!!!!!!!!!!! NOW RUNNING declare", + coq.say "D!!!!!!!!!!!!!! NOW RUNNING declare", disable-id-phant BSkel BSkelNoId, std.assert-ok! (coq.elaborate-skeleton BSkelNoId _ BNoId) "illtyped structure definition", @@ -236,17 +236,14 @@ declare Module BSkel Sort :- std.do! [ % i.e. [indt «hom_isMon.axioms_»] % we can use reexport-wrapper-as-instance to get the projection and build % the instances. - coq.say "D!!!!????? WrapperML " WrapperML, - coq.say "D!!!!????? EX (local context): " EX, - EX => std.forall WrapperML private.reexport-wrapper-as-instance, + coq.say "D!!!!!!!!!!!! WrapperML " WrapperML, + coq.say "D!!!!!!!!!!!! EX (local context): " EX, - % coq.say "???? NewClauses " NewClauses, + EX => std.forall WrapperML private.reexport-wrapper-as-instance, % tentative: generating wrapper instances from the available definitions. % Wrong approach: we actually need to check each new defined instance to % see if it triggers a wrapper instance too. We do this in instance.elpi. - % EX => std.forall WrapperML private.derive_wrapper_instances, - % NewClauses => std.forall WrapperML private.derive_wrapper_instances, if-verbose (coq.say {header} "abbreviation factory-by-classname"), @@ -789,20 +786,22 @@ mk-hb-eta.arity Structure ClassName SortProjection % HB.instance) pred reexport-wrapper-as-instance i:mixinname. % reexport-wrapper-as-instance M :- std.spy-do! [ -reexport-wrapper-as-instance M :- std.do! [ +reexport-wrapper-as-instance M :- std.do! [ + coq.say "RWAI!!!!!!!!!!! NOW RUNNING private.reexport-wrapper-as-instance", + exported-op M _ C, - coq.say "RWAI!!!???? NOW RUNNING private.reexport-wrapper-as-instance", - coq.say "RWAI!!!???? M = " M, - coq.say "RWAI!!!???? C = " C, + + coq.say "RWAI!!!!!!! M = " M, + coq.say "RWAI!!!!!!! C = " C, + B = (global (const C)), coq.env.typeof (const C) Ty, coq.count-prods Ty N0, coq.term->arity Ty N0 Arity, - coq.term->pp B PP0, - coq.pp->string PP0 Str0, -% need to get a valid idenfier out of a term, no @ -% std.string.concat "xx" [Str0, "ELIM"] Str2, - std.string.concat "xx" ["NAME", "ELIM"] Str2, + coq.term->string (global M) Str1, +% need to get a valid idenfier out of a term, no @ or . +% std.string.concat "__" [Str1, "ELIM"] Str2, + std.string.concat "__" ["hom_isMon", "ELIM"] Str2, instance.declare-const Str2 B Arity _ ]. diff --git a/structures.v b/structures.v index bbf85195c..b4d1cad8c 100644 --- a/structures.v +++ b/structures.v @@ -697,9 +697,7 @@ Elpi Accumulate Db hb.db. Elpi Accumulate lp:{{ main [const-decl Name (some BodySkel) TyWPSkel] :- !, - coq.say "************************* CALL const-decl", - with-attributes (with-logging (instance.declare-const Name BodySkel TyWPSkel _)), - coq.say "************************* END CALL const-decl". + with-attributes (with-logging (instance.declare-const Name BodySkel TyWPSkel _)). main [T0, F0] :- !, coq.warning "HB" "HB.deprecated" "The syntax \"HB.instance Key FactoryInstance\" is deprecated, use \"HB.instance Definition\" instead", with-attributes (with-logging (instance.declare-existing T0 F0)). diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 48348ac7a..f24ab92ea 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -46,10 +46,9 @@ Fail HB.structure HB.mixin Record hom_isMon T of Quiver T := { hom_isMon_private : forall A B, isMon (@hom T A B) }. -(* -About hom_isMon_private. -About hom_isMon.hom_isMon_private. -*) +(* Print Canonical Projections. *) +(* About hom_isMon.hom_isMon_private. *) +(* About hom_isMon_private. *) (* Step 2: at structure declaration, export the main and only projection of each declared wrapper as an instance of the wrapped structure on @@ -57,11 +56,9 @@ About hom_isMon.hom_isMon_private. HB.structure Definition Monoid_enriched_quiver := { Obj of isQuiver Obj & hom_isMon Obj }. - -(* -About hom_isMon.hom_isMon_private. -About hom_isMon_private. -*) + +(* About hom_isMon.hom_isMon_private. *) +(* About hom_isMon_private. *) (* as expected from step 2, now this instance declaration is no more necessary *) (* @@ -160,9 +157,9 @@ Check 2. Set Printing All. *) -(* + (* use the lemma to instantiate isMon. Notice the genericity of the type. *) -HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := +(* HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := funQ_isMonF A B. *) From 641d35dfa9f60ce251a836301b3352d4a18c5815 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 19 Jul 2023 19:34:10 +0200 Subject: [PATCH 48/63] gone back to old add-all-mixins (without std.forall), revised comments in instance.elpi, funQ_isMon back in --- HB/instance.elpi | 134 +++++++++++++++++++++++++++++++++-------------- 1 file changed, 96 insertions(+), 38 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 372df5cb6..b85d6afd1 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -24,7 +24,7 @@ declare-existing T0 F0 :- std.do! [ pred declare-const i:id, i:term, i:arity, o:list (pair id constant). declare-const Name BodySkel TyWPSkel CSL :- std.do! [ - coq.say "DC!!!!!!!!!!!!! NOW RUNNING (entry point) declare-const Name BodySkel TyWPSkel CSL", + coq.say "DC************************* NOW RUNNING (entry point) declare-const Name BodySkel TyWPSkel CSL", coq.say "DC!!!!!!!!!!!!! Name = " Name, coq.say "DC!!!!!!!!!!!!! BodySkel = " BodySkel, coq.say "DC!!!!!!!!!!!!! TyWPSkel = " TyWPSkel, @@ -92,6 +92,9 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ % Each mixin used in order to fulfill a class is returned together with its name. pred declare-all i:term, i:list class, o:list (pair id constant). declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- + + coq.say "NOW RUNNING!!!!!!!!!!!!!! declare-all", + if (not(has-CS-instance? T Struct)) true % we build it (if-verbose (coq.say {header} "skipping already existing" @@ -128,7 +131,7 @@ declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- if-verbose (coq.say {header} "structure instance" Name "declared"), - Clauses => declare-all T Rest L, + Clauses => declare-all T Rest L. /* % In a WRAPPING-RELEVANT INSTANCE, @@ -144,7 +147,7 @@ declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- % TheFactory = funQ_isMon % TheType = hom A B */ - +/* % Trying to reinsert here the call to derive-wrapper-instances (which was in declare-const). % Is it still needed? (not clear). % Apart from other problems, this assumes that CS is the canonical instance generated @@ -160,6 +163,7 @@ declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- ) true. % +*/ declare-all T [_|Rest] L :- declare-all T Rest L. declare-all _ [] []. @@ -239,9 +243,9 @@ pred declare-instance i:factoryname, i:term, i:term, declare-instance Factory T F Clauses CSL :- coq.say "DI!!!!!!!!!!!!!!! NOW RUNNING (C1) private.declare-instance Factory T F Clauses CSL", - coq.say "DI!!!!!!!! Factory " Factory, - coq.say "DI!!!!!!!! T " T, - coq.say "DI!!!!!!!! F " F, + coq.say "DI!!!!!!!! Factory = " Factory, + coq.say "DI!!!!!!!! T = " T, + coq.say "DI!!!!!!!! F = " F, current-mode (builder-from T TheFactory FGR _), !, if (get-option "local" tt) @@ -253,9 +257,9 @@ declare-instance Factory T F Clauses CSL :- declare-instance Factory T F Clauses CSL :- coq.say "DI!!!!!!!!!!!!!!! NOW RUNNING (C2) private.declare-instance Factory T F Clauses CSL", - coq.say "DI!!!!!!!!! Factory " Factory, - coq.say "DI!!!!!!!!! T " T, - coq.say "DI!!!!!!!!! F " F, + coq.say "DI!!!!!!!!! Factory = " Factory, + coq.say "DI!!!!!!!!! T = " T, + coq.say "DI!!!!!!!!! F = " F, declare-canonical-instances-from-factory Factory T F CSL, if (get-option "export" tt) @@ -265,6 +269,66 @@ declare-instance Factory T F Clauses CSL :- % [add-mixin T F _ M Cl] adds a constant being the mixin instance for M on type % T built from factory F +pred add-mixin i:term, i:factoryname, i:bool, i:mixinname, + o:list prop, o:list (pair id constant). +add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do! [ + + coq.say "AM!!!!!!!!!!!!!!!!!!!! NOW RUNNING add-mixin", + coq.say "AM!!!!!!!!!! In T (for the subject) = " T, + coq.say "AM!!!!!!!!!! In MissingMixin (might be a base one) = " MissingMixin, + + new_int N, % timestamp + + synthesis.assert!-infer-mixin T MissingMixin Bo, + MixinSrcCl = mixin-src T MixinName (global (const C)), + BuilderDeclCl = builder-decl (builder N FGR MixinName (const C)), + + std.assert-ok! (coq.typecheck Bo Ty) "declare-instances: mixin illtyped", + safe-dest-app Ty (global MixinNameAlias) _, + factory-alias->gref MixinNameAlias MixinName, + + std.assert! (MissingMixin = MixinName) "HB: anomaly: we built the wrong mixin", + + % If the mixin instance is already a constant there is no need to + % alias it. + if (Bo = global (const C)) true + (Name is {gref->modname FGR 2 "_"} ^"__to__" ^ {gref->modname MixinName 2 "_"}, + if-verbose (coq.say {header} "declare mixin instance" Name), + log.coq.env.add-const-noimplicits Name Bo Ty @transparent! C), + if (MakeCanon = tt, whd (global (const C)) [] (global (indc _)) _) + (std.do! [ + if-verbose (coq.say {header} "declare canonical mixin instance" C), + with-locality (log.coq.CS.declare-instance C), + CSL = [pr "_" C], + ]) (CSL = []), + + coq.say "AM!!!!!!!!!! Out C (instance name) = " C, + +]. + +pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, + o:list prop, o:list (pair id constant), o:list term. +add-all-mixins T FGR ML MakeCanon Clauses CSL Sbjs:- std.do! [ + + Sbjs = [T], + coq.say "AAM!!!!!!!!!!!!!!!!! NOW RUNNING add-all-mixins", + coq.say "AAM!!!!!!!!!! In T (subject, possibly a wrapping one, e.g. 'hom ...') = " T, + coq.say "AAM!!!!!!!!!! In Factory (FGR, the factory mixin) = " FGR, + coq.say "AAM!!!!!!!!!! In ML (atomic mixins for FGR; there might be a base one, e.g. 'isMonoid') = " ML, + coq.say "AAM!!!!!!!!!! In MakeCanon = " MakeCanon, + + std.map ML (m\ o\ sigma ClL CSL\ + add-mixin T FGR MakeCanon m ClL CSL, o = pr ClL CSL) ClLxCSL_L, + std.unzip ClLxCSL_L ClLL CSLL, + std.flatten ClLL Clauses, + std.flatten CSLL CSL, + + coq.say "AAM!!!!!!!!!! Out Clauses = " Clauses, + coq.say "AAM!!!!!!!!!! Out CSL = " CSL, + coq.say "AAM!!!!!!!!!! Out Sbjs = " Sbjs, +]. + +/* pred add-mixin i:term, i:factoryname, i:bool, i:mixinname, o:list prop, o:list (pair id constant), o:list term. add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL Subj :- std.do! [ @@ -296,18 +360,12 @@ add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL Subj :- s CSL = [pr "_" C], Subj = [T], ]) (CSL = []), (Subj = []), ]. - +*/ +/* pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, o:list prop, o:list (pair id constant), o: list term. add-all-mixins T FGR ML MakeCanon Clauses CSL Sbjs :- std.do! [ - coq.say "AAM!!!!!!!!!!!!!!! NOW RUNNING add-all-mixins", - - coq.say "AAM!!!!!!!!!! In T = " T, - coq.say "AAM!!!!!!!!!! In Factory (FGR) = " FGR, - coq.say "AAM!!!!!!!!!! In ML = " ML, - coq.say "AAM!!!!!!!!!! In MakeCanon" MakeCanon, - std.map ML (m\ o\ sigma ClL CSL\ add-mixin T FGR MakeCanon m ClL CSL Sbj, o = pr (pr ClL CSL) Sbj) ClLxCSLxSbj_L, stf.unzip ClLxCSLxSbj ClLxCSL_L Sbj_L, @@ -315,11 +373,8 @@ add-all-mixins T FGR ML MakeCanon Clauses CSL Sbjs :- std.do! [ std.flatten ClLL Clauses, std.flatten CSLL CSL, std.flatten Sbj_L Sbjs, - - coq.say "AAM!!!!!!!!!! Out Clauses = " Clauses, - coq.say "AAM!!!!!!!!!! Out CSL = " CSL, - coq.say "AAM!!!!!!!!!! Out Sbjs = " Sbjs, ]. +*/ % [postulate-arity A Acc T TS] postulates section variables % corresponding to parameters in arity A. TS is T applied @@ -363,6 +418,10 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ coq.say "DCIFF!!!!!!!!!!! NOW RUNNING declare-canonical-instances-from-factory", + coq.say "DCIFF!!!!!!! In Factory = " Factory, + coq.say "DCIFF!!!!!!! In T = " T, + coq.say "DCIFF!!!!!!! In F = " F, + % The order of the following two "under...do!" is crucial, % priority must be given to canonical mixins % as they are the ones which guarantee forgetful inheritance @@ -370,22 +429,21 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ synthesis.under-mixin-src-from-factory.do! T F [ synthesis.under-local-canonical-mixins-of.do! T [ list-w-params_list {factory-provides Factory} ML, + coq.say "DCIFF!!!!!!! In ML (mixin names) = " ML, - coq.say "DCIFF!!!!!!! In Factory = " Factory, - coq.say "DCIFF!!!!!!! In T = " T, - coq.say "DCIFF!!!!!!! In F = " F, - coq.say "DCIFF!!!!!!! In ML (mixin names) = " ML, + % currently, AllSubjects = [T] + add-all-mixins T Factory ML tt Clauses MCSL AllSubjects, + % old (Clauses not used) + instance.declare-all T {findall-classes-for ML} CCSL, + % std.forall AllSubjects (s \ instance.declare-all s {findall-classes-for ML} CCSL), + ] + ], -%% - /* - % Old code: - % notice the underscore in add-all-mixins, output clauses are not used - % pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, - % o:list prop, o:list (pair id constant). - add-all-mixins T Factory ML tt Clauses MCSL, - instance.declare-all T {findall-classes-for ML} CCSL, - ] ], -*/ + % Clauses => instance.declare-all T {findall-classes-for ML} CCSL, + % new (should use Clauses and AllSubjects) + % Clauses => std.forall AllSubjects (s \ instance.declare-all s {findall-classes-for ML} CCSL), + +/* %% New code: % this should output all the candidate subjects too, as a new output argument. add-all-mixins T Factory ML tt Clauses MCSL AllSubjects, @@ -394,9 +452,9 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ % AllSubjects = [T], % change this using the additional output in add-all-mixins % declare-all now is mapped on all the subjects, while Clauses is added to the context. Clauses => std.forall AllSubjects - (s\ instance.declare-all s {findall-classes-for ML} CCSL), + (s \ instance.declare-all s {findall-classes-for ML} CCSL), %% - +*/ std.append MCSL CCSL CSL, coq.say "DCIFF!!!!!!!!!! Out CSL = " CSL, ]. @@ -532,7 +590,7 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- % the body of the new wrapper instance NewInstance = app[global K| Args], - coq.say "DWI!!!!!!!! NewInstance =" {coq.term->string NewInstance}, + coq.say "DWI!!!!!!!!! NewInstance =" {coq.term->string NewInstance}, coq.typecheck NewInstance Ty Dgn, if (Dgn = error S) (coq.say "error in NewInstance" S) From 6bdfd5998cf93d29b61065599ace3189fa5bdaf5 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 19 Jul 2023 19:34:19 +0200 Subject: [PATCH 49/63] gone back to old add-all-mixins (without std.forall), revised comments in instance.elpi, funQ_isMon back in --- tests/monoid_enriched_cat.v | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index f24ab92ea..7adc2efa9 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -60,11 +60,11 @@ HB.structure (* About hom_isMon.hom_isMon_private. *) (* About hom_isMon_private. *) -(* as expected from step 2, now this instance declaration is no more necessary *) +(* as expected from step 2, now this instance declaration is no more necessay *) (* HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := @hom_isMon_private T A B. - *) +*) (* each instance of isMon should be tried as an instance of hom_isMon *) (* (* Step 3: for each instance of a wrapped mixin on a subject known @@ -157,11 +157,12 @@ Check 2. Set Printing All. *) - -(* use the lemma to instantiate isMon. Notice the genericity of the type. *) -(* HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := +(* use the lemma to instantiate isMon. Notice the genericity of the type. + In principle this instance should be derivable from the wrapper instance. + But since we haven't introduced the wrapper instance yet, we use this + HB command to actually introduce it. *) +HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := funQ_isMonF A B. -*) (* Print Canonical Projections. *) (* Check (fun A B : Type => hom A B : Monoid.type). *) From 790ca4414019b765a5dfa5e8a980078e1ba88e17 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 20 Jul 2023 16:56:20 +0200 Subject: [PATCH 50/63] added predicates to handle cumulative output over forall, avoiding duplicates in the association list (which was broken in DCIFF with std.forall) --- HB/instance.elpi | 145 +++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 128 insertions(+), 17 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index b85d6afd1..7429a3379 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -25,14 +25,17 @@ pred declare-const i:id, i:term, i:arity, o:list (pair id constant). declare-const Name BodySkel TyWPSkel CSL :- std.do! [ coq.say "DC************************* NOW RUNNING (entry point) declare-const Name BodySkel TyWPSkel CSL", - coq.say "DC!!!!!!!!!!!!! Name = " Name, - coq.say "DC!!!!!!!!!!!!! BodySkel = " BodySkel, - coq.say "DC!!!!!!!!!!!!! TyWPSkel = " TyWPSkel, + coq.say "DC!!!!!!!!!!!!! In Name = " Name, + coq.say "DC!!!!!!!!!!!!! In BodySkel = " BodySkel, + coq.say "DC!!!!!!!!!!!!! In TyWPSkel = " TyWPSkel, std.assert-ok! (coq.elaborate-arity-skeleton TyWPSkel _ TyWP) "Definition type illtyped", coq.arity->term TyWP Ty, std.assert-ok! (coq.elaborate-skeleton BodySkel Ty Body) "Definition illtyped", + coq.say "DC!!!!!!!!!!!!! Ex Body = " Body, + coq.say "DC!!!!!!!!!!!!! Ex Ty = " Ty, + % handle parameters via a section -- begin if (TyWP = arity SectionTy) ( % Do not open a section when it is not necessary (no parameters) @@ -46,6 +49,9 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ private.postulate-arity TyWP [] Body SectionBody SectionTy ), + coq.say "DC!!!!!!!!!!!!! Ex SectionBody = " SectionBody, + coq.say "DC!!!!!!!!!!!!! Ex SectionTy = " SectionTy, + % identify the factory std.assert! (coq.safe-dest-app SectionTy (global FactoryAlias) Args) "The type of the instance is not a factory", factory-alias->gref FactoryAlias Factory, @@ -63,6 +69,8 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ UnfoldClauses => copy SectionTy SectionTyUnfolded, ]) (SectionTy = SectionTyUnfolded), + coq.say "DC!!!!!!!!!!!!! Ex UnfoldClauses = " UnfoldClauses, + log.coq.env.add-const-noimplicits-failondup RealName OptimizedBody SectionTyUnfolded @transparent! C, TheFactory = (global (const C)), @@ -72,6 +80,7 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ private.check-non-forgetful-inheritance TheType Factory, + % Clauses and CSL are outputs. QUESTION: what is the context here? private.declare-instance Factory TheType TheFactory Clauses CSL, % handle parameters via a section -- end @@ -81,7 +90,10 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ ), % we accumulate clauses now that the section is over - acc-clauses current Clauses + % QUESTION - what is this really accumulating? appears to be always empty + acc-clauses current Clauses, + + coq.say "DC!!!!!!!!!!!!! Out Clauses = " Clauses, ]. % [declare-all T CL MCSTL] given a type T and a list of class definition @@ -94,6 +106,10 @@ pred declare-all i:term, i:list class, o:list (pair id constant). declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- coq.say "NOW RUNNING!!!!!!!!!!!!!! declare-all", + coq.say "DALL!!!!!!!!!! In T = " T, + coq.say "DALL!!!!!!!!!! In Class = " Class, + coq.say "DALL!!!!!!!!!! In Struct = " Struct, + coq.say "DALL!!!!!!!!!! In MLwP = " MLwP, if (not(has-CS-instance? T Struct)) true % we build it @@ -105,6 +121,8 @@ declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- params->holes MLwP Params, get-constructor Class KC, + coq.say "DALL!!!!!!!!!!!!!! Exec1 ", + if (synthesis.infer-all-args-let Params T KC KCApp ok) (if-verbose (coq.say {header} "we can build a" {nice-gref->string Struct} "on" {coq.term->string T})) @@ -112,6 +130,8 @@ declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- !, + coq.say "DALL!!!!!!!!!!!!!! Exec2 ", + Name is {cs-pattern->name {term->cs-pattern T}} ^ "__canonical__" ^ {gref->modname Struct 2 "_" }, @@ -131,6 +151,10 @@ declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- if-verbose (coq.say {header} "structure instance" Name "declared"), + coq.say "DALL!!!!!!!!!! Out Name = " Name, + coq.say "DALL!!!!!!!!!! Out CS = " CS, + coq.say "DALL!!!!!!!!!! Env Clauses = " Clauses, + Clauses => declare-all T Rest L. /* @@ -256,16 +280,18 @@ declare-instance Factory T F Clauses CSL :- T F TheFactory FGR Clauses CSL. declare-instance Factory T F Clauses CSL :- - coq.say "DI!!!!!!!!!!!!!!! NOW RUNNING (C2) private.declare-instance Factory T F Clauses CSL", - coq.say "DI!!!!!!!!! Factory = " Factory, - coq.say "DI!!!!!!!!! T = " T, - coq.say "DI!!!!!!!!! F = " F, + coq.say "DI!!!!!!!!!!!!!!!! NOW RUNNING (C2) private.declare-instance Factory T F Clauses CSL", + coq.say "DI!!!!!!!!! In Factory = " Factory, + coq.say "DI!!!!!!!!! In T = " T, + coq.say "DI!!!!!!!!! In F = " F, declare-canonical-instances-from-factory Factory T F CSL, if (get-option "export" tt) (coq.env.current-library File, std.map CSL (x\r\ sigma i c\ x = pr i c, r = instance-to-export File i c) Clauses) - (Clauses = []). + (Clauses = []), + + coq.say "DI!!!!!!!!! In Clauses = " Clauses. % [add-mixin T F _ M Cl] adds a constant being the mixin instance for M on type % T built from factory F @@ -275,7 +301,7 @@ add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do coq.say "AM!!!!!!!!!!!!!!!!!!!! NOW RUNNING add-mixin", coq.say "AM!!!!!!!!!! In T (for the subject) = " T, - coq.say "AM!!!!!!!!!! In MissingMixin (might be a base one) = " MissingMixin, + coq.say "AM!!!!!!!!!! In MissingMixin (the mixin, might be a base one) = " MissingMixin, new_int N, % timestamp @@ -289,6 +315,10 @@ add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do std.assert! (MissingMixin = MixinName) "HB: anomaly: we built the wrong mixin", + coq.say "AM!!!!!!!!!! Ex Bo = " Bo, + coq.say "AM!!!!!!!!!! Ex Ty = " Ty, + coq.say "AM!!!!!!!!!! Ex MixinName = " MixinName, + % If the mixin instance is already a constant there is no need to % alias it. if (Bo = global (const C)) true @@ -303,9 +333,60 @@ add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do ]) (CSL = []), coq.say "AM!!!!!!!!!! Out C (instance name) = " C, + coq.say "AM!!!!!!!!!! Out MixinSrcCl = " MixinSrcCl, + coq.say "AM!!!!!!!!!! Out BuilderDeclCl = " BuilderDeclCl, + coq.say "AM!!!!!!!!!! Out CSL = " CSL, ]. +% [add-mixin T F _ M Cl] adds a constant being the mixin instance for M on type +% T built from factory F +pred add-mixinW i:term, i:factoryname, i:bool, i:mixinname, + o:list prop, o:list (pair id constant). +add-mixinW T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do! [ + + coq.say "AM!!!!!!!!!!!!!!!!!!!! NOW RUNNING add-mixin", + coq.say "AM!!!!!!!!!! In T (for the subject) = " T, + coq.say "AM!!!!!!!!!! In MissingMixin (the mixin, might be a base one) = " MissingMixin, + + new_int N, % timestamp + + synthesis.assert!-infer-mixin T MissingMixin Bo, + MixinSrcCl = mixin-src T MixinName (global (const C)), + BuilderDeclCl = builder-decl (builder N FGR MixinName (const C)), + + std.assert-ok! (coq.typecheck Bo Ty) "declare-instances: mixin illtyped", + safe-dest-app Ty (global MixinNameAlias) _, + factory-alias->gref MixinNameAlias MixinName, + + std.assert! (MissingMixin = MixinName) "HB: anomaly: we built the wrong mixin", + + coq.say "AM!!!!!!!!!! Ex Bo = " Bo, + coq.say "AM!!!!!!!!!! Ex Ty = " Ty, + coq.say "AM!!!!!!!!!! Ex MixinName = " MixinName, + + % If the mixin instance is already a constant there is no need to + % alias it. + if (Bo = global (const C)) true + (Name is {gref->modname FGR 2 "_"} ^"__to__" ^ {gref->modname MixinName 2 "_"}, + if-verbose (coq.say {header} "declare mixin instance" Name), + log.coq.env.add-const-noimplicits Name Bo Ty @transparent! C), + if (MakeCanon = tt, whd (global (const C)) [] (global (indc _)) _) + (std.do! [ + if-verbose (coq.say {header} "declare canonical mixin instance" C), + with-locality (log.coq.CS.declare-instance C), + CSL = [pr "_" C], + ]) (CSL = []), + + coq.say "AM!!!!!!!!!! Out C (instance name) = " C, + coq.say "AM!!!!!!!!!! Out MixinSrcCl = " MixinSrcCl, + coq.say "AM!!!!!!!!!! Out BuilderDeclCl = " BuilderDeclCl, + coq.say "AM!!!!!!!!!! Out CSL = " CSL, + +]. + + + pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, o:list prop, o:list (pair id constant), o:list term. add-all-mixins T FGR ML MakeCanon Clauses CSL Sbjs:- std.do! [ @@ -409,6 +490,32 @@ declare-canonical-instances-from-factory-and-local-builders std.append MCSL CCSL CSL ]. +%%%%%%%%%%%%%% + +% cumulates output over forall +pred cumul-forall i:list A, i:(A -> B -> prop), o:list B. +cumul-forall [] _ []. +cumul-forall [X|L] P [Y|M] :- P X Y, cumul-forall L P M. + +% flattens cumulated list output +pred flat-cumul-forall i:list A, i:(A -> list B -> prop), o:list B. +flat-cumul-forall X P Y :- cumul-forall X P W, flatten W Y. + +% merges list1 and list2 so that list1 doesn't introduce k-duplicates +pred hmerge i:list (pair B C), i:list (pair B C), o:list (pair B C). +hmerge [] A A. +hmerge [(pr K _)|LA] LX LY :- coq.lookup! LX K _, hmerge LA LX LY. +hmerge [(pr K V)|LA] LX [(pr K V)|LY] :- hmerge LA LX LY. +%hmerge [(pr K1 V1)|LA] LX LY1 :- if (coq.lookup! LX K1 _) (LY1 = LY0) (LY1 = [(pr K1 V1)|LY0), +% hmerge LA LX LY0. + +% cumulates without k-duplicates +pred hcumul-forall i:list A, i:(A -> list (pair B C) -> prop), o:list (pair B C). +hcumul-forall [] _ []. +hcumul-forall [X|L] P M2 :- P X M1, hmerge M1 M0 M2, hcumul-forall L P M0. + +%%%%%%%%%%%%%%%%% + % [declare-canonical-instances-from-factory T F] given a factory F % it uses all known builders to declare canonical instances of structures % on T @@ -429,19 +536,20 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ synthesis.under-mixin-src-from-factory.do! T F [ synthesis.under-local-canonical-mixins-of.do! T [ list-w-params_list {factory-provides Factory} ML, - coq.say "DCIFF!!!!!!! In ML (mixin names) = " ML, + coq.say "DCIFF!!!!!!! Ex ML (mixin names) = " ML, - % currently, AllSubjects = [T] + % Clauses, MCSL and AllSubjects are outputs. currently, AllSubjects = [T] add-all-mixins T Factory ML tt Clauses MCSL AllSubjects, + coq.say "DCIFF!!!!!!!!!! Ex AllSubjects = " AllSubjects, % old (Clauses not used) - instance.declare-all T {findall-classes-for ML} CCSL, - % std.forall AllSubjects (s \ instance.declare-all s {findall-classes-for ML} CCSL), + % instance.declare-all T {findall-classes-for ML} CCSL, + % hcumul-forall AllSubjects (s \ instance.declare-all s {findall-classes-for ML}) CCSL, ] ], % Clauses => instance.declare-all T {findall-classes-for ML} CCSL, % new (should use Clauses and AllSubjects) - % Clauses => std.forall AllSubjects (s \ instance.declare-all s {findall-classes-for ML} CCSL), + Clauses => hcumul-forall AllSubjects (s \ instance.declare-all s {findall-classes-for ML}) CCSL, /* %% New code: @@ -455,10 +563,13 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ (s \ instance.declare-all s {findall-classes-for ML} CCSL), %% */ + coq.say "DCIFF!!!!!!!!!! Ex Clauses = " Clauses, + coq.say "DCIFF!!!!!!!!!! Ex CCSL = " CCSL, + std.append MCSL CCSL CSL, - coq.say "DCIFF!!!!!!!!!! Out CSL = " CSL, + coq.say "DCIFF!!!!!!!!!! Out CSL = " CSL, ]. - + % If you don't mention the factory in a builder, then Coq won't make % a lambda for it at section closing time. pred hack-section-discharging i:term, o:term. From f0975bbc7294ef64b0bb411a2173f9b54041a2d6 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 20 Jul 2023 19:43:00 +0200 Subject: [PATCH 51/63] added redirect-instances (instances.elpi), in progress --- HB/instance.elpi | 68 ++++++++++++++---------------------------------- 1 file changed, 20 insertions(+), 48 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 7429a3379..391377fd1 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -34,6 +34,7 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ std.assert-ok! (coq.elaborate-skeleton BodySkel Ty Body) "Definition illtyped", coq.say "DC!!!!!!!!!!!!! Ex Body = " Body, + coq.say "DC!!!!!!!!!!!!! Ex TyWP = " TyWP, coq.say "DC!!!!!!!!!!!!! Ex Ty = " Ty, % handle parameters via a section -- begin @@ -71,10 +72,13 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ coq.say "DC!!!!!!!!!!!!! Ex UnfoldClauses = " UnfoldClauses, + % Here the body of the definition (OptimizedBody) is associated with a name (C) log.coq.env.add-const-noimplicits-failondup RealName OptimizedBody SectionTyUnfolded @transparent! C, TheFactory = (global (const C)), + coq.say "DC!!!!!!!!!!!! Ex OptimizedBody (linking point with TheFactory) = " OptimizedBody, + % call HB.instance TheType TheFactory std.drop NParams Args [TheType|_], @@ -339,54 +343,6 @@ add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do ]. -% [add-mixin T F _ M Cl] adds a constant being the mixin instance for M on type -% T built from factory F -pred add-mixinW i:term, i:factoryname, i:bool, i:mixinname, - o:list prop, o:list (pair id constant). -add-mixinW T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do! [ - - coq.say "AM!!!!!!!!!!!!!!!!!!!! NOW RUNNING add-mixin", - coq.say "AM!!!!!!!!!! In T (for the subject) = " T, - coq.say "AM!!!!!!!!!! In MissingMixin (the mixin, might be a base one) = " MissingMixin, - - new_int N, % timestamp - - synthesis.assert!-infer-mixin T MissingMixin Bo, - MixinSrcCl = mixin-src T MixinName (global (const C)), - BuilderDeclCl = builder-decl (builder N FGR MixinName (const C)), - - std.assert-ok! (coq.typecheck Bo Ty) "declare-instances: mixin illtyped", - safe-dest-app Ty (global MixinNameAlias) _, - factory-alias->gref MixinNameAlias MixinName, - - std.assert! (MissingMixin = MixinName) "HB: anomaly: we built the wrong mixin", - - coq.say "AM!!!!!!!!!! Ex Bo = " Bo, - coq.say "AM!!!!!!!!!! Ex Ty = " Ty, - coq.say "AM!!!!!!!!!! Ex MixinName = " MixinName, - - % If the mixin instance is already a constant there is no need to - % alias it. - if (Bo = global (const C)) true - (Name is {gref->modname FGR 2 "_"} ^"__to__" ^ {gref->modname MixinName 2 "_"}, - if-verbose (coq.say {header} "declare mixin instance" Name), - log.coq.env.add-const-noimplicits Name Bo Ty @transparent! C), - if (MakeCanon = tt, whd (global (const C)) [] (global (indc _)) _) - (std.do! [ - if-verbose (coq.say {header} "declare canonical mixin instance" C), - with-locality (log.coq.CS.declare-instance C), - CSL = [pr "_" C], - ]) (CSL = []), - - coq.say "AM!!!!!!!!!! Out C (instance name) = " C, - coq.say "AM!!!!!!!!!! Out MixinSrcCl = " MixinSrcCl, - coq.say "AM!!!!!!!!!! Out BuilderDeclCl = " BuilderDeclCl, - coq.say "AM!!!!!!!!!! Out CSL = " CSL, - -]. - - - pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, o:list prop, o:list (pair id constant), o:list term. add-all-mixins T FGR ML MakeCanon Clauses CSL Sbjs:- std.do! [ @@ -733,6 +689,22 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- ]. derive-wrapper-instances _ _. +pred redirect-instances i:factoryname, i:term, i:term + o:list prop, o:list (pair id constant). +redirect-instances Factory TheType Body Clauses CSL :- std.do! [ + coq.safe-dest-app TheType TheTypeKey _, + + if (TheTypeKey = global TheTypeKeyGR) + (std.do! [ + std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, + coq.say "WRAPPERS: " Wrappers, + std.forall Wrappers (private.derive-wrapper-instances Body) + ] + ) + true, +]. + + /* GENERAL COMMENT 05/07/2023. We have already implemented the elimination rule for wrapper From 73e614b633ee48ba599850ba2a1efa1416e2f730 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Fri, 21 Jul 2023 19:20:54 +0200 Subject: [PATCH 52/63] instance.elpi, redirect-instances - in progress (section problem) --- HB/instance.elpi | 121 ++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 108 insertions(+), 13 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 391377fd1..b4fa00bd0 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -50,6 +50,7 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ private.postulate-arity TyWP [] Body SectionBody SectionTy ), + coq.say "DC!!!!!!!!!!!!! Ex SectionName = " SectionName, coq.say "DC!!!!!!!!!!!!! Ex SectionBody = " SectionBody, coq.say "DC!!!!!!!!!!!!! Ex SectionTy = " SectionTy, @@ -58,11 +59,18 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ factory-alias->gref FactoryAlias Factory, std.assert! (factory-nparams Factory NParams) "Not a factory synthesized by HB", + coq.say "DC!!!!!!!!!!!!! Ex Factory = " Factory, + coq.say "DC!!!!!!!!!!!!! Ex FactoryAlias = " FactoryAlias, + coq.say "DC!!!!!!!!!!!!! Ex Args = " Args, + coq.say "DC!!!!!!!!!!!!! Ex NParams = " NParams, + % declare the constant for the factory instance private.hack-section-discharging SectionBody SectionBodyHack, private.optimize-body SectionBodyHack OptimizedBody, if (Name = "_") (RealName is "HB_unnamed_factory_" ^ {std.any->string {new_int} }) (RealName = Name), + coq.say "DC!!!!!!!!!!!!! Ex RealName = " RealName, + % unfold local instances in the type of C if (current-mode (builder-from _ _ _ _)) (std.do![ findall-local-canonical LocalCSL, @@ -70,7 +78,9 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ UnfoldClauses => copy SectionTy SectionTyUnfolded, ]) (SectionTy = SectionTyUnfolded), - coq.say "DC!!!!!!!!!!!!! Ex UnfoldClauses = " UnfoldClauses, + coq.say "DC!!!!!!!!!!!! Ex LocalCSL = " LocalCSL, + coq.say "DC!!!!!!!!!!!! Ex UnfoldClauses = " UnfoldClauses, + coq.say "DC!!!!!!!!!!!! Ex SectionTyUnfolded = " SectionTyUnfolded, % Here the body of the definition (OptimizedBody) is associated with a name (C) log.coq.env.add-const-noimplicits-failondup RealName OptimizedBody @@ -78,14 +88,19 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ TheFactory = (global (const C)), coq.say "DC!!!!!!!!!!!! Ex OptimizedBody (linking point with TheFactory) = " OptimizedBody, - + coq.say "DC!!!!!!!!!!!! Ex C = " C, + % call HB.instance TheType TheFactory std.drop NParams Args [TheType|_], private.check-non-forgetful-inheritance TheType Factory, + coq.say "DC!!!!!!!!!!!!! Ex TheType = " TheType, + coq.say "DC!!!!!!!!!!!!! Ex TheFactory = " TheFactory, + % Clauses and CSL are outputs. QUESTION: what is the context here? - private.declare-instance Factory TheType TheFactory Clauses CSL, + % private.declare-instance Factory TheType TheFactory Clauses CSL, + private.redirect-instances Factory TheType TheFactory Body Clauses CSL, % handle parameters via a section -- end if (TyWP = arity _) true ( @@ -93,6 +108,24 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ log.coq.env.end-section-name SectionName ), + + + + coq.safe-dest-app TheType TheTypeKey _, + if (TheTypeKey = global TheTypeKeyGR) + (std.do! [ + std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, + coq.say "REDIN!!!!!!! WRAPPERS = " Wrappers, + if (Wrappers = [W|_]) + % there is a wrapper (we actually don't want more than one) + (private.dry-run TheFactory W _ _) + % there happens to be no wrapper, just treat it as a normal instance + true + ] + ) + true, + + % we accumulate clauses now that the section is over % QUESTION - what is this really accumulating? appears to be always empty acc-clauses current Clauses, @@ -610,6 +643,13 @@ check-non-forgetful-inheritance T Factory :- std.do! [ % |} % |}, isMon.phant_axioms (hom A B) +pred mk_wrapper_instance_name i:mixinname i:term o:string. +mk_wrapper_instance_name W Ins Str :- + coq.gref->modname W Str0, + coq.term->string Ins Str1, + % coq.term->string (global W) Str0, + std.string.concat "__" [Str1, Str0] Str. + % Not used, but possible useful pred mk_wrapper_instance_name i:mixinname i:term o:string. mk_wrapper_instance_name W Ins Str :- @@ -624,8 +664,9 @@ mk_wrapper_instance_name W Ins Str :- % Morever, in general this may apply to more than a mixin (if the base mixin is not a trivially % atomic one). % Important to ensure there is a consistent naming scheme. -pred derive-wrapper-instances i:term, i:prop. -derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.do! [ +pred derive-wrapper-instances i:term, i:prop, o:list prop, o:list (pair id constant). +derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) + Clauses CSL :- std.do! [ coq.say "DWI!!!!!!!!! NOW RUNNING derive-wrapper-instances Instance _", coq.say "DWI!!!!!!! Instance = " Instance, @@ -666,7 +707,8 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- % the name needs to be fixed. % name generation doesn't work because of dot occurrences % mk_wrapper_instance_name Wrapper_Mixin Instance Nm, - instance.declare-const "funq_instance_name" NewInstance {coq.term->arity Ty N0} _ + % instance.declare-const "funq_instance_name" NewInstance {coq.term->arity Ty N0} _ + instance.declare-instance WrapperMixin _ NewInstance Clauses CSL ) /* @@ -687,22 +729,75 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) :- std.forall WrapperProjections (export-wrapper-instance W) */ ]. -derive-wrapper-instances _ _. +derive-wrapper-instances _ _ [] []. -pred redirect-instances i:factoryname, i:term, i:term +% split between direct call to declare-instance and indirect one through derive-wrapper-instances +pred redirect-instances i:factoryname, i:term, i:term, i:term, o:list prop, o:list (pair id constant). -redirect-instances Factory TheType Body Clauses CSL :- std.do! [ +redirect-instances Factory TheType TheFactory Body Clauses CSL :- std.do! [ coq.safe-dest-app TheType TheTypeKey _, - + + coq.say "NOW RUNNING****************************** REDIN " + coq.say "REDIN!!!!!!! TheTypeKey = " TheTypeKey, + if (TheTypeKey = global TheTypeKeyGR) (std.do! [ std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, - coq.say "WRAPPERS: " Wrappers, - std.forall Wrappers (private.derive-wrapper-instances Body) + coq.say "REDIN!!!!!!! WRAPPERS = " Wrappers, + if (Wrappers = [W|_]) + % there is a wrapper (we actually don't want more than one) + (%private.derive-wrapper-instances TheFactory W Clauses CSL + private.declare-instance Factory TheType TheFactory Clauses CSL) + % there happens to be no wrapper, just treat it as a normal instance + (private.declare-instance Factory TheType TheFactory Clauses CSL) ] ) - true, + % there can be no wrapper, just treat it as a normal instance + (private.declare-instance Factory TheType TheFactory Clauses CSL) +]. + +% test predicate +pred dry-run i:term, i:prop, o:list prop, o:list (pair id constant). +dry-run Instance (wrapper-mixin WrapperMixin Subject Mixin) [] [] :- std.do! [ + + coq.say "DWI!!!!!!!!! NOW RUNNING derive-wrapper-instances Instance _", + coq.say "DWI!!!!!!! Instance = " Instance, + + % K is the mixin constructor (Build) for WrapperMixin + factory-constructor WrapperMixin K, + factory-nparams WrapperMixin NParams, + std.assert! (NParams = 0) "TODO support parameters", + + coq.say "DWI!!!!!!! K = " K, + coq.say "DWI!!!!!!! NParams = " NParams, + + coq.env.typeof K KTy, + coq.count-prods KTy KN, + KN0 = KN - 1, + coq.mk-n-holes KN0 Holes, + + std.append Holes [Instance] Args, + + coq.say "DWI!!!!!!! KTy = " KTy, + coq.say "DWI!!!!!!! KN = " KN, + coq.say "DWI!!!!!!! Args = " Args, + + % the body of the new wrapper instance + NewInstance = app[global K| Args], + + coq.say "DWI!!!!!!!!! NewInstance = " {coq.term->string NewInstance}, + + coq.typecheck NewInstance Ty Dgn, + + coq.say "DWI!!!!!!!!! Ty = " Ty, + coq.say "DWI!!!!!!!!! Dgn = " Dgn, + + %if (Dgn = error S) (coq.say "error in NewInstance" S) + %(% coq.count-prods Ty N0, + % instance.declare-instance WrapperMixin _ NewInstance Clauses CSL + %), ]. +dry-run _ _ [] []. /* From ab87dd8d805daff2afb8be16111a3e09468c2407 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Fri, 21 Jul 2023 19:24:43 +0200 Subject: [PATCH 53/63] instance.elpi, redirect-instances - in progress (section problem) --- HB/instance.elpi | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index b4fa00bd0..024533789 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -109,8 +109,8 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ ), - - + %%%%%%%%%%%%%%% temporary test code + %%% (type-check failure if called from inside the section) coq.safe-dest-app TheType TheTypeKey _, if (TheTypeKey = global TheTypeKeyGR) (std.do! [ @@ -124,6 +124,7 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ ] ) true, + %%%%%%%%%%%%%%%%%%%%%%%% % we accumulate clauses now that the section is over From 11baf58ba1147b161e7a5a9e4c44273bfc926c7d Mon Sep 17 00:00:00 2001 From: ptorrx Date: Sat, 22 Jul 2023 00:29:22 +0200 Subject: [PATCH 54/63] instance.elpi: redirect-instances in progress, still need to add call to declare-instance --- HB/instance.elpi | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 024533789..20ebfea22 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -100,7 +100,7 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ % Clauses and CSL are outputs. QUESTION: what is the context here? % private.declare-instance Factory TheType TheFactory Clauses CSL, - private.redirect-instances Factory TheType TheFactory Body Clauses CSL, + private.redirect-instances RealName Factory TheType TheFactory Body Clauses CSL, % handle parameters via a section -- end if (TyWP = arity _) true ( @@ -108,7 +108,7 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ log.coq.env.end-section-name SectionName ), - + /* %%%%%%%%%%%%%%% temporary test code %%% (type-check failure if called from inside the section) coq.safe-dest-app TheType TheTypeKey _, @@ -118,14 +118,14 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ coq.say "REDIN!!!!!!! WRAPPERS = " Wrappers, if (Wrappers = [W|_]) % there is a wrapper (we actually don't want more than one) - (private.dry-run TheFactory W _ _) + (private.dry-run Body W _ _) % there happens to be no wrapper, just treat it as a normal instance true ] ) true, %%%%%%%%%%%%%%%%%%%%%%%% - + */ % we accumulate clauses now that the section is over % QUESTION - what is this really accumulating? appears to be always empty @@ -733,28 +733,32 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) derive-wrapper-instances _ _ [] []. % split between direct call to declare-instance and indirect one through derive-wrapper-instances -pred redirect-instances i:factoryname, i:term, i:term, i:term, +pred redirect-instances i:id, i:factoryname, i:term, i:term, i:term, o:list prop, o:list (pair id constant). -redirect-instances Factory TheType TheFactory Body Clauses CSL :- std.do! [ +redirect-instances RealName Factory TheType TheFactory Body Clauses CSL :- std.do! [ coq.safe-dest-app TheType TheTypeKey _, coq.say "NOW RUNNING****************************** REDIN " coq.say "REDIN!!!!!!! TheTypeKey = " TheTypeKey, - if (TheTypeKey = global TheTypeKeyGR) + if (RealName = "hom_isMon__ELIM") + (private.declare-instance Factory TheType TheFactory Clauses CSL) + (if (TheTypeKey = global TheTypeKeyGR) (std.do! [ std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, coq.say "REDIN!!!!!!! WRAPPERS = " Wrappers, if (Wrappers = [W|_]) % there is a wrapper (we actually don't want more than one) - (%private.derive-wrapper-instances TheFactory W Clauses CSL - private.declare-instance Factory TheType TheFactory Clauses CSL) + (private.derive-wrapper-instances Body W Clauses CSL + % private.declare-instance Factory TheType TheFactory Clauses CSL + ) % there happens to be no wrapper, just treat it as a normal instance (private.declare-instance Factory TheType TheFactory Clauses CSL) ] ) % there can be no wrapper, just treat it as a normal instance (private.declare-instance Factory TheType TheFactory Clauses CSL) + ) ]. % test predicate @@ -793,10 +797,10 @@ dry-run Instance (wrapper-mixin WrapperMixin Subject Mixin) [] [] :- std.do! [ coq.say "DWI!!!!!!!!! Ty = " Ty, coq.say "DWI!!!!!!!!! Dgn = " Dgn, - %if (Dgn = error S) (coq.say "error in NewInstance" S) - %(% coq.count-prods Ty N0, - % instance.declare-instance WrapperMixin _ NewInstance Clauses CSL - %), + if (Dgn = error S) (coq.say "error in NewInstance" S) + (coq.count-prods Ty N0 + % instance.declare-instance WrapperMixin _ NewInstance Clauses CSL + ), ]. dry-run _ _ [] []. From 8e22bb38dca5becd0de8e5f6e48edafed84745e6 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Mon, 24 Jul 2023 11:34:28 +0200 Subject: [PATCH 55/63] instance.elpi: redirect-instances in progress, added call to declare-instance, not working yet --- HB/instance.elpi | 53 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 39 insertions(+), 14 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 20ebfea22..dcdb558d5 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -100,14 +100,15 @@ declare-const Name BodySkel TyWPSkel CSL :- std.do! [ % Clauses and CSL are outputs. QUESTION: what is the context here? % private.declare-instance Factory TheType TheFactory Clauses CSL, - private.redirect-instances RealName Factory TheType TheFactory Body Clauses CSL, + private.redirect-instances RealName Factory TheType TheFactory Body TyWP SectionName Clauses CSL, + /* % handle parameters via a section -- end if (TyWP = arity _) true ( if-verbose (coq.say {header} "closing instance section"), log.coq.env.end-section-name SectionName ), - + */ /* %%%%%%%%%%%%%%% temporary test code %%% (type-check failure if called from inside the section) @@ -669,7 +670,7 @@ pred derive-wrapper-instances i:term, i:prop, o:list prop, o:list (pair id const derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) Clauses CSL :- std.do! [ - coq.say "DWI!!!!!!!!! NOW RUNNING derive-wrapper-instances Instance _", + coq.say "DWI!!!!!!!!!! NOW RUNNING derive-wrapper-instances Instance _", coq.say "DWI!!!!!!! Instance = " Instance, % K is the mixin constructor (Build) for WrapperMixin @@ -702,14 +703,20 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) coq.say "DWI!!!!!!!!! NewInstance =" {coq.term->string NewInstance}, coq.typecheck NewInstance Ty Dgn, - if (Dgn = error S) (coq.say "error in NewInstance" S) + coq.say "REDIN!!!!!!!!!!!!!! Ty = " Ty, + + if (Dgn = error S) (coq.say "REDIN!!!!!!!!!!! error in NewInstance" S) (coq.count-prods Ty N0, % we then call declare-const to add the new instance. % the name needs to be fixed. - % name generation doesn't work because of dot occurrences - % mk_wrapper_instance_name Wrapper_Mixin Instance Nm, - % instance.declare-const "funq_instance_name" NewInstance {coq.term->arity Ty N0} _ - instance.declare-instance WrapperMixin _ NewInstance Clauses CSL + % name generation doesn't work because of dot occurrences + % mk_wrapper_instance_name Wrapper_Mixin Instance Nm, + % instance.declare-const "funq_instance_name" NewInstance {coq.term->arity Ty N0} _ + coq.say "REDIN!!!!!!!!!!!!!! OK", + coq.say "REDIN!!!!!!!!!!!!!! WrapperMixin = " WrapperMixin, + coq.say "REDIN!!!!!!!!!!!!!! NewInstance = " NewInstance, + + instance.declare-instance WrapperMixin _ NewInstance Clauses CSL ) /* @@ -732,28 +739,46 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) ]. derive-wrapper-instances _ _ [] []. +pred private.dec-inst-and-close i:factoryname, i:term, i:term, i:arity, i:id, + o:list prop, o:list (pair id constant). +private.dec-inst-and-close Factory TheType TheFactory TyWP SectionName Clauses CSL :- std.do! [ + + private.declare-instance Factory TheType TheFactory Clauses CSL, + % handle parameters via a section -- end + if (TyWP = arity _) true ( + if-verbose (coq.say {header} "closing instance section"), + log.coq.env.end-section-name SectionName + ) +]. + % split between direct call to declare-instance and indirect one through derive-wrapper-instances -pred redirect-instances i:id, i:factoryname, i:term, i:term, i:term, +pred redirect-instances i:id, i:factoryname, i:term, i:term, i:term, i:arity, i:id, o:list prop, o:list (pair id constant). -redirect-instances RealName Factory TheType TheFactory Body Clauses CSL :- std.do! [ +redirect-instances RealName Factory TheType TheFactory Body TyWP SectionName Clauses CSL :- + std.do! [ coq.safe-dest-app TheType TheTypeKey _, coq.say "NOW RUNNING****************************** REDIN " coq.say "REDIN!!!!!!! TheTypeKey = " TheTypeKey, if (RealName = "hom_isMon__ELIM") - (private.declare-instance Factory TheType TheFactory Clauses CSL) + (private.dec-inst-and-close Factory TheType TheFactory TyWP SectionName Clauses CSL) (if (TheTypeKey = global TheTypeKeyGR) (std.do! [ std.findall (wrapper-mixin _ TheTypeKeyGR Factory) Wrappers, coq.say "REDIN!!!!!!! WRAPPERS = " Wrappers, if (Wrappers = [W|_]) % there is a wrapper (we actually don't want more than one) - (private.derive-wrapper-instances Body W Clauses CSL + ( if (TyWP = arity _) true ( + if-verbose (coq.say {header} "closing instance section"), + log.coq.env.end-section-name SectionName ), + % we accumulate clauses now that the section is over + acc-clauses current Clauses0, + Clauses0 => private.derive-wrapper-instances Body W Clauses CSL % private.declare-instance Factory TheType TheFactory Clauses CSL ) % there happens to be no wrapper, just treat it as a normal instance - (private.declare-instance Factory TheType TheFactory Clauses CSL) + (private.dec-inst-and-close Factory TheType TheFactory TyWP SectionName Clauses CSL) ] ) % there can be no wrapper, just treat it as a normal instance @@ -799,7 +824,7 @@ dry-run Instance (wrapper-mixin WrapperMixin Subject Mixin) [] [] :- std.do! [ if (Dgn = error S) (coq.say "error in NewInstance" S) (coq.count-prods Ty N0 - % instance.declare-instance WrapperMixin _ NewInstance Clauses CSL + % instance.declare-instance WrapperMixin Ty NewInstance Clauses CSL ), ]. dry-run _ _ [] []. From 3dbe65e2cc02412210c3c6a027ba19f62b6d51fc Mon Sep 17 00:00:00 2001 From: ptorrx Date: Mon, 24 Jul 2023 14:46:22 +0200 Subject: [PATCH 56/63] instance.elpi: redirect-instances in progress, added call to declare-instance, now working --- HB/instance.elpi | 36 +++++++++++++++++++++++++----------- 1 file changed, 25 insertions(+), 11 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index dcdb558d5..ad6179032 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -528,20 +528,28 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ synthesis.under-local-canonical-mixins-of.do! T [ list-w-params_list {factory-provides Factory} ML, coq.say "DCIFF!!!!!!! Ex ML (mixin names) = " ML, + %std.findall (mixin-src (sort _) _ _) YYY, % Clauses, MCSL and AllSubjects are outputs. currently, AllSubjects = [T] - add-all-mixins T Factory ML tt Clauses MCSL AllSubjects, + add-all-mixins T Factory ML tt ClausesFromF MCSL AllSubjects, coq.say "DCIFF!!!!!!!!!! Ex AllSubjects = " AllSubjects, % old (Clauses not used) % instance.declare-all T {findall-classes-for ML} CCSL, - % hcumul-forall AllSubjects (s \ instance.declare-all s {findall-classes-for ML}) CCSL, + hcumul-forall AllSubjects (s \ + instance.declare-all s {findall-classes-for ML}) CCSL, ] ], % Clauses => instance.declare-all T {findall-classes-for ML} CCSL, % new (should use Clauses and AllSubjects) - Clauses => hcumul-forall AllSubjects (s \ instance.declare-all s {findall-classes-for ML}) CCSL, - + %std.findall (mixin-src (sort _) _ _) XXX, + %coq.say "XXX" XXX, + %coq.say "Clauses" Clauses, + %coq.say "YYY dentro il under-*" YYY, + %std.spy( + %Clauses => hcumul-forall AllSubjects (s \ + % instance.declare-all s {findall-classes-for ML}) CCSL + %), /* %% New code: % this should output all the candidate subjects too, as a new output argument. @@ -712,11 +720,15 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) % name generation doesn't work because of dot occurrences % mk_wrapper_instance_name Wrapper_Mixin Instance Nm, % instance.declare-const "funq_instance_name" NewInstance {coq.term->arity Ty N0} _ + coq.safe-dest-app Ty _Factory FArgs, + std.nth NParams FArgs WrapperSubject, coq.say "REDIN!!!!!!!!!!!!!! OK", coq.say "REDIN!!!!!!!!!!!!!! WrapperMixin = " WrapperMixin, coq.say "REDIN!!!!!!!!!!!!!! NewInstance = " NewInstance, - - instance.declare-instance WrapperMixin _ NewInstance Clauses CSL + coq.say "REDIN!!!!!!!!!!!!!! WrapperSubject = " WrapperSubject, + + + private.declare-instance WrapperMixin WrapperSubject NewInstance Clauses CSL ) /* @@ -739,9 +751,9 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) ]. derive-wrapper-instances _ _ [] []. -pred private.dec-inst-and-close i:factoryname, i:term, i:term, i:arity, i:id, +pred dec-inst-and-close i:factoryname, i:term, i:term, i:arity, i:id, o:list prop, o:list (pair id constant). -private.dec-inst-and-close Factory TheType TheFactory TyWP SectionName Clauses CSL :- std.do! [ +dec-inst-and-close Factory TheType TheFactory TyWP SectionName Clauses CSL :- std.do! [ private.declare-instance Factory TheType TheFactory Clauses CSL, % handle parameters via a section -- end @@ -773,8 +785,10 @@ redirect-instances RealName Factory TheType TheFactory Body TyWP SectionName Cla if-verbose (coq.say {header} "closing instance section"), log.coq.env.end-section-name SectionName ), % we accumulate clauses now that the section is over - acc-clauses current Clauses0, - Clauses0 => private.derive-wrapper-instances Body W Clauses CSL + %acc-clauses current Clauses0, + %coq.say "REDIN!!!!!!! Clauses0 = " Clauses0, + %Clauses0 => + private.derive-wrapper-instances TheFactory W Clauses CSL % private.declare-instance Factory TheType TheFactory Clauses CSL ) % there happens to be no wrapper, just treat it as a normal instance @@ -782,7 +796,7 @@ redirect-instances RealName Factory TheType TheFactory Body TyWP SectionName Cla ] ) % there can be no wrapper, just treat it as a normal instance - (private.declare-instance Factory TheType TheFactory Clauses CSL) + (private.dec-inst-and-close Factory TheType TheFactory TyWP SectionName Clauses CSL) ) ]. From e7361bfe9314b2b24b8b1936e8df9abaaab02717 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Mon, 24 Jul 2023 18:56:28 +0200 Subject: [PATCH 57/63] more comments in instance.elpi, added lemma in enriched_cat.v and factory-based example in monoid_enriched_cat_factory.v --- HB/instance.elpi | 26 +- tests/enriched_cat.v | 26 +- tests/monoid_enriched_cat.v | 14 +- tests/monoid_enriched_cat_factory.v | 359 ++++++++++++++++++++++++++++ 4 files changed, 413 insertions(+), 12 deletions(-) create mode 100644 tests/monoid_enriched_cat_factory.v diff --git a/HB/instance.elpi b/HB/instance.elpi index ad6179032..f58fa033a 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -519,6 +519,7 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ coq.say "DCIFF!!!!!!! In Factory = " Factory, coq.say "DCIFF!!!!!!! In T = " T, coq.say "DCIFF!!!!!!! In F = " F, + coq.safe-dest-app T Key _, % The order of the following two "under...do!" is crucial, % priority must be given to canonical mixins @@ -529,6 +530,15 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ list-w-params_list {factory-provides Factory} ML, coq.say "DCIFF!!!!!!! Ex ML (mixin names) = " ML, %std.findall (mixin-src (sort _) _ _) YYY, + + /* + % POSSIBLE CHANGE? + + (std.forall ML (m\ sigma Wrappers\ sigma KeyGR\ + Key = global KeyGR, + std.findall (wrapper-mixin _ KeyGR m) Wrappers, + coq.say "DOVREMMO FARE" Wrappers) ; true), + */ % Clauses, MCSL and AllSubjects are outputs. currently, AllSubjects = [T] add-all-mixins T Factory ML tt ClausesFromF MCSL AllSubjects, @@ -711,9 +721,9 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) coq.say "DWI!!!!!!!!! NewInstance =" {coq.term->string NewInstance}, coq.typecheck NewInstance Ty Dgn, - coq.say "REDIN!!!!!!!!!!!!!! Ty = " Ty, + coq.say "DWI!!!!!!!!!! Ty = " Ty, - if (Dgn = error S) (coq.say "REDIN!!!!!!!!!!! error in NewInstance" S) + if (Dgn = error S) (coq.say "DWI!!!!!!!!! error in NewInstance" S) (coq.count-prods Ty N0, % we then call declare-const to add the new instance. % the name needs to be fixed. @@ -722,12 +732,12 @@ derive-wrapper-instances Instance (wrapper-mixin WrapperMixin Subject Mixin) % instance.declare-const "funq_instance_name" NewInstance {coq.term->arity Ty N0} _ coq.safe-dest-app Ty _Factory FArgs, std.nth NParams FArgs WrapperSubject, - coq.say "REDIN!!!!!!!!!!!!!! OK", - coq.say "REDIN!!!!!!!!!!!!!! WrapperMixin = " WrapperMixin, - coq.say "REDIN!!!!!!!!!!!!!! NewInstance = " NewInstance, - coq.say "REDIN!!!!!!!!!!!!!! WrapperSubject = " WrapperSubject, + + coq.say "DWI!!!!!!!!!!! OK", + coq.say "DWI!!!!!!!!!!! WrapperMixin = " WrapperMixin, + coq.say "DWI!!!!!!!!!!! NewInstance = " NewInstance, + coq.say "DWI!!!!!!!!!!! WrapperSubject = " WrapperSubject, - private.declare-instance WrapperMixin WrapperSubject NewInstance Clauses CSL ) @@ -773,7 +783,7 @@ redirect-instances RealName Factory TheType TheFactory Body TyWP SectionName Cla coq.say "NOW RUNNING****************************** REDIN " coq.say "REDIN!!!!!!! TheTypeKey = " TheTypeKey, - if (RealName = "hom_isMon__ELIM") + if (RealName = "hom_isMon__ELIM") % meant to rule out generated instances (private.dec-inst-and-close Factory TheType TheFactory TyWP SectionName Clauses CSL) (if (TheTypeKey = global TheTypeKeyGR) (std.do! [ diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index a12c99caa..ba932ef1c 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -36,7 +36,8 @@ with the former... (broadly corresponding to 2?) *) HB.mixin Record hom_isMon1 T of Quiver T := { private : forall A B, hom_isMon_ty (@hom (Quiver.clone T _)) A B }. -(* abbreviation with parameters for homset and monoid *) +(* GENERIC WRAPPER. + abbreviation with parameters for homset and monoid *) Definition hom_isM_ty {T} (H: T -> T -> Type) (M: Type -> Type) (A B: T) : Type := M (H A B). @@ -120,4 +121,27 @@ Record Monoid_enriched_quiverN1 := { hsM1: forall A B, hom_isM_ty (@hom (HB.pack ObjN1 iQ1)) (fun X => isMon X) A B }. +(*************************************************************) + +(* shows that if a mixin can be decomposed into atomic ones, then its +wrapper can be decompoed into atomic wrappers *) +Lemma hom_isM_ty_split (M1 M2 M3: Type -> Type) : + ((forall X: Type, (M1 X * M2 X) -> M3 X) * + (forall X: Type, M3 X -> (M1 X * M2 X))) + -> + forall (T:Type) (H: T -> T -> Type), + ((forall x1 x2, M1 (H x1 x2)) * (forall x1 x2, M2 (H x1 x2)) -> + (forall x1 x2, M3 (H x1 x2))) * + ((forall x1 x2, M3 (H x1 x2)) -> + (forall x1 x2, M1 (H x1 x2)) * (forall x1 x2, M2 (H x1 x2))). + intros X T H; destruct X as [X1 X2]; split; intro X. + intros x1 x2. + eapply X1; eauto. + destruct X as [X3 X4]. + split; eauto. + + split; intros x1 x2; specialize (X2 (H x1 x2)); + specialize (X x1 x2); intuition. +Qed. + diff --git a/tests/monoid_enriched_cat.v b/tests/monoid_enriched_cat.v index 7adc2efa9..c0b511700 100644 --- a/tests/monoid_enriched_cat.v +++ b/tests/monoid_enriched_cat.v @@ -161,15 +161,23 @@ Set Printing All. In principle this instance should be derivable from the wrapper instance. But since we haven't introduced the wrapper instance yet, we use this HB command to actually introduce it. *) + +Check Type : Quiver.type. +Fail Check Type : Monoid_enriched_quiver.type. + HB.instance Definition funQ_isMon (A B: Type) : isMon (hom A B) := funQ_isMonF A B. -(* Print Canonical Projections. *) +Check Type : Monoid_enriched_quiver.type. + + + (* Check (fun A B : Type => hom A B : Monoid.type). *) -(* instantiate hom_isMon by using the generic isMon instance to define 'private' *) - HB.instance Definition funQ_hom_isMon := +(* instantiate hom_isMon by using the generic isMon instance to define 'private' *) +(* HB.instance Definition funQ_hom_isMon := hom_isMon.Build Type funQ_isMonF. + *) (* Print Canonical Projections. *) diff --git a/tests/monoid_enriched_cat_factory.v b/tests/monoid_enriched_cat_factory.v new file mode 100644 index 000000000..f5374330f --- /dev/null +++ b/tests/monoid_enriched_cat_factory.v @@ -0,0 +1,359 @@ +From HB Require Import structures. +From Coq Require Import ssreflect ssrfun. + +HB.mixin Record isQuiver Obj := { hom : Obj -> Obj -> Type }. + +HB.structure Definition Quiver := { Obj of isQuiver Obj }. + +HB.mixin Record isMon A := { + zero : A; + add : A -> A -> A; + addrA : associative add; + add0r : left_id zero add; + addr0 : right_id zero add; + }. + +HB.structure + Definition Monoid := { A of isMon A }. + +(* This is expected to fail, as it isn't a mixin *) +Fail HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & + (forall A B : Obj, isMon (@hom (Quiver.clone Obj _) A B)) }. + +(* About zero. + Print zero. +*) +(* Step 0: define a wrapper predicate in coq-elpi *) +(* 5 lines of documentation + 1 line of elpi code in structure.v + `pred wrapper-mixin o:mixinname, o:gref, o:mixinname` +*) +(* Step 1: add a wrapper attribute to declare wrappers, + they should index: + - the wrapped mixin (`isMon`) + - the wrapper mixin (`hom_isMon`) + - the new subject (`hom`) + This attribute will add an entry in the `wrapper-mixin` database. + As an addition substep, we should check that the wrapper has + exactly one field, which is the wrapped mixin. + *) +(* added wrapper attribute in utils.elpi. + added pred wrapper-mixin in structures.v. + added conditional rule for wrapper-mixin in factory.elpi. +*) +#[wrapper] +HB.mixin Record hom_isMon T of Quiver T := + { hom_isMon_private : forall A B, isMon (@hom T A B) }. + +(* Print Canonical Projections. *) +(* About hom_isMon.hom_isMon_private. *) +(* About hom_isMon_private. *) + +(* Step 2: at structure declaration, export the main and only projection + of each declared wrapper as an instance of the wrapped structure on + its subject *) +HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon Obj }. + +(* + HB.factory Record isMon2 A := + { + zero : A; + add : A -> A -> A; + addrA : associative add; + add0r : left_id zero add; + addr0 : right_id zero add; + foo : A; + }. + HB.builders Context X (f : isMon2 X). + + HB.instance Definition _ : isMon X := isMon.Build X zero add addrA add0r addr0. + + + HB.end. + *) +(* +HB.factory Record isMon2 A of Quiver A := +{ + zero : A; + add : A -> A -> A; + addrA : associative add; + add0r : left_id zero add; + addr0 : right_id zero add; + foo : forall X Y, isMon (@hom A X Y); +}. +HB.builders Context X (f : isMon2 X). + +HB.instance Definition _ : isMon X := isMon.Build X zero add addrA add0r addr0. + +HB.instance Definition _ : hom_isMon X := + hom_isMon.Build X foo. + +HB.end. +*) + + + +(* About hom_isMon.hom_isMon_private. *) +(* About hom_isMon_private. *) + +(* as expected from step 2, now this instance declaration is no more necessay *) +(* + HB.instance Definition _ (T : Monoid_enriched_quiver.type) (A B : T) : isMon (@hom T A B) := + @hom_isMon_private T A B. +*) +(* each instance of isMon should be tried as an instance of hom_isMon *) +(* + (* Step 3: for each instance of a wrapped mixin on a subject known + to be wrapped, automatically produce an instance of the wrapper mixin too. *) + HB.instance Definition _ := isQuiver.Build Type (fun A B => A -> B). + Fail HB.instance Definition homTypeMon (A B : Quiver.type) := isMon.Build (hom A B) (* ... *). + (* This last command should create a `Monoid_enriched_quiver`, in order to do so it should + automatically instanciate the wrapper `hom_isMon`: + HB.instance Definition _ := hom_isMon.Build Type homTypeMon. + *) +*) + +(* Essentially, step 2 is the elimination rule for the wrapper, step 3 is the introduction one *) + +(* quiver instance (simply typed functions between two types) *) +(* Elpi Trace Browser. *) + +HB.instance Definition funQ := isQuiver.Build Type + (fun A B => A -> option B). + +(* Print Canonical Projections. *) + +(* prove that for every two types the quiver is a monoid *) + +Require Import FunctionalExtensionality. + +Definition funQ_comp {A B} (f g: A -> option B) (x: A) : option B := + match f x with + | Some _ => f x + | _ => g x end. + + (* + Program Definition funQ_isMonF_alt (A B: Type) : isMon (hom A B) := + isMon.Build (A -> option B) (fun (_:A) => None) funQ_comp _ _ _. + Obligations. + Obligation 1. + unfold associative; intros. + eapply functional_extensionality; intro a. + unfold funQ_comp. + destruct (x a) eqn:K1. + simpl; auto. + destruct (y a); auto. + Qed. + Obligation 2. + unfold left_id; intros. + unfold funQ_comp; auto. + Qed. + Obligation 3. + unfold right_id; intros. + eapply functional_extensionality; intro a. + unfold funQ_comp. + destruct (x a); auto. + Qed. +*) + +Program Definition funQ_isMonF (A B: Type) : isMon2 (A -> option B) := + isMon2.Build (A -> option B) (fun (_:A) => None) funQ_comp _ _ _ (fun (_:A) => None). +(* Obligations. *) +Obligation 1. +unfold associative; intros. +eapply functional_extensionality; intro a. +unfold funQ_comp. +destruct (x a) eqn:K1. +simpl; auto. +destruct (y a); auto. +Qed. +Obligation 2. +unfold left_id; intros. +unfold funQ_comp; auto. +Qed. +Obligation 3. +unfold right_id; intros. +eapply functional_extensionality; intro a. +unfold funQ_comp. +destruct (x a); auto. +Qed. + +(* +Print Canonical Projections. +*) + +(* +Fail Check (nat -> option nat) : Monoid.type. + +Check 1. + +Print Canonical Projections. + +Check 2. +Set Printing All. +*) + +(* use the lemma to instantiate isMon. Notice the genericity of the type. + In principle this instance should be derivable from the wrapper instance. + But since we haven't introduced the wrapper instance yet, we use this + HB command to actually introduce it. *) + +Check Type : Quiver.type. +Fail Check Type : Monoid_enriched_quiver.type. + +HB.instance Definition funQ_isMon (A B: Type) : isMon2 (hom A B) := + funQ_isMonF A B. + +Check Type : Monoid_enriched_quiver.type. + + + +(* Check (fun A B : Type => hom A B : Monoid.type). *) + +(* instantiate hom_isMon by using the generic isMon instance to define 'private' *) +(* HB.instance Definition funQ_hom_isMon := + hom_isMon.Build Type funQ_isMonF. + *) + +(* Print Canonical Projections. *) + +(* Check (fun A B : Type => hom A B : Monoid.type). *) + +(* HB.about private. *) +(* Print Canonical Projections. *) +(* this has to be changed, it should be something like (hom nat nat): + Check (nat -> option nat) : Monoid.type. *) +(* +HB.about funQ_isMonF. +Fail HB.about funQ_hom_isMon. +About funQ_hom_isMon. +*) + +Elpi Print HB.structure. + + +(**************************************************************) +(* Elpi code moved to factory.elpi *) +(* +Elpi Command x. +Elpi Accumulate File "HB/common/stdpp.elpi". +Elpi Accumulate File "HB/common/database.elpi". +Elpi Accumulate File "HB/common/utils.elpi". +Elpi Accumulate File "HB/status.elpi". +Elpi Accumulate Db hb.db. + +(* extracts isMon *) +Elpi Accumulate lp:{{ + +pred extract_ret_type_name i:term, o:gref. +extract_ret_type_name (prod _ _ TF) Out1 :- + pi p\ + extract_ret_type_name (TF p) Out1. +extract_ret_type_name Ty GR1 :- + Ty = app [global GR0| _], + factory-alias->gref GR0 GR1. + +pred extract_wrapped1 i:indt-decl, o:gref. +extract_wrapped1 (parameter ID _ _ R) Out :- + pi p\ + extract_wrapped1 (R p) Out. +extract_wrapped1 (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + extract_ret_type_name Ty GR0. + +}}. +Elpi Typecheck. + +(* extracts hom *) +Elpi Accumulate lp:{{ + +pred extract_inner_type_name i:term, o:gref. +extract_inner_type_name (prod _ _ TF) Out1 :- + pi p\ + extract_inner_type_name (TF p) Out1. +extract_inner_type_name Ty Gr :- + Ty = (app [global _, app [global Gr| _]]). + +pred extract_subject1 i:indt-decl, o:gref. +extract_subject1 (parameter ID _ _ R) Out :- + pi p\ + extract_subject1 (R p) Out. +extract_subject1 (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + extract_inner_type_name Ty GR0. + +}}. +Elpi Typecheck. + +(* better version, with predicate parameters *) +Elpi Accumulate lp:{{ + +pred extract_from_record_decl i: (term -> gref -> prop), i:indt-decl, o:gref. +extract_from_record_decl P (parameter ID _ _ R) Out :- + pi p\ + extract_from_record_decl P (R p) Out. +extract_from_record_decl P (record ID _ KID (field _ _ Ty (x\end-record))) GR0 :- + P Ty GR0. + +pred extract_from_rtty i: (term -> gref -> prop), i: term, o:gref. +extract_from_rtty P (prod _ _ TF) Out1 :- + pi p\ + extract_from_rtty P (TF p) Out1. +extract_from_rtty P Ty Gr :- P Ty Gr. + +pred xtr_fst_op i:term, o:gref. +xtr_fst_op Ty Gr1 :- + Ty = (app [global Gr0| _]), + factory-alias->gref Gr0 Gr1. + +pred xtr_snd_op i:term, o:gref. +xtr_snd_op Ty Gr :- + Ty = (app [global _, app [global Gr| _]]). + +pred extract_wrapped i:indt-decl, o:gref. +extract_wrapped In Out :- + extract_from_record_decl (extract_from_rtty xtr_fst_op) In Out. + +pred extract_subject i:indt-decl, o:gref. +extract_subject In Out :- + extract_from_record_decl (extract_from_rtty xtr_snd_op) In Out. + +pred wrapper_mixin_aux i:gref, o:gref, o:gref. +wrapper_mixin_aux XX Gr1 Gr2 :- + XX = (indt I), + coq.env.indt-decl I D, + extract_subject D Gr1, + extract_wrapped D Gr2. + +}}. +Elpi Typecheck. + +(*for debugging - check /tmp/traced.tmp.json with Elpi Tracer *) +(* Elpi Trace Browser. *) +(* Elpi Bound Steps 1000. *) + +(* OK *) +Elpi Query lp:{{ + + coq.locate "hom_isMon.axioms_" XX, + wrapper_mixin_aux XX Gr1 Gr2. + +}}. + +(* also OK *) +Elpi Query lp:{{ + + coq.locate "hom_isMon.axioms_" XX, + XX = (indt I), + coq.env.indt-decl I D, + extract_wrapped1 D GR11, + extract_subject1 D GR12. + +}}. + +Elpi Print HB.structure. + +stop. +*) + From 9d80cdf3f17e6b4164b7848ee2971157288d4b48 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 26 Jul 2023 14:20:09 +0200 Subject: [PATCH 58/63] enriched_cat.v: minor changes --- tests/enriched_cat.v | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index ba932ef1c..6c8ac8de1 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -38,29 +38,27 @@ HB.mixin Record hom_isMon1 T of Quiver T := (* GENERIC WRAPPER. abbreviation with parameters for homset and monoid *) -Definition hom_isM_ty {T} (H: T -> T -> Type) (M: Type -> Type) (A B: T) : +Definition hom_isM_ty (M: Type -> Type) {T} (H: T -> T -> Type) (A B: T) : Type := M (H A B). (* three parameter relation *) Definition wrapper_spec {T} (H: T -> T -> Type) (M HM: Type -> Type) : - Prop := HM T = forall A B, hom_isM_ty H M A B. + Prop := HM T = forall A B, hom_isM_ty M H A B. (* one more wrapper definition (no real change) *) HB.mixin Record hom_isMon2 T of Quiver T := - { private : forall A B, hom_isM_ty (@hom (Quiver.clone T _)) - (fun X => isMon X) + { private : forall A B, hom_isM_ty (fun X => isMon X) + (@hom (Quiver.clone T _)) A B }. (* the parametric definition works, though it is problematic *) HB.mixin Record hom_isM2 (M: Type -> Type) T of Quiver T := - { private : forall (A B: T), @hom_isM_ty T (@hom (Quiver.clone T _)) - M + { private : forall (A B: T), @hom_isM_ty M T (@hom (Quiver.clone T _)) A B }. (* just a copy of hom_isM2 *) HB.mixin Record hom_isM3 (M: Type -> Type) T of Quiver T := - { private : forall (A B: T), @hom_isM_ty T (@hom (Quiver.clone T _)) - M + { private : forall (A B: T), @hom_isM_ty M T (@hom (Quiver.clone T _)) A B }. (* structure based on one of the wrappers *) @@ -109,8 +107,8 @@ Record isQuiverS (Obj: Type) : Type := { homS : Obj -> Obj -> Type }. Structure Monoid_enriched_quiverN := { ObjN: Type; iQ: isQuiverS ObjN; - hsM: forall A B, hom_isM_ty (homS ObjN iQ) - (fun X => isMon X) A B }. + hsM: forall A B, hom_isM_ty (fun X => isMon X) (homS ObjN iQ) + A B }. About hom. @@ -118,8 +116,8 @@ About hom. Record Monoid_enriched_quiverN1 := { ObjN1: Type; iQ1: isQuiver ObjN1; - hsM1: forall A B, hom_isM_ty (@hom (HB.pack ObjN1 iQ1)) - (fun X => isMon X) A B }. + hsM1: forall A B, hom_isM_ty (fun X => isMon X) (@hom (HB.pack ObjN1 iQ1)) + A B }. (*************************************************************) From 7835883b995f88ecb045b56d6af90b932aa348d1 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 26 Jul 2023 15:00:51 +0200 Subject: [PATCH 59/63] enriched_cat.v: minor changes --- tests/enriched_cat.v | 57 ++++++++++++++++++++++++++------------------ 1 file changed, 34 insertions(+), 23 deletions(-) diff --git a/tests/enriched_cat.v b/tests/enriched_cat.v index 6c8ac8de1..641acac05 100644 --- a/tests/enriched_cat.v +++ b/tests/enriched_cat.v @@ -36,30 +36,42 @@ with the former... (broadly corresponding to 2?) *) HB.mixin Record hom_isMon1 T of Quiver T := { private : forall A B, hom_isMon_ty (@hom (Quiver.clone T _)) A B }. -(* GENERIC WRAPPER. +(* GENERIC WRAPPER instantiated. abbreviation with parameters for homset and monoid *) -Definition hom_isM_ty (M: Type -> Type) {T} (H: T -> T -> Type) (A B: T) : +Definition HT_isM (M: Type -> Type) {T} (H: T -> T -> Type) (A B: T) : Type := M (H A B). + +Lemma wrap_up (M: Type -> Type) {T} (H: T -> T -> Type) (A B: T) + (x: M (H A B)) : HT_isM M H A B. +auto. +Qed. + +Lemma unwrap (M: Type -> Type) {T} (H: T -> T -> Type) (A B: T) + (x: HT_isM M H A B) : M (H A B). +auto. +Qed. -(* three parameter relation *) -Definition wrapper_spec {T} (H: T -> T -> Type) (M HM: Type -> Type) : - Prop := HM T = forall A B, hom_isM_ty M H A B. +Lemma wrap_eq (M: Type -> Type) {T} (H: T -> T -> Type) (A B: T) : + M (H A B) = HT_isM M H A B. + auto. +Qed. + +(* GENERIC WRAPPER *) +Definition wrapper (M: Type -> Type) {T} (H: T -> T -> Type) : + Type := forall A B, HT_isM M H A B. (* one more wrapper definition (no real change) *) HB.mixin Record hom_isMon2 T of Quiver T := - { private : forall A B, hom_isM_ty (fun X => isMon X) - (@hom (Quiver.clone T _)) - A B }. + { private : wrapper (fun X => isMon X) + (@hom (Quiver.clone T _)) }. (* the parametric definition works, though it is problematic *) HB.mixin Record hom_isM2 (M: Type -> Type) T of Quiver T := - { private : forall (A B: T), @hom_isM_ty M T (@hom (Quiver.clone T _)) - A B }. + { private : wrapper M (@hom (Quiver.clone T _)) }. -(* just a copy of hom_isM2 *) +(* just a copy of hom_isM2 *) HB.mixin Record hom_isM3 (M: Type -> Type) T of Quiver T := - { private : forall (A B: T), @hom_isM_ty M T (@hom (Quiver.clone T _)) - A B }. + { private : wrapper M (@hom (Quiver.clone T _)) }. (* structure based on one of the wrappers *) HB.structure Definition Monoid_enriched_quiver := @@ -96,6 +108,13 @@ HB.instance Definition funQ_isMon (A B: Type) : isMon (A -> B) := HB.instance Definition funQ_hom_isMon := hom_isMon2.Build Type (fun A B => funQ_isMon A B). +(* making it work with HB *) +Record Monoid_enriched_quiverN1 := { + ObjN1: Type; + iQ1: isQuiver ObjN1; + hsM1: forall A B, HT_isM (fun X => isMon X) (@hom (HB.pack ObjN1 iQ1)) + A B }. + (* HB.instance Definition _ := Monoid_enriched_quiver.Build ... *) (********************) @@ -107,17 +126,9 @@ Record isQuiverS (Obj: Type) : Type := { homS : Obj -> Obj -> Type }. Structure Monoid_enriched_quiverN := { ObjN: Type; iQ: isQuiverS ObjN; - hsM: forall A B, hom_isM_ty (fun X => isMon X) (homS ObjN iQ) - A B }. - -About hom. + hsM: forall A B, HT_isM (fun X => isMon X) (homS ObjN iQ) + A B }. -(* making it work with HB *) -Record Monoid_enriched_quiverN1 := { - ObjN1: Type; - iQ1: isQuiver ObjN1; - hsM1: forall A B, hom_isM_ty (fun X => isMon X) (@hom (HB.pack ObjN1 iQ1)) - A B }. (*************************************************************) From f8da4355f9362bd14739189ec45a0ea8f51c3632 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 3 Aug 2023 09:45:46 +0200 Subject: [PATCH 60/63] test commit, minor changes --- HB/instance.elpi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index f58fa033a..089ac33c2 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -24,7 +24,7 @@ declare-existing T0 F0 :- std.do! [ pred declare-const i:id, i:term, i:arity, o:list (pair id constant). declare-const Name BodySkel TyWPSkel CSL :- std.do! [ - coq.say "DC************************* NOW RUNNING (entry point) declare-const Name BodySkel TyWPSkel CSL", + coq.say "DC************************ NOW RUNNING (entry point) declare-const Name BodySkel TyWPSkel CSL", coq.say "DC!!!!!!!!!!!!! In Name = " Name, coq.say "DC!!!!!!!!!!!!! In BodySkel = " BodySkel, coq.say "DC!!!!!!!!!!!!! In TyWPSkel = " TyWPSkel, @@ -542,7 +542,7 @@ declare-canonical-instances-from-factory Factory T F CSL :- std.do! [ % Clauses, MCSL and AllSubjects are outputs. currently, AllSubjects = [T] add-all-mixins T Factory ML tt ClausesFromF MCSL AllSubjects, - coq.say "DCIFF!!!!!!!!!! Ex AllSubjects = " AllSubjects, + coq.say "DCIFF!!!!!!!!!!! Ex AllSubjects = " AllSubjects, % old (Clauses not used) % instance.declare-all T {findall-classes-for ML} CCSL, hcumul-forall AllSubjects (s \ From 2338a1f27dfb6cb907e1955a7ed3e5316f1df6a0 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Fri, 4 Aug 2023 18:36:12 +0200 Subject: [PATCH 61/63] adding examples in cmon_enriched_cat.v --- HB/instance.elpi | 2 +- HB/structure.elpi | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/HB/instance.elpi b/HB/instance.elpi index 089ac33c2..73b453cbc 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -783,7 +783,7 @@ redirect-instances RealName Factory TheType TheFactory Body TyWP SectionName Cla coq.say "NOW RUNNING****************************** REDIN " coq.say "REDIN!!!!!!! TheTypeKey = " TheTypeKey, - if (RealName = "hom_isMon__ELIM") % meant to rule out generated instances + if (rex.match ".*__ELIM" RealName) % meant to rule out generated instances (private.dec-inst-and-close Factory TheType TheFactory TyWP SectionName Clauses CSL) (if (TheTypeKey = global TheTypeKeyGR) (std.do! [ diff --git a/HB/structure.elpi b/HB/structure.elpi index e70915d99..4b18fbfbf 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -798,11 +798,12 @@ reexport-wrapper-as-instance M :- std.do! [ coq.env.typeof (const C) Ty, coq.count-prods Ty N0, coq.term->arity Ty N0 Arity, - coq.term->string (global M) Str1, +% coq.term->string (global M) Str1, % need to get a valid idenfier out of a term, no @ or . % std.string.concat "__" [Str1, "ELIM"] Str2, - std.string.concat "__" ["hom_isMon", "ELIM"] Str2, - instance.declare-const Str2 B Arity _ + Str0 is "Op_isMx" ^ "__" ^ {std.any->string {new_int}}, + std.string.concat "__" [Str0, "ELIM"] Str, + instance.declare-const Str B Arity _ ]. }} From 7907b7fe70d789996e58b17e587859b69bd8bcf8 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Wed, 9 Aug 2023 19:04:30 +0200 Subject: [PATCH 62/63] updated cmonoid_enriched_cat.v with new examples; some problems --- tests/cmonoid_enriched_cat.v | 514 +++++++++++++++++++++++++++++++++++ 1 file changed, 514 insertions(+) create mode 100644 tests/cmonoid_enriched_cat.v diff --git a/tests/cmonoid_enriched_cat.v b/tests/cmonoid_enriched_cat.v new file mode 100644 index 000000000..eb8115550 --- /dev/null +++ b/tests/cmonoid_enriched_cat.v @@ -0,0 +1,514 @@ +From HB Require Import structures. +From Coq Require Import ssreflect ssrfun. + +(** Quiver *) + +HB.mixin Record isQuiver Obj := { hom : Obj -> Obj -> Type }. + +HB.structure Definition Quiver := { Obj of isQuiver Obj }. + +(** Ohter base mixins *) + +HB.mixin Record isMon A := { + zero : A; + add : A -> A -> A; + addrA : associative add; + add0r : left_id zero add; + addr0 : right_id zero add; + }. + +HB.mixin Record isIAlg A := { + iadd : A -> A -> A; + iaddI : idempotent iadd; + }. + +HB.mixin Record isCAlg A := { + cadd : A -> A -> A; + caddrC : commutative cadd; + }. + +(** Base structures *) + +HB.structure Definition Monoid := { A of isMon A }. + +HB.structure Definition CAlgebra := { A of isCAlg A }. + +HB.structure Definition IAlgebra := { A of isIAlg A }. + +(** Complex mixins *) + +(*******************************************************************) +(********** Combining mixins ***************************************) + +(***** Vanilla Coq (no HB) *) + +Record isMon0 A := { + zero0 : A; + add0 : A -> A -> A; + addrA0 : associative add0; + add0r0 : left_id zero0 add0; + addr00 : right_id zero0 add0; + }. + +Record isIAlg0 A := { + iadd0 : A -> A -> A; + iaddI0 : idempotent iadd0; + }. + +Record isIMon0 A := { is_mon0 : isMon0 A; + is_ialg0 : isIAlg0 A; + mon_ialg_ch0 : add0 _ is_mon0 = iadd0 _ is_ialg0 ; + }. + + +(***** The analogous of vanilla does not work in HB *) + +Fail HB.mixin Record isIMonM A := { is_mon : isMon A; + is_ialg : isIAlg A; + mon_ialg_ch : add _ is_mon = iadd _ is_ialg ; + }. + +Fail HB.mixin Record isIMonS A := { is_mon : Monoid A; + is_ialg : IAlgebra A; + mon_ialg_ch : add _ is_mon = iadd _ is_ialg ; + }. + +(***** Basic approach (can be cumbersome) *) + +HB.mixin Record isIMonB A := { + zero : A; + add : A -> A -> A; + addrA : associative add; + add0r : left_id zero add; + addr0 : right_id zero add; + addI : idempotent add; +}. + +HB.mixin Record isCMonB A := { + zero : A; + add : A -> A -> A; + addrA : associative add; + add0r : left_id zero add; + addr0 : right_id zero add; + addC : commutative add; +}. + + +(***** Operator mixins *) + +(** single dependent pair parameter *) + +HB.mixin Record isOpMon1 (S: sigT (fun A => A -> A -> A)) := { + zero : projT1 S; + addrA : associative (projT2 S); + add0r : left_id zero (projT2 S); + addr0 : right_id zero (projT2 S); + }. + +HB.structure Definition OpMonoid1 := { C of isOpMon1 C }. + +HB.mixin Record isOpIAlg1 (S: sigT (fun A => A -> A -> A)) := { + addI : idempotent (projT2 S); + }. + +HB.structure Definition OpIAlgebra1 := { C of isOpIAlg1 C }. + +HB.mixin Record isOpIMon1 A of OpMonoid1 A & OpIAlgebra1 A. + + +(** two parameters (subject is Add) *) + +(**) +HB.mixin Record isOpMon2 A (Add: A -> A -> A) (Zero: A) := { + addrA : associative Add; + add0r : left_id Zero Add; + addr0 : right_id Zero Add; + }. + +(* HB.structure Definition OpMon2 A := { Add of isOpMon2 A Add }. *) + +HB.mixin Record isOpMonoid2 A := { add: A -> A -> A; + zero: A; + is_op_mon : isOpMon2 A add zero }. + +HB.structure Definition OpMonoid2 := { A of isOpMonoid2 A }. + +(**) +HB.mixin Record isOpIAlg2 A (Add: A -> A -> A) := { + addI : idempotent Add; + }. + +HB.mixin Record isOpIAlgebra2 A := { add: A -> A -> A; + is_op_ialg : isOpIAlg2 A add }. + +HB.structure Definition OpIAlgebra2 := { A of isOpIAlgebra2 A }. + +(**) +HB.mixin Record isOpCAlg2 A (Add: A -> A -> A) := { + addC : commutative Add; + }. + +HB.mixin Record isOpCAlgebra2 A := { add: A -> A -> A; + is_op_calg : isOpCAlg2 A add }. + +HB.structure Definition OpCAlgebra2 := { A of isOpCAlgebra2 A }. + +(**) +HB.mixin Record isOpIMon2 A (Add: A -> A -> A) (Zero: A) := { + is_op_mon : isOpMon2 A Add Zero ; + is_op_ialg : isOpIAlg2 A Add ; + }. + +HB.mixin Record isOpIMonoid2 A := { add: A -> A -> A; + zero: A; + is_op_imon : isOpIMon2 A add zero }. + +HB.structure Definition OpIMonoid2 := { A of isOpIMonoid2 A }. + +(**) +HB.mixin Record isOpCMon2 A (Add: A -> A -> A) (Zero: A) := { + is_op_mon : isOpMon2 A Add Zero ; + is_op_calg : isOpCAlg2 A Add ; + }. + +HB.mixin Record isOpCMonoid2 A := { add: A -> A -> A; + zero: A; + is_op_imon : isOpCMon2 A add zero }. + +HB.structure Definition OpCMonoid2 := { A of isOpCMonoid2 A }. + +(**) +HB.mixin Record isOpCIAlg2 A (Add: A -> A -> A) := { + is_op_ialg : isOpIAlg2 A Add ; + is_op_calg : isOpCAlg2 A Add ; + }. + +HB.mixin Record isOpCIAlgebra2 A := { add: A -> A -> A; + is_op_icalg : isOpCIAlg2 A add }. + +HB.structure Definition OpCIAlgebra2 := { A of isOpCIAlgebra2 A }. + +(**) +HB.mixin Record isOpICAlg2 A (Add: A -> A -> A) := { + is_op_calg : isOpCAlg2 A Add ; + is_op_ialg : isOpIAlg2 A Add ; + }. + +HB.mixin Record isOpICAlgebra2 A := { add: A -> A -> A; + is_op_calg : isOpICAlg2 A add }. + +HB.structure Definition OpICAlgebra2 := { A of isOpICAlgebra2 A }. + +(**) +HB.mixin Record isOpCIMon2 A (Add: A -> A -> A) (Zero: A) := { + is_op_mon : isOpIMon2 A Add Zero ; + is_op_calg : isOpCAlg2 A Add ; + }. + +HB.mixin Record isOpCIMonoid2 A := { add: A -> A -> A; + zero: A; + is_op_cimon : isOpCIMon2 A add zero }. + +HB.structure Definition OpCIMonoid2 := { A of isOpCIMonoid2 A }. + +(**) +HB.mixin Record isOpICMon2 A (Add: A -> A -> A) (Zero: A) := { + is_op_mon : isOpCMon2 A Add Zero ; + is_op_calg : isOpIAlg2 A Add ; + }. + +HB.mixin Record isOpICMonoid2 A := { add: A -> A -> A; + zero: A; + is_op_cimon : isOpICMon2 A add zero }. + +HB.structure Definition OpICMonoid2 := { A of isOpICMonoid2 A }. + + +(*******************************************************************) + +(** Wrapper mixins *) + +#[wrapper] +HB.mixin Record hom_isMon T of Quiver T := + { hom_isMon_private : forall A B, isOpMonoid2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isIAlg T of Quiver T := + { hom_isIAlg_private : forall A B, isOpIAlgebra2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isCAlg T of Quiver T := + { hom_isCAlg_private : forall A B, isOpCAlgebra2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isIMon T of Quiver T := + { hom_isIMon_private : forall A B, isOpIMonoid2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isCMon T of Quiver T := + { hom_isCMon_private : forall A B, isOpCMonoid2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isCIAlg T of Quiver T := + { hom_isCIAlg_private : forall A B, isOpCIAlgebra2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isICAlg T of Quiver T := + { hom_isICAlg_private : forall A B, isOpICAlgebra2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isCIMon T of Quiver T := + { hom_isCIMon_private : forall A B, isOpCIMonoid2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isICMon T of Quiver T := + { hom_isICMon_private : forall A B, isOpICMonoid2 (@hom T A B) }. + + +(** Base enriched structures *) + +HB.structure + Definition Monoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon Obj }. + +HB.structure + Definition IAlgebra_enriched_quiver := + { Obj of isQuiver Obj & hom_isIAlg Obj }. + +HB.structure + Definition CAlgebra_enriched_quiver := + { Obj of isQuiver Obj & hom_isCAlg Obj }. + +(** Complex enriched structures *) + +HB.structure + Definition IMonoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon Obj & hom_isIAlg Obj}. + +HB.structure + Definition CIAlgebra_enriched_quiver := + { Obj of isQuiver Obj & hom_isIAlg Obj & hom_isCAlg Obj}. + +HB.structure + Definition CIMonoid_enriched_quiver := + { Obj of isQuiver Obj & hom_isMon Obj & hom_isIAlg Obj & hom_isCAlg Obj}. + +(********* INSTANCES *****************************) + +Require Import FunctionalExtensionality. + +(** SAMPLE INSTANCE 1 *) + +HB.instance Definition funQ := isQuiver.Build Type + (fun A B => A -> option B). + +Definition funQ_comp {A B: Type} (f g: hom A B) : hom A B := + fun x => + match f x with + | Some _ => f x + | _ => g x end. + +Program Definition funQ_isMon (A B: Type) : + isOpMon2 (hom A B) funQ_comp (fun (_:A) => None) := + isOpMon2.Build _ _ (fun (_:A) => None) _ _ _. +Obligation 1. +unfold associative; intros. +eapply functional_extensionality; intro a. +unfold funQ_comp. +destruct (x a) eqn:K1. +simpl; auto. +destruct (y a); auto. +Qed. +Obligation 2. +unfold left_id; intros. +unfold funQ_comp; auto. +Qed. +Obligation 3. +unfold right_id; intros. +eapply functional_extensionality; intro a. +unfold funQ_comp. +destruct (x a); auto. +Qed. + +Program Definition funQ_isIAlg (A B: Type) : + isOpIAlg2 (hom A B) funQ_comp := + isOpIAlg2.Build _ _ _. +Obligation 1. +unfold idempotent; intros. +eapply functional_extensionality; intro a. +unfold funQ_comp. +destruct (x a); auto. +Qed. + +Program Definition funQ_isIMon (A B: Type) : + isOpIMon2 (hom A B) funQ_comp (fun (_:A) => None) := + isOpIMon2.Build (hom A B) _ _ _ _. +Obligation 1. +eapply funQ_isMon. +Qed. +Obligation 2. +eapply funQ_isIAlg. +Qed. + +HB.instance Definition funQ_isMonoid (A B: Type) : + isOpMonoid2 (hom A B) := + isOpMonoid2.Build (hom A B) funQ_comp (fun (_:A) => None) (funQ_isMon A B). + +HB.instance Definition funQ_isIAlgebra (A B: Type) : + isOpIAlgebra2 (hom A B) := + isOpIAlgebra2.Build (hom A B) funQ_comp (funQ_isIAlg A B). + +HB.instance Definition funQ_isIMonoid (A B: Type) : + isOpIMonoid2 (hom A B) := + isOpIMonoid2.Build (hom A B) funQ_comp (fun (_:A) => None) + (funQ_isIMon A B). + +Elpi Print HB.structure. + + +(** SAMPLE INSTANCE 2 *) + +Lemma zero_unique {B} (X: B -> B -> B) (zz0 zz1:B) : + left_id zz0 X -> right_id zz0 X -> left_id zz1 X -> right_id zz1 X -> + zz0 = zz1. + unfold left_id, right_id. + intros. + specialize (H0 zz1). + specialize (H1 zz0). + rewrite H1 in H0. + auto. +Qed. + +Open Scope type. + +HB.instance Definition cmfunQ := + isQuiver.Build (sigT (fun A => (A -> A -> A) * A)) + (fun X Y => isOpCMon2 (projT1 X) (fst (projT2 X)) (snd (projT2 X)) -> + isOpCMon2 (projT1 Y) (fst (projT2 Y)) (snd (projT2 Y)) -> + (projT1 X) -> (projT1 Y)). + +Definition cmfunQ_comp {A B: sigT (fun A => (A -> A -> A) * A)} + (f g: @hom _ A B) : hom A B := + fun (ca: isOpCMon2 (projT1 A) (fst (projT2 A)) (snd (projT2 A))) + (cb: isOpCMon2 (projT1 B) (fst (projT2 B)) (snd (projT2 B))) a => + match (f ca cb a, g ca cb a) with + | (b1, b2) => (fst (projT2 B)) b1 b2 end. + +Program Definition cmfunQ_zero {A B: sigT (fun A => (A -> A -> A) * A)} : + hom A B. +Proof. + unfold hom; intros. + unfold isQuiver.hom. + unfold Quiver.cmonoid_enriched_cat_isQuiver_mixin. + unfold Quiver.class. + simpl; intros. + destruct B as [X [f x1]]; simpl. + exact x1. +Defined. + +Program Definition cmfunQ_isCMon (A B: sigT (fun A => (A -> A -> A) * A)) : + isOpCMon2 (hom A B) cmfunQ_comp cmfunQ_zero := + isOpCMon2.Build (hom A B) cmfunQ_comp _ _ _. +Obligation 1. +unfold cmfunQ_comp; simpl. +econstructor. +{- unfold associative; intros. + eapply functional_extensionality; intro CMa. + eapply functional_extensionality; intro CMb. + eapply functional_extensionality; intro v. + remember CMb as CMb1. + destruct CMb. + destruct is_op_mon0. + unfold associative in addrA1. + simpl in addrA1. + eapply addrA1. +} +{- unfold left_id; intros. + eapply functional_extensionality; intro CMa. + eapply functional_extensionality; intro CMb. + eapply functional_extensionality; intro v. + remember CMb as CMb1. + destruct CMb. + destruct is_op_mon0. + unfold left_id in add0r1. + simpl in add0r1. + unfold cmfunQ_zero. + eapply add0r1. +} +{- unfold right_id; intros. + eapply functional_extensionality; intro CMa. + eapply functional_extensionality; intro CMb. + eapply functional_extensionality; intro v. + remember CMb as CMb1. + destruct CMb. + destruct is_op_mon0. + unfold right_id in addr1. + simpl in addr1. + unfold cmfunQ_zero. + eapply addr1. +} +Qed. +Obligation 2. + econstructor. + unfold cmfunQ_comp. + unfold commutative; simpl; intros. + eapply functional_extensionality; intro CMa. + eapply functional_extensionality; intro CMb. + eapply functional_extensionality; intro v. + remember CMb as CMb1. + destruct CMb. + destruct is_op_calg0. + simpl in addC. + eapply addC. +Qed. + +HB.instance Definition cmfunQ_isMonoid + (A B: sigT (fun A => (A -> A -> A) * A)) : + isOpCMonoid2 (hom A B) := + isOpCMonoid2.Build (hom A B) cmfunQ_comp cmfunQ_zero (cmfunQ_isCMon A B). + +Elpi Print HB.structure. + + + +(** SAMPLE INSTANCE 3 *) + +HB.instance Definition cimfunQ := + isQuiver.Build (sigT (fun A => A -> A -> A)) + (fun X Y => isOpCIAlg2 (projT1 X) (projT2 X) -> + isOpCIAlg2 (projT1 Y) (projT2 Y) -> + (projT1 X) -> option (projT1 Y)). + +Definition cimfunQ_comp {A B: sigT (fun A => A -> A -> A)} + (f g: hom A B) : hom A B := + fun (ca: isOpCIAlg2 (projT1 A) (projT2 A)) + (cb: isOpCIAlg2 (projT1 B) (projT2 B)) a => + match (f ca cb a, g ca cb a) with + | (Some b1, Some b2) => Some (projT2 B b1 b2) + | (Some b, None) => Some b + | (None, Some b) => Some b + | _ => None end. + +Definition cimfunQ_zero {A B: sigT (fun A => A -> A -> A)} : hom A B := + fun _ _ _ => None. + +(* +Program Definition funQ_isCIMon (A B: sigT (fun A => A -> A -> A)) : + isOpCIMon2 (hom A B) cimfunQ_comp cimfunQ_zero := + isOpCIMon2.Build _ _ cimfunQ_zero _ _. +Obligation 1. +econstructor. +econstructor. +unfold associative; intros. +eapply functional_extensionality; intro ca. +eapply functional_extensionality; intro cb. +eapply functional_extensionality; intro v. +unfold cimfunQ_comp. +destruct (x ca cb v) eqn:K1. +simpl; auto. +destruct (y ca cb v); auto. +destruct (z ca cb v); auto. +destruct cb. +Qed. +*) + From ce88b3d3e899c312016e2482aa23fc76bb5c4629 Mon Sep 17 00:00:00 2001 From: ptorrx Date: Thu, 10 Aug 2023 14:28:39 +0200 Subject: [PATCH 63/63] updated cmon_enriched_cat.v - now the file contains three examples; compilation glitch (it will compile only the first two of them, regardless of which you put first; so all the examples compile, but not together) --- tests/cmonoid_enriched_cat.v | 218 +++++++++++++++++++++++++++-------- 1 file changed, 169 insertions(+), 49 deletions(-) diff --git a/tests/cmonoid_enriched_cat.v b/tests/cmonoid_enriched_cat.v index eb8115550..79b9c4247 100644 --- a/tests/cmonoid_enriched_cat.v +++ b/tests/cmonoid_enriched_cat.v @@ -96,7 +96,7 @@ HB.mixin Record isCMonB A := { (***** Operator mixins *) -(** single dependent pair parameter *) +(**** single dependent pair parameter *) HB.mixin Record isOpMon1 (S: sigT (fun A => A -> A -> A)) := { zero : projT1 S; @@ -116,16 +116,35 @@ HB.structure Definition OpIAlgebra1 := { C of isOpIAlg1 C }. HB.mixin Record isOpIMon1 A of OpMonoid1 A & OpIAlgebra1 A. -(** two parameters (subject is Add) *) +(**** two parameters (subject is Add) *) (**) -HB.mixin Record isOpMon2 A (Add: A -> A -> A) (Zero: A) := { - addrA : associative Add; +HB.mixin Record isOpAAlg2 A (Add: A -> A -> A) := { + addA : associative Add; + }. + +HB.mixin Record isOpAAlgebra2 A := { add: A -> A -> A; + is_op_aalg : isOpAAlg2 A add }. + +HB.structure Definition OpAAlgebra2 := { A of isOpAAlgebra2 A }. + +(**) +HB.mixin Record isOpZAlg2 A (Add: A -> A -> A) (Zero: A) := { add0r : left_id Zero Add; addr0 : right_id Zero Add; }. -(* HB.structure Definition OpMon2 A := { Add of isOpMon2 A Add }. *) +HB.mixin Record isOpZAlgebra2 A := { add: A -> A -> A; + zero: A; + is_op_zalg : isOpZAlg2 A add zero }. + +HB.structure Definition OpZAlgebra2 := { A of isOpZAlgebra2 A }. + +(**) +HB.mixin Record isOpMon2 A (Add: A -> A -> A) (Zero: A) := { + is_op_zalg : isOpZAlg2 A Add Zero ; + is_op_aalg : isOpAAlg2 A Add ; + }. HB.mixin Record isOpMonoid2 A := { add: A -> A -> A; zero: A; @@ -184,7 +203,7 @@ HB.mixin Record isOpCIAlg2 A (Add: A -> A -> A) := { }. HB.mixin Record isOpCIAlgebra2 A := { add: A -> A -> A; - is_op_icalg : isOpCIAlg2 A add }. + is_op_cialg : isOpCIAlg2 A add }. HB.structure Definition OpCIAlgebra2 := { A of isOpCIAlgebra2 A }. @@ -199,6 +218,18 @@ HB.mixin Record isOpICAlgebra2 A := { add: A -> A -> A; HB.structure Definition OpICAlgebra2 := { A of isOpICAlgebra2 A }. +(**) +HB.mixin Record isOpACIAlg2 A (Add: A -> A -> A) := { + is_op_ialg : isOpIAlg2 A Add ; + is_op_calg : isOpCAlg2 A Add ; + is_op_aalg : isOpAAlg2 A Add ; + }. + +HB.mixin Record isOpACIAlgebra2 A := { add: A -> A -> A; + is_op_acialg : isOpACIAlg2 A add }. + +HB.structure Definition OpACIAlgebra2 := { A of isOpACIAlgebra2 A }. + (**) HB.mixin Record isOpCIMon2 A (Add: A -> A -> A) (Zero: A) := { is_op_mon : isOpIMon2 A Add Zero ; @@ -228,6 +259,14 @@ HB.structure Definition OpICMonoid2 := { A of isOpICMonoid2 A }. (** Wrapper mixins *) +#[wrapper] +HB.mixin Record hom_isAAlg T of Quiver T := + { hom_isAAlg_private : forall A B, isOpAAlgebra2 (@hom T A B) }. + +#[wrapper] +HB.mixin Record hom_isZAlg T of Quiver T := + { hom_isZAlg_private : forall A B, isOpZAlgebra2 (@hom T A B) }. + #[wrapper] HB.mixin Record hom_isMon T of Quiver T := { hom_isMon_private : forall A B, isOpMonoid2 (@hom T A B) }. @@ -256,6 +295,10 @@ HB.mixin Record hom_isCIAlg T of Quiver T := HB.mixin Record hom_isICAlg T of Quiver T := { hom_isICAlg_private : forall A B, isOpICAlgebra2 (@hom T A B) }. +#[wrapper] +HB.mixin Record hom_isACIAlg T of Quiver T := + { hom_isACIAlg_private : forall A B, isOpACIAlgebra2 (@hom T A B) }. + #[wrapper] HB.mixin Record hom_isCIMon T of Quiver T := { hom_isCIMon_private : forall A B, isOpCIMonoid2 (@hom T A B) }. @@ -289,10 +332,15 @@ HB.structure Definition CIAlgebra_enriched_quiver := { Obj of isQuiver Obj & hom_isIAlg Obj & hom_isCAlg Obj}. +HB.structure + Definition ACIAlgebra_enriched_quiver := + { Obj of isQuiver Obj & hom_isIAlg Obj & hom_isCAlg Obj & hom_isAAlg Obj}. + HB.structure Definition CIMonoid_enriched_quiver := { Obj of isQuiver Obj & hom_isMon Obj & hom_isIAlg Obj & hom_isCAlg Obj}. + (********* INSTANCES *****************************) Require Import FunctionalExtensionality. @@ -310,24 +358,27 @@ Definition funQ_comp {A B: Type} (f g: hom A B) : hom A B := Program Definition funQ_isMon (A B: Type) : isOpMon2 (hom A B) funQ_comp (fun (_:A) => None) := - isOpMon2.Build _ _ (fun (_:A) => None) _ _ _. + isOpMon2.Build _ _ (fun (_:A) => None) _ _. Obligation 1. -unfold associative; intros. -eapply functional_extensionality; intro a. -unfold funQ_comp. -destruct (x a) eqn:K1. -simpl; auto. -destruct (y a); auto. +econstructor. +{- unfold left_id; intros. + unfold funQ_comp; auto. +} +{- unfold right_id; intros. + eapply functional_extensionality; intro a. + unfold funQ_comp. + destruct (x a); auto. +} Qed. Obligation 2. -unfold left_id; intros. -unfold funQ_comp; auto. -Qed. -Obligation 3. -unfold right_id; intros. -eapply functional_extensionality; intro a. -unfold funQ_comp. -destruct (x a); auto. +econstructor. +{- unfold associative; intros. + eapply functional_extensionality; intro a. + unfold funQ_comp. + destruct (x a) eqn:K1. + simpl; auto. + destruct (y a); auto. +} Qed. Program Definition funQ_isIAlg (A B: Type) : @@ -399,7 +450,7 @@ Program Definition cmfunQ_zero {A B: sigT (fun A => (A -> A -> A) * A)} : Proof. unfold hom; intros. unfold isQuiver.hom. - unfold Quiver.cmonoid_enriched_cat_isQuiver_mixin. + unfold Quiver.cmonoid_enriched_cat4_isQuiver_mixin. unfold Quiver.class. simpl; intros. destruct B as [X [f x1]]; simpl. @@ -412,17 +463,7 @@ Program Definition cmfunQ_isCMon (A B: sigT (fun A => (A -> A -> A) * A)) : Obligation 1. unfold cmfunQ_comp; simpl. econstructor. -{- unfold associative; intros. - eapply functional_extensionality; intro CMa. - eapply functional_extensionality; intro CMb. - eapply functional_extensionality; intro v. - remember CMb as CMb1. - destruct CMb. - destruct is_op_mon0. - unfold associative in addrA1. - simpl in addrA1. - eapply addrA1. -} +econstructor. {- unfold left_id; intros. eapply functional_extensionality; intro CMa. eapply functional_extensionality; intro CMb. @@ -430,6 +471,7 @@ econstructor. remember CMb as CMb1. destruct CMb. destruct is_op_mon0. + destruct is_op_zalg0. unfold left_id in add0r1. simpl in add0r1. unfold cmfunQ_zero. @@ -442,11 +484,25 @@ econstructor. remember CMb as CMb1. destruct CMb. destruct is_op_mon0. + destruct is_op_zalg0. unfold right_id in addr1. simpl in addr1. unfold cmfunQ_zero. eapply addr1. } +econstructor. +{- unfold associative; intros. + eapply functional_extensionality; intro CMa. + eapply functional_extensionality; intro CMb. + eapply functional_extensionality; intro v. + remember CMb as CMb1. + destruct CMb. + destruct is_op_mon0. + destruct is_op_aalg0. + unfold associative in addA. + simpl in addA. + eapply addA. +} Qed. Obligation 2. econstructor. @@ -462,7 +518,7 @@ Obligation 2. eapply addC. Qed. -HB.instance Definition cmfunQ_isMonoid +HB.instance Definition cmfunQ_isCMonoid (A B: sigT (fun A => (A -> A -> A) * A)) : isOpCMonoid2 (hom A B) := isOpCMonoid2.Build (hom A B) cmfunQ_comp cmfunQ_zero (cmfunQ_isCMon A B). @@ -470,19 +526,18 @@ HB.instance Definition cmfunQ_isMonoid Elpi Print HB.structure. - (** SAMPLE INSTANCE 3 *) HB.instance Definition cimfunQ := isQuiver.Build (sigT (fun A => A -> A -> A)) - (fun X Y => isOpCIAlg2 (projT1 X) (projT2 X) -> - isOpCIAlg2 (projT1 Y) (projT2 Y) -> + (fun X Y => isOpACIAlg2 (projT1 X) (projT2 X) -> + isOpACIAlg2 (projT1 Y) (projT2 Y) -> (projT1 X) -> option (projT1 Y)). Definition cimfunQ_comp {A B: sigT (fun A => A -> A -> A)} (f g: hom A B) : hom A B := - fun (ca: isOpCIAlg2 (projT1 A) (projT2 A)) - (cb: isOpCIAlg2 (projT1 B) (projT2 B)) a => + fun (ca: isOpACIAlg2 (projT1 A) (projT2 A)) + (cb: isOpACIAlg2 (projT1 B) (projT2 B)) a => match (f ca cb a, g ca cb a) with | (Some b1, Some b2) => Some (projT2 B b1 b2) | (Some b, None) => Some b @@ -492,23 +547,88 @@ Definition cimfunQ_comp {A B: sigT (fun A => A -> A -> A)} Definition cimfunQ_zero {A B: sigT (fun A => A -> A -> A)} : hom A B := fun _ _ _ => None. -(* -Program Definition funQ_isCIMon (A B: sigT (fun A => A -> A -> A)) : +Program Definition cimfunQ_isCIMon (A B: sigT (fun A => A -> A -> A)) : isOpCIMon2 (hom A B) cimfunQ_comp cimfunQ_zero := isOpCIMon2.Build _ _ cimfunQ_zero _ _. Obligation 1. econstructor. econstructor. -unfold associative; intros. +econstructor. +{- unfold left_id; intros. + unfold cimfunQ_comp; simpl. + eapply functional_extensionality; intro ca. + eapply functional_extensionality; intro cb. + eapply functional_extensionality; intro v. + destruct (x ca cb v); auto. +} +{- unfold right_id; intros. + unfold cimfunQ_comp; simpl. + eapply functional_extensionality; intro ca. + eapply functional_extensionality; intro cb. + eapply functional_extensionality; intro v. + destruct (x ca cb v); auto. +} +econstructor. +{- unfold associative; intros. + unfold cimfunQ_comp; simpl. + eapply functional_extensionality; intro ca. + eapply functional_extensionality; intro cb. + eapply functional_extensionality; intro v. + remember cb as cb1. + destruct cb. + destruct is_op_aalg0. + simpl in addA. + unfold associative in addA. + destruct (x ca cb1 v); simpl; eauto. + {+ destruct (y ca cb1 v); simpl; eauto. + destruct (z ca cb1 v); simpl; eauto. + rewrite addA; auto. + destruct (z ca cb1 v); simpl; eauto. + } + {+ destruct (y ca cb1 v); simpl; eauto. + destruct (z ca cb1 v); simpl; eauto. + destruct (z ca cb1 v); simpl; eauto. + } +} +econstructor. +{- unfold idempotent; intros. + unfold cimfunQ_comp; simpl. + eapply functional_extensionality; intro ca. + eapply functional_extensionality; intro cb. + eapply functional_extensionality; intro v. + remember cb as cb1. + destruct cb. + destruct is_op_ialg0. + unfold idempotent in addI0. + simpl in addI0. + destruct (x ca cb1 v) eqn:K1. + rewrite addI0; auto. + auto. +} +Qed. +Obligation 2. +econstructor. +unfold commutative; intros. +unfold cimfunQ_comp; simpl. eapply functional_extensionality; intro ca. eapply functional_extensionality; intro cb. eapply functional_extensionality; intro v. -unfold cimfunQ_comp. -destruct (x ca cb v) eqn:K1. -simpl; auto. -destruct (y ca cb v); auto. -destruct (z ca cb v); auto. -destruct cb. +remember cb as cb1. +destruct cb. +destruct is_op_calg0. +unfold commutative in addC. +simpl in addC. +destruct (x ca cb1 v); simpl; eauto. +destruct (y ca cb1 v); simpl; eauto. +rewrite addC; auto. Qed. -*) + +HB.instance Definition cimfunQ_isCIMonoid + (A B: sigT (fun A => A -> A -> A)) : + isOpCIMonoid2 (hom A B) := + isOpCIMonoid2.Build (hom A B) cimfunQ_comp cimfunQ_zero + (cimfunQ_isCIMon A B). + +Elpi Print HB.structure. +