From: David Kastrup <dak@gnu.org>
Date: Sat, 20 Sep 2014 17:57:38 +0000 (+0200)
Subject: Issue 4121/2: Store markup command argument list names in docstring
X-Git-Tag: release/2.19.15-1~11
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=0fe36c1225b6060ef0431089d41fde5cc6bab3ce;p=lilypond.git

Issue 4121/2: Store markup command argument list names in docstring

For one thing, the doc string does not make a lot of sense without the
argument list and it cannot reliably be deduced from the doc string
itself.

For another, GUILEv2 does not do us the favor of storing the original
argument list anywhere where it could be retrieved with a useful amount
of labor.

While it would be nice to put the types of the arguments into the doc
string as well, the signature's actual predicates are only evaluated
after macro expansion and that is too late for generating the doc
string.

So we just stick the argument list (after uncurrying) as a line at the
top.
---

diff --git a/scm/document-markup.scm b/scm/document-markup.scm
index 318a26b9e6..97809f2a8c 100644
--- a/scm/document-markup.scm
+++ b/scm/document-markup.scm
@@ -42,19 +42,20 @@
     prop-strings))
 
 (define (doc-markup-function func)
-  (let* ((doc-str  (procedure-documentation func))
+  (let* ((full-doc (procedure-documentation func))
+         (match-args (and full-doc (string-match "^\\([^)]*\\)\n" full-doc)))
+         (arg-names (if match-args
+                        (with-input-from-string (match:string match-args) read)
+                        (circular-list "arg")))
+         (doc-str (if match-args (match:suffix match-args) full-doc))
          (f-name (symbol->string (procedure-name  func)))
          (c-name (regexp-substitute/global #f "-markup(-list)?$" f-name  'pre "" 'post))
          (sig (object-property func 'markup-signature))
-         (arg-names (let ((arg-list (cadr (procedure-source func))))
-                      (if (list? arg-list)
-                          (map symbol->string (cddr arg-list))
-                          (make-list (length sig) "arg"))))
          (sig-type-names (map type-name sig))
          (signature-str
           (string-join
-           (map (lambda (x y) (string-append
-                             "@var{" x "} (" y ")" ))
+           (map (lambda (x y)
+                  (format #f "@var{~a} (~a)" x y))
                 arg-names  sig-type-names)
            " " )))
 
diff --git a/scm/markup-macros.scm b/scm/markup-macros.scm
index 67db7b5e8c..5e446d12e8 100644
--- a/scm/markup-macros.scm
+++ b/scm/markup-macros.scm
@@ -110,14 +110,14 @@ command.  There is no protection against circular definitions.
            (set! body (cddr body)))
     `(begin
        ;; define the COMMAND-markup function
-       ,(let* ((documentation (if (string? (car body))
-                                  (list (car body))
-                                  '()))
-               (real-body (if (or (null? documentation)
+       ,(let* ((documentation
+                (format #f "~a\n~a" (cddr args)
+                        (if (string? (car body)) (car body) "")))
+               (real-body (if (or (not (string? (car body)))
                                   (null? (cdr body)))
                               body (cdr body))))
           `(define-public (,command-name ,@args)
-             ,@documentation
+             ,documentation
              (let ,(map (lambda (prop-spec)
                           (let ((prop (car prop-spec))
                                 (default-value (if (null? (cdr prop-spec))
@@ -168,14 +168,14 @@ interpreted, returns a list of stencils instead of a single one"
            (set! body (cddr body)))
     `(begin
        ;; define the COMMAND-markup-list function
-       ,(let* ((documentation (if (string? (car body))
-                                  (list (car body))
-                                  '()))
-               (real-body (if (or (null? documentation)
+       ,(let* ((documentation
+                (format #f "~a\n~a" (cddr args)
+                        (if (string? (car body)) (car body) "")))
+               (real-body (if (or (not (string? (car body)))
                                   (null? (cdr body)))
                               body (cdr body))))
           `(define-public (,command-name ,@args)
-             ,@documentation
+             ,documentation
              (let ,(map (lambda (prop-spec)
                           (let ((prop (car prop-spec))
                                 (default-value (if (null? (cdr prop-spec))