[feat] support for multiple subjects

HB/about.elpi

@@ -73,6 +73,11 @@ bulletize L F (glue [brk 0 0 | PLB]) :-
 
 % Print shortest qualified identifier of the module containing a gref
 func pp-module gref -> 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.
 
 func unif-hint? cs-instance -> .

HB/builders.elpi

@@ -28,7 +28,7 @@ begin CtxSkel :-
 
 }
 
-% "end" is a keyword, be put it in the namespace by hand
+% "end" is a keyword, we put it in the namespace by hand
 func builders.end.
 builders.end :- std.do! [
   current-mode (builder-from _ _ _ ModName),

HB/common/database.elpi

@@ -51,10 +51,10 @@ func module-to-export_module-nice prop -> id.
 module-to-export_module-nice (module-to-export _ M _) M.
 
 func instance-to-export_instance prop -> constant.
-instance-to-export_instance (instance-to-export _ _ M) M.
+instance-to-export_instance (instance-to-export _ M) M.
 
 func instance-to-export_instance-nice prop -> 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.
 
 func abbrev-to-export_name prop -> id.
 abbrev-to-export_name (abbrev-to-export _ N _) N.
@@ -77,6 +77,10 @@ sub-class? (class C1 _ ML1P) (class C2 _ ML2P) :-
   list-w-params_list ML2P ML2,
   std.forall ML2 (m2\ std.exists! ML1 (m1\ m1 = m2)).
 
+func sub-classname? classname, classname -> .
+sub-classname? C1 C2 :-
+  sub-class? {classname->def C1} {classname->def C2}.
+
 % [factory-provides F MLwP] computes the mixins MLwP generated by F
 func factory-provides factoryname -> mixins.
 factory-provides FactoryAlias MLwP :- std.do! [
@@ -177,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
 func toposort-classes.mk-class-edge prop -> pair classname classname.
 toposort-classes.mk-class-edge (sub-class C1 C2 _ _) (pr C2 C1).
@@ -439,12 +445,15 @@ structure-nparams Structure NParams :-
   factory->nparams Class NParams.
 
 func factory? term -> w-args factoryname.
-factory? S (triple F Params T) :-
+factory? S (triple F Params T) :- factory?-split S F [_|Params] T _.
+
+func factory?-split term -> factoryname, list term, term, 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.
@@ -464,3 +473,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 _.

HB/common/synthesis.elpi

@@ -20,6 +20,7 @@ infer-all-these-mixin-args Ps T ML F SFX :- std.do! [
   std.assert-ok! (coq.typecheck F Ty) "try-infer-these-mixin-args: F illtyped",
   coq.mk-eta (-1) Ty F EtaF,
   coq.subst-fun {std.append Ps [T]} EtaF FT,
+  % coq.say "instantiate-all-these-mixin-args on" {coq.term->string FT}, 
   private.instantiate-all-these-mixin-args FT T ML SFX,
 ].
 
@@ -74,12 +75,19 @@ 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
-func assert!-infer-mixin term, mixinname -> term.
-assert!-infer-mixin T M B :-
-  if (private.mixin-for T M B)
+func assert!-infer-mixin term, mixinname -> term, term.
+assert!-infer-mixin T M B Ty :-
+  if (private.mixin-for T M B Ty)
      true
      (coq.error "HB: cannot inhabit mixin"
        {nice-gref->string M} "on"{coq.term->string T}).
@@ -96,7 +104,7 @@ local-canonical-mixins-of.aux T [S|Ss] MSL'' :- std.do! [
 	].
 
 func local-canonical-mixins-of term -> list prop.
-local-canonical-mixins-of T MSL :- std.do! [
+local-canonical-mixins-of T MSL :- std.time-do! "local-canonical-mixins-of" [
   get-canonical-structures T CS,
 	std.map CS (s\c\ sigma w\ class-def (class c s w)) Cl,
 	toposort-classes Cl ClSorted,
@@ -112,6 +120,17 @@ under-mixin-src-from-factory.do! TheType TheFactory LP :-
   std.map ML (m\c\ c = mixin-src TheType m TheFactory) MLClauses,
   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 +182,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.
 
 :index (_ _ 2)
@@ -183,18 +203,26 @@ namespace private {
 
 % [mixin-for T M MI] synthesizes an instance of mixin M on type T using
 % the databases [mixin-src] and [from]
-func mixin-for term, mixinname -> term.
-mixin-for T M MICompressed :- mixin-src T M Tm, !,
+func mixin-for term, mixinname -> term, term.
+mixin-for T M MICompressed MICompressedTy :- mixin-src T M Tm, !,
   %if-verbose (coq.say {header} "Trying to infer mixin for" M),
   std.assert-ok! (coq.typecheck Tm Ty) "mixin-for: Tm illtyped",
 
 %%%%% mterm %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
-  factory? Ty (triple Factory Params _),
+  factory? Ty (triple Factory Params Subj),
 
-  if (M = Factory) (MI = Tm) (
-      private.builder->term Params T Factory M B,
-      coq.subst-fun [Tm] B MI
+  if (M = Factory)
+  (
+      if-verbose (coq.say {header} "Found mixin has type" Factory "on" Subj "no need to apply a builder"),
+      MI = Tm, MICompressedTy = Ty
+  )
+  (
+      if-verbose (coq.say {header} "Found mixin has type" Factory "on" Subj "hence we apply a builder"),
+
+      private.builder->term Params T Factory Tm M MI MITy, MICompressedTy = MITy
+      % private.builder->term Params T Factory M B,
+      % coq.subst-fun [Tm] B MI
   ),
 
   %if-verbose (coq.say {header} "Trying to compress mixin for" {coq.term->string MI}),
@@ -226,18 +254,25 @@ compress-coercion-paths MI MICompressed :-
      (MI = MICompressed).
 
 func mixin-for_mixin-builder prop -> term.
-mixin-for_mixin-builder (mixin-for _ _ B) B.
+mixin-for_mixin-builder (mixin-for _ _ B _) B.
 
 % [builder->term Params TheType Src Tgt MF] finds a builder from Src to Tgt
 % and fills in all the mixins required by the builder using mixin-src, obtaining
 % a function (MF = Builder Params TheType InferredStuff : Src -> Tgt)
-func builder->term list term, term, factoryname, mixinname -> term.
-builder->term Ps T Src Tgt B :- !, std.do! [
+func builder->term list term, term, factoryname, term, mixinname -> term, term.
+builder->term Ps T Src HasSrc Tgt B1 BTy :- !, std.do! [
   from Src Tgt FGR,
   F = global FGR,
   gref->deps Src MLwP,
   list-w-params_list MLwP ML,
-  infer-all-these-mixin-args Ps T ML F B,
+  if-verbose (coq.say {header} "Found builder" FGR "from" Src "to" Tgt),
+  if-verbose (coq.say {header} "Found builder" FGR "depends on" ML),
+  % infer-all-these-mixin-args Ps T ML F B,
+  coq.mk-n-holes {std.length ML} Holes,
+  coq.mk-app F {std.flatten [Ps,[T],Holes,[HasSrc]]} B,
+  std.time (std.assert-ok! (coq.typecheck B BTy) "builder illtyped") _Time1,
+  B = B1
+
 ].
 
 % [instantiate-all-these-mixin-args T F M_i TFX] where mixin-for T M_i X_i states that
@@ -250,9 +285,12 @@ func instantiate-all-these-mixin-args term, term, list mixinname -> term.
 instantiate-all-these-mixin-args (fun _ Tm F) T ML R :-
   coq.safe-dest-app Tm (global TmGR) _,
   factory-alias->gref TmGR M ok,
+  if-verbose (coq.say {header} "Looking at argument" M),
   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}), !,
+  if-verbose (coq.say {header} "We have to inhabit it on" T),
+  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.
 instantiate-all-these-mixin-args (fun N Ty F) T ML (fun N Ty FX) :- !,
   @pi-decl N Ty m\ instantiate-all-these-mixin-args (F m) T ML (FX m).
@@ -262,14 +300,24 @@ func instantiate-all-args-let term, term -> term, diagnostic.
 instantiate-all-args-let (fun N Tm F) T (let N Tm X R) Diag :- !, std.do! [
   coq.safe-dest-app Tm (global TmGR) _,
   factory-alias->gref TmGR M ok,
-  if (mixin-for T M X)
+  if (mixin-for T M X _)
      (@pi-def N Tm X m\ instantiate-all-args-let (F m) T (R m) Diag)
      (Diag = error Msg,
       Msg is "cannot synthesize mixin " ^ {nice-gref->string M} ^
              " for " ^ {coq.term->string T}),
 ].
 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
@@ -315,7 +363,7 @@ structure-instance->mixin-srcs.aux T  F CL :-
 % which can be generated by the factory instance FI which are not part of
 % OldMixins (that is, the contribution of FI to the current context)
 func factory-instance->new-mixins list mixinname, term -> list mixinname.
-factory-instance->new-mixins OldMixins X NewML :-
+factory-instance->new-mixins OldMixins X NewML :- std.time-do! "factory-instance->new-mixins" [
   std.assert-ok! (coq.typecheck X XTy) "mixin-src: X illtyped",
   if (not (coq.safe-dest-app XTy (global _) _))
      (coq.error "Term:\n" {coq.term->string X}
@@ -325,6 +373,7 @@ factory-instance->new-mixins OldMixins X NewML :-
   coq.term->gref XTy Src,
   factory-provides Src MLwP,
   list-w-params_list MLwP ML,
-  std.filter ML (m\ not(std.mem! OldMixins m)) NewML.
+  std.filter ML (m\ not(std.mem! OldMixins m)) NewML,
+].
 
 }}

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).
 
 func if-verbose (func) -> .

HB/common/utils.elpi

@@ -95,6 +95,7 @@ cs-pattern->name (cs-gref GR) Name :- gref->modname-label GR 1 "_" Name.
 
 
 func string->modpath string -> modpath.
+string->modpath "" _ :- !, fail. % bug in 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].
@@ -104,7 +105,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
@@ -113,7 +115,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.
+
 
 func avoid-name-collision string -> string.
 avoid-name-collision S S1 :-
@@ -314,7 +318,7 @@ pack? (indc K) C :-
   coq.env.indc K _ _ _ KTy, prod-last-gref KTy (indt I), % TODO: use new API
   std.once (class-def (class C (indt I) _)).
 
-func distribute-w-params list-w-params A -> list (one-w-params A).
+func distribute-w-params w-params (list A) -> 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 :-
@@ -336,6 +340,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.
 
+func disable-id-phant-indt-decl indt-decl -> 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.
+
+func re-enable-id-phant-indt-decl indt-decl -> 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.
+
 func prod-last term -> term.
 prod-last (prod N S X) Y :- !, @pi-decl N S x\ prod-last (X x) Y.
 prod-last X X :- !.
@@ -345,8 +361,56 @@ 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
-func saturate-type-constructor term -> term.
-saturate-type-constructor T ET :- 
+func saturate-type-constructor int, term -> 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.
+
+pred time-ctx o:string.
+func time-ctx->id (pred) -> string.
+time-ctx->id (time-ctx S) S.
+
+func with-time string, (func).
+with-time Cmd P :-
+  std.once(get-option "elpi.loc" L),
+  loc.fields L File _ _ Line _,
+  std.any->string Line LineS,
+  Header is File ^ ": " ^ LineS ^ ": " ^ Cmd ^ ": ",
+  time-ctx Header => P.
+
+func std.time-do!-report float -> .
+std.time-do!-report Begin :- std.do! [
+  gettimeofday End,
+  T is End - Begin,
+  std.findall (time-ctx _) CTX,
+  std.map CTX time-ctx->id CTXS,
+  std.rev CTXS [Header | Rest],
+  coq.say {calc (Header ^ {std.string.concat "." Rest} ^": " ^ {std.any->string T})}
+].
+
+func std.time-do! string, list (pred).
+std.time-do! S L :- get-option "verbose" tt, !,
+  gettimeofday Begin,
+  time-ctx S => if (std.do! L) (std.time-do!-report Begin) (std.time-do!-report Begin, fail). 
+std.time-do! _ L :- !, std.do! L.
+
+func term->size term -> int.
+term->size (app L) N :- !,
+  std.fold {std.map L term->size} 0 (x\a\r\r is x + a) M,
+  N is M + 1.
+term->size (fun _ T B) O :- !, term->size T N, pi x\ term->size (B x) M, O is N + M + 1.
+term->size (prod _ T B) O :- !, term->size T N, pi x\ term->size (B x) M, O is N + M + 1.
+term->size (let _ T X B) O :- !, term->size T N, term->size X N', pi x\ term->size (B x) M, O is N + N' + M + 1.
+term->size _ 1.