X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdocument-markup.scm;h=bbc8939e0281943478a32bfb2e7eed3fc1c8ba70;hb=HEAD;hp=91ec7b882d669315ead572564ab01aa059961c3e;hpb=cbff1a4a581b6c99ff063792b38fba3c1df7df5d;p=lilypond.git diff --git a/scm/document-markup.scm b/scm/document-markup.scm index 91ec7b882d..bbc8939e02 100644 --- a/scm/document-markup.scm +++ b/scm/document-markup.scm @@ -1,13 +1,24 @@ -;;;; document-markup.scm -- part of generated backend documentation +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 1998--2007 Han-Wen Nienhuys +;;;; Copyright (C) 1998--2015 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . (define (doc-markup-function-properties func) - (let ((properties (hashq-ref markup-functions-properties func)) + (let ((properties (markup-function-properties func)) (prop-strings (list))) (for-each (lambda (prop-spec) (set! prop-strings @@ -30,27 +41,29 @@ (or properties (list))) prop-strings)) -(define (doc-markup-function func) - (let* ((doc-str (procedure-documentation func)) - (f-name (symbol->string (procedure-name func))) +(define (doc-markup-function func-pair) + (let* ((f-name (symbol->string (car func-pair))) + (func (cdr func-pair)) + (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)) (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 (markup-command-signature func)) (sig-type-names (map type-name sig)) (signature-str (string-join - (map (lambda (x) (string-append - "@var{" (car x) "} (" (cadr x) ")" )) - (zip arg-names sig-type-names)) + (map (lambda (x y) + (format #f "@var{~a} (~a)" x y)) + arg-names sig-type-names) " " ))) - + (string-append "\n\n@item @code{\\" c-name "} " signature-str "\n@funindex \\" c-name "\n" - "\n@cindex \\" c-name "\n" + "\n@cindex \\" c-name "\n" (if (string? doc-str) doc-str "") @@ -58,57 +71,82 @@ (if (null? prop-strings) "\n" (string-append "\n\n\nUsed properties:\n@itemize\n" - (apply string-append prop-strings) + (string-concatenate prop-strings) "@end itemize\n")))))) -(define (markup-functionstring (procedure-name a)) (symbol->string (procedure-name b)))) - +(define (markup-namestring (car a)) (symbol->string (car b)))) + +(define all-markup-commands '()) +(define all-markup-list-commands '()) + +(for-each + (lambda (m) + (module-for-each (lambda (sym var) + (let ((val (variable-ref var))) + (cond ((markup-function? val) + (set! all-markup-commands + (acons sym val all-markup-commands))) + ((markup-list-function? val) + (set! all-markup-list-commands + (acons sym val all-markup-list-commands)))))) + (module-public-interface m))) + (cons (current-module) (map resolve-module '((lily) (scm accreg))))) + +(set! all-markup-commands (sort! all-markup-commands markup-namestring category)) - (category-name (string-capitalize (regexp-substitute/global #f - "-" category-string 'pre " " 'post))) - (markup-functions (hashq-ref markup-functions-by-category - category))) + (category-name (string-capitalize + (regexp-substitute/global + #f "-" category-string 'pre " " 'post))) + (markup-functions (filter + (lambda (fun) + (let ((cats (markup-function-category (cdr fun)))) + (if (pair? cats) + (memq category cats) + (eq? category cats)))) + all-markup-commands))) + (make + #:appendix #t #:name category-name #:desc "" #:text (string-append "@table @asis" - (apply string-append - (map doc-markup-function - (sort markup-functions markup-function + #:appendix #t #:name "Text markup commands" #:desc "" #:text "The following commands can all be used inside @code{\\markup @{ @}}." #:children (let* (;; when a new category is defined, update `ordered-categories' - (ordered-categories '(font align graphic music instrument-specific-markup other)) - (raw-categories (hash-fold (lambda (category functions categories) - (cons category categories)) - (list) - markup-functions-by-category)) + (ordered-categories '(font align graphic music instrument-specific-markup accordion-registers other)) + (raw-categories + (fold (lambda (next union) + (let ((cat (markup-function-category next))) + (cond ((pair? cat) + (lset-union eq? cat union)) + ((symbol? cat) + (lset-adjoin eq? cat union)) + (else union)))) + '() + all-markup-commands)) (categories (append ordered-categories - (filter (lambda (cat) - (not (memq cat ordered-categories))) - raw-categories)))) + (sort (lset-difference eq? + raw-categories + ordered-categories) + symbol - #:name "Text markup list commands" - #:desc "" - #:text (string-append - "The following commands can all be used with @code{\\markuplines}.\n" - (markup-list-doc-string)))) +(define (markup-list-doc-string) + (string-append + "@table @asis" + (string-concatenate + (map doc-markup-function all-markup-list-commands)) + "\n@end table"))