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

namespace about {

pred main i:string.
main S :-
  coq.locate-all S All,
  std.filter All (x\sigma gr a\x = loc-gref gr ; x = loc-abbreviation a) L,
  if (L = []) (coq.error "HB: unable to locate" S) true,
  std.forall L (about.main-located S).

pred main-located i:string, i:located.
main-located S (loc-gref GR) :- class-def (class Class GR MLwP), !,
  private.main-structure S Class GR MLwP.

main-located _ (loc-gref Class) :- class-def (class Class GR MLwP), !,
  gref->modname GR 2 "." M,
  coq.gref->id GR St,
  S is M ^ "." ^ St,
  private.main-structure S Class GR MLwP.

main-located S (loc-gref (indt I)) :- factory-constructor (indt I) _, !,
  private.main-factory S I.

main-located S (loc-gref (const C)) :- factory-constructor (const C) _, !,
  private.main-factory-alias S C.

main-located S (loc-gref (const C)) :- exported-op M _ C, !,
  private.main-operation S M C.

main-located S (loc-gref GR) :- factory-alias->gref GR F, not (F = GR), !,
  main-located S (loc-gref F).

main-located S (loc-abbreviation A) :- phant-abbrev GR PhB A, factory-constructor (indt F) GR, !,
  private.main-factory-constructor S F PhB GR.

main-located S (loc-abbreviation A) :-
  coq.notation.abbreviation-body A NArgs _,
  coq.notation.abbreviation A {coq.mk-n-holes NArgs} T,
  coq.safe-dest-app T (global GR) _, !,
  main-located S (loc-gref GR).

main-located S (loc-gref GR) :- from Factory Mixin GR, !,
  private.main-builder S Factory Mixin.

main-located S (loc-gref GR) :-
  std.filter {coq.CS.db-for _ (cs-gref GR)} (private.not1 private.unif-hint?) LV,
  coq.CS.db-for GR _ LP,
  std.filter {coq.coercion.db} (c\c = coercion GR _ _ _) LC,
  if (LV = [], LP = [], LC = [])
     (coq.error "HB: uninteresting constant" {coq.pp->string {private.pp-loc-of GR}})
     true,
  if (not (LV = [])) (private.main-canonical-value S LV) true,
  if (not (LP = [])) (private.main-canonical-projection S GR LP) true,
  if (not (LC = [])) (private.main-coercion S LC) true.

main-located S (loc-abbreviation _) :- coq.error "HB: unknown abbreviation" S.


/* ------------------------------------------------------------------------- */
/* ----------------------------- private code ------------------------------ */
/* ------------------------------------------------------------------------- */

namespace private {

shorten coq.pp.{ v , h, hv, hov , spc , str , box , glue , brk , empty }.

pred docstring-for-file i:string, o:prop.
docstring-for-file Rex (docstring Loc Doc) :- docstring Loc Doc,
  loc.fields Loc File _ _ _ _,
  rex.match {calc(".*" ^ Rex)} File.

pred main-canonical-value i:string, i:list cs-instance.
main-canonical-value S CanonicalValues :-
  group-by-loc CanonicalValues CanonicalValuesL,
  %format
  PpCanonicalValues = box (v 4) [
    str "HB: ", str S, str " is canonically equipped with mixins:",
    {bulletize CanonicalValuesL pp-canonical-solution-list}],
  % print
  coq.say {coq.pp->string PpCanonicalValues},
  coq.say.

pred group-by-loc i:list cs-instance, o:list (pair (option loc) (list cs-instance)).
group-by-loc [] [].
group-by-loc [cs-instance P V GR|L] [pr (some Loc) [cs-instance P V GR|SameLoc]|Rest1] :- decl-location GR Loc, !,
  std.partition L (x\ sigma GR1\ x = cs-instance _ _ GR1, decl-location GR1 Loc) SameLoc Rest,
  group-by-loc Rest Rest1.
group-by-loc [I|Rest] [pr none [I]|Rest1] :- group-by-loc Rest Rest1.

pred pp-canonical-solution-list i:pair (option loc) (list cs-instance), o:coq.pp.
pp-canonical-solution-list (pr none [CS]) Pp :-
  pp-canonical-solution CS Pp.
pp-canonical-solution-list (pr (some Loc) L) Pp :-
  Pp = box (v 0)
    { std.append {std.intersperse spc {std.map L pp-canonical-solution}}
                 [ spc, {pp-loc Loc} ] }.

pred pp-canonical-solution i:cs-instance, o:coq.pp.
pp-canonical-solution (cs-instance _Proj _Pat GR) Pp :-
  coq.env.typeof GR T,
  coq.prod-tgt->gref T F,
  if (class-def (class _ F _)) (gref->modname F 2 "." ID) (coq.gref->string F ID),
  Pp = box (hov 0) [ str ID ].

pred main-canonical-projection i:string, i:gref, i:list cs-instance.
main-canonical-projection S Proj CanonicalProjectionValues :-
  %format
  PpCanonicalProjectionOrigin = box (hov 4) [
    str "HB:", spc, str S, spc, str "is a canonical projection",
    spc, {pp-loc-of Proj}],
  PpCanonicalProjectionValues = box (v 4) [
    str "HB: ", str S, str " has the following canonical values:",
    {bulletize CanonicalProjectionValues pp-canonical-value}],
  % print
  coq.say {coq.pp->string PpCanonicalProjectionOrigin},
  coq.say {coq.pp->string PpCanonicalProjectionValues},
  coq.say.

pred pp-canonical-value i:cs-instance, o:coq.pp.
pp-canonical-value (cs-instance _Proj (cs-gref GR) _Sol) Pp :-
  coq.term->pp (global GR) V,
  Pp = box (hov 2) [ V , spc, {pp-loc-of GR} ].

pred main-coercion i:string, i:list coercion.
main-coercion S [coercion GR _ Src Tgt|_] :-
  % format
  if (class-def (class _ Src _) ; class-def (class Src _ _))
     (Source = str {gref->modname Src 2 "."})
     (coq.term->pp (global Src) Source),
  if2 (Tgt = grefclass TGR)
        (if (class-def (class _ TGR _) ; class-def (class TGR _ _))
          (Target = str {gref->modname TGR 2 "."})
          (coq.term->pp (global TGR) Target))
      (Tgt = sortclass)
        (Target = str "Sortclass")
      (Target = str "Funclass"),
  PpCoercionOrigin = box (hov 4) [
    str "HB:", spc, str S, spc, str "is a coercion from", spc,
    Source, str" to ", Target, spc, {pp-loc-of GR}],
  % print
  coq.say {coq.pp->string PpCoercionOrigin},
  coq.say.

pred main-operation i:string, i:mixinname, i:constant.
main-operation S MixinSource _ :-
  % fetch
  mixin-first-class MixinSource Class,
  class-def (class Class Structure _),
  % format
  PpOriginStructure = box (hov 4) [
    str "HB:", spc, str S, spc, str "is an operation of structure", spc,
    {pp-module Structure}, spc, {pp-loc-of Structure}],
  PpOriginMixin = box (hov 4) [
    str "HB:", spc, str S, spc, str "comes from mixin", spc,
    {pp-module MixinSource}, spc, {pp-loc-of MixinSource}],
  % print
  coq.say {coq.pp->string PpOriginStructure},
  coq.say {coq.pp->string PpOriginMixin},
  coq.say.

pred main-structure i:string, i:classname, i:structure, i:mixins.
main-structure S Class Structure MLwP :-
  % fetch
  list-w-params_list MLwP ML,
  std.map-filter ML (m\r\ sigma P O OPS\
    mixin-first-class m Class,
    std.findall (exported-op m P O) OPS,
    std.map OPS (c\out\ sigma p\ c = exported-op m p out) r) OPLL,
  std.flatten OPLL Operations,
  std.map {std.findall (sub-class Class C_)} (x\r\ x = sub-class Class r) SubClasses,
  std.map {std.findall (sub-class C_ Class)} (x\r\ x = sub-class r Class) SuperClasses,
  % format
  PpOrigin = box (hov 4) [
    str "HB: ", str S, str " is a structure", spc,
    {pp-loc-of Structure} ],
  PpOperations = box (v 4) [
    str "HB: ", str S, str " characterizing operations and axioms are:",
    {bulletize Operations pp-const}],
  PpClass = box (v 4) [
    str "HB: ", {pp-module Class}, str " is a factory for the following mixins:",
    {bulletize ML (m\r\ sigma tmp\
      if (mixin-first-class m Class)
         (pp-module m tmp, r = glue [tmp, str " (* new, not from inheritance *)"])
         (pp-module m r))}],
  PpSubClasses = box (v 4) [
    str "HB: ", {pp-module Class}, str " inherits from:",
    {bulletize SubClasses pp-module}],
  PpSuperClasses = box (v 4) [
    str "HB: ", {pp-module Class}, str " is inherited by:",
    {bulletize SuperClasses pp-module}],
  % print
  coq.say {coq.pp->string PpOrigin},
  coq.say {coq.pp->string PpOperations},  
  coq.say {coq.pp->string PpClass},  
  coq.say {coq.pp->string PpSubClasses},  
  coq.say {coq.pp->string PpSuperClasses},  
  print-docstring Structure,
  coq.say.

pred main-factory-constructor i:string, i:inductive, i:gref, i:gref.
main-factory-constructor S F PhBuild Build :-
  % fetch
  gref-deps Build DMLwP,
  list-w-params_list DMLwP DML,
  factory-provides (indt F) PMLwP,
  list-w-params_list PMLwP PML,
  coq.env.projections F FieldsOpts,
  std.map-filter FieldsOpts (x\r\ x = some r) Fields,
  coq.arguments.implicit PhBuild [Implicits],

  compute-arg-type DMLwP Fields [] ParamsNames TName FieldsNames ArgsTypes,
  compute-field-info FieldsNames Implicits FieldsNamesInfo,
  std.map ParamsNames (n\r\r = str n) ParamsPp,

  % format
  PpOrigin = box (hov 4) [
    str "HB: ", str S, str " is a factory constructor", spc,
    {pp-loc-of Build} ],
  PpRequires = box (v 4) [
    str "HB: ", str S, str " requires its subject to be already equipped with:",
    {bulletize DML pp-module}],
  PpProvides = box (v 4) [
    str "HB: ", str S, str " provides the following mixins:",
    {bulletize PML pp-module}],
  PpUsage = box (v 4) [box h {std.intersperse spc [
    str "HB: arguments:",
    glue {std.intersperse spc [str S | ParamsPp]},
    str TName,
    glue FieldsNamesInfo]},
    {bulletize ArgsTypes pp-arg-type}],
  % print
  coq.say {coq.pp->string PpOrigin},  
  coq.say {coq.pp->string PpRequires},  
  coq.say {coq.pp->string PpProvides},  
  coq.say {coq.pp->string PpUsage},
  print-docstring Build,
  coq.say.

pred compute-arg-type i:list-w-params mixinname, i:list constant, i:list term, o:list id, o:id, o:list id, o:list (pair id coq.pp).
compute-arg-type (w-params.cons ID Ty Rest) F Acc [ID|PN] TN FN [pr ID PPTy |Xs] :-
  coq.term->pp Ty PPTy,
  @pi-parameter ID Ty x\ compute-arg-type (Rest x) F [x|Acc] PN TN FN Xs.
compute-arg-type (w-params.nil ID Ty Rest) F Acc [] ID FN [pr ID PPTy|Xs] :-
  coq.term->pp Ty PPTy,
  @pi-parameter ID Ty x\ compute-arg-type.fields F {std.length (Rest x)} {std.rev [x|Acc]} Xs FN.
pred compute-arg-type.fields i:list constant, i:int, i:list term, o:list (pair id coq.pp), o:list id.
compute-arg-type.fields [] _ _ [] [].
compute-arg-type.fields [C|Cs] NDeps Args [pr ID PPTy|Xs] [ID|FN] :- exported-op _ C OP, !,
  coq.env.typeof (const OP) Ty,
  coq.gref->id (const OP) ID,
  coq.subst-prod Args Ty TyArgs,
  @pplevel! 200 => coq.term->pp TyArgs PPTy,
  compute-arg-type.fields Cs NDeps Args Xs FN.
compute-arg-type.fields [OP|Cs] NDeps Args [pr ID PPTy|Xs] [ID|FN] :-
  % factories don't get exported ops, so we hack their types :-/
  coq.env.typeof (const OP) OrigTy,
  copy OrigTy Ty,
  coq.gref->id (const OP) ID,
  coq.subst-prod Args Ty TyArgs,
  coq.mk-n-holes NDeps Deps,
  coq.subst-prod Deps TyArgs TyArgsDeps,
  coq.subst-prod [_] TyArgsDeps TyArgsDepsRecord,
  ToDrop is NDeps + 2,
  @pplevel! 200 => coq.term->pp TyArgsDepsRecord PPTy,
  @pi-parameter ID TyArgsDepsRecord op\
  (pi L L1 X\
    copy (app[global(const OP)|L]) X :- std.drop ToDrop L L1, coq.mk-app op L1 X) =>
    compute-arg-type.fields Cs NDeps Args Xs FN.

pred main-factory i:string, i:inductive.
main-factory S Factory :-
  % fetch
  coq.env.projections Factory Ps,
  std.map-filter Ps (x\r\ x = some r) Fields,
  gref-deps (indt Factory) DMLwP,
  list-w-params_list DMLwP DML,
  factory-provides (indt Factory) PMLwP,
  list-w-params_list PMLwP PML,
  % format
  PpOrigin = box (hov 4) [
    str "HB: ", str S, str " is a factory", spc,
    {pp-loc-of (indt Factory)} ],
  PpOperations = box (v 4) [
    str "HB: ", str S, str " operations and axioms are:",
    {bulletize Fields pp-const}],
  PpRequires = box (v 4) [
    str "HB: ", str S, str " requires the following mixins:",
    {bulletize DML pp-module}],
  PpProvides = box (v 4) [
    str "HB: ", str S, str " provides the following mixins:",
    {bulletize PML pp-module}],
  % print
  coq.say {coq.pp->string PpOrigin},  
  coq.say {coq.pp->string PpOperations},  
  coq.say {coq.pp->string PpRequires},  
  coq.say {coq.pp->string PpProvides},
  print-docstring (indt Factory),
  coq.say.

pred main-factory-alias i:string, i:constant.
main-factory-alias S _Const :-
  coq.say "HB: todo HB.about for factory alias" S.

pred main-builder i:string, i:factoryname, i:mixinname.
main-builder _S From To :-
  coq.say "HB: todo HB.about for builder from"
    {gref->modname From 2 "."} "to" {gref->modname To 2 "."}.

pred compute-field-info.aux i:list id, i:list implicit_kind, o:list coq.pp.
compute-field-info.aux [] _ [].
compute-field-info.aux [Name|NS] [explicit|IS] [str Name|PS] :-
  compute-field-info.aux NS IS PS.
compute-field-info.aux [Name|NS] [implicit|IS] [glue[str"[",str Name,str"]"]|PS] :-
  compute-field-info.aux NS IS PS.
compute-field-info.aux [Name|NS] [maximal|IS] [glue[str"{",str Name,str"}"]|PS] :-
  compute-field-info.aux NS IS PS.
compute-field-info.aux [Name|NS] [] [str Name|PS] :-
  compute-field-info.aux NS [] PS.
pred compute-field-info i:list id, i:list implicit_kind, o:list coq.pp.
compute-field-info Names Impls O :-
  compute-field-info.aux {std.rev Names} {std.rev Impls} Pp,
  std.intersperse spc {std.rev Pp} O.

pred pp-module i:gref, o:coq.pp.
pp-module M (str ID) :- gref->modname M 2 "." ID.

pred pp-const i:constant, o:coq.pp.
pp-const F (str ID) :- coq.gref->id (const F) ID.

pred pp-arg-type i:pair id coq.pp, o:coq.pp.
pp-arg-type (pr ID PPTy) (box (hov 2) [str ID, str" :", spc, PPTy]).

pred pp-if-verbose o:coq.pp, i:(coq.pp -> prop).
pp-if-verbose V P :- get-option "verbose" tt, !, P V.
pp-if-verbose empty _.

pred bulletize1 i:(A -> coq.pp -> prop), i:A, o:coq.pp.
bulletize1 F X (glue [str "- ", M]) :- F X M.

pred bulletize i:list A, i:(A -> coq.pp -> prop), o:coq.pp.
bulletize [] _ empty.
bulletize L F (glue [brk 0 0 | PLB]) :-
  std.map L (bulletize1 F) PL,
  std.intersperse (brk 0 0) PL PLB.

pred pp-loc-of i:gref, o:coq.pp.
pp-loc-of GR PP :- decl-location GR Loc, !, pp-loc Loc PP.
pp-loc-of _ coq.pp.empty.

pred pp-loc i:loc, o:coq.pp.
pp-loc Loc (coq.pp.glue PP) :-
  loc.fields Loc File _ _ Line _,
  QFile is "\"" ^ File ^ "\", line " ^ {std.any->string Line},
  PP = [str "(from ", str QFile, str")"].

pred docstring->pp i:string, o:coq.pp.
docstring->pp Txt (glue Doc) :-
  rex.replace "\n" " " Txt PlainTxt,
  rex.split " " PlainTxt Words,
  std.filter Words (w\not (w = "")) NEWords,
  std.map NEWords (w\r\ r = str w) PpWords,
  std.intersperse spc PpWords Doc.

pred docstring-of i:gref, o:option coq.pp.
docstring-of GR (some Doc) :- decl-location GR Loc, docstring Loc Txt, !, docstring->pp Txt Doc.
docstring-of _ none.

pred pp-docstring-of i:gref, o:coq.pp.
pp-docstring-of GR D :- docstring-of GR (some D), !.
pp-docstring-of _ coq.pp.empty.

pred print-docstring i:gref.
print-docstring GR :-
  if (docstring-of GR (some Doc))
     (coq.say {coq.pp->string (box (hov 5) [str"Doc: ",Doc])})
     true.

pred unif-hint? i:cs-instance.
unif-hint? (cs-instance _ (cs-gref GR) _) :- coq.CS.db-for GR _ [_|_].

pred not1 i:(A -> prop), i:A.
not1 P X :- not (P X).

}}
