fix: correct markdown header processing

src/verso-manual/VersoManual/Markdown.lean

@@ -47,9 +47,26 @@ def attr' (val : Array AttrText) : Except String String := do
   | .error e => .error e
   | .ok s => pure s
 
+/--
+A mapping from Markdown document header levels to actual Verso nesting levels.
+The values in the list are Markdown header levels. Their position in the list
+is the Verso nesting level, with the final element being Verso level 0.
+For example, the list
+    `[5,4,2,1]`
+is understood as associating:
+- Markdown level 1 to Verso nesting 0
+- Markdown level 2 to Verso nesting 1
+- Markdown level 4 to Verso nesting 2
+- Markdown level 5 to Verso nesting 3
+
+We need to keep this state to appropriately repair non-consecutive
+Markdown header levels.
+-/
+public def HeaderMapping := List Nat
+deriving Inhabited
+
 private structure MDState where
-  /-- A mapping from document header levels to actual nesting levels -/
-  inHeaders : List (Nat × Nat) := []
+  inHeaders : HeaderMapping := []
 deriving Inhabited
 
 private abbrev MDT m block inline α := ReaderT (MDContext m block inline) (StateT MDState m) α
@@ -123,17 +140,17 @@ private partial def getHeaderLevel [Monad m] (level : Nat) : MDT m b i Nat := do
   let hdrs := (← get).inHeaders
   match hdrs with
   | [] =>
-    modify ({· with inHeaders := [(level, 0)]})
+    modify ({· with inHeaders := [level]})
     pure 0
-  | (docLevel, nesting) :: more =>
+  | docLevel :: more =>
     if level < docLevel then
       modify ({· with inHeaders := more})
       getHeaderLevel level
     else if level = docLevel then
-      pure nesting
+      pure more.length
     else
-      modify ({· with inHeaders := (level, nesting + 1) :: hdrs})
-      pure (nesting + 1)
+      modify ({· with inHeaders := level :: hdrs})
+      pure (more.length + 1)
 
 private def getHeader  [Monad m] (level : Nat) : MDT m b i (Except String (Array i → m b)) := do
   let lvl ← getHeaderLevel level
@@ -241,36 +258,51 @@ where
 open Verso.Doc.Elab
 
 /--
-Updates the active sections given a new header with `level`.
+Closes all sections that have a Markdown header level that is greater
+than or equal to {name}`level`, to prepare the state for pushing new a
+part at level {name}`level`.
+
+We close a frame in the {name (full:=PartElabM.State.partContext)}`partContext` of {name}`PartElabM.State` exactly in lockstep
+with dropping the head of {name (full:=MDState.inHeaders)}`inHeaders` in {name}`MDState`.
 -/
-private partial def closeSections {m} [Monad m]
-    [MonadStateOf PartElabM.State m]
+private partial def closeMarkdownSections {m} [Monad m]
+    [MonadError m] [MonadStateOf PartElabM.State m]
     (level : Nat) : MDT m b i Unit := do
   let hdrs := (← getThe MDState).inHeaders
   match hdrs with
-  | [] => modifyThe MDState ({· with inHeaders := [(level, 0)]})
-  | (docLevel, nesting) :: more =>
-    if level ≤ docLevel then
-      if let some ctxt' := (← getThe PartElabM.State).partContext.close default then -- Markdown parser provides no source position
-        modifyThe PartElabM.State fun st => {st with partContext := ctxt'}
-        closeSections level
-      if level < docLevel then
-        modifyThe MDState ({· with inHeaders := more})
-    else
-      modifyThe MDState ({· with inHeaders := (level, nesting + 1) :: hdrs})
+  | [] => pure ()
+  | docLevel :: more =>
+    if docLevel ≥ level then
+      -- `default` here because the Markdown parser provides no source position
+      let some ctxt' := (← getThe PartElabM.State).partContext.close default
+        |  throwError m!"Failed to close verso part corresponding to markdown section: no parts left"
+      modifyThe PartElabM.State fun st => {st with partContext := ctxt'}
+      modifyThe MDState ({· with inHeaders := more})
+      closeMarkdownSections level
+
+/--
+In our header mapping bookkeeping, creates a new section with a new Markdown header with level {name}`level`.
+Also pushes a new part {name}`frame`.
+-/
+private partial def startMarkdownSection {m} [Monad m]
+    [MonadStateOf PartElabM.State m] [MonadLiftT PartElabM m]
+    (level : Nat) (frame : PartFrame) : MDT m b i Unit := do
+  let hdr := (← getThe MDState).inHeaders
+  modifyThe MDState ({· with inHeaders := level :: hdr})
+  PartElabM.push frame
 
 private partial def addPartFromMarkdownAux {m} [Monad m]
     [MonadLiftT PartElabM m] [MonadStateOf PartElabM.State m]
     [MonadQuotation m] [AddMessageContext m] [MonadError m]
     : MD4Lean.Block → MDT m Term Term Unit
   | .header level txt => do
-    closeSections level
+    closeMarkdownSections level
     let txtStxs ← txt.mapM inlineFromMarkdown |>.run' none
     let titleTexts ← match txt.mapM stringFromMarkdownText with
       | .ok t => pure t
       | .error e => throwError m!"Unsupported Markdown in header:\n{e}"
     let titleText := titleTexts.foldl (· ++ ·) ""
-    PartElabM.push {
+    startMarkdownSection level {
       titleSyntax := quote (k := `str) titleText
       expandedTitle := some (titleText, txtStxs)
       metadata := none
@@ -298,10 +330,72 @@ def addPartFromMarkdown {m} [Monad m]
     [MonadLiftT PartElabM m] [MonadStateOf PartElabM.State m]
     [MonadQuotation m] [AddMessageContext m] [MonadError m]
     (md : MD4Lean.Block)
-    (currentHeaderLevels : List (Nat × Nat) := [])
+    (currentHeaderLevels : HeaderMapping := [])
     (handleHeaders : List (Array Term → m Term) := [])
     (elabInlineCode : Option (Option String → String → m Term) := none)
-    (elabBlockCode : Option (Option String → Option String → String → m Term) := none) : m (List (Nat × Nat)) := do
+    (elabBlockCode : Option (Option String → Option String → String → m Term) := none) : m HeaderMapping := do
   let ctxt := {headerHandlers := ⟨handleHeaders⟩, elabInlineCode, elabBlockCode}
   let (_, { inHeaders }) ← (addPartFromMarkdownAux md |>.run ctxt |>.run {inHeaders := currentHeaderLevels})
   return inHeaders
+
+open Verso.Doc.Elab in
+/--
+Renders the entire structure of a finished part as Mardown-style headings, with a
+number of `'#'s` that reflects their nesting depth. This is a tool for debugging/testing
+only.
+
+To avoid off-by-one misunderstandings: The heading level is equal to
+the number of # characters in the opening sequence. (cf. [CommonMark
+Spec](https://spec.commonmark.org/0.31.2/))
+-/
+def displayPartStructure (part : FinishedPart) (level : Nat := 1) : String := match part with
+  | .mk _ _ title _ _ subParts _ =>
+       let partsStr : String := subParts.map (displayPartStructure · (level + 1))
+         |>.toList |> String.join
+       let pref := "".pushn '#' level
+       s!"{pref} {title}\n{partsStr}"
+  | .included name => s!"included {name}\n"
+
+/--
+Parses a Markdown string, returning the displayed part structure.
+-/
+def testAddPartFromMarkdown (input : String) : Elab.TermElabM String := do
+  let some parsed := MD4Lean.parse input
+    | throwError m!"Couldn't parse markdown {input}"
+  let addParts : PartElabM Unit := do
+    let mut levels := []
+    for block in parsed.blocks do
+      levels ← addPartFromMarkdown block levels
+    closePartsUntil 0 0
+  let (_, _, part) ← addParts.run (Syntax.node .none identKind #[]) (mkConst ``Manual) default default
+  part.partContext.priorParts.toList.map displayPartStructure |> String.join |> pure
+
+/--
+info:
+# header1
+## header2-a
+### header3-aa
+## header 2-b
+### header3-ba
+### header3-bb
+#### header4-bba
+### header3-bc
+# another header
+## one more
+-/
+#guard_msgs in
+/- Exercises how inconsistent Markdown header nesting depth
+is heuristically fixed. -/
+#eval do
+  IO.println <| "\n" ++ (← testAddPartFromMarkdown r#"
+# header1
+## header2-a
+### header3-aa
+## header 2-b
+##### header3-ba
+#### header3-bb
+###### header4-bba
+### header3-bc
+# another header
+## one more
+"#)

src/verso/Verso/Doc/Elab/Monad.lean

@@ -256,23 +256,54 @@ partial def FinishedPart.toTOC : FinishedPart → TOC
     .mk titleString titleStx endPos (subParts.map toTOC)
   | .included name => .included name
 
+/--
+Information describing a part still under construction.
+
+During elaboration, the current position in the document is
+represented by a stack of these frames, with each frame representing a
+layer of document section nesting. As the Verso document elaborator
+encounters new headers, stack frames are pushed and popped as
+indicated by the header's level.
+-/
 structure PartFrame where
   titleSyntax : Syntax
   expandedTitle : Option (String × Array (TSyntax `term)) := none
   metadata : Option (TSyntax `term)
   blocks : Array (TSyntax `term)
+  /--
+  The sibling parts at the same nesting level as the part represented by this frame. These siblings
+  are earlier in the document and have the same parent.
+  -/
   priorParts : Array FinishedPart
 deriving Repr, Inhabited
 
+/-- Turn an previously active {name}`PartFrame` into a {name}`FinishedPart`. -/
 def PartFrame.close (fr : PartFrame) (endPos : String.Pos) : FinishedPart :=
   let (titlePreview, titleInlines) := fr.expandedTitle.getD ("<anonymous>", #[])
   .mk fr.titleSyntax titleInlines titlePreview fr.metadata fr.blocks fr.priorParts endPos
 
+/--
+Information available while constructing a part. It extends {name}`PartFrame`
+because that data represents the current frame. The field
+{name PartContext.parents}`parents` represents other parts above
+us in the hierarchy that are still being built.
+-/
 structure PartContext extends PartFrame where
   parents : Array PartFrame
 deriving Repr, Inhabited
 
+/--
+The current nesting level is the number of frames in the stack of parent
+parts being built.
+-/
 def PartContext.level (ctxt : PartContext) : Nat := ctxt.parents.size
+
+/--
+Closes the current part.
+The resulting {name}`FinishedPart` is appended to {name}`priorParts`, and
+the top of the stack of our parents becomes the current frame. Returns
+{name}`none` if there are no parents.
+-/
 def PartContext.close (ctxt : PartContext) (endPos : String.Pos) : Option PartContext := do
   let fr ← ctxt.parents.back?
   pure {
@@ -284,6 +315,9 @@ def PartContext.close (ctxt : PartContext) (endPos : String.Pos) : Option PartCo
     priorParts := fr.priorParts.push <| ctxt.toPartFrame.close endPos
   }
 
+/--
+Makes the frame {name}`fr` the current frame. The former current frame is saved to the stack.
+-/
 def PartContext.push (ctxt : PartContext) (fr : PartFrame) : PartContext := ⟨fr, ctxt.parents.push ctxt.toPartFrame⟩
 
 structure PartElabM.State where