diff --git a/HB/about.elpi b/HB/about.elpi index 0c2c2806..bab0f8f1 100644 --- a/HB/about.elpi +++ b/HB/about.elpi @@ -72,6 +72,11 @@ bulletize L F (glue [brk 0 0 | PLB]) :- % Print shortest qualified identifier of the module containing a gref pred pp-module i:gref, o:coq.pp. +pp-module GR (str ID) :- wrapper-mixin GR Op WrappedMixin, !, + gref->modname_short WrappedMixin "." ID_W, + coq.gref->id Op ID_Op, + gref->modname_short GR "." ID_GR, + ID is ID_W ^ " " ^ ID_Op ^ " (* wrapped via " ^ ID_GR ^ " *)". pp-module GR (str ID) :- gref->modname_short GR "." ID. pred unif-hint? i:cs-instance. diff --git a/HB/builders.elpi b/HB/builders.elpi index 4c4ea543..0ad19350 100644 --- a/HB/builders.elpi +++ b/HB/builders.elpi @@ -28,7 +28,7 @@ begin CtxSkel :- std.do! [ } -% "end" is a keyword, be put it in the namespace by hand +% "end" is a keyword, we put it in the namespace by hand pred builders.end. builders.end :- std.do! [ current-mode (builder-from _ _ _ ModName), diff --git a/HB/common/database.elpi b/HB/common/database.elpi index 425a8b52..41fd251d 100644 --- a/HB/common/database.elpi +++ b/HB/common/database.elpi @@ -51,10 +51,10 @@ pred module-to-export_module-nice i:prop, o:id. module-to-export_module-nice (module-to-export _ M _) M. pred instance-to-export_instance i:prop, o:constant. -instance-to-export_instance (instance-to-export _ _ M) M. +instance-to-export_instance (instance-to-export _ M) M. pred instance-to-export_instance-nice i:prop, o:id. -instance-to-export_instance-nice (instance-to-export _ M _) M. +instance-to-export_instance-nice (instance-to-export _ M) ID :- coq.gref->id (const M) ID. pred abbrev-to-export_name i:prop, o:id. abbrev-to-export_name (abbrev-to-export _ N _) N. @@ -181,6 +181,8 @@ toposort-proj.acc Proj ES Acc [A|In] Out :- std.do![ topo-find B A => toposort-proj.acc Proj ES [B|Acc] In Out ]. +% TODO: check if topo-find-all is really needed + % Classes can be topologically sorted according to the subclass relation pred toposort-classes.mk-class-edge i:prop, o:pair classname classname. toposort-classes.mk-class-edge (sub-class C1 C2 _ _) (pr C2 C1). @@ -435,12 +437,15 @@ structure-nparams Structure NParams :- factory-nparams Class NParams. pred factory? i:term, o:w-args factoryname. -factory? S (triple F Params T) :- +factory? S (triple F Params T) :- factory?-split S F [_|Params] T _. + +pred factory?-split i:term, o:factoryname, o:list term, o:term, o:list term. +factory?-split S F [global GR|Params] T Rest :- not (var S), !, safe-dest-app S (global GR) Args, factory-alias->gref GR F ok, factory-nparams F NP, !, - std.split-at NP Args Params [T|_]. + std.split-at NP Args Params [T|Rest]. % [find-max-classes Mixins Classes] states that Classes is a list of classes % which contain all the mixins in Mixins. @@ -460,3 +465,8 @@ find-max-classes [M|Mixins] [C|Classes] :- ]. find-max-classes [M|_] _ :- coq.error "HB: cannot find a class containing mixin" M. +pred is-subject-lifter i:term, o:int, o:classname. +is-subject-lifter (global (const C)) N Class :- exported-op M _ C, wrapper-mixin _ (const C) _, factory-nparams M N, mixin-first-class M Class. +is-subject-lifter (app[global (const C)|_]) N Class :- exported-op M _ C, wrapper-mixin _ (const C) _, factory-nparams M N, mixin-first-class M Class. +is-subject-lifter (global GR) N Class :- tag GR Class N, wrapper-mixin _ GR _. +is-subject-lifter (app[global GR|_]) N Class :- tag GR Class N, wrapper-mixin _ GR _. diff --git a/HB/common/synthesis.elpi b/HB/common/synthesis.elpi index 6444e23c..033a6755 100644 --- a/HB/common/synthesis.elpi +++ b/HB/common/synthesis.elpi @@ -74,6 +74,13 @@ infer-all-args-let Ps T GR X Diag :- std.do! [ private.instantiate-all-args-let FT T X Diag, ]. +pred try-infer-all-args-let i:list term, i:term, i:gref, o:term. +try-infer-all-args-let Ps T GR X :- std.do! [ + coq.env.typeof GR Ty, + coq.mk-eta (-1) Ty (global GR) EtaF, + coq.subst-fun {std.append Ps [T]} EtaF FT, + private.try-instantiate-all-args-let FT T X, +]. % [assert!-infer-mixin TheType M Out] infers one mixin M on TheType and % aborts with an error message if the mixin cannot be inferred @@ -112,6 +119,17 @@ under-mixin-src-from-factory.do! TheType TheFactory LP :- std.do! [ MLClauses => std.do! LP ]. + +% Given TheType makes the provided list of mixins and instances +% available for inference. +pred under-these-mixin-src.do! i:term, i:list mixinname, i:list constant, o:list prop, i:list prop. +under-these-mixin-src.do! TheType ML TheMixins ClausesHas LP :- std.do! [ + std.map2 ML TheMixins (m\mi\c\ c = mixin-src TheType m (global (const mi))) MLClauses, + std.map-filter MLClauses mixin-src->has-mixin-instance ClausesHas, + MLClauses => std.do! LP +]. + + % Given TheType and a factory instance (on it), builds all the *new* mixins % provided by the factory available for and passes them to the given % continuation @@ -163,6 +181,7 @@ infer-coercion-tgt (w-params.cons ID Ty F) CoeClass :- @pi-parameter ID Ty x\ infer-coercion-tgt (F x) CoeClass. infer-coercion-tgt (w-params.nil _ {{ Type }} _) sortclass. infer-coercion-tgt (w-params.nil _ {{ forall x, _ }} _) funclass. % do not use {{ _ -> _ }} since Funclass can be a dependent function! +infer-coercion-tgt (w-params.nil _ T _) (grefclass _) :- name T, coq.error "The type of the structure carrier cannot be a parameter". infer-coercion-tgt (w-params.nil _ T _) (grefclass GR) :- coq.term->gref T GR. pred w-args.check-key i:list term, i:term, i:list (w-args A), o:prop. @@ -251,6 +270,7 @@ instantiate-all-these-mixin-args (fun _ Tm F) T ML R :- coq.safe-dest-app Tm (global TmGR) _, factory-alias->gref TmGR M ok, std.mem! ML M, + factory? Tm (triple _ _ Subj), Subj = T, % check the subject is T (do not pass T to factory?) !, if (mixin-for T M X) true (coq.error "HB: Unable to find mixin" {nice-gref->string M} "on subject" {coq.term->string T}), !, instantiate-all-these-mixin-args (F X) T ML R. @@ -270,6 +290,16 @@ instantiate-all-args-let (fun N Tm F) T (let N Tm X R) Diag :- !, std.do! [ ]. instantiate-all-args-let F _ F ok. +pred try-instantiate-all-args-let i:term, i:term, o:term. +try-instantiate-all-args-let (fun N Tm F) T (let N Tm X R) :- !, std.do! [ + coq.safe-dest-app Tm (global TmGR) _, + factory-alias->gref TmGR M ok, + (mixin-for T M X ; true), + (@pi-def N Tm X m\ try-instantiate-all-args-let (F m) T (R m)), +]. +try-instantiate-all-args-let F _ F. + + % [structure-instance->mixin-srcs TheType Structure] finds a CS instance for % Structure on TheType (if any) and builds mixin-src clauses for all the mixins % which can be candidates from that class instance. It finds instances which are diff --git a/HB/common/utils-synterp.elpi b/HB/common/utils-synterp.elpi index 73932c1a..6a6dccef 100644 --- a/HB/common/utils-synterp.elpi +++ b/HB/common/utils-synterp.elpi @@ -24,7 +24,9 @@ with-attributes P :- att "primitive" bool, att "non_forgetful_inheritance" bool, att "hnf" bool, - ] Opts, !, + att "wrapper" bool, + att "unsafe.univ" bool, + ] Opts, !, Opts => (save-docstring, P). pred if-verbose i:prop. diff --git a/HB/common/utils.elpi b/HB/common/utils.elpi index ae4216b6..5b6e6d0a 100644 --- a/HB/common/utils.elpi +++ b/HB/common/utils.elpi @@ -76,7 +76,7 @@ gref->modname GR NComp Sep ModName :- std.length Path Len, if (Len >= NComp) true (coq.error "Not enough enclosing modules for" {coq.gref->string GR}), std.take NComp Mods L, - std.string.concat Sep {std.rev L} ModName. + std.string.concat Sep {std.rev L} ModName. % TODO: check if the new_int is needed pred gref->modname-label i:gref, i:int, i:string, o:string. gref->modname-label GR NComp Sep ModName :- coq.gref->path GR Path, @@ -87,6 +87,7 @@ gref->modname-label GR NComp Sep ModName :- std.string.concat Sep {std.rev [{coq.gref->id GR}|L]} ModName. pred string->modpath i:string, o:modpath. +string->modpath "" _ :- !, fail. % bug is coq.locate-all if the string is empty string->modpath S MP :- std.filter {coq.locate-all S} (l\l = loc-modpath _) L, L = [loc-modpath MP]. @@ -96,7 +97,8 @@ gref->modname_short1 _ S [] S. gref->modname_short1 MP "" [X|L] L' :- gref->modname_short1 MP X L L'. gref->modname_short1 MP S _ S :- string->modpath S MP. gref->modname_short1 MP S [X|L] S' :- - gref->modname_short1 MP {std.string.concat "." [X,S]} L S'. + if (S = "") (P = X) (P is X ^ "." ^ S), + gref->modname_short1 MP P L S'. % Print shortest qualified identifier of the module containing a gref % Sep is used as separator @@ -105,7 +107,9 @@ gref->modname_short GR Sep IDS :- coq.gref->path GR Path, string->modpath {std.string.concat "." Path} MP, gref->modname_short1 MP "" {std.rev Path} ID, - rex.replace "[.]" Sep ID IDS. + rex.replace "[.]" Sep ID IDS, !. +gref->modname_short GR _ IDS :- coq.gref->id GR IDS. + pred avoid-name-collision i:string, o:string. avoid-name-collision S S1 :- @@ -294,7 +298,7 @@ pack? (indc K) C :- coq.env.indc K _ _ _ KTy, prod-last-gref KTy (indt I), % TODO: use new API class-def (class C (indt I) _). -pred distribute-w-params i:list-w-params A, o:list (one-w-params A). +pred distribute-w-params i:w-params (list A), o:list (w-params A). distribute-w-params (w-params.cons N T F) L :- pi x\ distribute-w-params (F x) (L1 x), std.map (L1 x) (bind-cons N T x) L. distribute-w-params (w-params.nil N T F) L :- @@ -316,6 +320,18 @@ re-enable-id-phant T T1 :- (pi f1 f2 t v\ copy {{lib:@hb.ignore_disabled lp:t lp:f1 lp:v lp:f2}} {{lib:@hb.ignore lp:t lp:v}} :- !) => copy T T1. +pred disable-id-phant-indt-decl i:indt-decl, o:indt-decl. +disable-id-phant-indt-decl D D1 :- + (pi fresh fresh1 t v\ copy {{lib:@hb.id lp:t lp:v}} {{lib:@hb.id_disabled lp:t lp:fresh lp:v lp:fresh1}} :- !) => + (pi fresh fresh1 t v\ copy {{lib:@hb.ignore lp:t lp:v}} {{lib:@hb.ignore_disabled lp:t lp:fresh lp:v lp:fresh1}} :- !) => + copy-indt-decl D D1. + +pred re-enable-id-phant-indt-decl i:indt-decl, o:indt-decl. +re-enable-id-phant-indt-decl D D1 :- + (pi f1 f2 t v\ copy {{lib:@hb.id_disabled lp:t lp:f1 lp:v lp:f2}} {{lib:@hb.id lp:t lp:v}} :- !) => + (pi f1 f2 t v\ copy {{lib:@hb.ignore_disabled lp:t lp:f1 lp:v lp:f2}} {{lib:@hb.ignore lp:t lp:v}} :- !) => + copy-indt-decl D D1. + pred prod-last i:term, o:term. prod-last (prod N S X) Y :- !, @pi-decl N S x\ prod-last (X x) Y. prod-last X X :- !. @@ -325,8 +341,19 @@ prod-last-gref (prod N S X) GR :- !, @pi-decl N S x\ prod-last-gref (X x) GR. prod-last-gref X GR :- coq.term->gref X GR. % saturate a type constructor with holes -pred saturate-type-constructor i:term, o:term . -saturate-type-constructor T ET :- +pred saturate-type-constructor i:int, i:term, o:term . +saturate-type-constructor 0 T ET :- !, coq.typecheck T TH ok, coq.count-prods TH N, coq.mk-app T {coq.mk-n-holes N} ET. +saturate-type-constructor N T ET :- + coq.mk-app T {coq.mk-n-holes N} ET. + + +pred with-unsafe-univ i:prop. +with-unsafe-univ P :- get-option "unsafe.univ" tt, !, + coq.option.get ["Universe","Checking"] Old, + coq.option.set ["Universe","Checking"] (coq.option.bool ff), + P, + coq.option.set ["Universe","Checking"] Old. +with-unsafe-univ P :- P. diff --git a/HB/context.elpi b/HB/context.elpi index 4b04e5f0..e9f7dd47 100644 --- a/HB/context.elpi +++ b/HB/context.elpi @@ -57,6 +57,40 @@ namespace private { % to the corresponding mixin using mixin-for pred postulate-mixin i:term, i:w-args mixinname, i:triple (list constant) (list prop) (list (w-args mixinname)), o:triple (list constant) (list prop) (list (w-args mixinname)). + +postulate-mixin TheType (triple M Ps T) (triple CL MSL MLwP) (triple OutCL [MC|MSL] [NewMwP|MLwP]) :- wrapper-mixin M _ _, !, MSL => std.do! [ + NameVar is "local_mixin_private_" ^ {gref->modname M 2 "_"}, + NameMixin is "local_mixin_" ^ {gref->modname M 2 "_"}, + + if-verbose (coq.say "HB: postulate and wrap" NameVar "on" {coq.term->string T}), + + synthesis.infer-all-gref-deps Ps T M TySkel, + % was synthesis.infer-all-mixin-args Ps T M TySkel, + % if-verbose (coq.say "HB: postulate-mixin checking" TySkel), + % std.assert-ok! (coq.typecheck Ty _) "postulate-mixin: Ty illtyped", + std.assert-ok! (coq.elaborate-ty-skeleton TySkel _ Ty) + "postulate-mixin: Ty illtyped", + + Ty = app[global M|Args], + factory-constructor M K, + coq.mk-app (global K) Args KArgs, + std.assert-ok! (coq.typecheck KArgs {{ lp:VarTy -> _ }}) "brrr", + + log.coq.env.add-section-variable-noimplicits NameVar VarTy V, + + coq.mk-app KArgs [global (const V)] TheMixin, + + log.coq.env.add-const-noimplicits NameMixin TheMixin Ty @transparent! C, + + factory? Ty NewMwP, + + declare-instances-from-postulated-mixin TheType M T C MC NewCL, + + std.append CL NewCL OutCL, + +]. + + postulate-mixin TheType (triple M Ps T) (triple CL MSL MLwP) (triple OutCL [MC|MSL] [NewMwP|MLwP]) :- MSL => std.do! [ Name is "local_mixin_" ^ {gref->modname M 2 "_"}, @@ -70,11 +104,19 @@ postulate-mixin TheType (triple M Ps T) (triple CL MSL MLwP) (triple OutCL [MC|M "postulate-mixin: Ty illtyped", log.coq.env.add-section-variable-noimplicits Name Ty C, factory? Ty NewMwP, + + declare-instances-from-postulated-mixin TheType M T C MC NewCL, + + std.append CL NewCL OutCL, + + ]. + +pred declare-instances-from-postulated-mixin i:term, i:mixinname, i:term, i:constant, o:prop, o:list constant. +declare-instances-from-postulated-mixin TheType M T C MC NewCL :- std.do! [ MC = mixin-src T M (global (const C)), MC => get-option "local" tt => - instance.declare-all TheType {findall-classes-for [M]} NewCSL, - std.map NewCSL snd NewCL, - std.append CL NewCL OutCL - ]. + instance.declare-all TheType {findall-classes-for [M]} NewCL, +]. + }} diff --git a/HB/export.elpi b/HB/export.elpi index 2fb15aa3..ea823332 100644 --- a/HB/export.elpi +++ b/HB/export.elpi @@ -47,7 +47,7 @@ export.reexport-all-modules-and-CS Filter :- std.do! [ std.forall2 NiceMods Mods log.coq.env.export-module, - std.findall (instance-to-export File NiceInstance_ Const_) InstCL, + std.findall (instance-to-export File Const_) InstCL, std.filter {std.list-uniq InstCL} (export.private.instance-in-module MFilter) InstCLFiltered, std.map InstCLFiltered instance-to-export_instance Insts, @@ -83,7 +83,7 @@ module-in-module PM (module-to-export _ _ M) :- std.appendR PM _ PC. % sublist pred instance-in-module i:list string, i:prop. -instance-in-module PM (instance-to-export _ _ C) :- +instance-in-module PM (instance-to-export _ C) :- coq.gref->path (const C) PC, std.appendR PM _ PC. % sublist diff --git a/HB/factory.elpi b/HB/factory.elpi index ef00f61a..81606565 100644 --- a/HB/factory.elpi +++ b/HB/factory.elpi @@ -226,6 +226,53 @@ 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 _ Ty R) Out :- + @pi-parameter ID Ty p\ + extract_from_record_decl P (R p) Out. +extract_from_record_decl P (record _ _ _ (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 N Ty TF) Out1 :- + @pi-decl N Ty 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 ok. + +pred xtr_snd_op i:term, o:gref. +xtr_snd_op Ty Gr :- + % TODO: use factory? from database.elpi + Ty = (app [global Gr0| Args]), + factory-alias->gref Gr0 Gr1 ok, + factory-nparams Gr1 N, + std.nth N Args (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 @@ -262,6 +309,12 @@ declare-mixin-or-factory MixinSrcClauses SectionCanonicalInstance % TODO: should this be in the Exports module? + % if the wrapper option is on, build the wrapper clause + if (get-option "wrapper" tt) + ((wrapper_mixin_aux (indt R) NSbj WMxn), + (WrapperClauses = [wrapper-mixin (indt R) NSbj WMxn])) + (WrapperClauses = []), + if-verbose (coq.say {header} "declare notation Build"), GRDepsClauses => phant.of-gref ff GRK [] PhGRK, @@ -278,7 +331,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/HB/instance.elpi b/HB/instance.elpi index 063b4fe0..2c9f4eb6 100644 --- a/HB/instance.elpi +++ b/HB/instance.elpi @@ -3,6 +3,7 @@ namespace instance { +% DEPRECATED % [declare-existing T F] equips T with all the canonical structures that can be % built using factory instance F pred declare-existing i:argument, i:argument. @@ -22,7 +23,7 @@ declare-existing T0 F0 :- std.do! [ % and equips the type the factory is used on with all the canonical structures % that can be built using factory instance B. CFL contains the list of % factories being defined, CSL the list of canonical structures being defined. -pred declare-const i:id, i:term, i:arity, o:list (pair id constant), o:list (pair id constant). +pred declare-const i:id, i:term, i:arity, o:list constant, o:list constant. declare-const Name BodySkel TyWPSkel CFL CSL :- std.do! [ std.assert-ok! (coq.elaborate-arity-skeleton TyWPSkel _ TyWP) "Definition type illtyped", coq.arity->term TyWP Ty, @@ -71,17 +72,52 @@ declare-const Name BodySkel TyWPSkel CFL CSL :- std.do! [ private.check-non-forgetful-inheritance TheType Factory, - private.declare-instance Factory TheType TheFactory Clauses CFL CSL, - - if (CSL = []) - (coq.warning "HB" "HB.no-new-instance" "HB: no new instance is generated") - true, - - % 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 - ), + if (current-mode (builder-from TheType TheFactoryForBuilderSection FGR _)) + % instance in a builder section for this subject %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + (std.do![ + if (get-option "local" tt) + (coq.error "HB: declare-instance: cannot make builders local. If you want temporary instances, make an alias, e.g. with let T' := T") true, + + private.declare-canonical-instances-from-factory-and-local-builders + Factory TheType TheFactory TheFactoryForBuilderSection FGR NM_CFL MsClauses CSL, + + std.map NM_CFL snd CFL, + + std.map NM_CFL (x\c\sigma N MixinName C\ new_int N, x = pr MixinName C, c = builder-decl (builder N FGR MixinName (const C))) BdClauses, + + std.append MsClauses BdClauses Clauses, + + private.close-section-if-has-params TyWP SectionName, + ]) + % instance in regular section %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + (std.do![ + + % derive all mixins the factory provides + private.declare-mixins-from-factory Factory TheType TheFactory ML TheMixins, + + % regular instance %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (get-option "wrapper" ff ; not(is-subject-lifter TheType _ _)) + % regular subject %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + (private.declare-regular-inst TheType ML TheMixins TyWP SectionName ClausesHas CSL, WMsClauses = [], WBdClauses = []) + % wrapper %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + (private.declare-wrapper-inst TheType ML TheMixins TyWP SectionName ClausesHas CSL WM WMC, + if (current-mode (builder-from TheLiftedType _ FGR _)) % we are in a builder section + ( + std.map2 WM WMC (MixinName\C\c\sigma N\ new_int N, c = builder-decl (builder N FGR MixinName (const C))) WBdClauses, + std.map2 WM WMC (MixinName\C\c\c = mixin-src TheLiftedType MixinName (global (const C))) WMsClauses + ) + (WMsClauses = [], WBdClauses = [])) + , + CFL = CSL, + + % shared to all branches + if (get-option "export" tt) + (coq.env.current-library File, + std.map CSL (c\r\ r = instance-to-export File c) ClausesExp) + (ClausesExp = []), + + std.flatten [ClausesHas, ClausesExp, WMsClauses, WBdClauses] Clauses, + ]), % we accumulate clauses now that the section is over acc-clauses current Clauses @@ -97,11 +133,11 @@ not-subclass-of HasNoInstance (class C _ _) :- not(sub-class C HasNoInstance _ _ % rest. For each fulfilled class it declares a local constant inhabiting the % corresponding structure and declares it canonical. % 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). +pred declare-all i:term, i:list class, o:list constant. declare-all _ [] []. declare-all T [class _ Struct _|Rest] L :- has-instance T Struct, !, declare-all T Rest L. -declare-all T [class Class Struct MLwP|Rest] [pr Name CS|L] :- +declare-all T [class Class Struct MLwP|Rest] [CS|L] :- infer-class T Class Struct MLwP S Name STy Clauses, @@ -118,15 +154,15 @@ declare-all T [class HasNoInstance _ _|Rest] L :- % for generic types, we need first to instantiate them by giving them holes, % so they can be used to instantiate the classes -pred declare-all-on-type-constructor i:term, i:list class, o:list (pair id constant). -declare-all-on-type-constructor _ [] []. -declare-all-on-type-constructor TK [class _ Struct _|Rest] L :- saturate-type-constructor TK T, has-instance T Struct, !, - declare-all-on-type-constructor TK Rest L. -declare-all-on-type-constructor TK [class Class Struct MLwP|Rest] [pr Name CS|L] :- +pred declare-all-on-type-constructor i:int, i:term, i:list class, o:list constant. +declare-all-on-type-constructor _ _ [] []. +declare-all-on-type-constructor Nargs TK [class _ Struct _|Rest] L :- saturate-type-constructor Nargs TK T, has-instance T Struct, !, + declare-all-on-type-constructor Nargs TK Rest L. +declare-all-on-type-constructor Nargs TK [class Class Struct MLwP|Rest] [CS|L] :- %TODO: compute the arity of the Class subject and saturate up to that point % there may even be more than one possibility - saturate-type-constructor TK T, + saturate-type-constructor Nargs TK T, infer-class T Class Struct MLwP S Name _STy Clauses, @@ -137,12 +173,12 @@ declare-all-on-type-constructor TK [class Class Struct MLwP|Rest] [pr Name CS|L] decl-const-in-struct Name SC SCTy CS, - Clauses => declare-all-on-type-constructor TK Rest L. + Clauses => declare-all-on-type-constructor Nargs TK Rest L. -declare-all-on-type-constructor TK [class HasNoInstance _ _|Rest] L :- +declare-all-on-type-constructor Nargs TK [class HasNoInstance _ _|Rest] L :- % filter out classes we can't build for sure std.filter Rest (not-subclass-of HasNoInstance) Rest1, - declare-all-on-type-constructor TK Rest1 L. + declare-all-on-type-constructor Nargs TK Rest1 L. pred has-instance i:term, i:structure. has-instance T Struct :- @@ -192,8 +228,8 @@ decl-const-in-struct Name S STy CS:- std.do![ ]. % create instances for all possible combinations of types and structure compatible -pred saturate-instances i:cs-pattern. -saturate-instances Filter :- std.do! [ +pred saturate-instances i:int, i:cs-pattern. +saturate-instances Nargs Filter :- std.do! [ findall-has-mixin-instance Filter ClausesHas, @@ -204,10 +240,10 @@ saturate-instances Filter :- std.do! [ findall-classes AllClasses, std.map ClausesHas has-mixin-instance->mixin-src Clauses, - - Clauses => std.forall2 TL UKL (t\k\sigma Classes\ + Clauses => std.forall2 TL UKL (t\k\sigma Classes\ std.do! [ std.filter AllClasses (no-instance-for k) Classes, - declare-all-on-type-constructor t Classes _), + declare-all-on-type-constructor Nargs t Classes _, + ]), ]. pred no-instance-for i:cs-pattern, i:class. @@ -224,33 +260,34 @@ namespace private { 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), o:list (pair id constant). -declare-instance Factory T F Clauses CFL CSL :- + o:list prop, o:list constant, o:list constant. +declare-instance Factory T F [] CFL CSL :- current-mode (builder-from T TheFactory FGR _), !, if (get-option "local" tt) (coq.error "HB: declare-instance: cannot make builders local. If you want temporary instances, make an alias, e.g. with let T' := T") true, !, declare-canonical-instances-from-factory-and-local-builders Factory - T F TheFactory FGR Clauses CFL CSL. + T F TheFactory FGR NM_CFL _ CSL, + std.map NM_CFL snd CFL. declare-instance Factory T F Clauses CFL CSL :- declare-canonical-instances-from-factory Factory T F Clauses1 CFL CSL, if (get-option "export" tt) (coq.env.current-library File, - std.map {std.append CFL CSL} (x\r\ sigma i c\ x = pr i c, r = instance-to-export File i c) Clauses2) + std.map CSL (c\r\ r = instance-to-export File c) Clauses21, + std.map CFL (c\r\ r = instance-to-export File c) Clauses22, + std.append Clauses21 Clauses22 Clauses2) (Clauses2 = []), std.append Clauses1 Clauses2 Clauses. -% [add-mixin T F _ M Cl] adds a constant being the mixin instance for M on type +% [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! [ - new_int N, % timestamp +pred add-mixin i:term, i:factoryname, i:mixinname, + o:prop, o:constant. +add-mixin T FGR MissingMixin MixinSrcCl C :- std.do! [ + % 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) _, @@ -264,24 +301,20 @@ add-mixin T FGR MakeCanon MissingMixin [MixinSrcCl, BuilderDeclCl] CSL :- std.do (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 = []), -]. -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! [ - 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 + MixinSrcCl = mixin-src T MixinName (global (const C)), + % BuilderDeclCl = builder-decl (builder N FGR MixinName (const C)), ]. + +pred add-all-mixins i:term, i:factoryname, i:list mixinname, + o:list prop, o:list constant. +add-all-mixins _T _FGR [] [] []. +add-all-mixins T FGR [M|ML] [MixinSrcCL | CL] [C|CC] :- std.do! [ + add-mixin T FGR M MixinSrcCL C, + add-all-mixins T FGR ML CL CC, +]. + % [postulate-arity A Acc T TS] postulates section variables % corresponding to parameters in arity A. TS is T applied % to all section variables (and hd-beta reduced). Acc should @@ -305,21 +338,29 @@ postulate-arity (arity Ty) ArgsRev X T Ty :- % can access their theory and notations pred declare-canonical-instances-from-factory-and-local-builders i:factoryname, i:term, i:term, i:term, i:factoryname, - o:list prop, o:list (pair id constant), o:list (pair id constant). + o:list (pair mixinname constant), o:list prop, o:list constant. declare-canonical-instances-from-factory-and-local-builders - Factory T F _TheFactory FGR Clauses CFL CSL :- std.do! [ + Factory T F _TheFactory FGR NM_CFL MsClauses CSL :- std.do! [ synthesis.under-new-mixin-src-from-factory.do! T F (NewMixins\ std.do! [ - add-all-mixins T FGR NewMixins ff Clauses CFL, + add-all-mixins T FGR NewMixins MsClauses CFL, + std.zip NewMixins CFL NM_CFL, ]), list-w-params_list {factory-provides Factory} ML, - Clauses => declare-all T {findall-classes-for ML} CSL, + MsClauses => declare-all T {findall-classes-for ML} CSL, +]. + +pred make-mixin-canonical i:constant, o:option constant. +make-mixin-canonical C (some C) :- 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), ]. +make-mixin-canonical _ none. % [declare-canonical-instances-from-factory T F] given a factory F % it uses all known builders to declare canonical instances of structures % on T pred declare-canonical-instances-from-factory - i:factoryname, i:term, i:term, o: list prop, o:list (pair id constant), o:list (pair id constant). + i:factoryname, i:term, i:term, o: list prop, o:list constant, o:list constant. declare-canonical-instances-from-factory Factory T F ClausesHas CFL CSL :- std.do! [ % The order of the following two "under...do!" is crucial, % priority must be given to canonical mixins @@ -329,13 +370,135 @@ declare-canonical-instances-from-factory Factory T F ClausesHas CFL CSL :- std.d synthesis.under-mixin-src-from-factory.do! T F [ MLCano => std.do! [ list-w-params_list {factory-provides Factory} ML, - add-all-mixins T Factory ML tt Clauses CFL, + add-all-mixins T Factory ML Clauses CFL, std.map-filter Clauses (mixin-src->has-mixin-instance ) ClausesHas, ClausesHas => declare-all T {findall-classes-for ML} CSL, % declare-all-on-type-constructor doesn't work here ] ], ]. +% [declare-mixins-from-factory T F] given a factory F +% it uses all known builders to declare canonical instances of structures +% on T +pred declare-mixins-from-factory + i:factoryname, i:term, i:term, o:list mixinname, o:list constant. +declare-mixins-from-factory Factory T F ML TheMixins :- std.do! [ + % 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 + % hence we add these clauses last. + synthesis.local-canonical-mixins-of T MLCano, + synthesis.under-mixin-src-from-factory.do! T F [ + MLCano => std.do! [ + list-w-params_list {factory-provides Factory} ML, + add-all-mixins T Factory ML _ TheMixins, + ] + ], +]. + +% [declare-structure-instance-from-mixins T ML MLI] given mixins ML and +% their implementation MLI declares all structure instances for T +pred declare-structure-instance-from-mixins i:term, i:list mixinname, i:list constant, o:list prop, o:list constant. +declare-structure-instance-from-mixins T ML TheMixins ClausesHas CL :- std.do! [ + % 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 + % hence we add these clauses last. + synthesis.local-canonical-mixins-of T MLCano, + synthesis.under-these-mixin-src.do! T ML TheMixins ClausesHas [ + MLCano => std.do! [ + instance.declare-all T {findall-classes-for ML} CL, + ] + ], +]. + +pred close-section-if-has-params i:arity, i:id. +close-section-if-has-params (arity _) _ :- !. +close-section-if-has-params _ SectionName :- + if-verbose (coq.say {header} "closing instance section"), + log.coq.env.end-section-name SectionName. + +pred declare-regular-inst i:term, i:list mixinname, i:list constant, i:arity, i:id, + o:list prop, o:list constant. +declare-regular-inst TheType ML TheMixins TyWP SectionName ClausesHas CSL :- std.do![ + private.declare-structure-instance-from-mixins TheType ML TheMixins ClausesHas CCSL, + + % TODO: share between the two cases and put just after declare-mixins-from-factory + % since it talks about the unwrapped mixins + std.map TheMixins private.make-mixin-canonical TheCanonicalMixins, + std.map-filter TheCanonicalMixins (x\r\x = some r) MCSL, + std.append MCSL CCSL CSL, + + private.close-section-if-has-params TyWP SectionName, +]. + +pred declare-wrapper-inst i:term, i:list mixinname, i:list constant, i:arity, i:id, + o:list prop, o:list constant, o:list mixinname, o:list constant. +declare-wrapper-inst TheType ML TheMixins TyWP SectionName ClausesHas CSL WML TheWrappedMixins :- std.do![ + coq.safe-dest-app TheType TheTypeKey _, + std.assert! (TheTypeKey = global TheTypeKeyGR) "The subject to be wrapped has no key", + private.close-section-if-has-params TyWP SectionName, + private.wrap-mixins TheTypeKeyGR ML TheMixins TheNewType WML TheWrappedMixins, + private.declare-structure-instance-from-mixins TheNewType WML TheWrappedMixins ClausesHas CSL, +]. + +pred derive-wrapper-instances i:term, i:mixinname, o:term, o:constant. +derive-wrapper-instances Instance WrapperMixin WrapperSubject C :- std.do! [ + + % K is the mixin constructor (Build) for WrapperMixin + factory-constructor WrapperMixin K, + + % the constructor of the new wrapper instance + phant-abbrev K _ Abb, + coq.notation.abbreviation-body Abb NArgs _, + coq.notation.abbreviation Abb {coq.mk-n-holes NArgs} AbbBo, + + coq.safe-dest-app AbbBo Hd ActualArgs, + std.assert-ok! (coq.typecheck Hd KTy) "wrap: cannot type constructor", + + % the arguments + coq.count-prods KTy KN, + KN0 is KN - 1 - {std.length ActualArgs}, + std.append {coq.mk-n-holes KN0} [Instance] Args, + + coq.mk-app AbbBo Args NewInstance, + std.assert-ok! (coq.typecheck NewInstance Ty) "cannot wrap", + + Name is "wrapped__" ^ {std.any->string {new_int}}, + log.coq.env.add-const-noimplicits Name NewInstance Ty @transparent! C, + + coq.safe-dest-app Ty _Factory FArgs, + factory-nparams WrapperMixin NParams, + std.nth NParams FArgs WrapperSubjectAsInferred, + + % we may have inferred as the subject the sort projection of an instance + + if (coq.safe-dest-app WrapperSubjectAsInferred (global (const P)) [_],structure-key P _ _) + (unwind {whd WrapperSubjectAsInferred []} WrapperSubject) % TODO: do 1 step + (WrapperSubject = WrapperSubjectAsInferred) + + ]. + +pred wrap-a-mixin i:gref, i:mixinname, i:constant, o:term, o:mixinname, o:constant. +wrap-a-mixin TheTypeKeyGR M TheMixin TheNewType WM TheWrappedMixin :- std.do! [ + std.findall (wrapper-mixin _ TheTypeKeyGR M) Wrappers, + std.assert! (not(Wrappers = [])) "wrap-a-mixin: no wrapper found", + if (Wrappers = [wrapper-mixin WM TheTypeKeyGR M]) + (TM = global (const TheMixin), + private.derive-wrapper-instances TM WM TheNewType TheWrappedMixin) + (coq.error "wrap-a-mixin: more than one way to wrap" TheTypeKeyGR "for" M), +]. + +pred wrap-mixins i:gref, i:list mixinname, i:list constant, + o:term, o:list mixinname, o:list constant. +wrap-mixins TheTypeKeyGR [ M | ML ] [ TheMixinInstance | TheMixins ] + TheNewType [ WM | WML ] [ TheWrappedMixin | TheWrappedMixins ] :- + wrap-a-mixin TheTypeKeyGR M TheMixinInstance TheNewType1 WM TheWrappedMixin, + std.assert! (TheNewType = TheNewType1) "wrapping leads to different subjects", + wrap-mixins TheTypeKeyGR ML TheMixins TheNewType WML TheWrappedMixins. +wrap-mixins _ [] [] _ [] []. + + % 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. diff --git a/HB/pack.elpi b/HB/pack.elpi index 3bd0d2cc..074da964 100644 --- a/HB/pack.elpi +++ b/HB/pack.elpi @@ -12,7 +12,6 @@ main Ty Args Instance :- std.do! [ std.assert! (Args = [trm TSkel|FactoriesSkel]) "HB.pack: not enough arguments", get-constructor Class KC, - get-constructor Structure KS, std.assert-ok! (d\ (coq.elaborate-ty-skeleton TSkel _ T d, d = ok) ; @@ -29,31 +28,73 @@ main Ty Args Instance :- std.do! [ (AllFactories = Factories) (AllFactories = Factories, Tkey = T), % it's a factory, won't add anything - private.synth-instance Params KC KS T Tkey AllFactories Instance, + private.synth-instance Params KC T Tkey AllFactories ClassInstance, + + get-constructor Structure KS, + std.append Params [T, ClassInstance] InstanceArgs, + Instance = app[global KS | InstanceArgs] + +]. + +pred main-use-factories i:term, i:list argument, o:term. +main-use-factories Ty FactoriesSkel ClassInstance :- std.do! [ + std.assert! (not(var Ty)) "HB.from: the class cannot be unknown", + + factory? {unwind {whd Ty []}} (triple Class Params T), + + std.assert! (class-def (class Class _ _)) "HB.from: not a class", + + get-constructor Class KC, + + private.elab-factories FactoriesSkel T Factories, + + if (var T) (coq.error "HB.from: you must pass a type or at least one factory") true, + if2 (T = app[global (const SortProj)|ProjParams], structure-key SortProj ClassProj _) + (AllFactories = [app[global (const ClassProj)|ProjParams] | Factories], Tkey = T) % already existing class on T + (def T _ _ Tkey) % we unfold letins if we can, they may hide constants with CS instances + (AllFactories = Factories) + (AllFactories = Factories, Tkey = T), % it's a factory, won't add anything + + private.try-synth-instance Params KC Tkey AllFactories ClassInstance, + ]. + + + /* ------------------------------------------------------------------------- */ /* ----------------------------- private code ------------------------------ */ /* ------------------------------------------------------------------------- */ namespace private { -pred synth-instance.aux i:list term, i:gref, i:gref, i:term, i:term, i:list term, i:list prop, o:term. -synth-instance.aux Params KC KS T Tkey [Factory|Factories] MLCano Instance :- +pred synth-instance.aux i:list term, i:gref, i:term, i:term, i:list term, i:list prop, o:term. +synth-instance.aux Params KC T Tkey [Factory|Factories] MLCano ClassInstance :- synthesis.under-new-mixin-src-from-factory.do! Tkey Factory (_\ - synth-instance.aux Params KC KS T Tkey Factories MLCano Instance). -synth-instance.aux Params KC KS T Tkey [] MLCano Instance :- + synth-instance.aux Params KC T Tkey Factories MLCano ClassInstance). +synth-instance.aux Params KC _T Tkey [] MLCano ClassInstance :- MLCano => std.do! [ std.assert-ok! (synthesis.infer-all-args-let Params Tkey KC ClassInstance) "HB.pack: cannot infer the instance", - std.append Params [T, ClassInstance] InstanceArgs, - Instance = app[global KS | InstanceArgs] ]. -pred synth-instance i:list term, i:gref, i:gref, i:term, i:term, i:list term, o:term. -synth-instance Params KC KS T Tkey Factories Instance :- +pred synth-instance i:list term, i:gref, i:term, i:term, i:list term, o:term. +synth-instance Params KC T Tkey Factories ClassInstance :- if (coq.safe-dest-app Tkey (global _) _) (synthesis.local-canonical-mixins-of Tkey MLCano) (MLCano = []), - synth-instance.aux Params KC KS T Tkey Factories MLCano Instance. + synth-instance.aux Params KC T Tkey Factories MLCano ClassInstance. + +pred try-synth-instance i:list term, i:gref, i:term, i:list term, o:term. +try-synth-instance Params KC Tkey [Factory|Factories] ClassInstance :- + synthesis.under-new-mixin-src-from-factory.do! Tkey Factory (_\ + try-synth-instance Params KC Tkey Factories ClassInstance). +try-synth-instance Params KC Tkey [] ClassInstance :- coq.safe-dest-app Tkey (global _) _, !, + synthesis.local-canonical-mixins-of Tkey MLCano, + MLCano => std.do! [ + synthesis.try-infer-all-args-let Params Tkey KC ClassInstance, +]. +try-synth-instance Params KC Tkey [] ClassInstance :- std.do! [ + synthesis.try-infer-all-args-let Params Tkey KC ClassInstance, +]. pred elab-factories i:list argument, i:term, o:list term. elab-factories [] _ []. diff --git a/HB/status.elpi b/HB/status.elpi index e6bf3684..b235ebe7 100644 --- a/HB/status.elpi +++ b/HB/status.elpi @@ -28,6 +28,13 @@ print-hierarchy :- std.do! [ std.forall BDL private.pp-builder-decl ), + std.findall (wrapper-mixin _ _ _) WL, + if (WL = []) true ( + coq.say "", + coq.say "--------------------- Wrappers ----------------------", + std.forall WL private.pp-wrapper + ), + std.findall (current-mode BF_) BFL, if (BFL = []) true ( coq.say "", @@ -80,5 +87,9 @@ pred pp-current-mode i:prop. pp-current-mode (current-mode (builder-from TheType TheFactory GRF Mod)) :- coq.say "The current key is" TheType "with factory" TheFactory "corresponding to Global Ref" GRF "in module" Mod. - + +pred pp-wrapper i:prop. +pp-wrapper (wrapper-mixin W O M) :- + coq.say "wrapper" W "for mixin" M "for lifter" O. + }} diff --git a/HB/structure.elpi b/HB/structure.elpi index 3702ce19..0597c2f0 100644 --- a/HB/structure.elpi +++ b/HB/structure.elpi @@ -6,12 +6,19 @@ namespace structure { % HB.structure Definition S P1 P2 := { T of F1 P1 T & F2 P1 (P2*P2) T } % cons p1\ cons p2\ nil t\ [triple f1 [p1] t,triple f2 [p1, {{p1 * p2}}] t] pred declare i:string, i:term, i:sort. -declare Module BSkel Sort :- std.do! [ +declare Module BSkel Sort :- private.declare-wrappers BSkel WrapperClauses, % move to factory.elpi + + WrapperClauses => std.do! [ disable-id-phant BSkel BSkelNoId, - std.assert-ok! (coq.elaborate-skeleton BSkelNoId _ BNoId) "illtyped structure definition", + private.failsafe-structure-inference BSkelNoId BSkelNoIdX, + %coq.say {coq.term->string BSkelNoIdX} BSkelNoIdX, + std.assert-ok! (coq.elaborate-skeleton BSkelNoIdX _ BNoId) "illtyped structure definition", re-enable-id-phant BNoId B, - private.sigT->list-w-params B GRFSwP ClosureCheck, - + private.sigT->list-w-params B GRFSwP_or_ThingtoBeWrapped ClosureCheck, + + % do some work to go back to factories on a single subject + private.lift-to-the-subject GRFSwP_or_ThingtoBeWrapped GRFSwP, + factories-provide GRFSwP PMLwP, list-w-params.flatten-map GRFSwP gref-deps RMLwP, % TODO: extract code from factories-provide @@ -126,7 +133,9 @@ declare Module BSkel Sort :- std.do! [ std.flatten [ Factories, [is-structure Structure], NewJoins, [class-def CurrentClass], GRDepsClauses, - [gref-deps GRPack MLwP], MixinMems, [StructKeyClause] + [gref-deps GRPack MLwP], MixinMems, [StructKeyClause], + WrapperClauses + ] NewClauses, acc-clauses current NewClauses, @@ -175,6 +184,13 @@ declare Module BSkel Sort :- std.do! [ log.coq.env.end-module-name ElpiOperationModName ElpiOperations, export.module ElpiOperationModName ElpiOperations, + % we need to assert locally the clauses in EX + EX => std.forall ML private.reexport-wrapper-as-instance, + + %hack + hack, + + if-verbose (coq.say {header} "abbreviation factory-by-classname"), ClassAlias => NewClauses => factory.declare-abbrev Module (factory.by-classname ClassName) ClassAbbrev, @@ -187,6 +203,11 @@ declare Module BSkel Sort :- std.do! [ % NewClauses => instance.saturate-instances, ]. +pred hack. +hack :- coq.next-synterp-action (begin-section X), coq.env.begin-section X, hack. +hack :- coq.next-synterp-action end-section, coq.env.end-section, hack. +hack. + /* ------------------------------------------------------------------------- */ /* ----------------------------- private code ------------------------------ */ /* ------------------------------------------------------------------------- */ @@ -608,16 +629,55 @@ if-coverage-not-good-error.one MS M :- mixin-first-class M C, !, "which contains at most" {std.map {coq.gref.set.elements {coq.gref.set.inter CMS MS}} nice-gref->string}). if-coverage-not-good-error.one _ _. % new class is the first covering M -pred product->triples i:term, o:list (w-args factoryname), o:bool. -product->triples {{ lib:hb.prod lp:A lp:B }} L ClosureCheck :- !, - product->triples B GRB ClosureCheck, - product->triples A GRA _, +% 1. write a predicate to recognize factory applied to op, maybe under a forall prefix +% factory-on-some-structure-op? +% 2. change the type of product->triples and sigT->list-w-params to +% return a list-w-params of either a factoryname or a thing-to-be-wrapper +% (eg mixin to be wrapped, operation) +% 3. the caller of sigT->list-w-params has to pre-process the list +% and generate wrapper mixins for each thing-to-be-wrapper and replace +% in the list the thing-to-be-wrapper with the wrapper mixin +% - one needs to find to which structure the operation belongs and +% use that structure to synthesize the type of the wrapper, eg +% hom belongs to Quiver, hence hom_isMon takes a "T of Quiver T" + +% checks if the term is forall A B C, Factory ... (Op A B C) ... +pred factory-on-some-structure-op? i:term, i:list term, o:gref, o:gref. +factory-on-some-structure-op? (prod N Ty Bo) VS F OP :- + @pi-decl N Ty x\ + factory-on-some-structure-op? (Bo x) [x|VS] F OP. +factory-on-some-structure-op? T VS F (const OP) :- std.do! [ + factory? T (triple F _ Subject), + hd-beta-zeta Subject [] (global (const OP)) Args, + exported-op _ _ OP, + std.appendR _ {std.rev VS} Args, +]. +factory-on-some-structure-op? T VS F GR :- std.do! [ + factory? T (triple F _ Subject), + hd-beta-zeta Subject [] (global GR) Args, + tag GR _ _, + std.appendR _ {std.rev VS} Args, +]. + +kind factory-on-subject type. +type factory-on-the-type w-args factoryname -> factory-on-subject. +type factory-on-subject-lifter term -> factoryname -> gref -> factory-on-subject. + +pred product->triples i:term, i:term, o:list factory-on-subject, o:bool. +product->triples {{ lib:hb.prod lp:A lp:B }} T L ClosureCheck :- !, + product->triples B T GRB ClosureCheck, + product->triples A T GRA _, std.append GRA GRB L. -product->triples {{ True }} [] tt :- !. -product->triples {{ False }} [] ff :- !. -product->triples A [GR] tt :- std.assert! (factory? A GR) "A structure can only mention known factories". +product->triples {{ True }} _ [] tt :- !. +product->triples {{ False }} _ [] ff :- !. +product->triples A T [factory-on-the-type F] tt :- (factory? A F), (F = triple _ _ T), !. +product->triples A _ [factory-on-subject-lifter A F OP] tt :- factory-on-some-structure-op? A [] F OP, !. +product->triples A T _ _ :- + coq.error "HB: expecting a factory on" {coq.term->string T} + "or a factory on a structure operation or tag. Got:" {coq.term->string A}. + -pred sigT->list-w-params i:term, o:list-w-params factoryname, o:bool. +pred sigT->list-w-params i:term, o:w-params (list factory-on-subject), o:bool. sigT->list-w-params (fun N T B) L C :- coq.name->id N ID, % TODO: we should read the ID from the definition type which is an arity containing ids L = w-params.cons ID T Rest, @@ -627,6 +687,249 @@ sigT->list-w-params {{ lib:@hb.sigT _ lp:{{ fun N Ty B }} }} L C :- coq.name->id N ID, % TODO: we should read the ID from the definition type which is an arity containing ids L = w-params.nil ID Ty Rest, @pi-decl N Ty t\ - product->triples (B t) (Rest t) C. + product->triples (B t) t (Rest t) C. + +%TODO expand factories in lift +pred lift-to-the-subject i:w-params (list factory-on-subject), o:list-w-params factoryname. +lift-to-the-subject (w-params.cons ID T Rest) (w-params.cons ID T Rest1) :- + @pi-parameter ID T x\ + lift-to-the-subject (Rest x) (Rest1 x). +lift-to-the-subject (w-params.nil ID T Rest) (w-params.nil ID T Rest1) :- + @pi-parameter ID T x\ + lift-to-the-subject.aux (Rest x) x (Rest1 x). +lift-to-the-subject.aux [] _ []. +lift-to-the-subject.aux [factory-on-the-type F|Rest] T [F|Rest1] :- + lift-to-the-subject.aux Rest T Rest1. +lift-to-the-subject.aux [factory-on-subject-lifter _ F OP|Rest] T [WF|Rest1] :- + wrapper-mixin Wrapper OP F, !, std.do! [ + factory-nparams Wrapper NParams, + coq.mk-app {coq.env.global Wrapper} {std.append {coq.mk-n-holes NParams} [T]} W, + factory? W WF, + lift-to-the-subject.aux Rest T Rest1, +]. +lift-to-the-subject.aux [factory-on-subject-lifter Expr _ _|_] _ _ :- + coq.error "NYI: automatic wrapping for" {coq.term->string Expr}. + +pred declare-wrappers i:term, o:list prop. +declare-wrappers B C :- std.do! [ + private.sigT->list-w-params B X _, + declare-wrappers.filter-lifted X Wrappers, + w-params.map Wrappers (_\_\std.flatten) Wrappers1, + distribute-w-params Wrappers1 WrappersWP, + std.fold WrappersWP [] declare-wrapper C, +]. +pred declare-wrappers.filter-lifted i:w-params (list factory-on-subject), o:w-params (list (list (pair gref (w-args mixinname)))). +declare-wrappers.filter-lifted (w-params.cons ID T F) (w-params.cons ID T F1) :- + @pi-parameter ID T x\ declare-wrappers.filter-lifted (F x) (F1 x). +declare-wrappers.filter-lifted (w-params.nil ID T F) (w-params.nil ID T F1) :- + @pi-parameter ID T x\ declare-wrappers.filter-lifted.aux (F x) (F1 x). +declare-wrappers.filter-lifted.aux [factory-on-the-type _|XS] R :- declare-wrappers.filter-lifted.aux XS R. +declare-wrappers.filter-lifted.aux [factory-on-subject-lifter T F G|XS] [WL|R] :- + factory? T (triple _ Params S), + factory-provides F MLwP, + apply-w-params MLwP Params S Triples, + std.map-filter Triples (declare-wrappers.filter-new G) WL, + declare-wrappers.filter-lifted.aux XS R. +declare-wrappers.filter-lifted.aux [] []. + +pred declare-wrappers.filter-new i:gref, i:w-args mixinname, o:pair gref (w-args mixinname). +declare-wrappers.filter-new G (triple F _ _ as T) (pr G T) :- not (wrapper-mixin _ G F). + +pred wrap-deps i:gref, i:mixins, o:mixins. +wrap-deps OP (w-params.cons ID T F) (w-params.cons ID T F1) :- + @pi-parameter ID T x\ wrap-deps OP (F x) (F1 x). +wrap-deps OP (w-params.nil ID T F) (w-params.nil ID T F1) :- + @pi-parameter ID T x\ wrap-deps.mixins OP (F x) (F1 x). + +pred wrap-deps.mixins i:gref, i:list (w-args mixinname), o:list (w-args mixinname). +wrap-deps.mixins _ [] []. +wrap-deps.mixins OP [triple M P X|ML] [triple WM P X|ML1] :- + std.assert! (wrapper-mixin WM OP M) "no wrapper for the lifter on a dep", + wrap-deps.mixins OP ML ML1. + +pred declare-wrapper i:w-params (pair gref (w-args mixinname)), i:list prop, o:list prop. +declare-wrapper F C0 C :- C0 => std.do! [ + %coq.say "Missing" F, + missing-wrapper->record F RSkel OP M, + %coq.say "Wrapper skel" F "=" RSkel, + %disable-id-phant-indt-decl RSkel RSkelNoId, + %std.assert-ok! (coq.elaborate-indt-decl-skeleton RSkelNoId RDeclNoId) "illtyped wrapper", + %re-enable-id-phant-indt-decl RDeclNoId RDecl, + %coq.say "Record wrapper" RDecl, + gref-deps M MDeps, + wrap-deps OP MDeps WrappedDeps, + ((pi X Y L\ copy X Y :- var X _ L, prune Y L) => copy-indt-decl RSkel RSkel'), expand-structures RSkel' WrappedDeps W', + %coq.say "Expanded record wrapper" W', + %std.assert-ok! (coq.typecheck-indt-decl W) "illtyped wrapper record", + coq.say "Wrapper for" OP "and" M "is" W', + std.assert-ok! (coq.elaborate-indt-decl-skeleton W' W) "illtyped wrapper record", + %coq.say W, + log.coq.env.add-indt W R, + coq.env.indt R tt _ _ _ [K] _, + GRK = indc K, + GR = indt R, + + coq.gref->id GR Name, + + wrapper-deps F W MLwP, + %coq.say "W deps" F "=" MLwP, + + w-params.nparams MLwP NParams, + factory.private.build-deps-for-projections R MLwP GRDepsClausesProjs, + GRDepsClauses = [ gref-deps GR MLwP, gref-deps (indc K) MLwP | GRDepsClausesProjs], + GRDepsClauses => phant.of-gref ff GRK [] PhGRK, + GRDepsClauses => phant.add-abbreviation {calc (Name ^ "_Build")} PhGRK BuildConst BuildAbbrev, + GRDepsClauses => phant.of-gref ff GR [] PhTerm, + GRDepsClauses => phant.add-abbreviation {calc (Name ^ "_axiom")} PhTerm PhC Abbrv, + + FRClauses = [ + phant-abbrev GRK (const BuildConst) BuildAbbrev, + phant-abbrev GR (const PhC) Abbrv, + ], + + GRDepsClauses => FRClauses => factory.private.declare-id-builder GR IdBuilderClause, + + std.flatten [ C0, + [ wrapper-mixin GR OP M, + factory-constructor GR GRK, + factory-nparams GR NParams, + IdBuilderClause], + FRClauses, + GRDepsClauses, + ] C, + %factory-builder-nparams BuildConst NParams, + coq.say "Wrapper DONE" F, +]. + +pred missing-wrapper->record i:w-params (pair gref (w-args mixinname)), o:indt-decl, o:gref, o:mixinname. +missing-wrapper->record (w-params.cons ID T F) (parameter ID explicit T F1) OP M:- + @pi-parameter ID T x\ missing-wrapper->record (F x) (F1 x) OP M. +missing-wrapper->record (w-params.nil ID T F) (parameter ID explicit T F1) OP M:- + @pi-parameter ID T x\ missing-wrapper->record.body (F x) (F1 x) OP M. + +pred unfold-phant i:term, o:term. +unfold-phant (app [global (const C)|A]) R :- + coq.env.const C (some B) _, + unwind {hd-beta B A} R. + +pred missing-wrapper->record.body i:pair gref (w-args mixinname), o:indt-decl, o:gref, o:mixinname. +missing-wrapper->record.body (pr OP (triple M Params Subject)) + (record Name _ Bname (field [] Fname T (x\end-record))) OP M :- std.do! [ + coq.mk-app {coq.env.global M} {std.append Params [Subject]} T, + + Name is "wrapper_" ^ {std.any->string {new_int}} ^ "_" ^ {coq.gref->id OP} ^ "_" ^ {nice-gref->string M}, + Fname is Name ^ "_private", + Bname is Name ^ "_build", +]. + +pred wrapper-deps i:w-params (pair gref (w-args gref)), i:indt-decl, o:mixins. +wrapper-deps (w-params.cons _ _ F) (parameter ID explicit T F1) (w-params.cons ID T ML) :- + @pi-parameter ID T x\ wrapper-deps (F x) (F1 x) (ML x). +wrapper-deps (w-params.nil _ _ _) (parameter ID explicit T F1) (w-params.nil ID T ML) :- + @pi-parameter ID T x\ wrapper-deps.aux (F1 x) x (ML x). +wrapper-deps.aux (parameter ID explicit T F1) X [triple M Params X|ML] :- + coq.safe-dest-app T Mixin ParamsXStuff, + coq.env.global M Mixin, + std.appendR Params [X|_] ParamsXStuff, + @pi-parameter ID T x\ wrapper-deps.aux (F1 x) X ML. +wrapper-deps.aux (record _ _ _ _) _ []. + +pred expand-structures i:indt-decl, i:mixins, o:indt-decl. +expand-structures (parameter ID I T ((s\record _ _ _ (field _ _ (X s) _\end-record)) as R)) Deps (parameter ID I _ R1) :- !, std.do! [ + (@pi-decl `TheType` T x\ coq.typecheck-ty T _ ok, std.assert-ok! (coq.typecheck (X x) (Ty_ x)) "illtyped subject"), + coq.safe-dest-app T (global GR) Args, is-structure GR, class-def (class C GR ML), + coq.mk-n-holes {w-params.nparams Deps} Holes, + get-constructor C K, + get-constructor GR SK, + coq.mk-app (global SK) Args SKArgs, + (@pi-decl `TheType` T x\ % TYPE is wrong + apply-w-params ML Args x (F x), + apply-w-params Deps Holes x (DepsX x), + %toposort-mixins {std.append (F x) (DepsX x)} (MoreParams x), + expand-structures.aux (F x) (DepsX x) [] {coq.mk-app SKArgs [x]} K Args x R (R1 x)), +]. +expand-structures(parameter ID I T F) Deps (parameter ID I T F1) :- + @pi-parameter ID T x\ expand-structures (F x) Deps (F1 x). +expand-structures.aux [triple M PS X|MS] D ACC Pack K KA Subj R (parameter "m" explicit Ty R1) :- std.do! [ + synthesis.infer-all-gref-deps PS X M Ty, + (@pi-decl `m` Ty m\ mixin-src X M m => + expand-structures.aux MS D ACC Pack K KA Subj R (R1 m)), +]. +expand-structures.aux [] [triple M PS X|D] ACC Pack K KA Subj R (parameter "m" explicit Ty R1) :- std.do! [ + synthesis.infer-all-gref-deps PS X M Ty, + coq.safe-dest-app Ty _ Args, + M = indt I, + std.assert! (coq.env.projections I [some Priv]) "wrapper with no projection", + (@pi-decl `m` Ty m\ sigma PM\ + coq.mk-app (app [{coq.env.global (const Priv)}|Args]) [m] PM, + mixin-src X M m => + expand-structures.aux [] D [PM|ACC] Pack K KA Subj R (R1 m)), +]. +expand-structures.aux [] [] WrappedDepsRev Pack K KA Subj R R2 :- std.do! [ + synthesis.infer-all-gref-deps KA Subj K Class, + R1 = R {coq.mk-app Pack [Class]}, + R1 = record N S NK (field FA FN T _\end-record), + R2 = record N S NK (field FA FN T1 _\end-record), + factory? T (triple F Params LiftedSubject), + %std.assert! (std.forall Deps var) "wrapper: deps should be inferred, not given", + %CONVOLUTED + std.rev WrappedDepsRev WrappedDeps, + coq.mk-app (app [global F|Params]) [LiftedSubject|WrappedDeps] T1, +]. + +% 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) +pred reexport-wrapper-as-instance i:mixinname. +reexport-wrapper-as-instance M :- wrapper-mixin M _ _, !, std.do! [ + + % need the body of the wrapper projection type + exported-op M _ C, + B = (global (const C)), + coq.env.typeof (const C) Ty, + coq.count-prods Ty N0, + coq.term->arity Ty N0 Arity, + + % need a recognisable valid idenfier for the derived instance + Str0 is "Op_isMx" ^ "__" ^ {std.any->string {new_int}}, + std.string.concat "__" [Str0, "ELIM"] Str, + + get-option "wrapper" ff => instance.declare-const Str B Arity _ _ + ]. +reexport-wrapper-as-instance _ :- + std.assert! (coq.next-synterp-action (begin-section SectionName)) "synterp code did not open section", + coq.env.begin-section SectionName, + std.assert! (coq.next-synterp-action (end-section)) "synterp code did not close section", + coq.env.end-section. + +pred failsafe-structure-inference i:term, o:term. +failsafe-structure-inference T T1 :- + (pi T T2 F_Params F_Params1 Args Args1 Subject Subject1 NP ArgsOp ArgsOp1 OP S\ + copy (app [global _|_] as T) T2 :- + factory?-split T _ F_Params Subject Args, + std.map F_Params copy F_Params1, + std.map Args copy Args1, + is-subject-lifter Subject NP Class, + coq.safe-dest-app Subject OP ArgsOp, + std.nth NP ArgsOp S, + (var S ; name S), % TODO: should be the subject of the structure, not a random name + !, + eta-structure-record S NP Class ArgsOp ArgsOp1, + coq.mk-app OP ArgsOp1 Subject1, + coq.mk-app (app F_Params1) [Subject1|Args1] T2) => + copy T T1. + +pred eta-structure-record i:term, i:int, i:classname, i:list term, o:list term. +eta-structure-record S NP Class L L1 :- + std.split-at NP L Params [_|Rest], + class-def (class Class Structure _), + get-constructor Structure K, + std.map Params copy Params1, + std.map Rest copy Rest1, + coq.mk-app {coq.env.global K} {std.append Params1 [S,_]} EtaS, + std.append Params1 [EtaS|Rest1] L1. }} diff --git a/HB/structures.v b/HB/structures.v index e3a0b52e..df46bfaa 100644 --- a/HB/structures.v +++ b/HB/structures.v @@ -171,6 +171,18 @@ 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. + +% designated identity function for wrapping (sometimes you don't have a +% structure op for it). +% [tag GR Class NParams] +pred tag o:gref, o:classname, o:int. + %%%%%% 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 @@ -182,7 +194,9 @@ pred mixin-mem i:term, o:gref. % that contains the mixin M pred mixin-first-class o:mixinname, o:classname. -% memory of exported operations (TODO: document fiels) +% memory of exported operations. +% [exported-op Mixin MixinProjection Operation], where Operation is a +% structure projection. pred exported-op o:mixinname, o:constant, o:constant. % memory of factory sort coercion @@ -232,7 +246,7 @@ pred current-mode o:declaration. % library, nice-name, object pred module-to-export o:string, o:id, o:modpath. -pred instance-to-export o:string, o:id, o:constant. +pred instance-to-export o:string, o:constant. pred abbrev-to-export o:string, o:id, o:gref. pred clause-to-export o:string, o:prop. @@ -588,6 +602,34 @@ Elpi Export HB.pack. (* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) (* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) +Elpi Tactic HB.from. +Elpi Accumulate Db hb.db. +Elpi Accumulate File "HB/common/stdpp.elpi". +Elpi Accumulate File "HB/common/database.elpi". +Elpi Accumulate File "HB/common/compat_acc_clauses_all.elpi". +#[skip="8.1[89].*"] Elpi Accumulate File "HB/common/compat_add_secvar_all.elpi". +#[only="8.1[89].*"] Elpi Accumulate File "HB/common/compat_add_secvar_18_19.elpi". +Elpi Accumulate File "HB/common/utils.elpi". +Elpi Accumulate File "HB/common/log.elpi". +Elpi Accumulate File "HB/common/synthesis.elpi". +Elpi Accumulate File "HB/pack.elpi". +Elpi Accumulate lp:{{ + +solve (goal _ _ Ty _ Args as G) GLS :- with-attributes (with-logging (std.do! [ + pack.main-use-factories Ty Args Instance, + refine Instance G GLS, +])). + +}}. +Elpi Typecheck. + +Tactic Notation "HB.from" open_constr_list(L) := + elpi HB.from ltac_term_list:(L). + +(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) +(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) +(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) + (** [HB.structure] declares a packed structure. Syntax to declare a structure combing the axioms from [Factory1] … [FactoryN]. @@ -660,7 +702,7 @@ main [const-decl N (some B) Arity] :- std.do! [ % compute the universe for the structure (default ) prod-last {coq.arity->term Arity} Ty, if (ground_term Ty) (Sort = Ty) (Sort = {{Type}}), sort Univ = Sort, - with-attributes (with-logging (structure.declare N B Univ)), + with-attributes (with-logging (with-unsafe-univ (structure.declare N B Univ))), ]. }}. @@ -684,6 +726,10 @@ actions N :- coq.env.current-library File, coq.elpi.accumulate current "export.db" (clause _ _ (module-to-export File E)), coq.elpi.accumulate current "export.db" (clause _ _ (module-to-export File O)), + + % hack + std.forall {std.iota 30} (x\begin-section "x",end-section), + if (get-option "mathcomp" tt ; get-option "mathcomp.axiom" _) (actions-compat N) true. pred actions-compat i:id. @@ -737,10 +783,10 @@ Elpi Accumulate File "HB/instance.elpi". Elpi Accumulate File "HB/context.elpi". Elpi Accumulate File "HB/factory.elpi". Elpi Accumulate lp:{{ -main [] :- !, with-attributes (with-logging (instance.saturate-instances _)). -main [str "Type"] :- !, with-attributes (with-logging (instance.saturate-instances (cs-sort _))). -main [str K] :- !, coq.locate K GR, with-attributes (with-logging (instance.saturate-instances (cs-gref GR))). -main [trm T] :- !, term->cs-pattern T P, with-attributes (with-logging (instance.saturate-instances P)). +main [] :- !, with-attributes (with-logging (instance.saturate-instances 0 _)). +main [str "Type"] :- !, with-attributes (with-logging (instance.saturate-instances 0 (cs-sort _))). +main [str K] :- !, coq.locate K GR, with-attributes (with-logging (instance.saturate-instances 0 (cs-gref GR))). +main [trm T] :- !, term->cs-pattern T P, coq.safe-dest-app T _ L, std.length L N, with-attributes (with-logging (instance.saturate-instances N P)). main _ :- coq.error "Usage: HB.saturate [key]". }}. Elpi Typecheck. @@ -1217,6 +1263,70 @@ check-or-not Skel :- Elpi Typecheck. Elpi Export HB.check. + +(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) +(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) +(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) + +(** [HB.tag] declares a tag for mixin subjects + +[[ +HB.tag Definition N Params (x : S.type) : Type := x +]] + +*) + +#[arguments(raw)] Elpi Command HB.tag. +Elpi Accumulate Db hb.db. +Elpi Accumulate File "HB/common/stdpp.elpi". +Elpi Accumulate File "HB/common/database.elpi". +Elpi Accumulate File "HB/common/compat_acc_clauses_all.elpi". +Elpi Accumulate File "HB/common/utils.elpi". +Elpi Accumulate File "HB/common/log.elpi". +Elpi Accumulate File "HB/common/synthesis.elpi". +Elpi Accumulate File "HB/context.elpi". +Elpi Accumulate File "HB/instance.elpi". +Elpi Accumulate lp:{{ + +main [const-decl Name (some BodySkel) AritySkel] :- !, std.do! [ + std.assert-ok! (coq.elaborate-arity-skeleton AritySkel _ Arity) "HB: type illtyped", + coq.arity->nparams Arity N, + coq.arity->term Arity Ty, + std.assert-ok! (coq.elaborate-skeleton BodySkel Ty Body) "HB: body illtyped", + with-attributes (with-logging (std.do! [ + log.coq.env.add-const Name Body Ty @transparent! C, + coq.arity->implicits Arity CImpls, + if (coq.any-implicit? CImpls) + (@global! => coq.arguments.set-implicit (const C) [CImpls]) + true, + ])), + M is N - 1, + class-of-nth-arg M Ty Class, + acc-clause current (tag (const C) Class M), +]. +main [str G, str"|", int M] :- !, + coq.locate G GR, + coq.env.typeof GR Ty, + class-of-nth-arg M Ty Class, + acc-clause current (tag GR Class M). + +main _ :- coq.error "Usage: HB.tag Definition ... := T ...\nUsage: HB.tag | ". + +pred class-of-nth-arg i:int, i:term, o:classname. +class-of-nth-arg 0 (prod _ (global S) _\_) Class :- class-def (class Class S _). +class-of-nth-arg 0 (prod _ (app [global S|_]) _\_) Class :- class-def (class Class S _). +class-of-nth-arg N (prod Name Ty Bo) Class :- N > 0, !, M is N - 1, + @pi-decl Name Ty x\ class-of-nth-arg M (Bo x) Class. +class-of-nth-arg 0 T _ :- !, + coq.error "HB: the last parameter of a tag must be of a structure type:" {coq.term->string T}. +class-of-nth-arg _ T _ :- !, + coq.error "HB: not enough argsuments:" {coq.term->string T}. + +}}. +Elpi Typecheck. +Elpi Export HB.tag. + + (* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) (* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) (* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) diff --git a/Makefile b/Makefile index 8f9d3f73..e6b6579d 100644 --- a/Makefile +++ b/Makefile @@ -170,6 +170,6 @@ endif structures.vo : %.vo: __always__ Makefile.coq +$(COQMAKE) $@ -$(addsuffix o,$(wildcard examples/*.v examples/*/*.v tests/*.v tests/unit/*.v)): __always__ config build Makefile.test-suite.coq Makefile.test-suite-stdlib.coq +$(addsuffix o,$(wildcard examples/*.v examples/*/*.v tests/*.v tests/*/*.v tests/unit/*.v)): __always__ config build Makefile.test-suite.coq Makefile.test-suite-stdlib.coq +$(COQMAKE_TESTSUITE) $@ +$(COQMAKE_TESTSUITE_stdlib) $@ diff --git a/Makefile.test-suite.coq.local b/Makefile.test-suite.coq.local index fcba0fe2..96db64e3 100644 --- a/Makefile.test-suite.coq.local +++ b/Makefile.test-suite.coq.local @@ -9,7 +9,7 @@ output_for=`\ DIFF=\ @if [ -z "$$COQ_ELPI_ATTRIBUTES" ]; then \ echo OUTPUT DIFF $(1);\ - $(COQTOP) $(COQFLAGS) $(COQLIBS) -topfile $(1) \ + $(COQTOP) $(COQFLAGS) $(COQLIBS) -w -deprecated-from-Coq -topfile $(1) \ < $(1) 2>&1 \ | sed 's/Coq < *//g' \ | sed 's/Rocq < *//g' \ diff --git a/_CoqProject.test-suite b/_CoqProject.test-suite index 31c827eb..fe9ed2dd 100644 --- a/_CoqProject.test-suite +++ b/_CoqProject.test-suite @@ -65,6 +65,20 @@ tests/bug_447.v tests/unimported_relevant_class.v tests/unimported_irrelevant_class.v +tests/tag_wrap.v +tests/wrap.v +tests/auto_wrap.v + + +tests/MinimalWrapBugs/aboutAutowrap.v +tests/MinimalWrapBugs/aboutAutowrap2.v +tests/MinimalWrapBugs/buildersofwrap.v +tests/MinimalWrapBugs/buildersofwrap2.v +tests/MinimalWrapBugs/canonicalByHand.v +tests/MinimalWrapBugs/mwb.v +tests/MinimalWrapBugs/noglobref.v +tests/MinimalWrapBugs/typeNotInfered.v + -R tests HB.tests -R examples HB.examples diff --git a/tests/MinimalWrapBugs/aboutAutowrap.v b/tests/MinimalWrapBugs/aboutAutowrap.v new file mode 100644 index 00000000..652fb562 --- /dev/null +++ b/tests/MinimalWrapBugs/aboutAutowrap.v @@ -0,0 +1,28 @@ +From HB Require Import structures. + +HB.mixin Record Q T (t : T) := { + q : True +}. + +HB.mixin Record hasPoint T := { + x : T +}. + +HB.structure Definition Pointed := {T of hasPoint T}. + +(* WORKAROUND: *) +(* +#[wrapper] +HB.mixin Record Q__on__Pointed_x T ( _ : Pointed T) := { + private : Q T x +}. + +HB.structure Definition QPointed := {T of hasPoint T & Q__on__Pointed_x T }. + +HB.about QPointed. *) + +HB.structure Definition QPointed := {T of hasPoint T & Q _ (@x T) }. +(* BUG: HB.about fails on structure defined relying on autowrap *) + +HB.about QPointed. +HB.about QPointed.type. diff --git a/tests/MinimalWrapBugs/aboutAutowrap2.v b/tests/MinimalWrapBugs/aboutAutowrap2.v new file mode 100644 index 00000000..3c6e87c7 --- /dev/null +++ b/tests/MinimalWrapBugs/aboutAutowrap2.v @@ -0,0 +1,29 @@ +From HB Require Import structures. + +HB.mixin Record isAssoc T (op : T -> T -> T) := { + opA : True; +}. + +HB.mixin Record hasOp T := { + op' : T -> T -> T +}. + +HB.structure Definition Magma := {T of hasOp T}. + +(* WORKAROUND: *) +(* +#[wrapper] +HB.mixin Record isAssoc__on__Magma_op' T ( _ : Magma T) := { + private : isAssoc T op' +}. + +#[short(type="semigroupType")] +HB.structure Definition Semigroup := {T of Magma T & isAssoc__on__Magma_op' T }. + +HB.about Semigroup. *) + +HB.structure Definition Semigroup := {T of hasOp T & isAssoc _ (@op' T) }. + +(* BUG: HB.about fails on structure defined relying on autowrap *) +HB.about Semigroup. +HB.about Semigroup.type. diff --git a/tests/MinimalWrapBugs/buildersofwrap.v b/tests/MinimalWrapBugs/buildersofwrap.v new file mode 100644 index 00000000..9f840e1d --- /dev/null +++ b/tests/MinimalWrapBugs/buildersofwrap.v @@ -0,0 +1,31 @@ +From HB Require Import structures. + +HB.mixin Record Q T (t : T) := { + q : True +}. + +HB.mixin Record hasPoint T := { + x : T +}. + +HB.structure Definition Pointed := {T of hasPoint T}. + +#[wrapper] +HB.mixin Record Q__on__Pointed_x T ( _ : Pointed T) := { + private : Q T x +}. + +HB.factory Record isQPointed T := { + y : T; + qy : True +}. + +HB.builders Context T of isQPointed T. + +HB.instance Definition _ := hasPoint.Build T y. + +HB.instance Definition _ := Q.Build T x qy. + +HB.end. + +HB.structure Definition QPointed' := {T of isQPointed T}. diff --git a/tests/MinimalWrapBugs/buildersofwrap2.v b/tests/MinimalWrapBugs/buildersofwrap2.v new file mode 100644 index 00000000..0ad1451b --- /dev/null +++ b/tests/MinimalWrapBugs/buildersofwrap2.v @@ -0,0 +1,44 @@ +From HB Require Import structures. + +HB.mixin Record Q T (t : T) := { + q : True +}. + +HB.mixin Record hasPoint T := { + x : T +}. + +HB.structure Definition Pointed := {T of hasPoint T}. + +#[wrapper] +HB.mixin Record Q__on__Pointed_x T ( _ : Pointed T) := { + private : Q T x +}. + +HB.structure Definition QPointed := {T of hasPoint T & Q__on__Pointed_x T }. + +HB.factory Record isQPointed T := { + y : T; + qy : True +}. + +(* WORKAROUND *) + (* HB.builders Context T of isQPointed T. + + HB.instance Definition _ := hasPoint.Build T y. + + HB.instance Definition temp := Q.Build T y qy. + HB.instance Definition _ := Q__on__Pointed_x.Build T temp. + + HB.end. + HB.status. *) + +HB.builders Context T of isQPointed T. + +HB.instance Definition _ := hasPoint.Build T y. + +HB.instance Definition _ := Q.Build T x qy. + +HB.end. + +HB.status. (* BUG: The builder targetting Q__on__Pointed_x is missing *) diff --git a/tests/MinimalWrapBugs/canonicalByHand.v b/tests/MinimalWrapBugs/canonicalByHand.v new file mode 100644 index 00000000..622ef767 --- /dev/null +++ b/tests/MinimalWrapBugs/canonicalByHand.v @@ -0,0 +1,78 @@ +From HB Require Import structures. + +HB.mixin Record IdLaw T (t:T) (l : T -> T) := { + is_id : l t = t; +}. + +HB.structure Definition IdMap T (t:T) := {l of IdLaw T t l}. + +HB.mixin Record IdempotentLaw T (t:T) (l : T -> T) := { + is_sinv : l (l t) = l t; +}. + +HB.structure Definition IdempotentMap T (t:T) := {l of IdempotentLaw T t l}. + + +(* nove very meaningful *) +HB.structure Definition FooMap T (t:T) := {l of IdLaw T t l & IdempotentLaw T t l}. + + +HB.mixin Record hasPoint T := { + point : T +}. +HB.structure Definition Pointed := {T of hasPoint T}. + +HB.mixin Record hasSelfMap T := { + selfmap : T -> T +}. +HB.structure Definition SelfMapped := {T of hasSelfMap T}. + + +HB.structure Definition PointedSelfMapped + := {T of Pointed T & SelfMapped T}. + +#[wrapper] +HB.mixin Record IdLaw__on__PointedSelfMapped_t T of PointedSelfMapped T := { + private : IdLaw T point selfmap +}. +HB.structure Definition IdPSM +:= {T of PointedSelfMapped T & IdLaw__on__PointedSelfMapped_t T}. + +#[wrapper] +HB.mixin Record IdempotentLaw__on__PointedSelfMapped_t T of PointedSelfMapped T := { + private : IdempotentLaw T point selfmap +}. +HB.structure Definition IdemPSM := {T of PointedSelfMapped T & IdempotentLaw__on__PointedSelfMapped_t T}. + +(* HB.structure Definition FooPSM := {T of PointedSelfMapped T & IdPSM T & IdemPSM T}. *) +HB.structure Definition FooPSM := {T of PointedSelfMapped T & IdLaw__on__PointedSelfMapped_t T & IdempotentLaw__on__PointedSelfMapped_t T}. + +Print Canonical Projections selfmap. +HB.saturate (@selfmap _). (* for the instance FooMap on selfmap to exist, one needs the join FooPSM *) +Print Canonical Projections selfmap. + +HB.factory Record BuggyFactory T := { + p : T; + s : T -> T; + sid : s p = p; + sinv : s (s p) = s p +}. + +HB.builders Context T of BuggyFactory T. + +HB.instance Definition _ := hasPoint.Build T p. +HB.instance Definition _ := hasSelfMap.Build T s. + +HB.instance Definition _ := IdLaw.Build T point selfmap sid. +#[verbose] HB.instance Definition _ := IdempotentLaw.Build T point selfmap sinv. + +Check selfmap : IdMap.type T point. +Check selfmap : IdempotentMap.type T point. +Check selfmap : FooMap.type T point. + +HB.end. + +HB.status. + + +Check fun (R : FooPSM.type) => @selfmap R : FooMap.type R (@point R). diff --git a/tests/MinimalWrapBugs/mwb.v b/tests/MinimalWrapBugs/mwb.v new file mode 100644 index 00000000..677cf263 --- /dev/null +++ b/tests/MinimalWrapBugs/mwb.v @@ -0,0 +1,147 @@ +(*Random things to try: +-) replece "True" with "unit" and/or with the actual proerties/definitions +-) Use Module and #[export] +-) Remove the primes "'" +-) make op unary and/or nullary +-) maybe the problem lies in the join with choice? +*) + +From HB Require Import structures. + +HB.mixin Record isAssoc T (op : T -> T -> T) := { + opA : True; +}. + +#[short(type="AssocOpType")] +HB.structure Definition AssocOp T := {op of isAssoc T op}. + +HB.mixin Record isUnital T (idm : T) (op : T -> T -> T) := { + op1m : True; + opm1 : True; +}. + +(* #[short(type="UnitalOpType")] *) +#[export] +HB.structure Definition UnitalOp T idm := {op of isUnital T idm op}. + +(* #[short(type="MonoidOpType")] *) +#[export] +HB.structure Definition MonoidOp T idm + := {op of isAssoc T op & isUnital T idm op}. + +HB.factory Record isMonoidOp T (idm : T) (op : T -> T -> T) := { + opA' : True; + op1m' : True; + opm1' : True; +}. + +HB.builders Context T idm op of isMonoidOp T idm op. + +HB.instance Definition _ := isAssoc.Build T op opA'. +HB.instance Definition _ := isUnital.Build T idm op op1m' opm1'. + +HB.end. + + +HB.mixin Record hasOp T := { + op' : T -> T -> T +}. + +(* #[short(type="MagmaType")] *) +HB.structure Definition Magma := {T of hasOp T}. + +(* +(*BUG: HB.about fails on structure defined relying on autowrap *) + (* #[short(type="semigroupType")] *) + HB.structure Definition Semigroup := {T of hasOp T & isAssoc _ (@op' T) }. + HB.about Semigroup. + HB.about Semigroup.type. + (* Anomaly "Uncaught exception Failure("split_dirpath")."*) + Print wrapper_xx_op'_mwb_isAssoc. *) + +#[wrapper] +HB.mixin Record isAssoc__on__Magma_op' T ( _ : Magma T) := { + private : isAssoc T op' +}. + +#[short(type="semigroupType")] +HB.structure Definition Semigroup := {T of Magma T & isAssoc__on__Magma_op' T }. + +HB.about Semigroup. +HB.about Semigroup.type. + + +HB.factory Record isSemigroup T := { + op'' : T -> T -> T; + opA'' : True +}. + +HB.builders Context G of isSemigroup G. + +HB.instance Definition _ := hasOp.Build G op''. + +(*BUG: the following line does not generate the correspoinding builder*) + (* HB.instance Definition _ := isAssoc.Build G op'' opA''. *) + +HB.instance Definition temp := isAssoc.Build G op'' opA''. +HB.instance Definition _ := isAssoc__on__Magma_op'.Build G temp. + +HB.end. + +HB.mixin Record hasOne T := { + one : T +}. + +HB.structure Definition PointedMagma := {G of hasOne G & Magma G}. + +#[wrapper] +HB.mixin Record isUnital__on__Magma_op' T of PointedMagma T := { + private : isUnital T one op' +}. + +#[short(type="UnitalMagmaType")] +HB.structure Definition UnitalMagma + := {T of PointedMagma T & isUnital__on__Magma_op' T }. + +HB.factory Record isUnitalMagma T of Magma T := { + one' : T; + op1m'' : True; + opm1'' : True +}. + +HB.builders Context T of isUnitalMagma T. + +HB.instance Definition _ := hasOne.Build T one'. + +(*BUG: The one' (from the factory) is not recognized as the one (from hasOne) if the type of temp is not explicity given*) +(* HB.instance Definition temp + : isUnital.phant_axioms T one' op' + (*you can either comment or not the previous line specifying the type, the instruction will fail anyway (the workaround is to remove the prime from one)*) + (*BUG: the "correct" type is not infered *) + := isUnital.Build T one' op' op1m'' opm1''. *) +(* [...] The [...] term has type "isUnital.phant_axioms T one' op'" + which should be a subtype of "isUnital.phant_axioms T one op'". *) +(* NOTE: They are judgmentally equal though*) +Check eq_refl +: isUnital.phant_axioms T one' op' += isUnital.phant_axioms T one op'. + +(* In monoid.v the T can be implicit, is it correctly infered? *) +(* In monoid.v one and one' have the same name*) + + +HB.instance Definition temp +: isUnital.phant_axioms T one op' +:= isUnital.Build T one' op' op1m'' opm1''. + +(* other working alternative: *) +(* HB.instance Definition temp +:= isUnital.Build T one op' op1m'' opm1''. *) + + +HB.instance Definition _ := isMonoidLaw__on__BaseUMagma_MulOne.Build G pippo. +Check isUnital.phant_axioms T one' op'. +Check isUnital.phant_axioms T one op'. + +HB.end. + diff --git a/tests/MinimalWrapBugs/noglobref.v b/tests/MinimalWrapBugs/noglobref.v new file mode 100644 index 00000000..ff07f008 --- /dev/null +++ b/tests/MinimalWrapBugs/noglobref.v @@ -0,0 +1,7 @@ +From HB Require Import structures. + +HB.mixin Record isLaw T (l:T) (op : T) := { + opA : True; +}. + +Fail HB.structure Definition Law T l := {op of isLaw T l op}. diff --git a/tests/MinimalWrapBugs/typeNotInfered.v b/tests/MinimalWrapBugs/typeNotInfered.v new file mode 100644 index 00000000..10b31a07 --- /dev/null +++ b/tests/MinimalWrapBugs/typeNotInfered.v @@ -0,0 +1,63 @@ +From HB Require Import structures. + +HB.mixin Record Q T (l r : T) := { + q : True +}. + +HB.mixin Record hasLeft T := { + sx : T +}. +HB.structure Definition Lefted := {T of hasLeft T}. + +HB.mixin Record hasRight T := { + dx : T +}. +HB.structure Definition Righted := {T of hasRight T}. + +HB.structure Definition Ambidextrous + := {T of Lefted T & Righted T}. + +#[wrapper] +HB.mixin Record Q__on__Ambidextrous_dx T of Ambidextrous T := { + private : Q T sx dx +}. + +HB.structure Definition QAmbidextrous + := {T of Ambidextrous T & Q__on__Ambidextrous_dx T}. + +HB.factory Record isQAmbidextrous T := { + l : T; + r : T; + qlr : True +}. + +HB.builders Context T of isQAmbidextrous T. + +HB.instance Definition _ := hasLeft.Build T l. +HB.instance Definition _ := hasRight.Build T r. + +(*WORKAROUND*) + (* HB.instance Definition temp + : Q.axioms_ T sx dx + := Q.Build T l dx qlr. *) + +(*other WORKAROUND*) + (* HB.instance Definition temp + := Q.Build T sx dx qlr. *) + +(*other WORKAROUND*) + (* HB.instance Definition temp + := Q.Build T sx r qlr. *) + (* is it ok that this work?*) + +(*BUG: Despite being judgmentally equal using the data from the factory or from the infered structure is relevant (note that, in practice, they can have the same name)*) +Check eq_refl : l = sx. +Check eq_refl : r = dx. + + +HB.instance Definition temp +(* : Q.axioms_ T l dx *) +:= Q.Build T l dx qlr. + +(* HB.instance Definition _ := Q__on__Ambidextrous_dx.Build T temp. *) +HB.end. \ No newline at end of file diff --git a/tests/auto_wrap.v b/tests/auto_wrap.v new file mode 100644 index 00000000..018c9e8c --- /dev/null +++ b/tests/auto_wrap.v @@ -0,0 +1,20 @@ +From HB Require Import structures. + +HB.mixin Record isAssoc T (op : T -> T -> T) := { opA : forall x y z, op (op x y) z = op x (op y z) }. +HB.structure Definition Assop T := { op of isAssoc T op }. + + +HB.mixin Record hasOp T := { op : T -> T -> T }. +HB.structure Definition Magma := { T of hasOp T }. + +(* HB.structure Definition Monoid := { T of hasOp T & isAssoc T op }. *) +(* HB.structure Definition Monoid := { T of hasOp T & isAssoc _ (op : T -> _ -> _) }. *) +HB.structure Definition Monoid := { T of hasOp T & isAssoc _ (@op T) }. + +Axiom plus_ass : forall x y z, plus (plus x y) z = plus x (plus y z). + +HB.instance Definition _ : hasOp nat := hasOp.Build nat plus. +(* HB.instance Definition _ : isAssoc nat plus := isAssoc.Build nat plus plus_ass. *) +HB.instance Definition _ : isAssoc nat op := isAssoc.Build nat plus plus_ass. + +Check nat : Monoid.type. \ No newline at end of file diff --git a/tests/hnf.v b/tests/hnf.v index b219a6a8..a36d1e6f 100644 --- a/tests/hnf.v +++ b/tests/hnf.v @@ -14,5 +14,5 @@ Print HB_unnamed_mixin_8. HB.instance Definition _ := f.Build bool (3 + 2). Print Datatypes_bool__canonical__hnf_S. -Print HB_unnamed_mixin_12. +Print hnf_f__to__hnf_M__11. diff --git a/tests/not_same_key.v.out b/tests/not_same_key.v.out index b04461f4..21820874 100644 --- a/tests/not_same_key.v.out +++ b/tests/not_same_key.v.out @@ -1,2 +1,3 @@ The command has indeed failed with message: -HB: all mixins must have the same key +HB: expecting a factory on T +or a factory on a structure operation or tag. Got: B.phant_axioms T T1 diff --git a/tests/tag_wrap.v b/tests/tag_wrap.v new file mode 100644 index 00000000..d8768fc4 --- /dev/null +++ b/tests/tag_wrap.v @@ -0,0 +1,39 @@ +From HB Require Import structures. + +HB.mixin Record isSomething T := { clearly : True }. +HB.structure Definition Something := { T of isSomething T }. + +HB.mixin Record isSomethingElse (T : Type) := { p : True }. + +HB.tag Definition tag1 (T : Something.type) : Type := T. + +#[wrapper] +HB.mixin Record tag1_isSomethingElse T of Something T := { + private : isSomethingElse (tag1 T) +}. + +HB.tag Definition tag2 (T : Something.type) : Type := T. + +#[wrapper] +HB.mixin Record tag2_isSomethingElse T of Something T := { + private : isSomethingElse (tag2 T) +}. + +(* This is a bug, maybe even in master. If I declare an instance on a mixin + which leads to no new structure instance, then the mixin is not use later + on *) +HB.structure Definition magic1 := { T of + isSomething T & + isSomethingElse (tag1 T) +}. + +HB.structure Definition magic := { T of + isSomething T & + isSomethingElse (tag1 T) & + isSomethingElse (tag2 T) +}. + +HB.instance Definition _ : isSomething nat := isSomething.Build nat I. +HB.instance Definition _ : isSomethingElse (tag1 nat) := isSomethingElse.Build nat I. +HB.instance Definition _ : isSomethingElse (tag2 nat) := isSomethingElse.Build nat I. +Check nat : magic.type. diff --git a/tests/unit/close_hole_term.v b/tests/unit/close_hole_term.v index 6370fe04..61ff98f9 100644 --- a/tests/unit/close_hole_term.v +++ b/tests/unit/close_hole_term.v @@ -21,7 +21,7 @@ inj x y : S (f x) (f y) -> R x y. Elpi Query HB.structure lp:{{ Y = {{Inj}}, %Inj has 5 implicit arguments - saturate-type-constructor Y X, + saturate-type-constructor 0 Y X, % X needs to be typechecked here to get rid of the holes of the types of its arguments coq.typecheck X _ ok, abstract-holes.main X Z, diff --git a/tests/unit/enrich_type.v b/tests/unit/enrich_type.v index b25bdeba..21e9061c 100644 --- a/tests/unit/enrich_type.v +++ b/tests/unit/enrich_type.v @@ -3,18 +3,18 @@ From elpi Require Import elpi. From Corelib Require Export Setoid. Elpi Query HB.structure lp:{{ - saturate-type-constructor {{nat}} X, + saturate-type-constructor 0 {{nat}} X, std.assert! (X = {{nat}}) "wrong enriched type" }}. Elpi Query HB.structure lp:{{ - saturate-type-constructor {{list}} X, + saturate-type-constructor 0 {{list}} X, std.assert! (X = app [{{list}}, Y_]) "wrong enriched type" }}. Elpi Query HB.structure lp:{{ Y = (x \ (y \ {{(prod (list lp:x) (list lp:y))}})), - saturate-type-constructor (Y _ _) X, + saturate-type-constructor 0 (Y _ _) X, std.assert! (X = (app [{{prod}}, (app[{{list}},X1_]), app[{{list}},C_]])) "wrong enriched type" }}. @@ -22,6 +22,6 @@ Class Inj {A B} (R : relation A) (S : relation B) (f : A -> B) : Prop := inj x y : S (f x) (f y) -> R x y. Elpi Query HB.structure lp:{{ - saturate-type-constructor {{Inj}} X, + saturate-type-constructor 0 {{Inj}} X, std.assert! (X = app [(global (const Inj_)), A_, B_, R_, S_, F_]) "wrong enriched type" }}. diff --git a/tests/wrap.v b/tests/wrap.v new file mode 100644 index 00000000..4914237e --- /dev/null +++ b/tests/wrap.v @@ -0,0 +1,24 @@ +From HB Require Import structures. + +HB.mixin Record isAssoc T (op : T -> T -> T) := { opA : forall x y z, op (op x y) z = op x (op y z) }. +HB.structure Definition Assop T := { op of isAssoc T op }. + + +HB.mixin Record hasOp T := { op : T -> T -> T }. +HB.structure Definition Magma := { T of hasOp T }. + + +#[wrapper] +HB.mixin Record isAssoc__for__Magma_op T of Magma T := { + private : isAssoc T op +}. + +HB.structure Definition Monoid := { T of hasOp T & isAssoc__for__Magma_op T }. + +Axiom plus_ass : forall x y z, plus (plus x y) z = plus x (plus y z). + +HB.instance Definition _ : hasOp nat := hasOp.Build nat plus. +(* HB.instance Definition _ : isAssoc nat plus := isAssoc.Build nat plus plus_ass. *) +HB.instance Definition _ : isAssoc nat op := isAssoc.Build nat plus plus_ass. + +Check nat : Monoid.type. \ No newline at end of file