X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=ceb6a86a245332109bf5b9af71f50fb54915be76;hb=1a788358cd2d55e1d8f7556861e984f94c1ce2e9;hp=c47cb4a6c3685206678ef8ad9fd54111a8c28b9e;hpb=8c00ef0a0eb95417f6db5056c0c03b7cfa2e7571;p=lilypond.git

diff --git a/scm/markup.scm b/scm/markup.scm
index c47cb4a6c3..ceb6a86a24 100644
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -2,7 +2,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
-;;;; (c) 2003--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; (c) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 "
 Internally markup is stored as lists, whose head is a function.
@@ -37,25 +37,45 @@ The command is now available in markup mode, e.g.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; markup definer utilities
 
-(define-macro (define-builtin-markup-command command-and-args signature . body)
+;; For documentation purposes
+;; category -> markup functions
+(define-public markup-functions-by-category (make-hash-table 150))
+;; markup function -> used properties
+(define-public markup-functions-properties (make-hash-table 150))
+;; List of markup list functions
+(define-public markup-list-function-list (list))
+
+(define-macro (define-builtin-markup-command command-and-args signature
+                category properties-or-copied-function . body)
   "
 * Define a COMMAND-markup function after command-and-args and body,
 register COMMAND-markup and its signature,
 
-* add COMMAND-markup to markup-function-list,
+* add COMMAND-markup to markup-functions-by-category,
 
 * sets COMMAND-markup markup-signature and markup-keyword object properties,
 
 * define a make-COMMAND-markup function.
 
 Syntax:
-  (define-builtin-markup-command (COMMAND layout props arg1 arg2 ...)
-                                 (arg1-type? arg2-type? ...)
+  (define-builtin-markup-command (COMMAND layout props . arguments)
+                                 argument-types
+                                 category
+                                 properties
     \"documentation string\"
     ...command body...)
  or:
-  (define-builtin-markup-command COMMAND (arg1-type? arg2-type? ...)
-    function)
+  (define-builtin-markup-command COMMAND
+                                 argument-types
+                                 category
+                                 function)
+
+where:
+  argument-types is a list of type predicates for arguments
+  category is either a symbol or a symbol list
+  properties a list of (property default-value) lists or COMMANDx-markup elements
+    (when a COMMANDx-markup is found, the properties of the said commandx are
+    added instead). No check is performed against cyclical references!
 "
   (let* ((command (if (pair? command-and-args) (car command-and-args) command-and-args))
          (args (if (pair? command-and-args) (cdr command-and-args) '()))
@@ -64,51 +84,111 @@ Syntax:
     `(begin
        ;; define the COMMAND-markup function
        ,(if (pair? args)
-            `(define-public (,command-name ,@args)
-               ,@body)
+            (let ((documentation (car body))
+                  (real-body (cdr body))
+                  (properties properties-or-copied-function))
+              `(define-public (,command-name ,@args)
+                 ,documentation
+                 (let ,(filter identity
+                               (map (lambda (prop-spec)
+                                      (if (pair? prop-spec)
+                                          (let ((prop (car prop-spec))
+                                                (default-value (if (null? (cdr prop-spec))
+                                                                   #f
+                                                                   (cadr prop-spec)))
+                                                (props (cadr args)))
+                                            `(,prop (chain-assoc-get ',prop ,props ,default-value)))
+                                          #f))
+                                    properties))
+                   ,@real-body)))
             (let ((args (gensym "args"))
-                  (markup-command (car body)))
-            `(define-public (,command-name . ,args)
-               ,(format #f "Copy of the ~a command." markup-command)
-               (apply ,markup-command ,args))))
+                  (markup-command properties-or-copied-function))
+              `(define-public (,command-name . ,args)
+                 ,(format #f "Copy of the ~a command." markup-command)
+                 (apply ,markup-command ,args))))
        (set! (markup-command-signature ,command-name) (list ,@signature))
-       ;; add the command to markup-function-list, for markup documentation
-       (if (not (member ,command-name markup-function-list))
-           (set! markup-function-list (cons ,command-name markup-function-list)))
+       ;; Register the new function, for markup documentation
+       ,@(map (lambda (category)
+                `(hashq-set! markup-functions-by-category ',category
+                             (cons ,command-name
+                                   (or (hashq-ref markup-functions-by-category ',category)
+                                       (list)))))
+              (if (list? category) category (list 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-or-copied-function
+                                    (list)))))
        ;; 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))))))
 
-(define-macro (define-builtin-markup-list-command command-and-args signature . body)
+(define-macro (define-builtin-markup-list-command command-and-args signature
+                properties . body)
   "Same as `define-builtin-markup-command, but defines a command that, when
 interpreted, returns a list of stencils instead os a single one"
   (let* ((command (if (pair? command-and-args) (car command-and-args) command-and-args))
-	 (args (if (pair? command-and-args) (cdr command-and-args) '()))
-	 (command-name (string->symbol (format #f "~a-markup-list" command)))
-	 (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
+         (args (if (pair? command-and-args) (cdr command-and-args) '()))
+         (command-name (string->symbol (format #f "~a-markup-list" command)))
+         (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
     `(begin
        ;; define the COMMAND-markup-list function
        ,(if (pair? args)
-	    `(define-public (,command-name ,@args)
-	       ,@body)
-	    (let ((args (gensym "args"))
-		  (markup-command (car body)))
-	    `(define-public (,command-name . ,args)
-	       ,(format #f "Copy of the ~a command." markup-command)
-	       (apply ,markup-command ,args))))
+            (let ((documentation (car body))
+                  (real-body (cdr body)))
+              `(define-public (,command-name ,@args)
+                 ,documentation
+                 (let ,(filter identity
+                               (map (lambda (prop-spec)
+                                      (if (pair? prop-spec)
+                                          (let ((prop (car prop-spec))
+                                                (default-value (if (null? (cdr prop-spec))
+                                                                   #f
+                                                                   (cadr prop-spec)))
+                                                (props (cadr args)))
+                                            `(,prop (chain-assoc-get ',prop ,props ,default-value)))
+                                          #f))
+                                    properties))
+                   ,@body)))
+            (let ((args (gensym "args"))
+                  (markup-command (car body)))
+            `(define-public (,command-name . ,args)
+               ,(format #f "Copy of the ~a command." markup-command)
+               (apply ,markup-command ,args))))
        (set! (markup-command-signature ,command-name) (list ,@signature))
        ;; add the command to markup-list-function-list, for markup documentation
        (if (not (member ,command-name markup-list-function-list))
-	   (set! markup-list-function-list (cons ,command-name
-						 markup-list-function-list)))
+           (set! markup-list-function-list (cons ,command-name
+                                                 markup-list-function-list)))
+       ;; 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)))))
        ;; it's a markup-list command:
        (set-object-property! ,command-name 'markup-list-command #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)))))))
+         (let ((sig (list ,@signature)))
+           (list (make-markup ,command-name
+                              ,(symbol->string make-markup-name) sig args)))))))
 
 (define-public (make-markup markup-function make-name signature args)
   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
@@ -127,8 +207,8 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
         (ly:error
 	 (string-append
 	  make-name ": "
-	  (_ "Invalid argument in position ~A.  Expect: ~A, found: ~S.")
-	  error-msg))
+	  (_ "Invalid argument in position ~A.  Expect: ~A, found: ~S."))
+	  (car error-msg) (cadr error-msg)(caddr error-msg))
 	(cons markup-function args))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -189,24 +269,26 @@ Use `markup*' in a \\notemode context."
   (cond ((and (pair? expr)
               (keyword? (car expr)))
          ;; expr === (#:COMMAND arg1 ...)
-         (let* ((command (symbol->string (keyword->symbol (car expr))))
-                (sig (markup-command-signature
-		      (car (lookup-markup-command command))))
-                (sig-len (length sig)))
-           (do ((i 0 (1+ i))
-                (args '() args)
-                (rest (cdr expr) rest))
-               ((>= i sig-len)
-                (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
-             (cond ((eqv? (list-ref sig i) markup-list?)
-                    ;; (car rest) is a markup list
-                    (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
-                    (set! rest (cdr rest)))
-                   (else
-                    ;; pick up one arg in `rest'
-                    (receive (a r) (compile-markup-arg rest)
-                             (set! args (cons a args))
-                             (set! rest r)))))))
+         (let ((command (symbol->string (keyword->symbol (car expr)))))
+            (if (not (pair? (lookup-markup-command command)))
+                (ly:error (_ "Not a markup command: ~A") command))
+            (let* ((sig (markup-command-signature
+                         (car (lookup-markup-command command))))
+                   (sig-len (length sig)))
+              (do ((i 0 (1+ i))
+                   (args '() args)
+                   (rest (cdr expr) rest))
+                  ((>= i sig-len)
+                   (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
+                (cond ((eqv? (list-ref sig i) markup-list?)
+                       ;; (car rest) is a markup list
+                       (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
+                       (set! rest (cdr rest)))
+                      (else
+                       ;; pick up one arg in `rest'
+                       (receive (a r) (compile-markup-arg rest)
+                         (set! args (cons a args))
+                         (set! rest r))))))))
         ((and (pair? expr)
               (pair? (car expr))
               (keyword? (caar expr)))
@@ -289,10 +371,6 @@ Use `markup*' in a \\notemode context."
   (make-procedure-with-setter markup-command-signature-ref
                               markup-command-signature-set!))
 
-;; For documentation purposes
-(define-public markup-function-list (list))
-(define-public markup-list-function-list (list))
-
 (define-public (markup-signature-to-keyword sig)
   " (A B C) -> a0-b1-c2 "
   (if (null? sig)