From c2480d10422f176bf06081de9d601f3b7249a83c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 13 Apr 2020 02:09:09 +0200
Subject: doc: Avoid invalid 'match' pattern in 'syntax-highlighted-html'.

This is a followup to da9deba13d551e316f5a99a614834efa27ddc7d1.

Last-minute modification of the 'match' pattern would lead to an error:

  "multiple ellipsis patterns not allowed at same level"

* doc/build.scm (syntax-highlighted-html)[build](collect-anchors):
Add 'worthy-entry?' procedure and use it instead of the unsupported
pattern for ('dt ...).
---
 doc/build.scm | 23 ++++++++++++++++-------
 1 file changed, 16 insertions(+), 7 deletions(-)

(limited to 'doc')

diff --git a/doc/build.scm b/doc/build.scm
index c3d61f837b..ca81d813a9 100644
--- a/doc/build.scm
+++ b/doc/build.scm
@@ -373,17 +373,26 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
                   (('*ENTITY* _ ...) #t)
                   (_ #f)))
 
+              (define (worthy-entry? lst)
+                ;; Attempt to match:
+                ;;   Scheme Variable: <strong>x</strong>
+                ;; but not:
+                ;;   <code>cups-configuration</code> parameter: …
+                (let loop ((lst lst))
+                  (match lst
+                    (((? string-or-entity?) rest ...)
+                     (loop rest))
+                    ((('strong _ ...) _ ...)
+                     #t)
+                    (_ #f))))
+
               (let ((shtml (call-with-input-file file html->shtml)))
                 (let loop ((shtml shtml)
                            (vhash vhash))
                   (match shtml
-                    ;; Attempt to match:
-                    ;;  <dt>Scheme Variable: <strong>x</strong></dt>
-                    ;; but not:
-                    ;;  <dt><code>cups-configuration</code> parameter: …</dt>
-                    (('dt ('@ ('id id))
-                          (? string-or-entity?) ... ('strong _ ...) _ ...)
-                     (if (string-prefix? "index-" id)
+                    (('dt ('@ ('id id)) rest ...)
+                     (if (and (string-prefix? "index-" id)
+                              (worthy-entry? rest))
                          (vhash-cons (anchor-id->key id)
                                      (string-append (basename file)
                                                     "#" id)
-- 
cgit 1.4.1