hb.elpi

/*        Hierarchy Builder: algebraic hierarchies made easy
    This software is released under the terms of the MIT license              */

%%%%%%% Naming converntions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

/*
   - under-foobar.do! Arg [ Code ]
     enriches the context with foobar, the runs std.do! [ Code ]
   - under-foobar.then Arg F Out
     enriches the context with foobar, the runs F Out, as a consequence
     the spilling expression {under-foobar.then Arg F} can be used
   - foo_bar
     projection from foo to its field bar
   - foo->bar
     conversion from type foo to type bar (it can be arbitrarily complex)
   - get-foobar
     reads foobar from the Coq world
   - findall-foobar
     reads foobar from hb.db, the output is sorted whenever it makes sense
   - main-foobar
     main entry point for a user facing (or almost user facing) command foobar
   - declare-foobar
     predicate adding to the Coq ennvironment a foobar
   - postulate-foobar
     predicate assuming a foobar (declaring a Coq section variable)
   - TheType, TheClass, TheFoobar
     the thing the current code is working on, eg the type of the structure
     begin defined
   - FooAlias
     see phant-abbrev, used to talk about the non canonical name of Foo
   - when foo is the constructor of a data type with type A1 -> .. -> AN -> t
     we define mk-foo as:
       mk-foo A1 .. AN (foo A1 .. AN)
*/

shorten coq.{ term->gref, subst-fun, safe-dest-app, mk-app, mk-eta, subst-prod }.

%%%%%%%%% Elpi Utils %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% This code could be moved in Elpi's standard library

% printing the local mixin context
pred print-ctx.
print-ctx :- declare_constraint print-ctx [].
constraint print-ctx mixin-src {
  rule \ (G ?- print-ctx) | (coq.say "The context is:" G).
}

% TODO: pred toposort i:(A -> A -> prop), i:list A, o:list A.
%       pred edge? i:int, i:int.
%       toposort edge? [1,2,3,4] TopoList
pred topovisit i: list (pair A A), i: A,      i: list A, i: list A, o: list A, o: list A.
topovisit _ X VS PS VS PS :- std.mem PS X, !.
topovisit _ X VS _ _ _ :- std.mem VS X, !, halt "cycle detected.".
topovisit ES X VS PS VS' [X|PS'] :-
  toporec ES {std.map {std.filter ES (e\ fst e X)} snd} [X|VS] PS VS' PS'.
pred toporec   i: list (pair A A), i: list A, i: list A, i: list A, o: list A, o: list A.
toporec _ [] VS PS VS PS.
toporec ES [X|XS] VS PS VS'' PS'' :-
  topovisit ES X VS PS VS' PS', toporec ES XS VS' PS' VS'' PS''.
pred toposort i: list (pair A A), i: list A, o: list A.
toposort ES XS XS'' :-
  toporec ES XS [] [] _ XS',
  std.filter XS' (std.mem XS) XS''.

pred bubblesort i:list A, i:(A -> A -> prop), o:list A.
bubblesort [] _ [] :- !.
bubblesort [X] _ [X] :- !.
bubblesort [X,Y|TL] Rel [X|Rest1] :- Rel X Y, !, bubblesort [Y|TL] Rel Rest1.
bubblesort [X,Y|TL] Rel [Y|Rest1] :- bubblesort [X|TL] Rel Rest1.

pred list-diff i:list A, i:list A, o:list A.
list-diff X [] X.
list-diff L [D|DS] R :-
  std.filter L (x\ not(x = D)) L1,
  list-diff L1 DS R.

pred list-eq-set i:list A, i:list A.
list-eq-set L1 L2 :- list-diff L1 L2 [], list-diff L2 L1 [].

pred under.do! i:((A -> Prop) -> A -> prop), i:list prop.
under.do! Then LP :- Then (_\ std.do! LP) _.

%%%%% Logging Utils %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

pred logger o:list coq.pp, o:bool.

pred logger-extend i:list coq.pp, i:coq.pp.
logger-extend [] _ :- coq.error "HB: logger was closed".
logger-extend (uvar as X) V :- X = [V|FRESH_].
logger-extend [_|XS] V :- logger-extend XS V.

pred logger-close i:list coq.pp.
logger-close (uvar as X) :- X = [].
logger-close [_|XS] :- logger-close XS.

pred log-vernac i:coq.vernac.
log-vernac V :- logger L Nice, !,
  if (Nice = tt) (PPALL = []) (PPALL = [@ppmost!]),
  logger-extend L {PPALL => coq.vernac->pp [V]}.
log-vernac _.

pred with-logging i:prop.
with-logging P :- get-option "log" tt,
  logger L tt => P,
  logger-close L,
  std.intersperse coq.pp.spc L PP,
  coq.pp->string (coq.pp.box (coq.pp.v 0) PP) S,
  coq.say "(* \n" S "\n*)".
with-logging P :- get-option "elpi.log_hb" _, % env variable
  logger L ff => P,
  logger-close L,
  std.intersperse coq.pp.spc L PP,
  coq.pp->string (coq.pp.box (coq.pp.v 0) PP) S,
  get-option "elpi.loc" Loc,
  rex_split "," Loc [FILE|_],
  FILENAME is FILE ^ ".hb",
  open_append FILENAME OC,
  std.string.concat "\n" ["","HIERARCHY BUILDER PATCH",Loc,S] PATCH,
  output OC PATCH,
  close_out OC.
with-logging P :- P.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Coq document

% This is a very minimalistic AST to represent a Coq document equipped with
% pretty printing facilities.
%
% When "complete enough" this should be moved to coq-elpi proper.

kind coq.vernac type.
type coq.vernac.begin-module  string -> option string       -> coq.vernac.
type coq.vernac.end-module    string                        -> coq.vernac.
type coq.vernac.begin-section string                        -> coq.vernac.
type coq.vernac.end-section   string                        -> coq.vernac.
type coq.vernac.import-module string                        -> coq.vernac.
type coq.vernac.export-module string                        -> coq.vernac.
type coq.vernac.definition    string -> option term -> term -> coq.vernac.
type coq.vernac.variable      string -> term                -> coq.vernac.
type coq.vernac.inductive     indt-decl                     -> coq.vernac.
type coq.vernac.abbreviation  string -> int -> term         -> coq.vernac.
type coq.vernac.coercion      string -> gref -> class       -> coq.vernac.
type coq.vernac.canonical     string                        -> coq.vernac.
type coq.vernac.implicit      string -> list implicit_kind  -> coq.vernac.
type coq.vernac.comment       A                             -> coq.vernac.

% The main entry point to print vernacular commands is coq.vernac->pp

{
shorten coq.vernac.{ begin-module , end-module , begin-section, end-section }.
shorten coq.vernac.{ import-module , export-module }.
shorten coq.vernac.{ definition , variable , comment }.
shorten coq.{ vernac.inductive , vernac.implicit }.
shorten coq.vernac.{ canonical , abbreviation , coercion }.
shorten coq.pp.{ box , h , spc , v , str , hv , hov, glue, brk }.

pred coq.vernac->pp i:list coq.vernac, o:coq.pp.
coq.vernac->pp L (box (v 0) L2) :-
  std.map L coq.vernac->pp1 L1,
  std.intersperse spc L1 L2.

pred coq.vernac->pp1 i:coq.vernac, o:coq.pp.
coq.vernac->pp1 (begin-module Name none) PP :-
  PP = box h [str "Module ", str Name, str "."].
coq.vernac->pp1 (begin-module Name (some TyName)) PP :-
  PP = box h [str "Module ", str Name, str " : ", str TyName, str "."].
coq.vernac->pp1 (end-module Name) PP :-
  PP = box h [str "End ", str Name, str "."].
coq.vernac->pp1 (begin-section Name) PP :-
  PP = box h [str "Section ", str Name, str "."].
coq.vernac->pp1 (end-section Name) PP :-
  PP = box h [str "End ", str Name, str "."].
coq.vernac->pp1 (definition Name none Body) PP :-
  PP = box (hv 2) [str "Definition ", str Name, str " :=", spc, B, str "."],
  coq.term->pp Body B.
coq.vernac->pp1 (definition Name (some Ty) Body) PP :-
  PP = box (hv 2) [str "Definition ", str Name, str " : ", T, str " :=", spc, B, str "."],
  coq.term->pp Ty T,
  coq.term->pp Body B.
coq.vernac->pp1 (variable Name Ty) (box (hv 2) [box h [str "Variable ", str Name, str " :"], spc, TY, str "."]) :-
  coq.term->pp Ty TY.
coq.vernac->pp1 (import-module Name) (box h [str "Import ", str Name, str "."]).
coq.vernac->pp1 (export-module Name) (box h [str "Export ", str Name, str "."]).
coq.vernac->pp1 (abbreviation Name NParams Term) (box (hv 2) [box h [str "Notation ",str Name|StrParams], str " :=", spc, B, str "."]) :-
  coq.vernac->ppabbrterm NParams Term StrParams B.
coq.vernac->pp1 (canonical Name) (box h [str "Canonical ", str Name, str "."]).
coq.vernac->pp1 (coercion Name SRC TGT) (box h [str "Coercion ", str Name, str " : ", str S, str " >-> ", str T, str "."]) :-
  coq.gref->path SRC SP, std.string.concat "." {std.take-last 2 SP} S,
  if2 (TGT = sortclass) (T = "Sortclass")
      (TGT = funclass)  (T = "Funclass")
                        (TGT = grefclass GR, coq.gref->path GR GRP, std.string.concat "." {std.take-last 2 GRP} T).
coq.vernac->pp1 (vernac.inductive I) PP :-
  coq.vernac->ppinductive I [] PP.
coq.vernac->pp1 (vernac.implicit Name []) (box h [str "Arguments ", str Name, str " : clear implicits."]).
coq.vernac->pp1 (vernac.implicit Name L) (box h [str "Arguments ", str Name, spc, glue PP, str "."]) :-
  std.map L coq.vernac->ppimparg PP1,
  std.intersperse spc PP1 PP.
coq.vernac->pp1 (comment A) (box (hov 2) [str"(*", str S, str"*)"]) :-
  std.any->string A S.


pred coq.vernac->ppimparg i:implicit_kind, o:coq.pp.
coq.vernac->ppimparg explicit (str "_").
coq.vernac->ppimparg maximal  (str "{_}").
coq.vernac->ppimparg implicit (str "[_]").

pred coq.vernac->ppinductive i:indt-decl, i:list (pair implicit_kind term), o:coq.pp.
coq.vernac->ppinductive (parameter ID IMPL TY I) Acc R :-
  @pi-parameter ID TY p\ coq.vernac->ppinductive (I p) [pr IMPL p|Acc] R.
coq.vernac->ppinductive (record ID SORT KID RD) ParamsRev PP :-
  PP = (box (hov 0) [
         box (hov 0) [str "Record", spc, str ID, brk 1 4, glue ParamsPP,
                      str " : ", SortPP, brk 1 2, str":= ", str KID],
         brk 1 2,
         box (hv 2) [str"{", spc, glue FieldsPP, str"}"],
         str"."]),
  std.rev ParamsRev Params,
  coq.vernac->ppinductiveparams Params ParamsPP,
  coq.term->pp SORT SortPP,
  coq.vernac->pprecordfields RD FieldsPP.
coq.vernac->ppinductive (inductive ID IsInd Arity Ks) ParamsRev PP :-
  PP = (box (hov 0) [
         str CO,str "Inductive", spc,
         box (hov 0) [
           str ID, brk 1 4, glue ParamsPP, ArityPP, str " :="],
         brk 0 2,
         box (hv 2) [str"  ", glue KsPp],
         str "."]),
  std.rev ParamsRev Params,
  coq.vernac->ppinductiveparams Params ParamsPP,
  std.map Params snd ParamsAsArgs,
  if (IsInd = tt) (CO = "") (CO = "Co"),
  coq.arity->pp Arity ArityPP,
  @pi-inductive ID Arity x\
    coq.mk-app x ParamsAsArgs (X x),
    coq.vernac->ppinductiveconstructor (Ks (X x)) KsPp.

pred coq.vernac->ppinductiveconstructor i:list indc-decl, o:list coq.pp.
coq.vernac->ppinductiveconstructor [] [].
coq.vernac->ppinductiveconstructor [constructor ID Arity|Ks] PP :-
  PP = [str ID,{coq.arity->pp Arity},SEP|Rest],
  if (Ks = []) (SEP = str"") (SEP = glue [brk 1 0, str "| "]),
  coq.vernac->ppinductiveconstructor Ks Rest.

pred coq.vernac->ppinductiveparams i:list (pair implicit_kind term), o:list coq.pp.
coq.vernac->ppinductiveparams [] [].
coq.vernac->ppinductiveparams [pr Imp T|Rest] PP :-
  PP = [box (hov 2) [str A,str ID,str " : ", TY,str B]|PPRest],
  decl T Name Ty, coq.name->id Name ID, coq.term->pp Ty TY,
  if2 (Imp = explicit) (A = "(", B = ")")
      (Imp = maximal)  (A = "{", B = "}")
                       (A = "[", B = "]"),
  coq.vernac->ppinductiveparams Rest PPRest.

pred coq.vernac->pprecordfields i:record-decl, o:list coq.pp. 
coq.vernac->pprecordfields end-record [].
coq.vernac->pprecordfields (field _ ID TY F) [ str ID, str " : ", TYPP, str ";", spc|FPP] :- % TODO attributes
  coq.term->pp TY TYPP,
  @pi-parameter ID TY p\ coq.vernac->pprecordfields (F p) FPP.

pred coq.vernac->ppabbrterm i:int, i:term, o:list coq.pp, o:coq.pp.
coq.vernac->ppabbrterm 0 T [] B :- !, @holes! => coq.term->pp T B.
coq.vernac->ppabbrterm N (fun _ _ F) [spc,str ID|StrParams] B :-
  ID is "X" ^ {std.any->string N},
  coq.id->name ID Name,
  M is N - 1,
  @pi-decl Name (sort prop) x\ coq.vernac->ppabbrterm M (F x) StrParams B.

}

%%%%% HB Utils %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


% HACK: move to coq-elpi proper, remove when coq-elpi > 1.9.2
type attmap attribute-type.

% runs P in a context where Coq #[attributes] are parsed
pred with-attributes i:prop.
with-attributes P :-
  attributes A,

% HACK: move to coq-elpi proper, remove when coq-elpi > 1.9.2
(pi S L AS Prefix R R1 Map PS\ 
  parse-attributes.aux [attribute S (node L)|AS] Prefix R :-
    if (Prefix = "") (PS = S) (PS is Prefix ^ "." ^ S), supported-attribute (att PS attmap), !,
    parse-attributes.aux AS Prefix R1,
    (pi x\ supported-attribute (att x string) :- !) => parse-attributes.aux L "" Map,
    std.append R1 [get-option PS Map] R
) =>

  coq.parse-attributes A [
    att "verbose" bool,
    att "mathcomp" bool,
    att "mathcomp.axiom" string,
    att "infer" attmap,
    att "log" bool,
  ] Opts, !,
  Opts => P.


pred if-verbose i:prop.
if-verbose P :- get-option "verbose" tt, !, P.
if-verbose _.

pred if-MC-compat i:(option gref -> prop).
if-MC-compat P :- get-option "mathcomp" tt, !, P none.
if-MC-compat P :- get-option "mathcomp.axiom" S, !,
  std.assert! (coq.locate S GR) "The name passed to the mathcomp.axiom attribute does not exist",
  P (some GR).
if-MC-compat _.

% TODO: Should this only be used for gref that are factories? (and check in the first/second branch so?)
% Should we make this an HO predicate, eg "located->gref S L is-factory? GR"
pred located->gref i:string, i:list located, o:gref.
located->gref _ [loc-gref GR|_] GR.
located->gref _ [loc-abbreviation Abbrev|_] GR :- phant-abbrev GR _ Abbrev, !.
located->gref S [loc-abbreviation _|_] _ :- coq.error S "is an abbreviation out of the control of HB".
located->gref S [loc-modpath _|_] _ :- coq.error S "should be a factory, but is a module".
located->gref S [loc-modtypath _|_] _ :- coq.error S "should be a factory, but is a module type".
located->gref S [] _ :- coq.error "Could not locate name" S.

% TODO: generalize/rename when we support parameters
pred argument->gref i:argument, o:gref.
argument->gref (str S) GR :- located->gref S {coq.locate-all S} GR.
argument->gref X _ :- coq.error "Argument" X "is expected to be a string".

pred argument->term i:argument, o:term.
argument->term (str S) (global GR) :- !, argument->gref (str S) GR.
argument->term (trm T) T1 :- !, std.assert-ok! (coq.elaborate-skeleton T _ T1) "not well typed term".
argument->term X _ :- coq.error "Argument" X " is expected to be a term or a string".

pred argument->ty i:argument, o:term.
argument->ty (str S) T1 :- !, argument->gref (str S) GR, std.assert-ok! (coq.elaborate-ty-skeleton (global GR) _ T1) "global reference is not a type".
argument->ty (trm T) T1 :- !, std.assert-ok! (coq.elaborate-ty-skeleton T _ T1) "not well typed type".
argument->ty X _ :- coq.error "Argument" X " is expected to be a type or a string".

% Type to share code between HB.mixin and HB.factory (that supports alias factories)
kind asset type.
type asset-mixin asset.
type asset-factory asset.

kind asset-decl type.
type asset-parameter  id -> term -> (term -> asset-decl) -> asset-decl.
type asset-record     id -> term -> id -> record-decl    -> asset-decl.
type asset-alias      id -> term                         -> asset-decl.

pred name-of-asset-decl i:asset-decl, o:string.
name-of-asset-decl (asset-parameter _ _ R) X :-
  pi x\ name-of-asset-decl (R x) X.
name-of-asset-decl (asset-record X _ _ _) X.
name-of-asset-decl (asset-alias X _) X.

pred argument->asset i:argument, o:asset-decl.
argument->asset (indt-decl (parameter ID _ImplicitStatus TySkel I)) (asset-parameter ID Ty A) :- !,
  % Should we check that _ImplicitStatus is explicit?
  coq.string->name ID Name,
  std.assert-ok! (coq.elaborate-ty-skeleton TySkel _ Ty) "parameter illtyped",
  @pi-decl Name Ty a\
    argument->asset (indt-decl (I a)) (A a).
argument->asset (indt-decl (record Rid Ty Kid F)) (asset-record Rid Ty Kid F) :- !.
argument->asset (const-decl Id (some (fun _ _ Bo)) (parameter ID _ SrcSkel Ty)) (asset-parameter ID Src A) :- !,
  coq.id->name ID Name,
  std.assert-ok! (coq.elaborate-ty-skeleton SrcSkel _ Src) "parameter illtyped",
  @pi-decl Name Src a\
    argument->asset (const-decl Id (some (Bo a)) (Ty a)) (A a).
argument->asset (const-decl Id (some Bo) (arity Ty)) (asset-alias Id Bo) :- !,
  std.assert! (var Ty) "Factories aliases should not be given a type".
argument->asset X _ :- coq.error "Unsupported asset:" X.

pred builder->string i:builder, o:string.
builder->string (builder _ _ _ B) S :- coq.term->string (global B) S.

pred nice-gref->string i:gref, o:string.
nice-gref->string X Mod :-
  coq.gref->path X Path,
  std.rev Path [_,Mod|_], !.
nice-gref->string X S :-
  coq.term->string (global X) S.

pred target-gref i:term, o:gref.
target-gref T GR :- whd1 T T1, !, target-gref T1 GR.
target-gref (prod N Src Tgt) GR :- !, @pi-decl N Src x\ target-gref (Tgt x) GR.
target-gref End GR :- term->gref End GR.

pred append-phant-unify i:phant-term, o:phant-term.
append-phant-unify (phant-term LP T) (phant-term LPU T) :-
  std.append LP [unify-arg] LPU.

pred copy-fields i:record-decl, o:record-decl.
copy-fields end-record end-record.
copy-fields (field C N T R) (field C N T1 R1) :-
  copy T T1,
  pi x\ copy x x => copy-fields (R x) (R1 x).

pred copy-triple i:(A -> A1 -> prop), i:(B -> B1 -> prop), i:(C -> C1 -> prop), i:triple A B C, o:triple A1 B1 C1.
copy-triple F G H (triple X Y Z) (triple X1 Y1 Z1) :- F X X1, G Y Y1, H Z Z1.

pred triple_1 i:triple A B C, o:A.
triple_1 (triple A _ _) A.

pred copy-list i:(A -> A1 -> prop), i:list A, o: list A1.
copy-list _ [] [].
copy-list F [X|XS] [Y|YS] :- F X Y, copy-list F XS YS.

pred gref->modname i:mixinname, o:id.
gref->modname GR ModName :-
  coq.gref->path GR Path,
  if (std.rev Path [_,ModName|_]) true (coq.error "No enclosing module for " GR).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% function to predicate generic constructions %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

pred mk-nil o:any.
mk-nil [].
pred mk0 i:any, o:any.
mk0 F R :- constant R F [].
pred mk1 i:any, i:any, o:any.
mk1 F X1 R :- constant R F [X1].
pred mk2 i:any, i:any, i:any, o:any.
mk2 F X1 X2 R :- constant R F [X1, X2].
pred mk3 i:any, i:any, i:any, i:any, o:any.
mk3 F X1 X2 X3 R :- constant R F [X1, X2, X3].
pred mk4 i:any, i:any, i:any, i:any, i:any, o:any.
mk4 F X1 X2 X3 X4 R :- constant R F [X1, X2, X3,X4].

pred mk-fun i:name, i:term, i:(term -> term), o:term.
mk-fun N Ty Body (fun N Ty Body).

% generic argument to pass to w-params
pred ignore i:name, i:term, i:(term -> A), o:A.
ignore _ _ F X :- (pi x y\ F x = F y), X = F (sort prop).

% combining body and type
pred mk-fun-prod i:name, i:term, o:(term -> pair term term), o:pair term term.
mk-fun-prod N Ty (x\ pr (Body x) (Type x)) (pr (fun N Ty Body) (prod N Ty Type)).

pred mk-parameter i:implicit_kind, i:name, i:term, i:(term -> indt-decl), o:indt-decl.
mk-parameter IK Name X F Decl :- !, Decl = parameter {coq.name->id Name} IK X F.

%%%%%%%%%%%%%%%%%%%%%%
% w-params interface %
%%%%%%%%%%%%%%%%%%%%%%

pred apply-w-params i:w-params A, i:list term, i:term, o:A.
apply-w-params (w-params.cons _ _ PL) [P|PS] T R :- !, apply-w-params (PL P) PS T R.
apply-w-params (w-params.nil _ _ L) [] T R :- !, R = L T.
apply-w-params _ _ _ _ :- coq.error "apply-w-params".

pred w-params.nparams i:w-params A, o:int.
w-params.nparams (w-params.cons _ _ F) N :- pi x\ w-params.nparams (F x) M, N is M + 1.
w-params.nparams (w-params.nil _ _ _) 0.

% [w-params.fold AwP Cons Nil Out] states that Out has shape
%   Cons `x_1` T_1 p_1 \ .. \ Nil [p_1 .. p_n] `T` Ty F
%   where AwP = w-params.cons `x_1` T_1 p_1 \ ... \ w-params.nil `T` Ty F
pred w-params.fold i:w-params A, i:(name -> term -> (term -> B) -> B -> prop),
   i:(list term -> name -> term -> (term -> A) -> B -> prop), o:B.
w-params.fold L Cons Nil Out :- w-params.fold.params L Cons Nil [] Out.

pred w-params.fold.params i:w-params A,
   i:(name -> term -> (term -> B) -> B -> prop),
   i:(list term -> name -> term -> (term -> A) -> B -> prop),
   i:list term, % accumulator
   o:B.
w-params.fold.params (w-params.cons N PTy F) Cons Nil RevPs Out :- !, std.do! [
  (@pi-decl N PTy p\ w-params.fold.params (F p) Cons Nil [p|RevPs] (Body p)),
  Cons N PTy Body Out].
w-params.fold.params (w-params.nil NT TTy F) _ Nil RevParams Out :- !,
  std.rev RevParams Params, !, Nil Params NT TTy F Out.

% [w-params.then AwP Cons Nil Out] states that Out has shape
%   Cons `x_1` T_1 p_1 \ .. \ Nil [p_1 .. p_n] `T` Ty t \ Body
%   where Pred [p_1 .. p_n] T Body
%   and AwP = w-params.cons `x_1` T_1 p_1 \ ... \ w-params.nil `T` Ty F
pred w-params.then i:w-params A,
   i:(name -> term -> (term -> C) -> C -> prop),
   i:(name -> term -> (term -> B) -> C -> prop),
   i:(list term -> term -> A -> B -> prop),
   o:C.
w-params.then L Cons Nil Pred Out :-
  w-params.fold L Cons (ps\ n\ ty\ f\ out\ sigma Body\
    (@pi-decl n ty t\ Pred ps t (f t) (Body t)),
    Nil n ty Body out) Out.

pred w-params.map i:w-params A, i:(list term -> term -> A -> B -> prop), o:w-params B.
w-params.map AL F BL :- w-params.then AL (mk3 w-params.cons) (mk3 w-params.nil) F BL.

% on the fly abstraction
pred bind-nil i:name, i:term, i:term, i:A, o:w-params A.
bind-nil N T X V (w-params.nil N T A) :- V = A X.

pred bind-cons i:name, i:term, i:term, i:w-params A, o:w-params A.
bind-cons N T X V (w-params.cons N T A) :- V = A X.

% Specific to list-w-params
pred list-w-params_list i:list-w-params A, o:list A.
list-w-params_list AwP R :- w-params.then AwP ignore ignore
   (p\ t\ x\ std.map x triple_1) R.

pred list-w-params.append i:list-w-params A, i:list-w-params A, o:list-w-params A.
list-w-params.append (w-params.nil N T ML1) (w-params.nil N T ML2) (w-params.nil N T ML) :-
  pi x\ std.append (ML1 x) (ML2 x) (ML x).
list-w-params.append (w-params.cons N Ty ML1) (w-params.cons N Ty ML2) (w-params.cons N Ty ML) :-
  pi x\ list-w-params.append (ML1 x) (ML2 x) (ML x).

pred list-w-params.flatten-map
  i:list-w-params A,
  i:(A -> list-w-params B -> prop),
  o:list-w-params B.
list-w-params.flatten-map (w-params.cons N T L) F (w-params.cons N T L1) :-
  @pi-decl N T p\
    list-w-params.flatten-map (L p) F (L1 p).
list-w-params.flatten-map (w-params.nil N TTy L) F (w-params.nil N TTy L1) :-
  @pi-decl N TTy t\
    list-w-params.flatten-map.aux (L t) F (L1 t).

pred list-w-params.flatten-map.aux
  i:list (w-args A), i:(A -> list-w-params B -> prop), o:list (w-args B).
list-w-params.flatten-map.aux [] _ [].
list-w-params.flatten-map.aux [triple M Ps T|L] F Res1 :-
  F M MwP,
  apply-w-params MwP Ps T ML,
  list-w-params.flatten-map.aux L F Res,
  std.append ML Res Res1.

% [build-list-w-params TheParams TheType Factorties ListWParams]
% Params is a list of pairs (section variable, its type).
% ListWParams has as many w-params.cons as TheParams and the terms
% in Factories are abstracted wrt the first component of TheParams.
pred build-list-w-params i:list (pair term term), i:term, i:list (w-args A), o: list-w-params A.
build-list-w-params [pr P Pty|PS] TheType Factories (w-params.cons `p` Pty1 R) :- std.do! [
  copy Pty Pty1,
  (pi p\ (copy P p :- !) => build-list-w-params PS TheType Factories (R p)),
].
build-list-w-params [] TheType Factories (w-params.nil `t` TT R) :- std.do! [
  std.assert-ok! (coq.typecheck TheType TT) "BUG: TheType does not typecheck",
  (pi t\ (copy TheType t :- !) =>
         std.map Factories (copy-triple (=) (copy-list copy) copy) (R t)),
].

pred distribute-w-params i:list-w-params A, o:list (one-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 :-
  pi x\ std.map (F x) (bind-nil N T x) L.

% Specific to one-w-params
pred w-params_1 i:one-w-params A, o:A.
w-params_1 X Y :- w-params.then X ignore ignore (p\ t\ triple_1) Y.


pred hb-set-implicit i:gref, i:list implicit_kind.
hb-set-implicit GR I :-  std.do! [
  coq.arguments.set-implicit GR [I],
  log-vernac (coq.vernac.implicit {coq.gref->id GR} I),
].


pred hb-add-const i:id, i:term, i:term, i:opaque?, o:constant.
hb-add-const Name Bo Ty Opaque C :- std.do! [
  coq.env.add-const Name Bo Ty Opaque C,
  if (var Ty) (Ty? = none) (Ty? = some Ty),
  log-vernac (coq.vernac.definition Name Ty? Bo),
  hb-set-implicit (const C) [],
].

pred hb-add-variable i:id, i:term, o:constant.
hb-add-variable Name Ty C :- std.do! [
  if (Name = "_") (ID is "fresh_name_" ^ {std.any->string {new_int}}) (ID = Name),
  coq.env.add-section-variable ID Ty C,
  log-vernac (coq.vernac.variable ID Ty),
  hb-set-implicit (const C) [],
].

pred hb-add-indt i:indt-decl, o:inductive.
hb-add-indt Decl I :- std.do! [
  coq.env.add-indt Decl I,
  log-vernac (coq.vernac.inductive Decl),
].

pred hb-begin-module i:id.
hb-begin-module Name :- std.do! [
  coq.env.begin-module Name none,
  log-vernac (coq.vernac.begin-module Name none),
].

pred hb-end-module i:id, o:modpath.
hb-end-module Name M :- std.do! [
  coq.env.end-module M,
  log-vernac (coq.vernac.end-module Name),
].

pred hb-begin-section i:id.
hb-begin-section Name :- std.do! [
  coq.env.begin-section Name,
  log-vernac (coq.vernac.begin-section Name),
].

pred hb-end-section i:id.
hb-end-section Name :- std.do! [
  coq.env.end-section,
  log-vernac (coq.vernac.end-section Name),
].

pred hb-declare-instance i:gref.
hb-declare-instance GR  :- std.do! [
  coq.CS.declare-instance GR,
  coq.gref->id GR Name,
  log-vernac (coq.vernac.canonical Name),
].

pred hb-add-abbreviation i:id, i:int, i:term, i:bool, o:abbreviation.
hb-add-abbreviation Name NArgs Body OnlyParsing O :- std.do! [
  coq.notation.add-abbreviation Name NArgs Body OnlyParsing O,
  log-vernac (coq.vernac.abbreviation Name NArgs Body),
].


pred hb-export-module i:modpath.
hb-export-module M :- std.do! [
  coq.env.export-module M,
  coq.modpath->path M MP,
  std.take-last 2 MP MPNice,
  log-vernac (coq.vernac.export-module {std.string.concat "." MPNice}),
].

pred hb-coercion-declare i:coercion.
hb-coercion-declare C :- std.do! [
  coq.coercion.declare C,
  C = coercion GR _ SRCGR TGTCL,
  coq.gref->id GR Name,
  log-vernac (coq.vernac.coercion Name SRCGR TGTCL),
].

%%%%%%%%% HB database %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%Specialize coq.elpi.accumulate to "hiearchy.db"
pred hb-accumulate i:scope, i:clause.
hb-accumulate S CL :- std.do! [
  coq.elpi.accumulate S "hb.db" CL,
  if-verbose (log-vernac (coq.vernac.comment CL)),
].

pred from_mixin i:prop, o:mixinname.
from_mixin (from _ X _) X.

pred from_builder i:prop, o:term.
from_builder (from _ _ X) (global X).

pred mixin-src_mixin i:prop, o:mixinname.
mixin-src_mixin (mixin-src _ M _) M.

pred mixin-src_src i:prop, o:term.
mixin-src_src (mixin-src _ _ S) S.

pred class_name i:class, o:classname.
class_name (class N _ _) N.

pred class-def_name i:prop, o:classname.
class-def_name (class-def (class N _ _)) N.

pred classname->def i:classname, o:class.
classname->def CN (class CN S ML) :- class-def (class CN S ML), !.

pred extract-builder i:prop, o:builder.
extract-builder (builder-decl B) B.

pred leq-builder i:builder, i:builder.
leq-builder (builder N _ _ _) (builder M _ _ _) :- N =< M.

% [factory-alias->gref X GR] when X is already a factory X = GR
% however, when X is a phantom abbreviated gref, we find the underlying
% factory gref GR associated to it.
pred factory-alias->gref i:gref, o:gref.
factory-alias->gref PhGR GR :- phant-abbrev GR PhGR _, !.
factory-alias->gref GR GR :- phant-abbrev GR _ _, !.

pred sub-class? i:class, i:class.
sub-class? (class _ _ ML1P) (class _ _ ML2P) :-
  list-w-params_list ML1P ML1,
  list-w-params_list ML2P ML2,
  std.forall ML2 (m2\ std.exists ML1 (m1\ m1 = m2)).

% TODO: maybe the right API is to have this
% pred factory-provides i:factoryname, i:list-w-params mixiname.
% one can use w-params.then now!
% [factory-provides F ML] computes the mixins ML generated by F
pred factory-provides i:factoryname, o:list-w-params mixinname.
factory-provides FactoryAlias MLwP :- std.do! [
  factory-alias->gref FactoryAlias Factory,
  factory-requires Factory RMLwP,
  w-params.map RMLwP (factory-provides.base Factory) MLwP
].

pred factory-provides.base i:factoryname, i:list term, i: term,
  i:list (w-args mixinname), o:list (w-args mixinname).
factory-provides.base Factory Params T _RMLwP MLwP :- std.do! [
  std.findall (from Factory T_ F_) All,
  std.map All from_mixin ML,
  std.map All from_builder BL,
  std.map2 BL ML (factory-provides.one Params T) MLwP,
].

pred factory-provides.one i:list term, i:term, i:term, i:mixinname, o:w-args mixinname.
factory-provides.one Params T B M (triple M PL T) :- std.do! [
  std.assert-ok! (coq.typecheck B Ty) "Builder illtyped",
  subst-prod [T] {subst-prod Params Ty} TyParams,
  std.assert! (extract-conclusion-params TyParams PL) "The conclusion of a builder is a mixin whose parameters depend on other mixins",
].

pred extract-conclusion-params i:term, o:list term.
extract-conclusion-params (prod _ S T) R :- !,
  @pi-decl _ S x\ extract-conclusion-params (T x) R.
extract-conclusion-params (app [global GR|Args]) R :- !,
  factory-alias->gref GR Factory,
  factory-nparams Factory NP,
  std.take NP Args R.
extract-conclusion-params T R :- whd1 T T1, !, extract-conclusion-params T1 R.


% [factories-provide FL ML] computes the mixins ML generated by all F in FL
%
%  cons tp p\ nil t\ [pr f1 [p,t]]
%    f1 p t = m1 t, m2 p t
%  cons tp p\ nil t\ [pr m1 [t], pr m2 [p,t]]
pred factories-provide i:list-w-params factoryname, o:list-w-params mixinname.
factories-provide FLwP MLwP :-
  list-w-params.flatten-map FLwP factory-provides UnsortedMLwP,
  w-params.map UnsortedMLwP (p\t\ toposort-mixins) MLwP.

% Mixins can be topologically sorted according to their dependencies
pred toposort-mixins.mk-mixin-edge i:prop, o:list (pair mixinname mixinname).
toposort-mixins.mk-mixin-edge (factory-requires M Deps) L :-
  std.map {list-w-params_list Deps} (d\r\ r = pr d M) L.

pred toposort-mixins i:list (w-args mixinname), o:list (w-args mixinname).
toposort-mixins In Out :- std.do! [
  std.findall (factory-requires M_ Deps_) AllMixins,
  std.flatten {std.map AllMixins toposort-mixins.mk-mixin-edge} ES,
  toposort-proj triple_1 ES In Out,
].

pred toposort-proj i:(A -> B -> prop), i:list (pair B B), i:list A, o:list A.
toposort-proj Proj ES In Out :- !, toposort-proj.hb-accumulate Proj ES [] In Out.
pred topo-find i:B, o:A.
pred toposort-proj.hb-accumulate i:(A -> B -> prop), i:list (pair B B), i:list B, i:list A, o:list A.
toposort-proj.hb-accumulate _ ES Acc [] Out :- !,
  std.map {toposort ES Acc} topo-find Out.
toposort-proj.hb-accumulate Proj ES Acc [A|In] Out :- std.do![
  Proj A B,
  topo-find B A => toposort-proj.hb-accumulate Proj ES [B|Acc] In Out
].

% 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).
pred toposort-classes i:list classname, o:list classname.
toposort-classes In Out :- std.do! [
  std.findall (sub-class C1_ C2_) SubClasses,
  std.map SubClasses toposort-classes.mk-class-edge ES,
  toposort ES In Out,
].

pred findall-classes o:list class.
findall-classes CLSortedDef :- std.do! [
  std.findall (class-def C_) All,
  std.map All class-def_name CL,
  toposort-classes CL CLSorted,
  std.map CLSorted classname->def CLSortedDef,
].

pred findall-builders o:list builder.
findall-builders LFIL :-
  std.map {std.findall (builder-decl B_)} extract-builder LFILunsorted,
  bubblesort LFILunsorted leq-builder LFIL.

% [distinct-pairs-below C AllSuper C1 C2] finds C1 and C2 in
% AllSuper (all super classes of C) such that C1 != C2
% and for which there is no join C3.
% If there exists a join C3 of C1 and C2 then C is a subclass
% of C3 (otherwise C should have been declared before C3)
%
%        / --- /-- C1
%    C -- no C3    !=
%        \ --- \-- C2
%
% [findall-newjoins C AllSuper] finds all C1 and C2 such that C is a (new) join for
% them
pred distinct-pairs-below i:class, i:list class, o:class, o:class.
distinct-pairs-below CurrentClass AllSuper C1 C2 :-
  std.mem AllSuper C1, std.mem AllSuper C2,
  % no cut until here, since we don't know which C1 and C2 to pick
  std.do! [
    cmp_term C1 C2 lt,
    C1 = class C1n _ _,
    C2 = class C2n _ _ ,
    not(sub-class? C1 C2),
    not(sub-class? C2 C1),
    if (join C1n C2n C3n)
       (assert-building-bottom-up CurrentClass C3n, fail) % a join, not a valid pair
       true, % no join, valid pair
  ].

pred assert-building-bottom-up i:class, i:classname.
assert-building-bottom-up CurrentClass C3n :-
  class-def (class C3n X Y),
  CurrentClass = class CC _ _,
  if (not (sub-class? CurrentClass (class C3n X Y)))
     (coq.error "You must declare the current class" CC "before" C3n)
     true.

pred distinct-pairs_pair i:prop, o:pair class class.
distinct-pairs_pair (distinct-pairs-below _ _ X Y) (pr X Y).

pred findall-newjoins i:class, i:list class, o:list (pair class class).
findall-newjoins CurrentClass AllSuper TodoJoins :-
  std.findall (distinct-pairs-below CurrentClass AllSuper C1_ C2_) JoinOf,
  std.map JoinOf distinct-pairs_pair TodoJoins.

%%%%% Coq Database %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% [get-structure-coercion S1 S2 F] finds the coecion F from the structure S1 to S2
pred get-structure-coercion i:structure, i:structure, o:term.
get-structure-coercion S T (global F) :-
  coq.coercion.db-for (grefclass S) (grefclass T) L,
  if (L = [pr F _]) true (coq.error "No one step coercion from" S "to" T).

pred get-structure-sort-projection i:structure, o:term.
get-structure-sort-projection (indt S) Proj :- !,
  coq.CS.canonical-projections S L,
  if (L = [some P, _]) true (coq.error "No canonical sort projection for" S),
  Proj = global (const P).
get-structure-sort-projection S _ :- coq.error "get-structure-sort-projection: not a structure" S.

pred get-structure-class-projection i:structure, o:term.
get-structure-class-projection (indt S) T :- !,
  coq.CS.canonical-projections S L,
  if (L = [_, some P]) true (coq.error "No canonical class projection for" S),
  T = global (const P).
get-structure-class-projection S _ :- coq.error "get-structure-class-projection: not a structure" S.

pred get-constructor i:gref, o:gref.
get-constructor (indt R) (indc K) :- !,
 if (coq.env.indt R _ _ _ _ [K] _) true (coq.error "Not a record" R).
get-constructor I _ :- coq.error "get-constructor: not an inductive" I.

pred head-gref-under-prods i:term, o:gref.
head-gref-under-prods (prod N T Body) Hd :-
  @pi-decl N T x\ head-gref-under-prods (Body x) Hd.
head-gref-under-prods T Hd :- whd1 T T', head-gref-under-prods T' Hd.
head-gref-under-prods T Hd :- safe-dest-app T (global Hd) _.

%% finding for locally defined structures
pred get-cs-structure i:cs-instance, o:structure.
get-cs-structure (cs-instance _ _ (global Inst)) Struct :- std.do! [
  coq.env.typeof Inst InstTy,
  head-gref-under-prods InstTy Struct
].

pred has-cs-instance i:gref, i:cs-instance.
has-cs-instance GTy (cs-instance _ (cs-gref GTy) _).

pred get-local-structures i:term, o:list structure.
get-local-structures TyTrm StructL :- std.do! [
  std.filter {coq.CS.db} (has-cs-instance {term->gref TyTrm}) DBGTyL,
  std.map DBGTyL get-cs-structure RecL,
  std.filter RecL is-structure StructL
].

pred local-cs? i:term, i:structure.
local-cs? TyTerm Struct :-
  get-local-structures TyTerm StructL,
  std.mem! StructL Struct.

pred structure-nparams i:structure, o:int.
structure-nparams Structure NParams :-
  class-def (class Class Structure _),
  factory-nparams Class NParams.

pred get-canonical-mixins-of i:term, i:structure, o:list prop.
get-canonical-mixins-of T S MSL :- std.do! [
  get-structure-sort-projection S Sort,
  structure-nparams S NParams,
  coq.mk-n-holes NParams Holes,
  coq.mk-app Sort {std.append Holes [ST]} SortHolesST,
  if (coq.unify-eq T SortHolesST ok) (
    % Hum, this unification problem is not super trivial. TODO replace by something simpler
    get-constructor S KS,
    coq.mk-app (global KS) {std.append Holes [T, C]} KSHolesC,
    std.assert-ok! (coq.unify-eq ST KSHolesC) "HB: get-canonical-mixins-of: ST = _ _ C",
    C = app Stuff,
    std.drop {calc (NParams + 2)} Stuff MIL,
    std.map MIL (mixin-srcs T) MSLL,
    std.flatten MSLL MSL
  )
    (MSL = [])
].

pred under-canonical-mixins-of.do! i:term, i:list prop.
under-canonical-mixins-of.do! T P :-
  get-local-structures T CS,
  std.map CS (get-canonical-mixins-of T) MSLL,
  std.flatten MSLL MSL,
  MSL => std.do! P.

%%%%% mterm %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% mterm is always of the form [mterm P T ML F], which is the data of
% parameters PL a type T, and a list of mixins ML and a term F
% where F should applied to PL, T and instances of the mixins in ML
kind mterm type.
type mterm list term -> term -> list mixinname -> term -> mterm.

% Notations /à la/ *pack* are always of the shape
% [Notation N x_0 .. x_n := C x_0 .. _ _ id .. x_i .. _ id _ _ id]
% with a variable number of [_] between each [id], and where
% - [x_i] is given by the user
% - [_]   correspond to arguments that are left implicit,
% - [id]  trigger unification as described in
% /Canonical Structures for the working Coq user/ by Mahboubi and Tassi
%
% phant-arg encode these three kind of arguments
% - [x_i] is encoded using [real-arg x_i]
% - [_]              using [implicit-arg]
% - [id]             using [unify-arg]
kind phant-arg type.
type real-arg name -> phant-arg.
type infer-type name -> phant-arg.
type implicit-arg phant-arg.
type unify-arg phant-arg.

% phant-term is a pair of a list of argument kinds together with a term
kind phant-term type.
type phant-term list phant-arg -> term -> phant-term.

pred phant-fun i:phant-arg, i:term, i:(term -> phant-term), o:phant-term.
phant-fun Arg Ty PhF (phant-term [Arg|ArgL] (fun N Ty F)) :-
  if (Arg = real-arg N) true (N = `_`),
  @pi-decl N Ty x\ PhF x = phant-term ArgL (F x).

pred phant-fun-real i:name, i:term, i:(term -> phant-term), o:phant-term.
phant-fun-real N T F Res :- !, phant-fun (real-arg N) T F Res.

% [phant-fun-unify N X1 X2 PF PUF] states that PUF is a phant-term that
% is starts with unifing X1 and X2 and then outputs PF.
% N is ignored
pred phant-fun-unify i:term, i:term, i:term, i:phant-term, o:phant-term.
phant-fun-unify Msg X1 X2 (phant-term AL F) (phant-term [unify-arg|AL] UF) :-
  std.assert-ok! (coq.typecheck X1 T1) "phant-fun-unify: X1 illtyped",
  std.assert-ok! (coq.typecheck X2 T2) "phant-fun-unify: X2 illtyped",
  UF = {{fun unif_arbitrary : lib:hb.unify lp:T1 lp:T2 lp:X1 lp:X2 lp:Msg => lp:F}}.

% [phant-fun-implicit N Ty PF PUF] states that PUF is a phant-term
% which quantifies [PF x] over [x : Ty] (with name N)
pred phant-fun-implicit i:name, i:term, i:(term -> phant-term), o:phant-term.
phant-fun-implicit N Ty PF (phant-term [implicit-arg|AL] (fun N Ty F)) :- !,
  @pi-decl N Ty t\ PF t = phant-term AL (F t).

pred phant-fun-unify-mixin i:term, i:name, i:term, i:(term -> phant-term), o:phant-term.
phant-fun-unify-mixin T N Ty PF Out :- !, std.do! [
  safe-dest-app Ty (global M) _,
  Msg is "phant-fun-unify-mixin: No mixin-src on " ^ {coq.term->string T},
  std.assert! (mixin-src T M Msrc) Msg,
  (@pi-decl `m` Ty m\ phant-fun-unify {{lib:hb.nomsg}} m Msrc (PF m) (PFM m)),
  phant-fun-implicit N Ty PFM Out
].

% [phant-fun-struct T S Params PF PSF] states that PSF is a phant-term
% which postulate a structure [s : S Params] such that [T = sort s]
% and then outputs [PF s]
pred phant-fun-struct i:term, i:name, i:structure, i:list term, i:(term -> phant-term), o:phant-term.
phant-fun-struct T Name S Params PF Out :- std.do! [
  get-structure-sort-projection S SortProj,
  mk-app (global S) Params SParams,
  mk-app SortProj Params SortProjParams,
  % Msg = {{lib:hb.nomsg}},
  Msg = {{lib:hb.some (lib:hb.pair lib:hb.not_a_msg lp:SParams)}},
  (@pi-decl Name SParams s\ phant-fun-unify Msg T {mk-app SortProjParams [s]} (PF s) (UnifSI s)),
  phant-fun-implicit Name SParams UnifSI Out
].

% [builder->term Params T Src Tgt MF] provides a term which is
% a function to transform Src into Tgt under the right mixin-src.
pred builder->term i:list term, i:term, i:factoryname, i:mixinname, o:term.
builder->term Ps T Src Tgt B :- !, std.do! [
  from Src Tgt FGR,
  F = global FGR,
  factory-requires Src MLwP,
  list-w-params_list MLwP ML,
  mterm->term (mterm Ps T ML F) B,
].

% [instantiate-mixin T F M_i TFX] where mixin-for T M_i X_i states that
% if    F  ~  fun xs (m_0 : M_0 T) .. (m_n : M_n T ..) ys
%            => F xs m_0 .. m_{i-1} m_i m_{i+1} .. m_n ys
% then TFX := fun xs m_0 .. m_{i-1}     m_{i+1} .. m_n ys
%            => F xs m_0 .. m_{i-1} X_i m_{i+1} .. m_n ys
% thus instanciating an abstraction on mixin M_i with X_i
pred instantiate-mixin i:term, i:mixinname, i:term, o:term.
instantiate-mixin T M (fun _ Tm F) R :-
  safe-dest-app Tm (global TmGR) _,
  factory-alias->gref TmGR M, !,
  mixin-for T M X, !,
  R = F X.
instantiate-mixin T M (fun N Ty F) (fun N Ty FX) :- !,
  pi m\ instantiate-mixin T M (F m) (FX m).
instantiate-mixin _ _ F F.

% [mterm->term MF TFX] assumes that MF is a mterm
% (mterm ML F) and perform the substitution as above
% for every mixin-for entry out of the list ML = [M_0, .., M_n].
pred mterm->term i:mterm, o:term.
mterm->term (mterm Ps T ML F) SFX :- std.do! [
  std.assert-ok! (coq.typecheck F Ty) "mterm->term: F illtyped",
  mk-eta (-1) Ty F EtaF,
  subst-fun {std.append Ps [T]} EtaF FT,
  std.fold ML FT (instantiate-mixin T) SFX
].

% [mgref->term Params T GR X] computes the dependencies of GR in mixins,
% (through factory-requires if it exist, otherwise gr-deps)
% and instanciates all of them through mixin-src, and fails if it cannot.
pred mgref->term i:list term, i:term, i:gref, o:term.
mgref->term Ps T GR X :- factory-requires GR MLwP, !, std.do! [
  list-w-params_list MLwP ML,
  mterm->term (mterm Ps T ML (global GR)) X
].
mgref->term Ps T GR X :- !, std.do! [
  std.assert! (gr-deps GR MLwP) "BUG: gr-deps should never fail",
  list-w-params_list MLwP ML,
  mterm->term (mterm Ps T ML (global GR)) X
].

% [mixin-srcs T X MSL] states that MSL is a list of [mixin-src T m X]
% where m ranges all the mixins that the factory Src can provide,
% where Src is the type of X.
pred mixin-srcs i:term, i:term, o:list prop.
mixin-srcs T X MSL :- std.do! [
  std.assert-ok! (coq.typecheck X XTy) "mixin-src: X illtyped",
  if (not (safe-dest-app XTy (global _) _))
     (coq.error "Term:\n" {coq.term->string X}
                "\nhas type:\n" {coq.term->string XTy}
                "\nwhich is not a record")
     true,
  term->gref XTy Src,
  factory-provides Src MLwP,
  list-w-params_list MLwP ML,
  % TODO: skip mixins for which there is already a source.
  std.map ML (m\r\ r = mixin-src T m X) MSL
].

pred under-mixin-src-from-factory.then i:term, i:term, i:(term -> prop), o:term.
under-mixin-src-from-factory.then TheType TheFactory P X :- std.do![
  mixin-srcs TheType TheFactory ML,
  ML => P X
].

pred under-mixin-src-from-factory.do! i:term, i:term, i:list prop.
under-mixin-src-from-factory.do! TheType TheFactory LP :-
  under.do! (under-mixin-src-from-factory.then TheType TheFactory) LP.

pred under-mixin-src-from-factories.then i:term, i:list term, i:(term -> prop), o:term.
under-mixin-src-from-factories.then TheType Factories P X :-
  std.map Factories (mixin-srcs TheType) MLL,
  std.flatten MLL ML,
  ML => P X.

pred under-mixin-src-from-factories.do! i:term, i:list term, i:list prop.
under-mixin-src-from-factories.do! TheType Factories LP :-
  under.do! (under-mixin-src-from-factories.then TheType Factories) LP.

% [mixin-for T M X] states that X has type [M T ...]
% it is reconstructed from two databases [mixin-src] and [from]
pred mixin-for i:term, i:mixinname, o:term.
mixin-for T M MI :- mixin-src T M Tm, !, std.do! [
  std.assert-ok! (coq.typecheck Tm Ty) "mixin-for: Tm illtyped",

  factory? Ty (triple Factory Params _),

  if (M = Factory) (MI = Tm) (
      builder->term Params T Factory M B,
      subst-fun [Tm] B MI
  )
].
pred assert!-mixin-for i:term, i:mixinname, o:term.
assert!-mixin-for T M B :-
  Msg is "HB: cannot inhabit mixin" ^
    {nice-gref->string M} ^ "on" ^ {coq.term->string T},
  std.assert! (mixin-for T M B) Msg.

% ----------- Finding and instantiating mixin arguments -------------------

% [ty-deps Ty MLwP] states that ML is a list with parameters of
% mixins with arguments which the type Ty rely on, i.e.
% Ty = forall p_1 ... p_n (T : Type) (m_0 : M_0 T) ... (m_n : M_n T ..), (zero : T), ..... axioms_ T
% MLwP = w-params.cons p_1 P_1 (... w-param.cons p_n P_n
%          (w-param.nil T Type [(M_0, T, qs_0), .., (M_n, T, qs_n)]))
% pred ty-deps i:term, o:list-w-params mixinname.
% ty-deps (prod N S R) ML' :- !,
%   @pi-decl N S x\
%     ty-deps (R x) ML,
%     safe-dest-app S HD _,
%     if (HD = global GR, factory-alias->gref GR F, from  _ F _, !)
%       (ML' = [F|ML]) (ML' = ML).
% ty-deps Ty ML :- whd1 Ty Ty1, !, ty-deps Ty1 ML.
% ty-deps _Ty [].

pred factory? i:term, o:w-args factoryname.
factory? S (triple F Params T) :-
  safe-dest-app S (global GR) Args, factory-alias->gref GR F, factory-nparams F NP, !,
  std.split-at NP Args Params [T|_].

pred prod-src-is-factory i:term.
prod-src-is-factory (prod _ S _) :- factory? S _.
prod-src-is-factory Ty :- whd1 Ty Ty1, !, prod-src-is-factory Ty1.

pred ty-deps i:term, o:list-w-params mixinname.
ty-deps Ty ML :- ty-deps.aux Ty ML, !.
ty-deps (prod N T _) (w-params.nil N T _\[]) :- T = {{Type}}, !. % TODO: relax to any type later on.
ty-deps T _ :- % TODO: forall p1 ... pn (T : indexed Type) with indexed being the id function
  coq.error "ty-deps: BUG: could not get the parameters and the dependencies of"
    {coq.term->string T}.
pred ty-deps.aux i:term, o:list-w-params mixinname.
ty-deps.aux (prod N S R) ML :- !,
  @pi-decl N S x\
    if (prod-src-is-factory (R x); S = {{ lib:hb.indexed Type }})
      (ML = w-params.nil  N S MLP, ty-deps.factories (R x) (MLP x))
      (ML = w-params.cons N S ML1, ty-deps.aux (R x) (ML1 x)).
ty-deps.aux Ty ML :- whd1 Ty Ty1, !, ty-deps.aux Ty1 ML.

pred ty-deps.factories i:term, o:list (w-args factoryname).
ty-deps.factories (prod N S R) FS :-
  @pi-decl N S x\
    if (factory? S FwP) (FS = [FwP|FS1]) (FS = FS1),
    ty-deps.factories (R x) FS1.
ty-deps.factories Ty FS :- whd1 Ty Ty1, !, ty-deps.factories Ty1 FS.
ty-deps.factories _ [].

% [term-deps T ML] states that ML is the list of
% mixins which the term T rely on, i.e. T has type
% forall (m_0 : M_0 T) ... (m_n : M_n T ..), _ and ML = [M_0, .., M_n]
pred term-deps i:term, o:list-w-params mixinname.
term-deps T ML :-
  std.assert-ok! (coq.typecheck T Ty) "term-deps: T illtyped",
  ty-deps Ty ML.

% shorthand for gref.
pred gr-deps i:gref, o:list-w-params mixinname.
gr-deps GR ML :- term-deps (global GR) ML.

% [find-max-classes Mixins Classes] states that Classes is a list of classes
%   which contain all the mixins in Mixins.
% Although it is not strictly necessary, but desirable for debugging,
% we use a heuristic that tries to minimize the number
% of classes by assuming Mixins are reversed topologically sorted.
% Note: works with flat mixins, no params
pred find-max-classes i:list mixinname, o:list classname.
find-max-classes [] [].
find-max-classes [M|Mixins] [C|Classes] :-
  mixin-first-class M C,
  std.do! [
    class-def (class C _ MLwP),
    list-w-params_list MLwP ML,
    std.filter Mixins (x\ not (std.mem! ML x)) Mixins',
    find-max-classes Mixins' Classes
  ].
find-max-classes [M|_] _ :- coq.error "HB: cannot find a class containing mixin" M.

pred under-mixins.then i:list (w-args mixinname),
    i:(name -> term -> (term -> A) -> A -> prop),
    i:(A -> prop), o:A.
under-mixins.then [] _ Pred Body :- !, Pred Body.
under-mixins.then [triple M Args T|ML] Mixin Pred Out :- std.do! [
  mgref->term Args T M MTy,
  (@pi-decl `m` MTy m\ mixin-src T M m =>
    under-mixins.then ML Mixin Pred (Body m)),
  Mixin `m` MTy Body Out,
].

% [mk-mixin-fun.then MLwP Pred F] states that F has shape
%   fun p_1 .. p_k T,
%      (m_0 : M_0 ..p.. T) .. (m_n : M_n ..p.. T m_i0 .. m_ik) =>
%      Body m_0 .. m_n
% where  MLwP contains M_0, .., M_n (under p_1 .. p_k)
%   and  Body is such that [..,mixin-src T M_i m_i,..] => Pred Body
%   and  ..p.. is a list of terms built using p_1 .. p_k and T
pred mk-mixin-fun.then i:list-w-params mixinname, i:(list term -> term -> term -> prop), o:term.
mk-mixin-fun.then L P Out :- !,
  w-params.then L mk-fun mk-fun
    (p\ t\ ml\ under-mixins.then ml mk-fun (P p t)) Out.

% A *pack* notation can be easiliy produced from a phant-term using
% [mk-phant-abbrev N PT C], which states that C is a new constant
% which name is phant_N, and which produces a simple notation
% with name N using the data of the phant-term PT to reconstruct a notation
% [Notation N x0 .. xn := C x0 _ _ id .. xi .. _ id _ _ id]
% as described above.
pred mk-phant-abbrev.term i:int, i:term, i:list phant-arg, o:int, o:term.
mk-phant-abbrev.term K F [] K F.
mk-phant-abbrev.term K F [real-arg N|AL] K'' (fun N _ AbbrevFx) :- !,
  pi x\ mk-phant-abbrev.term K {mk-app F [x]} AL K' (AbbrevFx x),
  K'' is K' + 1.
mk-phant-abbrev.term K F [infer-type N|AL] K'' (fun N _ AbbrevFx) :- !,
  pi x\ mk-phant-abbrev.term K {mk-app F [{{ lib:hb.Phant lp:x }}]} AL K' (AbbrevFx x),
  K'' is K' + 1.
mk-phant-abbrev.term K F [implicit-arg|AL] K' FAbbrev :- !,
  mk-phant-abbrev.term K {mk-app F [_]} AL K' FAbbrev.
mk-phant-abbrev.term K F [unify-arg|AL] K' FAbbrev :- !,
  mk-phant-abbrev.term K {mk-app F [{{lib:@hb.id _ _}}]} AL K' FAbbrev.

pred mk-phant-abbrev i:string, i:phant-term, o:constant, o:abbreviation.
mk-phant-abbrev N (phant-term AL T1) C Abbrev :- std.do! [
  NC is "phant_" ^ N,
  std.assert-ok! (coq.elaborate-skeleton T1 TTy T) "mk-phant-abbrev: T illtyped",
  hb-add-const NC T TTy @transparent! C,
  mk-phant-abbrev.term 0 (global (const C)) AL NParams AbbrevT,
  @global! => hb-add-abbreviation N NParams AbbrevT tt Abbrev,
].

% [hb-accumulate-phant-abbrev Str GR PhGR Abbrev] makes a phantom abbreviation for F
pred hb-accumulate-phant-abbrev i:string, i:gref, o:gref, o:abbreviation.
hb-accumulate-phant-abbrev Str GR (const PhC) Abbrev :- !, std.do! [
  mk-phant-term (global GR) PhGR,
  mk-phant-abbrev Str PhGR PhC Abbrev
].

% [phant-fun-mixin N Ty PF PUF] states that PUF is a phant-term
% which quantifies [PF x] over [x : Ty] (with name N)
% Ty must be an (applied) mixin M, and the phantom status of this mixin
% is determined by [phant-mixin-real M].
pred phant-mixin-real o:mixinname.
pred phant-fun-mixin i:name, i:term, i:(term -> phant-term), o:phant-term.
phant-fun-mixin N Ty PF (phant-term [Status|AL] (fun N Ty F)) :- !, std.do! [
  @pi-decl N Ty t\ PF t = phant-term AL (F t),
  safe-dest-app Ty (global Mixin) _,
  if (phant-mixin-real Mixin) (Status = real-arg N) (Status = implicit-arg)
].

% [mk-phant-term F PF] states that
% if F = fun p1 .. p_k T m_0 .. m_n => _
% then PF = phant-term
%   [real-arg p_1, ... real-arg p_k, real-arg T, implicit-arg, .., implicit-arg,
%       implicit-arg, .., implicit-arg,
%         implicit-arg, unify-arg,
%         implicit-arg, unify-arg,
%         implicit-arg, .., implicit-arg, unify-arg,
%         unify-arg, ..., unify-arg,
%       ...,
%       implicit-arg, .., implicit-arg,
%         implicit-arg, unify-arg,
%         implicit-arg, unify-arg,
%         implicit-arg, .., implicit-arg, unify-arg,
%         unify-arg, ..., unify-arg]
%   {{fun p_1 ... p_k T m_0 .. m_n =>
%       fun q_1 .. q_l =>
%         [find s_0 | T ~ s_0]
%         [find c_0 | s_0 ~ SK q_1 .. q_l T c_0]
%         [find m'_{i_0_0}, .., m'_{i_0_n0} | c_0 ~ CK m'_{i_0_0} .. m'_{i_0_n0}]
%         fun of hb.unify m_{i_0_0} m'_{i_0_0} & ... & hb.unify m_{i_0_n0} m'_{i_0_n0} =>
%       ...
%       fun q'_1 .. q'_l' =>
%         [find s_k | T ~ s_k]
%         [find c_k | s_k ~ SK q'_1 .. q'_l' T c_k]
%         [find m'_{i_k_0}, .., m'_{i_k_nk} | c_0 ~ CK m'_{i_k_0} .. m'_{i_k_nk}]
%         fun of hb.unify m_{i_0_0} m'_{i_0_0} & ... & hb.unify m_{i_k_nk} m'_{i_k_nk} =>
%       F p_1 ... p_k T m_i0_j0 .. m_il_jl}}
pred mk-phant-term.mixins i:term, i:classname, i:phant-term,
  i:list term, i:name, i:term, i:(term -> list (w-args mixinname)), o:phant-term.
mk-phant-term.mixins T CN PF Params N Ty MLwA Out :- std.do! [
  class-def (class CN SI _),
  mk-app (global SI) Params SIParams,
  NoMsg = {{lib:hb.nomsg}},
  coq.name-suffix N "local" Nlocal,
  (@pi-decl Nlocal Ty t\ sigma SK KC ML\ std.do! [
    std.map (MLwA t) triple_1 ML,
    std.append Params [T] ParamsT,
    SKPT = app [global {get-constructor SI} | ParamsT],
    ClassTy = app [global CN | ParamsT],
    (@pi-decl `s` SIParams s\ @pi-decl `c` ClassTy c\ sigma PF2\ std.do![
       under-mixins.then (MLwA t) (phant-fun-unify-mixin T) (mk-phant-term.mixins.aux t Params c CN PF) PF2,
       phant-fun-unify NoMsg s {mk-app SKPT [c]} PF2 (PFU t s c)])
  ]),
  Out = {phant-fun-struct T `s` SI Params s\
          {phant-fun-implicit `c` ClassTy (PFU T s)}}
].

mk-phant-term.mixins.aux T Params C CN PF X :- std.do![
  get-constructor CN KC,
  mgref->term Params T KC KCM,
  phant-fun-unify {{lib:hb.nomsg}} KCM C PF X,
].

pred mk-phant-term.class i:term, i:classname, i:phant-term, o:phant-term.
mk-phant-term.class T CN PF CPF :- !, std.do! [
  class-def (class CN _ CMLwP),
  w-params.fold CMLwP phant-fun-implicit (mk-phant-term.mixins T CN PF) CPF
].

pred mk-phant-term.classes i:term, i:list classname, i:list term, i:term,
                      i:list (w-args mixinname), o:phant-term.
mk-phant-term.classes EtaF CNF PL T MLwA PhF :- !, std.do! [
  std.map MLwA triple_1 ML,
  under-mixins.then MLwA phant-fun-mixin (out\ sigma FPLTM\ std.do! [
    mterm->term (mterm PL T ML EtaF) FPLTM,
    std.fold CNF (phant-term [] FPLTM) (mk-phant-term.class T) out]) PhF
].

pred mk-phant-term i:term, o:phant-term.
mk-phant-term F PhBody:- !, std.do! [
  std.assert-ok! (coq.typecheck F FTy) "mk-phant-term: F illtyped",
  ty-deps FTy MLwP,
  mk-eta (-1) FTy F EtaF,
%  toposort-mixins ML MLSorted,
  MLwP = MLwPSorted, % Assumes we give them already sorted in dep order.
  std.rev {list-w-params_list MLwPSorted} MLSortedRev,

  % phant-mixin-real is used to tag mixins which are passed as arguments
  std.filter MLSortedRev (m\not(phant-mixin-real m)) MLSortedRevFiltered,
  find-max-classes MLSortedRevFiltered CNL,
  assert-good-coverage! MLSortedRevFiltered CNL,

  w-params.then MLwP phant-fun-real phant-fun-real
    (mk-phant-term.classes EtaF CNL) PhBody,
].

pred classname->mixins i:classname, o:list-w-params mixinname.
classname->mixins CN MLwP :- class-def (class CN _ MLwP).

pred class-coverage i:list classname, o:coq.gref.set.
class-coverage CNL CSet :-
  std.map CNL classname->mixins CMLLwP,
  std.map CMLLwP list-w-params_list CMLL,
  coq.gref.list->set {std.flatten CMLL} CSet.

pred coq.gref.list->set i:list mixinname, o:coq.gref.set.
coq.gref.list->set L S :-
  std.fold L {coq.gref.set.empty} coq.gref.set.add S.

pred assert-good-coverage! i:list mixinname, i:list classname.
assert-good-coverage! MLSortedRev CNL :- std.do! [
  coq.gref.list->set MLSortedRev MLSet,
  class-coverage CNL CMLSet,
  if (not(coq.gref.set.equal MLSet CMLSet))
     (coq.gref.set.diff CMLSet MLSet Extra,
      coq.error "I could not find classes covering exactly mixins:"
        {std.any->string MLSortedRev}
        "In particular the covering" CNL "also includes mixins:"
        {coq.gref.set.elements Extra}
        "This should never happen, please report a bug.")
     true
].

pred if-coverage-not-good-error i:list mixinname.
if-coverage-not-good-error ML :-
  coq.gref.list->set ML MS,
  std.forall ML (if-coverage-not-good-error.one MS).

pred if-coverage-not-good-error.one i:coq.gref.set, i:mixinname.
if-coverage-not-good-error.one MS M :- mixin-first-class M C, !,
  class-coverage [C] CMS,
  if (coq.gref.set.subset CMS MS)
     true
     (coq.gref.set.elements {coq.gref.set.remove M CMS} MissinFromCurrent,
      coq.error "HB: the first structure declared in this hierarchy containing" {nice-gref->string M} "is" {nice-gref->string C}
       "which also contains" {std.map MissinFromCurrent nice-gref->string} "."
       "\nThe are two ways to fix this problem:"
       "1) change the current structure to contain" {std.map MissinFromCurrent nice-gref->string} "as well;"
       "2) amend the hierarchy by declaring a structure before" {nice-gref->string 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


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                              Synthesis                                     %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

pred params->holes i:list-w-params A, o:list term.
params->holes (w-params.nil _ _ _) [].
params->holes (w-params.cons _ _ F) [_|PS] :- pi x\ params->holes (F x) PS.

% [declare-instances T CL MCSTL] given a type T and a list of class definition
% CL in topological order (from least dep to most) looks for classes
% for which all the dependencies (mixins) were postulated so far and skips the
% 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-instances i:term, i:list class, o:list constant.
declare-instances T [class Class Struct MLwP|Rest] [CS|L] :-
  params->holes MLwP Params,
  get-constructor Class KC,

  if (not(local-cs? T Struct))
     true % we build it
     (if-verbose (coq.say "HB: skipping alreay existing"
                    {nice-gref->string Struct} "instance on"
                    {coq.term->string T}),
      fail),

  if (mgref->term Params T KC KCApp)
     (if-verbose (coq.say "HB: we can build a" {nice-gref->string Struct} "on"
        {coq.term->string T}))
     fail,

  !,
  term->gref T TGR,
  coq.gref->id TGR TID,
  Name is TID ^ "_is_a_" ^ {gref->modname Struct},

  if-verbose (coq.say "HB: declare canonical structure instance" Name),

  get-constructor Struct KS,
  mk-app (global KS) {std.append Params [T, KCApp]} S,
  std.assert-ok! (coq.typecheck S STy) "declare-instances: S illtyped",

  hb-add-const Name S STy @transparent! CS, % Bug coq/coq#11155, could be a Let
  hb-declare-instance (const CS), % Bug coq/coq#11155, should be local
  declare-instances T Rest L.
declare-instances T [_|Rest] L :- declare-instances T Rest L.
declare-instances _ [] [].

kind factory-abbrev type.
type factory-by-classname gref -> factory-abbrev.
type factory-by-phantabbrev abbreviation -> factory-abbrev.

pred declare-factory-abbrev i:id, i:factory-abbrev.
declare-factory-abbrev Name (factory-by-classname GR) :-
  % looks fishy (the parameters are not taken into account)
  @global! => hb-add-abbreviation Name 1 (fun _ _ t\ app[global GR,t]) tt _.
declare-factory-abbrev Name (factory-by-phantabbrev Abbr) :-
  coq.notation.abbreviation-body Abbr Nargs AbbrTrm,
  @global! => hb-add-abbreviation Name Nargs AbbrTrm tt _.

% [mk-factory-requires-clause-and-abbrev Str GR FL CL FactAbbrev]
% computes the list of mixins ML provided by FL,
% creates a clause in CL stating that GR requires ML (factory-requires ..), and
% creates an abbreviation for GR names Str and creates a phant-abbrev clause in CL.
% FactAbbrev is the short name for the factory (either an alias of the class record)
pred mk-factory-requires-clause-and-abbrev i:string, i:gref, i:list-w-params factoryname, o:list prop, o:factory-abbrev.
mk-factory-requires-clause-and-abbrev Str GR GRFS [FactoryRequires|Aliases] FactAbbrev :- !, std.do! [
  factories-provide GRFS ML,
  FactoryRequires = factory-requires GR ML,
  if (factory-alias->gref GR _)
     (Aliases = [],
      FactAbbrev = factory-by-classname GR)
     (hb-accumulate-phant-abbrev Str GR PhGR Abbrv,
      Aliases = [phant-abbrev GR PhGR Abbrv],
      FactAbbrev = factory-by-phantabbrev Abbrv),
].

% The identity builder
pred declare-id-builder i:factoryname, o:prop.
declare-id-builder GR (from GR GR (const C)) :- std.do! [
  mk-mixin-fun.then {factory-requires GR}
    (params\ t\ body\ sigma MTy\
      mgref->term params t GR MTy,
      body = fun `x` MTy x\x)
    IDBody,
  std.assert-ok! (coq.typecheck IDBody IDType) "identity builder illtyped",
  hb-add-const "identity_builder" IDBody IDType @transparent! C,
].


% [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
% be [] at call site.
pred postulate-arity i:arity, i:list term, i:term, o:term, o:term.
postulate-arity (parameter ID _ S A) Acc T T1 Ty :-
  std.assert-ok! (coq.typecheck-ty S _) "arity parameter illtyped",
  if-verbose (coq.say "HB: postulating" ID),
  if (var S) (coq.fresh-type S) true,
  hb-add-variable ID S C,
  Var = global (const C),
  postulate-arity (A Var) [Var|Acc] T T1 Ty.
postulate-arity (arity Ty) ArgsRev X T Ty :-
  hd-beta X {std.rev ArgsRev} X1 Stack1,
  unwind X1 Stack1 T.

% Given a type T, a fresh number N, and a mixin M it postulates
% a variable "mN" inhabiting M applied to T and
% all its dependencies, previously postulated and associated
% to the corresponding mixin using mixin-for
pred postulate-mixin i:w-args mixinname, i:list prop, o:list prop.
postulate-mixin (triple M Ps T) MSL [mixin-src T M (global (const C))|MSL] :- MSL => std.do! [
  Name is "mixin_" ^ {gref->modname M},

  if-verbose (coq.say "HB: postulate" Name "on" {coq.term->string T}),

  mgref->term Ps T M Ty,
  std.assert-ok! (coq.typecheck Ty _) "postulate-mixin: Ty illtyped",
  hb-add-variable Name Ty C
].

% [main-declare-context TheType Parameters Factories Clauses] postulates a
% (section) context with all the mixins provided by the factories and all
% the structure instances we can derive on TheType from these. Clauses
% contain mixin-src for each postulated mixin
pred main-declare-context i:term, i:list term, i:list-w-params factoryname, o:list prop, o:list constant.
main-declare-context TheType TheParams GRFSwP MSL CL :-  std.do! [
  factories-provide GRFSwP MLwP,
  apply-w-params MLwP TheParams TheType MLwAllArgs,
  std.fold MLwAllArgs [] postulate-mixin MSL,
  MSL => declare-instances TheType {findall-classes} CL,
  std.forall MSL (ms\ hb-accumulate current (clause _ _ ms)),
].

% [main-declare-builder (builder _ F M B) From MoreFrom] Given B of type FB, it
% declares all the new builders F to M via B.
% From holds the (from F Mi Bi) new clauses during folding.
pred main-declare-builder i:builder, i:list prop, o:list prop.
main-declare-builder (builder _ SrcFactory TgtMixin B) FromClauses MoreFromClauses :-
  FromClauses => std.do! [
    if (from SrcFactory TgtMixin _)
       (if-verbose (coq.say "HB: skipping duplicate builder from"
          {nice-gref->string SrcFactory} "to" {nice-gref->string TgtMixin}),
        MoreFromClauses = FromClauses)
       (if-verbose (coq.say "HB: declare builder from"
          {nice-gref->string SrcFactory} "to" {nice-gref->string TgtMixin}),
        MoreFromClauses = [from SrcFactory TgtMixin B|FromClauses])
  ].

% [export Module] exports a Module now adds it to the collection of
% modules to export in the end of the current enclosing module,
% by the command HB.Exports

pred to-export o:modpath.
pred export i:modpath.
export Module :- !,
  hb-export-module Module,
  hb-accumulate current (clause _ _ (to-export Module)).

pred main-reexport.
main-reexport :- !,
  std.findall (to-export Module_) Mods,
  std.forall Mods (x\ sigma y\ to-export y = x, coq.env.export-module y).

pred mk-mixin-fun i:list-w-params mixinname, i:term, o:term.
mk-mixin-fun ML X MLX :- mk-mixin-fun.then ML (p\ t\ body\ body = X) MLX.

% const Po : forall p1 .. pm T m1 .. mn, Extra  (Eg Extra = forall x y, x + y = y + z)
% const C : forall p1 .. pm s, Extra
% Po P1 .. PM T M1 .. MN PoArgs -> C P1 .. PM S PoArgs
pred clean-op-ty i:list prop, i:term, i:term, o:term.
clean-op-ty [] _ T1 T2 :- copy T1 T2.
clean-op-ty [exported-op _ Po C|Ops] S T1 T2 :-
  gr-deps (const Po) MLwP,
  w-params.nparams MLwP NParams,
  std.length {list-w-params_list MLwP} NMixins,

  (pi L L1 Params Rest PoArgs\
    copy (app [global (const Po)| L]) (app [global (const C) | L1]) :-
      std.split-at NParams L Params [_|Rest],
      std.drop NMixins Rest PoArgs,
      std.append Params [S|PoArgs] L1) =>

  clean-op-ty Ops S T1 T2.

pred operation-body-and-ty i:list prop, i:constant, i:structure, i:term, i:term,
  i:list term, i:term, i:w-args A, o:pair term term.
operation-body-and-ty EXI Poperation Struct Psort Pclass Params _T (triple _ Params _) (pr Bo Ty) :- std.do! [
  mk-app (global Struct) Params StructType,
  mk-app Psort Params PsortP,
  mk-app Pclass Params PclassP,
  Bo = fun `s` StructType Body,
  Ty = prod `s` StructType BodyTy,
  (@pi-decl `s` StructType s\ sigma Carrier Class\ std.do! [
      mk-app PsortP [s] Carrier,
      mk-app PclassP [s] Class,
      under-mixin-src-from-factory.do! Carrier Class [
        % just in case..
        mgref->term Params Carrier (const Poperation) (Body s),
        std.assert-ok! (coq.typecheck (Body s) (DirtyTy s)) "export-1-operation: Body illtyped",
        clean-op-ty EXI s (DirtyTy s) (BodyTy s),
      ],
  ]),
].

% given an operation (a mixin projection) we generate a constant projection the
% same operation out of the package structure (out of the class field of the
% structure). We also provide all the other mixin dependencies (other misins)
% of the package structure.
pred export-1-operation i:mixinname, i:structure, i:term, i:term, i:one-w-params mixinname, i:option constant, i:list prop, o:list prop.
export-1-operation _ _ _ _ _ none EX EX :- !. % not a projection, no operation
export-1-operation M Struct Psort Pclass MwP (some Poperation) EXI EXO :- !, std.do! [
  coq.gref->id (const Poperation) Name,

  w-params.then MwP mk-fun-prod ignore (operation-body-and-ty EXI Poperation Struct Psort Pclass) (pr Body BodyTy),

  if-verbose (coq.say "HB: export operation" Name),
  hb-add-const Name Body BodyTy @transparent! C,

  w-params.nparams MwP NP,
  NImplicits is NP + 1,
  std.map {std.iota NImplicits} (_\r\ r = maximal) Implicits,
  @global! => hb-set-implicit (const C) Implicits,

  EXO = [exported-op M Poperation C|EXI]
].

% Given a list of mixins, it exports all operations in there
pred export-operations.aux i:structure, i:term, i:term, i:one-w-params mixinname, i:list prop, o:list prop.
export-operations.aux Struct ProjSort ProjClass MwP EX1 EX2 :- !, std.do! [
  w-params_1 MwP (indt M),
  coq.CS.canonical-projections M Poperations,
  std.fold Poperations EX1 (export-1-operation (indt M) Struct ProjSort ProjClass MwP) EX2,
].

pred mixin-not-already-declared i:one-w-params mixinname.
mixin-not-already-declared MwP :-
  w-params_1 MwP M, not(mixin-first-class M _), M = indt _.

pred export-operations i:structure, i:term, i:term, i:list-w-params mixinname, i:list prop, o:list prop, o:list mixinname.
export-operations Structure ProjSort ProjClass MLwP EX1 EX2 MLToExport :- std.do! [
  distribute-w-params MLwP LMwP,
  std.filter LMwP mixin-not-already-declared LMwPToExport,
  std.fold LMwPToExport EX1 (export-operations.aux Structure ProjSort ProjClass) EX2,
  std.map LMwPToExport w-params_1 MLToExport,
].

pred mk-coe-class-body
  i:factoryname, % From class
  i:factoryname, % To class
  i:list-w-params mixinname, % To mixins
  i:list term, i:term, % Params, T
  i:list (w-args mixinname),
  o:term.
mk-coe-class-body FC TC TMLwP Params T _ CoeBody :- std.do! [
  mk-app (global FC) {std.append Params [T]} Class,

  list-w-params_list TMLwP TML,
  std.map TML (from FC) Builders,
  std.map Builders (x\r\mk-app (global x) Params r) BuildersP,

  mk-app (global {get-constructor TC})
    {coq.mk-n-holes {factory-nparams TC}} KCHoles,

  (pi c\ sigma Mixes\
    std.map BuildersP (builder\r\ r = app[builder, T, c]) Mixes,
    mk-app KCHoles [T | Mixes] (ClassCoercion c)),

  CoeBody = {{ fun (c : lp:Class) => lp:(ClassCoercion c) }}
].

pred mk-coe-structure-body
  i:structure, % From structure
  i:structure, % To structure
  i:factoryname, % To factory (for nparams)
  i:term, % class coercion
  i:term, % sort projection
  i:term, % class projection
  i:list term, i:term, % Params, T
  i:list (w-args mixinname),
  o:term.
mk-coe-structure-body StructureF StructureT TC Coercion SortProjection ClassProjection
    Params _T _ SCoeBody :- std.do! [

  mk-app (global StructureF) Params StructureP,
  mk-app     SortProjection  Params SortP,
  mk-app     ClassProjection Params ClassP,
  mk-app     Coercion        Params CoercionP,

  mk-app (global {get-constructor StructureT})
    {coq.mk-n-holes {factory-nparams TC}} PackPH,

  SCoeBody = {{ fun s : lp:StructureP =>
     let T : Type := lp:SortP s in
     lp:PackPH T (lp:CoercionP T (lp:ClassP s)) }},
].

% [declare-coercion P1 P2 C1 C2] declares a structure and a class coercion
% from C1 to C2 given P1 P2 the two projections from the structure of C1
pred declare-coercion i:term, i:term, i:class, i:class.
declare-coercion SortProjection ClassProjection
    (class FC StructureF FMLwP) (class TC StructureT TMLwP) :- std.do! [

  hb-accumulate current (clause _ _ (sub-class FC TC)),

  gref->modname StructureF ModNameF,
  gref->modname StructureT ModNameT,
  CName is ModNameF ^ "_class_to_" ^ ModNameT ^ "_class",
  SName is ModNameF ^ "_to_" ^ ModNameT,

  if-verbose (coq.say "HB: declare coercion" SName),

  w-params.then FMLwP mk-fun mk-fun
    (mk-coe-class-body FC TC TMLwP) CoeBody,

  std.assert-ok! (coq.typecheck CoeBody Ty) "declare-coercion: CoeBody illtyped",

  if-verbose (coq.say "HB: declare coercion hint" CName),

  hb-add-const CName CoeBody Ty @transparent! C,
  @global! => hb-coercion-declare (coercion (const C) 1 FC (grefclass TC)),

  Coercion = global (const C),
  w-params.then FMLwP mk-fun ignore
    (mk-coe-structure-body StructureF StructureT TC Coercion SortProjection ClassProjection)
    SCoeBody,

  std.assert-ok! (coq.typecheck SCoeBody STy) "declare-coercion: SCoeBody illtyped",

  if-verbose (coq.say "HB: declare unification hint" SName),

  hb-add-const SName SCoeBody STy @transparent! SC,
  @global! => hb-coercion-declare (coercion (const SC) 0 StructureF (grefclass StructureT)),
  hb-declare-instance (const SC), % TODO: API in Elpi, take a @constant instead of gref
].

pred join-body i:int, i:int, i:structure, i:term, i:term, i:term, i:term, i:term,
  i:list term, i:name, i:term, i:(term -> A), o:term.
join-body N1 N2 S3 S2_Pack S1_sort S3_to_S1 S2_class S3_to_S2
  P N _Ty _F (fun N S3P Pack) :- !,
  mk-app (global S3) P S3P, !,
  coq.mk-n-holes N2 Holes2, !,
  coq.mk-n-holes N1 Holes1, !,
  @pi-decl N S3P s\
  sigma S3_to_S1_Ps S3_to_S2_Ps S1_sortS3Ps S2_classS3Ps \ std.do! [
    mk-app S3_to_S1 {std.append P [s]} S3_to_S1_Ps,
    mk-app S1_sort {std.append Holes1 [S3_to_S1_Ps]} S1_sortS3Ps,
    mk-app S3_to_S2 {std.append P [s]} S3_to_S2_Ps,
    mk-app S2_class {std.append Holes2 [S3_to_S2_Ps]} S2_classS3Ps ,
    mk-app S2_Pack {std.append Holes2 [S1_sortS3Ps, S2_classS3Ps]} (Pack s)
  ].

pred declare-join i:class, i:pair class class, o:prop.
declare-join (class C3 S3 MLwP3) (pr (class C1 S1 _) (class C2 S2 _)) (join C1 C2 C3) :-
  Name is "join_" ^ {gref->modname S3} ^
    "_between_" ^ {gref->modname S1} ^ "_and_" ^ {gref->modname S2},

  get-structure-coercion S3 S2 S3_to_S2,
  get-structure-coercion S3 S1 S3_to_S1,
  get-structure-sort-projection S1 S1_sort,
  get-structure-class-projection S2 S2_class,
  get-constructor S2 S2_Pack,

  factory-nparams C1 N1,
  factory-nparams C2 N2,

  if-verbose (coq.say "HB: declare unification hint" Name),
  w-params.fold MLwP3 mk-fun (join-body N1 N2 S3
    (global S2_Pack) S1_sort S3_to_S1 S2_class S3_to_S2) JoinBody,
  std.assert-ok! (coq.typecheck JoinBody Ty) "declare-join: JoinBody illtyped",
  hb-add-const Name JoinBody Ty @transparent! J,
  hb-declare-instance (const J).

% TODO: this works under the invariant: we never have two classes that
% contain exactly the same mixins. hb.structure should enforce this
% and eventually just alias the existing one rather than failing.
% TODO: hb.structure should check we are not inserting the class
% in the middle of existing ones. Possible fix: always declare all intermediate
% possibilities but without proper names (requires the previous TODO about
% aliasing already existing stuff).
pred declare-unification-hints i:term, i:term, i:class, o:list prop.
declare-unification-hints SortProj ClassProj CurrentClass NewJoins :- std.do! [
  findall-classes All,

  std.filter All (sub-class? CurrentClass) AllSuper,
  std.forall AllSuper (declare-coercion SortProj ClassProj CurrentClass),

  findall-newjoins CurrentClass AllSuper TodoJoins,

  std.map TodoJoins (declare-join CurrentClass) NewJoins
].

% For each mixin we declare a field and apply the mixin to its dependencies
% (that are previously declared fields recorded via field-for-mixin)
pred synthesize-fields i:term, i:list (w-args mixinname), o:record-decl.
synthesize-fields _T []     end-record.
synthesize-fields T  [triple M Args _|ML] (field _ Name MTy Fields) :- std.do! [
  Name is {gref->modname M} ^ "_mixin",
  if-verbose (coq.say "HB: typing class field" M),
  std.assert! (mgref->term Args T M MTy) "anomaly: a field type cannot be solved",
  @pi-decl `m` MTy m\ mixin-src T M m => synthesize-fields T ML (Fields m)
].

pred synthesize-fields.body i:list term, i:term, i:list (w-args mixinname), o:indt-decl.
synthesize-fields.body _Params T ML (record "axioms" {{ Type }} "Class" FS) :-
  synthesize-fields T ML FS.

pred mk-record+sort-field i:name, i:term, i:(term -> record-decl), o:indt-decl.
mk-record+sort-field _ T F (record RecordName {{ Type }} "Pack" (field _ "sort" T F)) :-
  if (get-option "infer" _) (RecordName = "type_") (RecordName = "type").

pred mk-class-field i:classname, i:list term, i:term, i:list (w-args mixinname), o:record-decl.
mk-class-field ClassName Params T _ (field _ "class" (app [global ClassName|Args]) _\end-record) :-
  std.append Params [T] Args.

% Builds the axioms record and the factories from this class to each mixin
% TODO params
pred declare-class+structure i:list-w-params mixinname, o:factoryname, o:structure, o:term, o:term, o:list prop.
declare-class+structure MLwP (indt ClassInd) (indt StructureInd) SortProjection ClassProjection AllFactories :- std.do! [

  if-verbose (coq.say "HB: declare axioms record"),

  w-params.then MLwP (mk-parameter explicit) (mk-parameter explicit)
    synthesize-fields.body ClassDeclaration,

  std.assert-ok! (coq.typecheck-indt-decl ClassDeclaration) "declare-class: illtyped",
  hb-add-indt ClassDeclaration ClassInd,
  coq.CS.canonical-projections ClassInd Projs,
  % TODO: put this code in a named clause
  w-params.nparams MLwP NParams,
  std.map2 {list-w-params_list MLwP} Projs (m\ p\ r\ sigma P\
    p = some P,
    r = from (indt ClassInd) m (const P)) Factories,
  AllFactories = [factory-nparams (indt ClassInd) NParams | Factories],

  if-verbose (coq.say "HB: declare type record"),

  w-params.then MLwP (mk-parameter explicit) mk-record+sort-field
    (mk-class-field (indt ClassInd)) StructureDeclaration,

  std.assert-ok! (coq.typecheck-indt-decl StructureDeclaration) "declare-structure: illtyped",
  hb-add-indt StructureDeclaration StructureInd,

  coq.CS.canonical-projections StructureInd [some SortP, some ClassP],
  global (const SortP) = SortProjection,
  global (const ClassP) = ClassProjection,
].

% Declares "sort" as a coercion Structurename >-> Sortclass
pred declare-sort-coercion i:structure, i:term.
declare-sort-coercion StructureName (global Proj) :-

  if-verbose (coq.say "HB: declare sort coercion"),

  @global! => hb-coercion-declare (coercion Proj 0 StructureName sortclass).

pred if-class-already-exists-error i:id, i:list class, i:list mixinname.
if-class-already-exists-error _ [] _.
if-class-already-exists-error N [class _ S ML1wP|CS] ML2 :-
  list-w-params_list ML1wP ML1,
  if (list-eq-set ML1 ML2)
     (coq.error "Structure" {nice-gref->string S} "contains the same mixins of" N)
     (if-class-already-exists-error N CS ML2).

pred export-mixin-coercion i:classname, i:option constant.
export-mixin-coercion _ none.
export-mixin-coercion ClassName (some C) :-
  coq.env.typeof (const C) CTy,
  head-gref-under-prods CTy MixinGR,
  if-verbose (coq.say "HB: export class to mixin coercion for mixin" {nice-gref->string MixinGR}),
  @global! =>
    hb-coercion-declare (coercion (const C) _ ClassName (grefclass MixinGR)).

pred mc-compat-structure i:string, i:modpath, i:list mixinname, i:int, i:classname, i:term, i:option gref.
mc-compat-structure ModuleName _Module NewMixins CNParams ClassName ClassProjection Axioms :- std.do! [
  CompatModuleName is "MathCompCompat" ^ ModuleName,
  hb-begin-module CompatModuleName, % to avoid collisions
  hb-begin-module ModuleName,

  if (Axioms = some GR)
    (@global! => hb-add-abbreviation "axiom" 0 (global GR) ff _)
    true,

  if (NewMixins = [NewMixin]) (std.do! [
    if-verbose (coq.say "mc-compat-structure: declaring notations 'axioms', 'mixin_of' and 'Mixin'"),
    MArgs is {factory-nparams NewMixin} + 1,
    mk-eta MArgs {coq.env.typeof NewMixin} (global NewMixin) EtaNewMixin,
    @global! => hb-add-abbreviation "axioms" MArgs EtaNewMixin ff _,
    @global! => hb-add-abbreviation "mixin_of" MArgs EtaNewMixin ff _,
    std.assert! (factory-constructor NewMixin FK) "BUG: Factory constructor missing",
    std.assert! (phant-abbrev FK _ PhAbb) "BUG: missing phant-abbrev",
    @global! => hb-add-abbreviation "Mixin" 0
      {coq.notation.abbreviation PhAbb {coq.mk-n-holes MArgs}} ff _,
    if-verbose (coq.say "mc-compat-structure: declaring pack abbreviation"),
    class-def (class ClassName _ ClassMixins),
    w-params.then ClassMixins mk-fun mk-fun (pack-body ClassName) Pack,
    (phant-mixin-real NewMixin => mk-phant-abbrev "pack" {mk-phant-term Pack} _ _),
    ])
    (if-verbose (coq.say "mc-compat-structure: not exactly one new mixin")),

  if-verbose (coq.say "mc-compat-structure: declaring notation 'class_of'"),
  std.assert-ok! (coq.typecheck ClassProjection ClassProjectionTy) "wtf",
  CArgs is CNParams + 1,
  mk-eta CArgs ClassProjectionTy ClassProjection EtaClassProjection,
  @global! => hb-add-abbreviation "class_of" CArgs EtaClassProjection ff _,

  hb-end-module ModuleName _,
  hb-end-module CompatModuleName MCCompat,
  hb-export-module MCCompat,
  %coq.env.import-module Module,
].

pred clone-phant-body i:factoryname, i:term, i:structure, i:list term, i:term, i:list (w-args mixinname), o:phant-term.
clone-phant-body ClassName SortProjection ((indt I) as Structure) PL T _ PhF :- std.do! [
  std.assert! (coq.env.indt I _ _ _ _ [PackC] _) "wtf",
  mk-app (global (indc PackC)) {std.append PL [T]} PackPLT,
  mk-app (global Structure) PL SPL,
  (@pi-decl `cT` SPL cT\
  mk-app (global ClassName) {std.append PL [T]} CPL,
  @pi-decl `c` CPL c\
  (Ph cT c) =
    {phant-fun-unify {{lib:hb.nomsg}} T {mk-app {mk-app SortProjection PL} [cT]}
      {phant-fun-unify {{lib:hb.nomsg}} cT {mk-app PackPLT [c]}
        (phant-term [] {mk-app PackPLT [c]}) }}),
  PhF = {phant-fun-real `cT` SPL cT\ {phant-fun-implicit `c` CPL c\ Ph cT c }}
].

% [pack-body ClassName P T MLwA B] asserts
%  B = fun m0 ... mn => Pack P T (Class P T m0 ... mn)
% under a context with P and T
pred pack-body.mixins i:list term, i:term, i:gref, i:gref, o:term.
pack-body.mixins PL T BuildC PackS Body :- !, std.do! [
  mgref->term PL T BuildC Class,
  mk-app (global PackS) {std.append PL [T, Class]} Body
].

pred pack-body i:classname, i:list term, i:term, i:list (w-args mixinname), o:term.
pack-body ClassName PL T MLwA F :- std.do! [
  class-def (class ClassName S _),
  get-constructor ClassName BuildC,
  get-constructor S PackS,
  under-mixins.then MLwA mk-fun (pack-body.mixins PL T BuildC PackS) F
].

pred declare-auto-infer-params-abbrev i:structure, i:list-w-params mixinname.
declare-auto-infer-params-abbrev GR MLwP :- get-option "infer" Map, !,
  Map => mk-infer (global GR) MLwP PHT,
  mk-phant-abbrev "type" PHT _ _.
declare-auto-infer-params-abbrev _ _.

pred mk-infer i:term, i:list-w-params mixinname, o:phant-term.
mk-infer T (w-params.nil _ _ _) (phant-term [] T).
mk-infer T (w-params.cons N Ty W) (phant-term [implicit-arg, infer-type N|A] R1) :-
  coq.name->id N ID, (get-option ID "Type" ; get-option ID ""), !,
  R1 = (fun N Ty n\ fun `ph` {{ lib:@hb.phant lp:n }} _\ R n),
  @pi-decl N Ty n\
    mk-infer {mk-app T [n]} (W n) (phant-term A (R n)).
mk-infer T (w-params.cons N Ty W) (phant-term [real-arg N|A] (fun N Ty R)) :-
   coq.name->id N ID, not (get-option ID _), !,
  @pi-decl N Ty x\  mk-infer {mk-app T [x]} (W x) (phant-term A (R x)).
mk-infer _ (w-params.cons N _ _) _ :- coq.name->id N ID, get-option ID Infer,
  coq.error "Automatic inference of paramter" N "from" Infer "not supported".

% 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 main-declare-structure i:string, i:list-w-params gref, i:bool.
main-declare-structure Module GRFSwP ClosureCheck :- std.do! [
  factories-provide GRFSwP PMLwP,

  list-w-params.flatten-map GRFSwP factory-requires RMLwP, % TODO: extract code from factories-provide
  list-w-params.append PMLwP RMLwP UnsortedMLwP,
  w-params.map UnsortedMLwP (p\t\ toposort-mixins) MLwP,

  list-w-params_list PMLwP PML,
  list-w-params_list MLwP ML,

  if (ClosureCheck = tt, not({std.length PML} = {std.length ML}))
     (coq.warn "HB: pulling in dependencies:" {std.map {list-diff ML PML} nice-gref->string}
               "\nPlease list them or end the declaration with '&'")
     true,

  if-class-already-exists-error Module {findall-classes} ML,
  if-coverage-not-good-error ML,

  % TODO: check we never define the superclass of an exising class

  if-verbose (coq.say "HB: start module" Module),

  hb-begin-module Module,

  declare-class+structure MLwP
    ClassName Structure SortProjection ClassProjection Factories,

  w-params.map MLwP (_\_\_\ mk-nil) NilwP,
  ClassRequires = factory-requires (ClassName) NilwP,
  ClassAlias = (factory-alias->gref ClassName ClassName),
  CurrentClass = (class ClassName Structure MLwP),
  
  declare-auto-infer-params-abbrev Structure MLwP,

  if-verbose (coq.say "HB: declaring clone abbreviation"),

  w-params.then MLwP phant-fun-real phant-fun-real
    (clone-phant-body ClassName SortProjection Structure) PhClone,

  mk-phant-abbrev "clone" PhClone _ _,

  if-verbose (coq.say "HB: start module Exports"),

  hb-begin-module "Exports",
  declare-sort-coercion Structure SortProjection,

  if-verbose (coq.say "HB: exporting unification hints"),
  ClassAlias => ClassRequires => Factories =>
    declare-unification-hints SortProjection ClassProjection CurrentClass NewJoins,
  % Register in Elpi's DB the new structure
  % NOT TODO: All these hb-accumulate are correctly locaed in an Export Module

  if (ClassName = indt ClassInd) (std.do![
    if-verbose (coq.say "HB: exporting coercions from class to mixins"),
    std.forall {coq.CS.canonical-projections ClassInd}
      (export-mixin-coercion ClassName)
    ])
    (coq.say "declare-structure:" ClassName "should be an inductive", fail),

  if-verbose (coq.say "HB: accumulating various props"),
  std.flatten [
      Factories, [ClassRequires], [ClassAlias], [is-structure Structure],
      NewJoins, [class-def CurrentClass]
    ]
    NewClauses,
  std.forall NewClauses (c\ hb-accumulate current (clause _ _ c)),

  if-verbose (coq.say "HB: stop module Exports"),
  hb-end-module "Exports" Exports,

  hb-end-module Module ModulePath,

  if-verbose (coq.say "HB: end modules; export" Exports),

  export Exports,

  if-verbose (coq.say "HB: exporting operations"),
    ClassAlias => ClassRequires => Factories =>
      export-operations Structure SortProjection ClassProjection MLwP [] EX   MLToExport,
    % TODO: issue an Arguments op T : rename, where T is the name written by
    %   the user in Definition foo := { T of ... }

  if-verbose (coq.say "HB: start operations meta-data module ElpiOperations"),
  ElpiOperationModName is "ElpiOperations" ^ {std.any->string {new_int}},
  coq.env.begin-module ElpiOperationModName none,
    std.map MLToExport (m\r\ r = mixin-first-class m ClassName) MixinFirstClass,
    std.forall {std.append EX MixinFirstClass} (c\ hb-accumulate current (clause _ _ c)),
  coq.env.end-module ElpiOperations,
  export ElpiOperations,

  declare-factory-abbrev Module (factory-by-classname ClassName),

  NewClauses => if-MC-compat (mc-compat-structure Module ModulePath MLToExport {w-params.nparams MLwP} ClassName ClassProjection),

].

/* HB.context?
pred main-begin-declare i:string, i:string, i:list gref, i:declaration.
main-begin-declare Module TName GRFS Decl :- std.do! [

  if-verbose (coq.say "HB: start module and section" Module),

  hb-begin-module Module none,
  hb-begin-section Module,

  if-verbose (coq.say "HB: postulate type" TName),

  coq.fresh-type Ty,
  @local! => hb-add-const TName _ Ty @opaque! T, % no body, local -> a variable
  main-declare-context (global (const T)) [] GRFS _, % TODO params
  hb-accumulate current (clause _ _ (current-mode Decl))
].
*/

pred main-end-declare-builders.
main-end-declare-builders :- std.do! [
  current-mode (builder-from _ GR ModName),

  hb-end-section ModName,

  findall-builders LFIL,

  std.fold LFIL [] main-declare-builder Clauses,

  if (Clauses = [])
     (coq.error "No builders to declare, did you forget HB.instance?")
     true,

  % TODO: Do we need this module?
  gref->modname GR M,
  Name is M ^ "_Exports",
  hb-begin-module Name,
  (std.forall Clauses c\ hb-accumulate current (clause _ _ c)),

  hb-end-module Name Exports,
  hb-end-module ModName _,
  export Exports,
].

pred add-mixin i:term, i:factoryname, i:bool, i:mixinname, i:term, o:list prop.
add-mixin T FGR MakeCanon MissinMixin Bo [MixinSrcCl, BuiderDeclCl] :-
  MixinSrcCl = mixin-src T MixinName (global (const C)),
  BuiderDeclCl = builder-decl (builder N FGR MixinName (const C)),
  new_int N, % timestamp

  std.assert-ok! (coq.typecheck Bo Ty) "declare-instances: mixin illtyped",
  safe-dest-app Ty (global MixinNameAlias) _,
  factory-alias->gref MixinNameAlias MixinName,

  std.assert! (MissinMixin = MixinName) "HB: anomaly: we built the wrong mixin",

  % If the mixin instance is alreaduy a constant there is no need to
  % alias it.
  if (Bo = global (const C)) true
    (Name is {nice-gref->string FGR} ^"_to_" ^ {nice-gref->string MixinName} ^ "__" ^ {std.any->string {new_int}},
     if-verbose (coq.say "HB: declare" Name),
     hb-add-const Name Bo Ty @transparent! C),
  if (MakeCanon = tt, whd (global (const C)) [] (global (indc _)) _)
     (if-verbose (coq.say "HB: declare canonical mixin instance" C),
      hb-declare-instance (const C))
     true.

pred mixin-for_mixin-builder i:prop, o:term.
mixin-for_mixin-builder (mixin-for _ _ B) B.

pred add-all-mixins i:term, i:factoryname, i:list mixinname, i:bool, o:list prop.
add-all-mixins T FGR MissingMixins MakeCanon Clauses :- std.do! [
  std.map MissingMixins (assert!-mixin-for T) MBL,
  std.map2 MissingMixins MBL (add-mixin T FGR MakeCanon) ClausesL,
  std.flatten ClausesL Clauses,
].

pred findall-mixin-src i:term, o:list mixinname.
findall-mixin-src T ML :-
  std.map {std.findall (mixin-src T M_ V_)} mixin-src_mixin ML.

% We find the new mixins that F build, we build them and shedule them
% for becoming builders at section closing time. We also declare
% all canonical instances these new mixins allow for, so that the user
% can access their theory and notations
pred declare-canonical-instances-from-factory-and-local-builders i:term, i:term, i:term, i:factoryname, o:list prop.
declare-canonical-instances-from-factory-and-local-builders T F _TheFactory FGR Clauses :- std.do! [
  findall-mixin-src T OldMixins,
  mixin-srcs T F MixinSrcFromF,
  std.map MixinSrcFromF mixin-src_mixin FMixins,
  std.filter FMixins (m\ not(std.mem! OldMixins m)) MissingMixins,
  if-verbose (coq.say "HB: new mixins from"
    {coq.term->string F} "on" {coq.term->string T} ":"
    {std.map MissingMixins nice-gref->string}),
  MixinSrcFromF => add-all-mixins T FGR MissingMixins ff Clauses,
  Clauses => declare-instances T {findall-classes} _
].

% [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:term, i:term.
declare-canonical-instances-from-factory T F :-
  coq.typecheck F TyF ok,
  target-gref TyF GRF,
  under-canonical-mixins-of.do! T [
    under-mixin-src-from-factory.do! T F [
      add-all-mixins T GRF {list-w-params_list {factory-provides GRF}} tt _,
      declare-instances T {findall-classes} _
    ]
  ].

% entry point for HB.instance
pred main-declare-instance i:term, i:term, o:list prop.
main-declare-instance T F Clauses :- current-mode (builder-from TheFactory FGR _), !,
  declare-canonical-instances-from-factory-and-local-builders T F TheFactory FGR Clauses.
main-declare-instance T F [] :-
  declare-canonical-instances-from-factory T F.

pred declare-old-located i:string, i:located.
declare-old-located Id (loc-gref GR) :-
  @global! => hb-add-abbreviation Id 0 (global GR) ff _.
declare-old-located Id (loc-abbreviation Abbrev) :-
  coq.notation.abbreviation Abbrev [] T,
  % FIXME: this assumes the abbreviation has no arg
  % we should fix it.
  @global! => hb-add-abbreviation Id 0 T ff _.

pred declare-old-constant i:option constant.
declare-old-constant none.
declare-old-constant (some C) :-
  coq.gref->id (const C) Id,
  std.forall {coq.locate-all Id} (declare-old-located Id).
declare-old-constant _ :- true.

pred elaborate-context-skel->factory i:context-decl, o:context-decl, o:factoryname, o:diagnostic.
elaborate-context-skel->factory
  (context-item IDT IT TTySkel none t\ context-item IDF IF (TFSkel t) none _\ context-end)
  (context-item IDT IT TTy none t\ context-item IDF IF (TFSkel t) none _\ context-end) GRF Diag
:- !, std.do-ok! Diag [
  coq.elaborate-ty-skeleton TTySkel _ TTy,
  (d\ coq.id->name IDT NameT),
  (d\ @pi-decl NameT TTy t\ purge-id (TFSkel t) (TFSkel1 t), coq.elaborate-ty-skeleton (TFSkel1 t) _ (TF1 t) d),
  (d\ @pi-decl NameT TTy t\ std.assert! (factory? (TF1 t) (triple GRF _Params t)) "the last argument must be a factory applied to the type variable"),
].
elaborate-context-skel->factory (context-item ID I TSkel none C) (context-item ID I T none C1) GRF Diag :- !, std.do-ok! Diag [
  coq.elaborate-ty-skeleton TSkel _ T,
  (d\ coq.id->name ID Name),
  (d\ @pi-decl Name T x\ elaborate-context-skel->factory (C x) (C1 x) GRF d),
].
elaborate-context-skel->factory (context-item ID _ _ (some _) _) _ _ _ :-
  coq.error "context item cannot be given a body:" ID.

pred purge-id i:term, o:term.
purge-id T T1 :-
  (pi fresh t v\ copy {{lib:@hb.id lp:t lp:v}} fresh :- !) => copy T T1.

pred main-begin-declare-builders i:context-decl.
main-begin-declare-builders CtxSkel :- std.do! [
  Name is "Builders_" ^ {term_to_string {new_int}}, % TODO?
  std.assert-ok! (elaborate-context-skel->factory CtxSkel Ctx GRF) "Context illtyped",
  if-verbose (coq.say "HB: context to factory"),
  hb-begin-module Name,
  if-verbose (coq.say "HB: begin module for builders"),
  if (GRF = indt FRecord) (std.do! [
    if-verbose (coq.say "HB: begin module Super"),
    hb-begin-module "Super",
    std.forall {coq.CS.canonical-projections FRecord} declare-old-constant,
    hb-end-module "Super" _,
    if-verbose (coq.say "HB: ended module Super")]) (true),
  hb-begin-section Name,
  if-verbose (coq.say "HB: postulating factories"),
  builders-postulate-factories Name Ctx,
].

pred postulate-factory-abbrev i:term, i:list term, i:id, i:factoryname, o:term.
postulate-factory-abbrev TheType Params Name Falias TheFactory :- std.do! [
  factory-alias->gref Falias F,
  phant-abbrev F _ Fabv,
  coq.notation.abbreviation Fabv {std.append Params [TheType]} Package,
  Msg is "Unable to declare factory " ^ Name,
  std.assert-ok! (coq.typecheck-ty Package _) Msg,
  hb-add-variable Name Package C,
  TheFactory = global (const C),
].

% Only record fields can be exported as operations.
pred define-factory-operations i:term, i:list term, i:term, i:gref.
define-factory-operations TheType Params TheFactory (indt I) :- !,
  coq.env.indt I _ NIParams _ _ _ _,
  NHoles is NIParams - 1 - {std.length Params},
  coq.CS.canonical-projections I PL,
  std.forall PL (define-factory-operation TheType Params TheFactory NHoles).
define-factory-operations _ _ _ _.

pred define-factory-operation i:term, i:list term, i:term, i:int, i:option constant.
define-factory-operation _ _ _ _ none.
define-factory-operation TheType Params TheFactory NHoles (some P) :-
  coq.mk-n-holes NHoles Holes,
  std.append Holes [TheFactory] Holes_Factory,
  std.append Params [TheType|Holes_Factory] Args,
  T = app[global (const P)|Args],
  std.assert-ok! (coq.typecheck T _) "Illtyped applied factory operation",
  coq.gref->id (const P) Name,
  @local! => hb-add-abbreviation Name 0 T ff _.

pred fresh-indexed-type o:term.
fresh-indexed-type Ty :-
  Ty = {{lib:hb.indexed Type}},
  std.assert-ok! (coq.typecheck-ty Ty _) "impossible".

pred builders-postulate-factories i:id, i:context-decl.
builders-postulate-factories ModName (context-item IDT _ TySkel none t\ context-item IDF _ (TF t) none _\ context-end) :- !, std.do! [
  % TODO we should allow T to be anything.
  std.assert-ok! (coq.elaborate-ty-skeleton TySkel _ Ty) "builders-postulate-factory: illtyped context",
  if (var Ty) (fresh-indexed-type Ty)
     (std.assert-ok! (coq.unify-eq Ty {{Type}}) "The last context item before the factory must be a type variable"),
  if-verbose (coq.say "HB: postulating type" IDT),
  hb-add-variable IDT Ty C,
  TheType = global (const C),

  std.assert! (factory? (TF TheType) (triple GRF Params TheType))
    "the last argument must be a factory applied to the type variable",
  factory-requires GRF GRFMLwP, % TODO: remove, pass to main-declare-context the list-w-params-eta-expansion of GRF
  main-declare-context TheType Params GRFMLwP _ _,
  postulate-factory-abbrev TheType Params IDF GRF TheFactory,
  define-factory-operations TheType Params TheFactory GRF,
  hb-accumulate current (clause _ _ (current-mode (builder-from TheFactory GRF ModName))),
].

builders-postulate-factories ModName (context-item ID _ TSkel none Factories) :- std.do! [
  if-verbose (coq.say "HB: postulating" ID),
  std.assert-ok! (coq.elaborate-ty-skeleton TSkel _ T) "builders-postulate-factories: illtyped context",
  if (var T) (coq.fresh-type T) true,
  hb-add-variable ID T P,
  TheParam = global (const P),
  builders-postulate-factories ModName (Factories TheParam),
].

builders-postulate-factories _ (context-item ID _ _ (some _) _) :-
  coq.error "context item cannot be given a body:" ID.

% In an asset like HB.mixing Recoord P1 .. PN A of F1 .. & FK ..
% we call "named" P1 .. PN A, hence A is the last named asset param
pred is-last-named-asset-param i:asset-decl.
is-last-named-asset-param (asset-parameter _ {{ lib:hb.indexed _ }} _) :- !.
is-last-named-asset-param (asset-parameter _ _ p\ asset-parameter _ (M p) _) :- pi p\ factory? (M p) _, !.
is-last-named-asset-param (asset-parameter _ _ _\ asset-record _ _ _ _) :- !.
is-last-named-asset-param (asset-parameter _ _ _\ asset-alias _ _) :- !.

% [main-declare-asset Asset AssetKind] unifies the code paths for
% mixins, factories (and alias factories)
pred main-declare-asset i:asset-decl, i:asset.
main-declare-asset Asset AssetKind :- std.do! [
  name-of-asset-decl Asset Module,

  if-verbose (coq.say "HB: start module and section" Module),

  hb-begin-module Module,
  hb-begin-section Module,

  % We start by postulating the parameters
  process-asset-named-parameters Asset AssetKind Module [],
].

pred process-asset-named-parameters i:asset-decl, i:asset, i:id, i:list (pair term term).
% We reached TheType
process-asset-named-parameters (asset-parameter Name T Rest as R) D Module Params :- is-last-named-asset-param R, !, std.do! [

  if-verbose (coq.say "HB: postulate type" Name),
  if (var T) (fresh-indexed-type Ty) (Ty = T),
  hb-add-variable Name Ty C,

  TheType = global (const C),
  % We postulate the dependencies
  process-asset-unnamed-parameters (Rest TheType) [] Module TheType D {std.rev Params}
].
% This is a real parameter, we postulate it
process-asset-named-parameters (asset-parameter Name T Rest) D Module Params :- std.do! [
  std.assert-ok! (coq.typecheck-ty T _) "Illtyped parameter",
  if-verbose (coq.say "HB: postulate " Name),
  if (var T) (coq.fresh-type T) true,
  hb-add-variable Name T C,
  TheParam = global (const C),
  process-asset-named-parameters (Rest TheParam) D Module [pr TheParam T|Params],
].

pred process-asset-unnamed-parameters
  i:asset-decl, i:list (w-args factoryname), i:id, i:term, i:asset, i:list (pair term term).
process-asset-unnamed-parameters (asset-parameter _ T Rest) FS Module TheType D Params :- std.do! [
  std.assert! (factory? T (triple F Ps TheType)) "Not a factory applied to the type variable",
  std.assert! (pi x y\ Rest y = Rest x) "Factories cannot be explicitly mentioned in the mixin",
  Dummy = sort prop,
  process-asset-unnamed-parameters (Rest Dummy) [triple F Ps TheType|FS] Module TheType D Params,
].

process-asset-unnamed-parameters (asset-alias _ Ty) GRFS Module TheType D Params :- std.do! [
  std.assert! (D = asset-factory) "Mixins cannot be aliases",
  build-list-w-params Params  TheType {std.rev GRFS} GRFSwParams,
  declare-factory-alias Ty GRFSwParams Module TheType {std.map Params fst},
].

process-asset-unnamed-parameters (asset-record _ Sort _ Fields) GRFS Module TheType D Params :- std.do! [
  build-list-w-params Params  TheType {std.rev GRFS} GRFSwParams,
  declare-mixin-or-factory Sort Fields GRFSwParams Module TheType D {std.map Params fst},
].

pred declare-factory-alias i:term, i:list-w-params factoryname, i:id, i:term, i:list term.
declare-factory-alias Ty1Skel GRFSwP Module TheType TheParams :- std.do! [

  % TODO maybe main-declare-context should just take GRFSwP and postulate
  % the parameters and the type
  main-declare-context TheType TheParams GRFSwP Hyps _,

  std.assert-ok! (coq.elaborate-ty-skeleton Ty1Skel _ Ty1) "Illtyped alias factory",
  hb-add-const "axioms_" Ty1 _ @transparent! C,

  std.assert! (safe-dest-app Ty1 (global PhF) _Args) "Argument must be a factory",
  std.assert! (factory-alias->gref PhF F) "BUG: Factory alias declaration missing",
  std.assert! (factory-constructor F FK) "BUG: Factory constructor missing",

  Hyps => mgref->term TheParams TheType FK MFK,
  std.assert-ok! (coq.typecheck MFK MFKTy) "BUG: typecking of former factory constructor failed",
  (pi Args\ copy (app [global F|Args]) (global (const C))) => copy MFKTy MFKTyC,
  hb-add-const "Axioms_" MFK MFKTyC @transparent! CK,
  GRK = const CK,

  hb-end-section Module,

  @global! => coq.arguments.set-implicit GRK [[]],

  mk-phant-term (global GRK) PhGRK0,
  if (mixin-first-class F _) (PhGRK = PhGRK0) (append-phant-unify PhGRK0 PhGRK),
  mk-phant-abbrev "Build" PhGRK BuildConst _,

  % std.map Hyps mixin-src_mixin ML,
  factories-provide GRFSwP MLwP,
  mk-factory-requires-clause-and-abbrev "axioms" (const C) MLwP Clauses FactAbbrev,

  if-verbose (coq.say "HB: start module Exports"),

  hb-begin-module "Exports",
  std.forall Clauses (c\ hb-accumulate current (clause _ _ c)),
  % std.map {gr-deps GRK} (_\ r\ r = maximal) Implicits,
  % hb-set-implicit GRK [maximal|Implicits],
  w-params.nparams MLwP NParams,
  hb-accumulate current (clause _ _ (factory-nparams (const C) NParams)),
  hb-accumulate current (clause _ _ (factory-constructor (const C) GRK)),
  hb-accumulate current (clause _ _ (factory-builder-nparams BuildConst NParams)),
  hb-end-module "Exports" Exports,
  hb-end-module Module _,

  if-verbose (coq.say "HB: end modules and sections; export" Exports),

  export Exports,

  declare-factory-abbrev Module FactAbbrev,
].

pred hack-append-phant-unify i:int, i:phant-term, o:phant-term.
hack-append-phant-unify 0 X Y :- append-phant-unify X Y.
hack-append-phant-unify M X Y :- M > 0, !,
  N is M - 1,
  hack-append-phant-unify N {append-phant-unify X} Y.


pred hack-section-discharge-unused i:list term, i:record-decl, o:record-decl.
hack-section-discharge-unused [] F F.
hack-section-discharge-unused [T|TS] F (field _ "_" {{ lib:hb.unify lp:TT lp:TT lp:T lp:T lib:hb.nomsg }} _\ F0) :-
  std.assert-ok! (coq.typecheck T TT) "wtf",
  hack-section-discharge-unused TS F F0.


pred copy-indt-decl i:indt-decl, o:indt-decl.
copy-indt-decl (parameter ID I Ty D) (parameter ID I Ty1 D1) :-
  copy Ty Ty1,
  @pi-parameter ID Ty1 x\ copy-indt-decl (D x) (D1 x).
copy-indt-decl (inductive ID CO A D) (inductive ID CO A1 D1) :-
  copy-arity A A1,
  coq.id->name ID N, coq.arity->term A1 T, @pi-decl N T i\ std.map (D i) copy-constructor (D1 i).
  % @pi-inductive ID A1 i\ std.map (D i) copy-constructor (D1 i). % requires Coq-Elpi 1.9.x
copy-indt-decl (record ID T IDK F) (record ID T1 IDK F1) :-
  copy T T1,
  copy-fields F F1.

pred copy-fields i:record-decl, o:record-decl.
copy-fields end-record end-record.
copy-fields (field Att ID T F) (field Att ID T1 F1) :-
  copy T T1,
  @pi-parameter ID T1 x\ copy-fields (F x) (F1 x).

pred copy-constructor i:indc-decl, o:indc-decl.
copy-constructor (constructor ID A) (constructor ID A1) :- copy-arity A A1.

pred abstract-indt-decl i:list term, i:indt-decl, o:indt-decl.
abstract-indt-decl [] X X1 :- copy-indt-decl X X1.
abstract-indt-decl [global (const C)|CS] X (parameter ID explicit Ty1 X1) :-
  coq.gref->string (const C) ID,
  coq.env.typeof (const C) Ty,
  copy Ty Ty1,
  @pi-parameter ID Ty x\
    (copy (global (const C)) x :- !) =>
    abstract-indt-decl CS X (X1 x).

pred copy-clauses-for-unfold i:list constant, o:list prop.
copy-clauses-for-unfold [] [].
copy-clauses-for-unfold [C|CS] [ClauseApp,Clause|L] :-
  coq.env.const C (some B) _,
  ClauseApp = (pi B1 Args Args1 B2 Args2 R\
    copy (app[global (const C)|Args]) R :- !,
      copy B B1,
      std.map Args copy Args1,
      hd-beta B1 Args1 B2 Args2,
      unwind B2 Args2 R),
  Clause = (pi B1\
    copy (global (const C)) B1 :- !, copy B B1),
  copy-clauses-for-unfold CS L.

pred declare-mixin-or-factory i:term, i:record-decl, i:list-w-params factoryname, i:id, i:term, i:asset, i:list term.
declare-mixin-or-factory Sort1 Fields GRFSwP Module TheType D TheParams :- std.do! [
  main-declare-context TheType TheParams GRFSwP MixinSrcClauses SectionCanonicalInstance,

  % HACK: work around section discharging unused stuff
  if (D = asset-mixin) (Section = [])
      (std.map MixinSrcClauses mixin-src_src Mixins,
       std.append TheParams [TheType|{std.rev Mixins}] Section),

  if-verbose (coq.say "HB: declare record axioms_"),

  Kname = "Axioms_",
  RDeclSkel = record "axioms_" Sort1 Kname Fields,
  std.assert-ok! (coq.elaborate-indt-decl-skeleton RDeclSkel RDecl) "record declaration illtyped",

  % We discharge by hand the record declaration so that we can be sure all
  % parameters and mixins are abstracted (even if unused).
  copy-clauses-for-unfold SectionCanonicalInstance CopyUnfold,
  CopyUnfold => abstract-indt-decl Section RDecl RDeclClosed,
  hb-add-indt RDeclClosed R,
  hb-end-section Module, % We need to anyway declare the record inside the section
    % since closing the section purges the unused universe level we may have
    % allocated by typechecking the skeleton just above

  coq.env.indt R tt _ _ _ [K] _,
  GRK = indc K,
  @global! => coq.arguments.set-implicit (indt R) [[]],
  @global! => coq.arguments.set-implicit GRK [[]],

  % TODO: should this be in the Exports module?
  if-verbose (coq.say "HB: declare notation axioms"),

  mk-phant-term (global GRK) PhGRK,

  if-verbose (coq.say "HB: declare notation Axioms"),

  mk-phant-abbrev "Build" PhGRK BuildConst BuildAbbrev,

  % std.map Hyps mixin-src_mixin ML,
  factories-provide GRFSwP MLwP,
  if (D = asset-mixin)
     (mk-factory-requires-clause-and-abbrev "axioms" (indt R) MLwP FRClauses FactAbbrev,
      FRClauses => declare-id-builder (indt R) IdBuilderClause,
      Clauses = [IdBuilderClause|FRClauses])
     (mk-factory-requires-clause-and-abbrev "axioms" (indt R) MLwP Clauses FactAbbrev),

  if-verbose (coq.say "HB: start module Exports"),

  hb-begin-module "Exports",
  std.forall Clauses (c\ hb-accumulate current (clause _ _ c)),
  w-params.nparams MLwP NParams,
  hb-accumulate current (clause _ _ (factory-nparams (indt R) NParams)),
  std.map {list-w-params_list {gr-deps GRK}} (_\ r\ r = maximal) Implicits,
  @global! => hb-set-implicit GRK [maximal|Implicits],
  hb-accumulate current (clause _ _ (factory-constructor (indt R) GRK)),
  hb-accumulate current (clause _ _ (factory-builder-nparams BuildConst NParams)),
  hb-accumulate current (clause _ _ (phant-abbrev GRK (const BuildConst) BuildAbbrev)),
  hb-end-module "Exports" Exports,
  hb-end-module Module _,

  if-verbose (coq.say "HB: end modules and sections; export" Exports),

  export Exports,

  declare-factory-abbrev Module FactAbbrev,
].