diff --git a/DocGen4/Output/Inductive.lean b/DocGen4/Output/Inductive.lean
index 521c42c..85fcda0 100644
--- a/DocGen4/Output/Inductive.lean
+++ b/DocGen4/Output/Inductive.lean
@@ -5,7 +5,6 @@ namespace Output
open scoped DocGen4.Jsx
-
def ctorToHtml (i : NameInfo) : HtmlM Html := do
let name := i.name.components'.head!.toString
return
{name} : [←infoFormatToHtml i.type]
diff --git a/DocGen4/Output/Module.lean b/DocGen4/Output/Module.lean
index 5990f89..91d28ab 100644
--- a/DocGen4/Output/Module.lean
+++ b/DocGen4/Output/Module.lean
@@ -5,6 +5,7 @@ Authors: Henrik Böving
-/
import DocGen4.Output.Template
import DocGen4.Output.Inductive
+import DocGen4.Output.Structure
namespace DocGen4
namespace Output
@@ -30,6 +31,19 @@ def argToHtml (arg : Arg) : HtmlM Html := do
else
html
+def structureInfoHeader (s : StructureInfo) : HtmlM (Array Html) := do
+ let mut nodes := #[]
+ if s.parents.size > 0 then
+ nodes := nodes.push extends
+ let mut parents := #[]
+ for parent in s.parents do
+ let link := {parent.toString}
+ let inner := Html.element "span" true #[("class", "fn")] #[link]
+ let html:= Html.element "span" false #[("class", "decl_parent")] #[inner]
+ parents := parents.push html
+ nodes := nodes.append (parents.toList.intersperse (Html.text ", ")).toArray
+ nodes
+
def docInfoHeader (doc : DocInfo) : HtmlM Html := do
let mut nodes := #[]
-- TODO: noncomputable, partial
@@ -44,14 +58,19 @@ def docInfoHeader (doc : DocInfo) : HtmlM Html := do
for arg in doc.getArgs do
nodes := nodes.push (←argToHtml arg)
+
+ if let DocInfo.structureInfo i := doc then
+ nodes := nodes.append (←structureInfoHeader i)
+
nodes := nodes.push :
nodes := nodes.push $ Html.element "div" true #[("class", "decl_type")] (←infoFormatToHtml doc.getType)
-- TODO: The final type of the declaration
return [nodes]
def docInfoToHtml (doc : DocInfo) : HtmlM Html := do
- let doc_html := match doc with
+ let doc_html ← match doc with
| DocInfo.inductiveInfo i => inductiveToHtml i
+ | DocInfo.structureInfo i => structureToHtml i
| _ => #[]
return
diff --git a/DocGen4/Output/Structure.lean b/DocGen4/Output/Structure.lean
new file mode 100644
index 0000000..af5eeb4
--- /dev/null
+++ b/DocGen4/Output/Structure.lean
@@ -0,0 +1,15 @@
+import DocGen4.Output.Template
+
+namespace DocGen4
+namespace Output
+
+open scoped DocGen4.Jsx
+
+def fieldToHtml (f : NameInfo) : HtmlM Html := do
+ return
{s!"{f.name} : "} [←infoFormatToHtml f.type]
+
+def structureToHtml (i : StructureInfo) : HtmlM (Array Html) := do
+ #[Html.element "ul" false #[("class", "structure_fields"), ("id", s!"{i.name.toString}.mk")] (←i.fieldInfo.mapM fieldToHtml)]
+
+end Output
+end DocGen4
diff --git a/DocGen4/Process.lean b/DocGen4/Process.lean
index 51020b3..42f4e35 100644
--- a/DocGen4/Process.lean
+++ b/DocGen4/Process.lean
@@ -56,13 +56,8 @@ structure InductiveInfo extends Info where
isUnsafe : Bool
deriving Inhabited
-structure FieldInfo extends NameInfo where
- projFn : Name
- subobject? : Option Name
- deriving Inhabited
-
structure StructureInfo extends Info where
- fieldInfo : Array FieldInfo
+ fieldInfo : Array NameInfo
parents : Array Name
ctor : NameInfo
deriving Inhabited
@@ -162,33 +157,36 @@ def InductiveInfo.ofInductiveVal (v : InductiveVal) : MetaM InductiveInfo := do
let ctors ← v.ctors.mapM (λ name => do NameInfo.mk name (←getConstructorType name))
return InductiveInfo.mk info ctors v.isUnsafe
-def getFieldTypeAux (type : Expr) (vars : List Name) : (Expr × List Name) :=
- match type with
- | Expr.forallE `self _ b .. => (b, (`self :: vars))
- | Expr.forallE n _ b .. => getFieldTypeAux b (n :: vars)
- | _ => (type, vars)
+def dropArgs (type : Expr) (n : Nat) : (Expr × List (Name × Expr)) :=
+ match type, n with
+ | e, 0 => (e, [])
+ | Expr.forallE name type body _, x + 1 =>
+ let body := body.instantiate1 $ mkFVar ⟨name⟩
+ let next := dropArgs body x
+ { next with snd := (name, type) :: next.snd}
+ | e, x + 1 => panic! s!"No forallE left"
-def getFieldType (projFn : Name) : MetaM Expr := do
- let fn ← mkConstWithFreshMVarLevels projFn
- let type ← inferType fn
- let (type, vars) := getFieldTypeAux type []
- type.instantiate $ vars.toArray.map mkConst
-
-def FieldInfo.ofStructureFieldInfo (i : StructureFieldInfo) : MetaM FieldInfo := do
- let type ← getFieldType i.projFn
- let ni := NameInfo.mk i.fieldName (←prettyPrintTerm type)
- FieldInfo.mk ni i.projFn i.subobject?
+def getFieldTypes (ctor : ConstructorVal) (parents : Nat) : MetaM (Array NameInfo) := do
+ let type := ctor.type
+ let (field_function, params) := dropArgs type (ctor.numParams + parents)
+ let (_, fields) := dropArgs field_function (ctor.numFields - parents)
+ let mut field_infos := #[]
+ for (name, type) in fields do
+ field_infos := field_infos.push { name := name, type := ←prettyPrintTerm type}
+ field_infos
def StructureInfo.ofInductiveVal (v : InductiveVal) : MetaM StructureInfo := do
let info ← Info.ofConstantVal v.toConstantVal
let env ← getEnv
let parents := getParentStructures env v.name
- let ctor := getStructureCtor env v.name |>.name
- let ctorType ← getConstructorType ctor
+ let ctor := getStructureCtor env v.name
+ let ctorType ← prettyPrintTerm ctor.type
match getStructureInfo? env v.name with
| some i =>
- let fieldInfos ← i.fieldInfo.mapM FieldInfo.ofStructureFieldInfo
- return StructureInfo.mk info fieldInfos parents ⟨ctor, ctorType⟩
+ if i.fieldNames.size - parents.size > 0 then
+ return StructureInfo.mk info (←getFieldTypes ctor parents.size) parents ⟨ctor.name, ctorType⟩
+ else
+ return StructureInfo.mk info #[] parents ⟨ctor.name, ctorType⟩
| none => panic! s!"{v.name} is not a structure"
def ClassInfo.ofInductiveVal (v : InductiveVal) : MetaM ClassInfo := do
diff --git a/static/style.css b/static/style.css
index 5743e2f..e930689 100644
--- a/static/style.css
+++ b/static/style.css
@@ -421,7 +421,7 @@ main h2, main h3, main h4, main h5, main h6 {
border-radius: 5px;
}
-.decl_args, .decl_type {
+.decl_args, .decl_type .decl_parent {
font-weight: normal;
}
@@ -430,7 +430,7 @@ main h2, main h3, main h4, main h5, main h6 {
white-space: nowrap;
}
-.decl_kind, .decl_name {
+.decl_kind, .decl_name, .decl_extends {
font-weight: bold;
}
@@ -480,14 +480,7 @@ pre code { padding: 0 0; }
.structure_field {
display: block;
-}
-.structure_field:before {
- content: '(';
- color: gray;
-}
-.structure_field:after {
- content: ')';
- color: gray;
+ margin-left: 2ex;
}
.constructor {