scm/document-markup.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
   4 ;;;;                 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19
  20 (define (doc-markup-function-properties func)
  21   (let ((properties (markup-function-properties func))
  22         (prop-strings (list)))
  23     (for-each (lambda (prop-spec)
  24                 (set! prop-strings
  25                       (if (list? prop-spec)
  26                           ;; either (prop value) or (prop)
  27                           (cons (if (null? (cdr prop-spec))
  28                                     (format #f "@item @code{~a}\n" (car prop-spec))
  29                                     (format #f "@item @code{~a} (~a)\n"
  30                                             (car prop-spec)
  31                                             (let ((default (cadr prop-spec)))
  32                                               (if (and (list? default)
  33                                                        (null? default))
  34                                                   "'()"
  35                                                   default))))
  36                                 prop-strings)
  37                           ;; a markup command: get its properties
  38                           ;; FIXME: avoid cyclical references
  39                           (append (doc-markup-function-properties prop-spec)
  40                                   prop-strings))))
  41               (or properties (list)))
  42     prop-strings))
  43
  44 (define (doc-markup-function func-pair)
  45   (let* ((f-name (symbol->string (car func-pair)))
  46          (func (cdr func-pair))
  47          (full-doc (procedure-documentation func))
  48          (match-args (and full-doc (string-match "^\\([^)]*\\)\n" full-doc)))
  49          (arg-names (if match-args
  50                         (with-input-from-string (match:string match-args) read)
  51                         (circular-list "arg")))
  52          (doc-str (if match-args (match:suffix match-args) full-doc))
  53          (c-name (regexp-substitute/global #f "-markup(-list)?$" f-name  'pre "" 'post))
  54          (sig (markup-command-signature func))
  55          (sig-type-names (map type-name sig))
  56          (signature-str
  57           (string-join
  58            (map (lambda (x y)
  59                   (format #f "@var{~a} (~a)" x y))
  60                 arg-names  sig-type-names)
  61            " " )))
  62
  63     (string-append
  64      "\n\n@item @code{\\" c-name "} " signature-str
  65      "\n@funindex \\" c-name "\n"
  66      "\n@cindex \\" c-name "\n"
  67      (if (string? doc-str)
  68          doc-str
  69          "")
  70      (let ((prop-strings (doc-markup-function-properties func)))
  71        (if (null? prop-strings)
  72            "\n"
  73            (string-append "\n\n\nUsed properties:\n@itemize\n"
  74                           (string-concatenate prop-strings)
  75                           "@end itemize\n"))))))
  76
  77 (define (markup-name<? a b)
  78   (ly:string-ci<? (symbol->string (car a)) (symbol->string (car b))))
  79
  80 (define all-markup-commands '())
  81 (define all-markup-list-commands '())
  82
  83 (for-each
  84  (lambda (m)
  85    (module-for-each (lambda (sym var)
  86                       (let ((val (variable-ref var)))
  87                         (cond ((markup-function? val)
  88                                (set! all-markup-commands
  89                                      (acons sym val all-markup-commands)))
  90                               ((markup-list-function? val)
  91                                (set! all-markup-list-commands
  92                                      (acons sym val all-markup-list-commands))))))
  93                     (module-public-interface m)))
  94  (cons (current-module) (map resolve-module '((lily) (scm accreg)))))
  95
  96 (set! all-markup-commands (sort! all-markup-commands markup-name<?))
  97 (set! all-markup-list-commands (sort! all-markup-list-commands markup-name<?))
  98
  99 (define (markup-category-doc-node category)
 100   (let* ((category-string (symbol->string category))
 101          (category-name (string-capitalize
 102                          (regexp-substitute/global
 103                           #f "-" category-string 'pre " " 'post)))
 104          (markup-functions (filter
 105                             (lambda (fun)
 106                               (let ((cats (markup-function-category (cdr fun))))
 107                                 (if (pair? cats)
 108                                     (memq category cats)
 109                                     (eq? category cats))))
 110                             all-markup-commands)))
 111
 112     (make <texi-node>
 113       #:appendix #t
 114       #:name category-name
 115       #:desc ""
 116       #:text (string-append
 117               "@table @asis"
 118               (string-concatenate
 119                (map doc-markup-function markup-functions))
 120               "\n@end table"))))
 121
 122 (define (markup-doc-node)
 123   (make <texi-node>
 124     #:appendix #t
 125     #:name "Text markup commands"
 126     #:desc ""
 127     #:text "The following commands can all be used inside @code{\\markup @{ @}}."
 128     #:children (let* (;; when a new category is defined, update `ordered-categories'
 129                       (ordered-categories '(font align graphic music instrument-specific-markup accordion-registers other))
 130                       (raw-categories
 131                        (fold (lambda (next union)
 132                                (let ((cat (markup-function-category next)))
 133                                  (cond ((pair? cat)
 134                                         (lset-union eq? cat union))
 135                                        ((symbol? cat)
 136                                         (lset-adjoin eq? cat union))
 137                                        (else union))))
 138                              '()
 139                              all-markup-commands))
 140                       (categories (append ordered-categories
 141                                           (sort (lset-difference eq?
 142                                                                  raw-categories
 143                                                                  ordered-categories)
 144                                                 symbol<?))))
 145                  (map markup-category-doc-node categories))))
 146
 147 (define (markup-list-doc-string)
 148   (string-append
 149    "@table @asis"
 150    (string-concatenate
 151     (map doc-markup-function all-markup-list-commands))
 152    "\n@end table"))