05/06: doc: Avoid invalid 'match' pattern in 'syntax-highlighted-html'.

[guix-commits]

civodul pushed a commit to branch version-1.1.0
in repository guix.

commit 4487e42cba15110bce91d729b3e964f62347ed50
Author: Ludovic Courtès <address@hidden>
AuthorDate: Mon Apr 13 02:09:09 2020 +0200

    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(-)

diff --git a/doc/build.scm b/doc/build.scm
index c3d61f8..ca81d81 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)