X-Git-Url: https://git.donarmstrong.com/lilypond.git?a=blobdiff_plain;f=scm%2Fmarkup-macros.scm;h=297f850b3c736e2fbdc0f4294182d1eb0351a29f;hb=fd565020849c9cd24d4e7ce47c50f756198a44c9;hp=72b107f8468a83261d38c31209f0d29235534115;hpb=cf137655b7aee9988ef536d6fa5e38d279ee73cf;p=lilypond.git

diff --git a/scm/markup-macros.scm b/scm/markup-macros.scm
index 72b107f846..297f850b3c 100644
--- a/scm/markup-macros.scm
+++ b/scm/markup-macros.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2003--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -47,12 +47,10 @@ The command is now available in markup mode, e.g.
 ;;; markup definer utilities
 
 ;; For documentation purposes
-;; category -> markup functions
-(define-public markup-functions-by-category (make-hash-table 150))
+;; markup function -> categories
+(define-public markup-function-category (make-object-property))
 ;; markup function -> used properties
-(define-public markup-functions-properties (make-weak-key-hash-table 151))
-;; List of markup list functions
-(define-public markup-list-functions (make-weak-key-hash-table 151))
+(define-public markup-function-properties (make-object-property))
 
 (use-modules (ice-9 optargs))
 
@@ -64,9 +62,9 @@ The command is now available in markup mode, e.g.
 * Define a COMMAND-markup function after command-and-args and body,
 register COMMAND-markup and its signature,
 
-* add COMMAND-markup to markup-functions-by-category,
+* add categories to markup-function-category,
 
-* sets COMMAND-markup markup-signature object property,
+* sets the markup-signature object property,
 
 * define a make-COMMAND-markup function.
 
@@ -94,7 +92,7 @@ After `argument-types', you may also specify
                                  [ #:category category ]
 where:
   `category' is either a symbol or a symbol list specifying the
-             category for this markup command in the docs.
+             categories for this markup command in the docs.
 
 As an element of the `properties' list, you may directly use a
 COMMANDx-markup symbol instead of a `(prop value)' list to indicate
@@ -110,14 +108,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))
@@ -129,32 +127,20 @@ command.  There is no protection against circular definitions.
                ,@real-body)))
        (set! (markup-command-signature ,command-name) (list ,@signature))
        ;; Register the new function, for markup documentation
-       ,@(map (lambda (category)
-                `(hashq-set!
-                  (or (hashq-ref markup-functions-by-category ',category)
-                      (let ((hash (make-weak-key-hash-table 151)))
-                        (hashq-set! markup-functions-by-category ',category
-                                    hash)
-                        hash))
-                  ,command-name #t))
-              (if (list? category) category (list category)))
+       (set! (markup-function-category ,command-name) ',category)
        ;; Used properties, for markup documentation
-       (hashq-set! markup-functions-properties
-                   ,command-name
-                   (list ,@(map (lambda (prop-spec)
-                                  (cond ((symbol? prop-spec)
-                                         prop-spec)
-                                        ((not (null? (cdr prop-spec)))
-                                         `(list ',(car prop-spec) ,(cadr prop-spec)))
-                                        (else
-                                         `(list ',(car prop-spec)))))
-                                (if (pair? args)
-                                    properties
-                                    (list)))))
+       (set! (markup-function-properties ,command-name)
+             (list ,@(map (lambda (prop-spec)
+                            (cond ((symbol? prop-spec)
+                                   prop-spec)
+                                  ((not (null? (cdr prop-spec)))
+                                   `(list ',(car prop-spec) ,(cadr prop-spec)))
+                                  (else
+                                   `(list ',(car prop-spec)))))
+                          properties)))
        ;; define the make-COMMAND-markup function
        (define-public (,make-markup-name . args)
-         (let ((sig (list ,@signature)))
-           (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
+         (,make-markup ,command-name ,(symbol->string make-markup-name) args)))))
 
 (defmacro*-public define-markup-list-command
   (command-and-args signature #:key (properties '()) #:rest body)
@@ -168,14 +154,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))
@@ -186,28 +172,22 @@ interpreted, returns a list of stencils instead of a single one"
                         (filter pair? properties))
                ,@real-body)))
        (set! (markup-command-signature ,command-name) (list ,@signature))
-       ;; add the command to markup-list-function-list, for markup documentation
-       (hashq-set! markup-list-functions ,command-name #t)
        ;; Used properties, for markup documentation
-       (hashq-set! markup-functions-properties
-                   ,command-name
-                   (list ,@(map (lambda (prop-spec)
-                                  (cond ((symbol? prop-spec)
-                                         prop-spec)
-                                        ((not (null? (cdr prop-spec)))
-                                         `(list ',(car prop-spec) ,(cadr prop-spec)))
-                                        (else
-                                         `(list ',(car prop-spec)))))
-                                (if (pair? args)
-                                    properties
-                                    (list)))))
+       (set! (markup-function-properties ,command-name)
+             (list ,@(map (lambda (prop-spec)
+                            (cond ((symbol? prop-spec)
+                                   prop-spec)
+                                  ((not (null? (cdr prop-spec)))
+                                   `(list ',(car prop-spec) ,(cadr prop-spec)))
+                                  (else
+                                   `(list ',(car prop-spec)))))
+                          properties)))
        ;; it's a markup-list command:
-       (set-object-property! ,command-name 'markup-list-command #t)
+       (set! (markup-list-function? ,command-name) #t)
        ;; define the make-COMMAND-markup-list function
        (define-public (,make-markup-name . args)
-         (let ((sig (list ,@signature)))
-           (list (make-markup ,command-name
-                              ,(symbol->string make-markup-name) sig args)))))))
+         (list (,make-markup ,command-name
+                             ,(symbol->string make-markup-name) args))))))
 
 ;;;;;;;;;;;;;;;
 ;;; Utilities for storing and accessing markup commands signature
@@ -220,29 +200,16 @@ interpreted, returns a list of stencils instead of a single one"
 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 ;;;
 
-(define-public (markup-command-signature-ref markup-command)
-  "Return markup-command's signature (the 'markup-signature object property)"
-  (object-property markup-command 'markup-signature))
-
-(define-public (markup-command-signature-set! markup-command signature)
-  "Set markup-command's signature (as object property)"
-  (set-object-property! markup-command 'markup-signature signature)
-  signature)
-
-(define-public markup-command-signature
-  (make-procedure-with-setter markup-command-signature-ref
-                              markup-command-signature-set!))
+(define-public markup-command-signature (make-object-property))
 
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; markup type predicates
 
-(define (markup-function? x)
+(define-public (markup-function? x)
   (and (markup-command-signature x)
-       (not (object-property x 'markup-list-command))))
+       (not (markup-list-function? x))))
 
-(define (markup-list-function? x)
-  (and (markup-command-signature x)
-       (object-property x 'markup-list-command)))
+(define-public markup-list-function? (make-object-property))
 
 (define-public (markup-command-list? x)
   "Determine if `x' is a markup command list, ie. a list composed of
@@ -317,11 +284,14 @@ Uncovered - cheap-markup? is used."
 ;;
 (define-public markup? cheap-markup?)
 
-(define-public (make-markup markup-function make-name signature args)
+(define (make-markup markup-function make-name args)
   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
-against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
+against signature, reporting MAKE-NAME as the user-invoked function.
 "
   (let* ((arglen (length args))
+         (signature (or (markup-command-signature markup-function)
+                        (ly:error (_ "~S: Not a markup (list) function: ~S")
+                                  make-name markup-function)))
          (siglen (length signature))
          (error-msg (if (and (> siglen 0) (> arglen 0))
                         (markup-argument-list-error signature args 1)