X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=7b7e2838eb5242e5d895e8b7580df357aa779a78;hb=d0a10b130ca01f3923b6a793a785d1d66455ab55;hp=2b9bd32b1b344812623794b6ce6c3e0e38ae7f30;hpb=37a1acdcb64020041d724e42e3e41b921e655709;p=lilypond.git

diff --git a/scm/markup.scm b/scm/markup.scm
index 2b9bd32b1b..7b7e2838eb 100644
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2010 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
@@ -22,7 +22,7 @@ Internally markup is stored as lists, whose head is a function.
 
 When the markup is formatted, then FUNCTION is called as follows
 
-  (FUNCTION GROB PROPS ARG1 ARG2 ... ) 
+  (FUNCTION GROB PROPS ARG1 ARG2 ... )
 
 GROB is the current grob, PROPS is a list of alists, and ARG1.. are
 the rest of the arguments.
@@ -66,67 +66,67 @@ register COMMAND-markup and its signature,
 
 * add COMMAND-markup to markup-functions-by-category,
 
-* sets COMMAND-markup markup-signature and markup-keyword object properties,
+* sets COMMAND-markup markup-signature object property,
 
 * define a make-COMMAND-markup function.
 
 Syntax:
   (define-markup-command (COMMAND layout props . arguments)
                                  argument-types
-                                 [ #:category category ]
                                  [ #:properties properties ]
     \"documentation string\"
     ...command body...)
- or:
-  (define-markup-command COMMAND
-                                 argument-types
-                                 [ #:category 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!
-
-  The specified properties are available as let-bound variables in the
-  command body.
+  `argument-types' is a list of type predicates for arguments
+  `properties' a list of (property default-value) lists
+
+The specified properties are available as let-bound variables in the
+command body, using the respective `default-value' as fallback in case
+`property' is not found in `props'.  `props' itself is left unchanged:
+if you want defaults specified in that manner passed down into other
+markup functions, you need to adjust `props' yourself.
+
+The autogenerated documentation makes use of some optional
+specifications that are otherwise ignored:
+
+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.
+
+As an element of the `properties' list, you may directly use a
+COMMANDx-markup symbol instead of a `(prop value)' list to indicate
+that this markup command is called by the newly defined command,
+adding its properties to the documented properties of the new
+command.  There is no protection against circular definitions.
 "
-  (let* ((command (if (pair? command-and-args) (car command-and-args) command-and-args))
-         (args (if (pair? command-and-args) (cdr command-and-args) '()))
+  (let* ((command (car command-and-args))
+         (args (cdr command-and-args))
          (command-name (string->symbol (format #f "~a-markup" command)))
          (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
     (while (and (pair? body) (keyword? (car body)))
 	   (set! body (cddr body)))
     `(begin
        ;; define the COMMAND-markup function
-       ,(if (pair? args)
-            (let* ((documentation (if (string? (car body))
-				      (list (car body))
-				      '()))
-		   (real-body (if (or (null? documentation)
-				      (null? (cdr body)))
-				  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))
-                   ,@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))))
+       ,(let* ((documentation (if (string? (car body))
+				  (list (car body))
+				  '()))
+	       (real-body (if (or (null? documentation)
+				  (null? (cdr body)))
+			      body (cdr body))))
+	  `(define-public (,command-name ,@args)
+	     ,@documentation
+	     (let ,(map (lambda (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))))
+			(filter pair? properties))
+	       ,@real-body)))
        (set! (markup-command-signature ,command-name) (list ,@signature))
        ;; Register the new function, for markup documentation
        ,@(map (lambda (category)
@@ -140,99 +140,90 @@ where:
 	      (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
-                                    (list)))))
+		   ,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)))))
        ;; 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))))))
+	 (let ((sig (list ,@signature)))
+	   (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
 
 (defmacro*-public define-markup-list-command
   (command-and-args signature #:key (properties '()) #:rest body)
-  "Same as `define-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) '()))
+  "Same as `define-markup-command', but defines a command that, when
+interpreted, returns a list of stencils instead of a single one"
+  (let* ((command (car command-and-args))
+         (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))))
     (while (and (pair? body) (keyword? (car body)))
 	   (set! body (cddr body)))
     `(begin
        ;; define the COMMAND-markup-list function
-       ,(if (pair? args)
-            (let* ((documentation (if (string? (car body))
-				      (list (car body))
-				      '()))
-		   (real-body (if (or (null? documentation)
-				      (null? (cdr body)))
-				  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))
-                   ,@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))))
+       ,(let* ((documentation (if (string? (car body))
+				  (list (car body))
+				  '()))
+	       (real-body (if (or (null? documentation)
+				  (null? (cdr body)))
+			      body (cdr body))))
+	  `(define-public (,command-name ,@args)
+	     ,@documentation
+	     (let ,(map (lambda (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))))
+			(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)))))
+		   ,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
 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 "
   (let* ((arglen (length args))
-         (siglen (length signature))
-         (error-msg (if (and (> siglen 0) (> arglen 0))
-                        (markup-argument-list-error signature args 1)
-                        #f)))
+	 (siglen (length signature))
+	 (error-msg (if (and (> siglen 0) (> arglen 0))
+			(markup-argument-list-error signature args 1)
+			#f)))
     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
-        (ly:error (string-append make-name ": "
-                   (_ "Wrong number of arguments.  Expect: ~A, found ~A: ~S"))
+	(ly:error (string-append make-name ": "
+		   (_ "Wrong number of arguments.  Expect: ~A, found ~A: ~S"))
 		  siglen arglen args))
     (if error-msg
-        (ly:error
+	(ly:error
 	 (string-append
 	  make-name ": "
 	  (_ "Invalid argument in position ~A.  Expect: ~A, found: ~S."))
@@ -261,17 +252,17 @@ Example:
          <==>
   (markup \"foo\"
           #:raise 0.2 #:hbracket #:bold \"bar\"
-          #:override '(baseline-skip . 4) 
+          #:override '(baseline-skip . 4)
           #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
 Use `markup*' in a \\notemode context."
-  
+
   (car (compile-all-markup-expressions `(#:line ,body))))
 
 (defmacro*-public markup* (#:rest body)
   "Same as `markup', for use in a \\notes block."
   `(ly:export (markup ,@body)))
-  
-  
+
+
 (define (compile-all-markup-expressions expr)
   "Return a list of canonical markups expressions, e.g.:
   (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
@@ -366,58 +357,28 @@ Use `markup*' in a \\notemode context."
 
 ;;;;;;;;;;;;;;;
 ;;; Utilities for storing and accessing markup commands signature
-;;; and keyword.
 ;;; Examples:
 ;;;
 ;;; (set! (markup-command-signature raise-markup) (list number? markup?))
-;;; ==> ((#<primitive-procedure number?> #<procedure markup? (obj)>) . scheme0-markup1)
+;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 ;;;
 ;;; (markup-command-signature raise-markup)
 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 ;;;
-;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
-;;; 
-
-(define-public (markup-command-keyword markup-command)
-  "Return markup-command's argument keyword, ie a string describing the command
-  arguments, eg. \"scheme0markup1\""
-  (object-property markup-command 'markup-keyword))
 
 (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 and keyword (as object properties)"
+  "Set markup-command's signature (as object property)"
   (set-object-property! markup-command 'markup-signature signature)
-  (set-object-property! markup-command 'markup-keyword 
-                        (markup-signature-to-keyword signature))
   signature)
 
 (define-public markup-command-signature
   (make-procedure-with-setter markup-command-signature-ref
                               markup-command-signature-set!))
 
-(define-public (markup-signature-to-keyword sig)
-  " (A B C) -> a0-b1-c2 "
-  (if (null? sig)
-      'empty
-      (string->symbol (string-join (map
-                                    (let* ((count 0))
-                                      (lambda (func)
-                                        (set! count (+ count 1))
-                                        (string-append
-                                         ;; for reasons I don't get,
-                                         ;; (case func ((markup?) .. )
-                                         ;; doesn't work.
-                                         (cond 
-                                          ((eq? func markup?) "markup")
-                                          ((eq? func markup-list?) "markup-list")
-                                          (else "scheme"))
-                                         (number->string (- count 1)))))
-                                    sig)
-                         "-"))))
-
 (define (lookup-markup-command-aux symbol)
   (let ((proc (catch 'misc-error
                 (lambda ()
@@ -429,13 +390,13 @@ Use `markup*' in a \\notemode context."
   (let ((proc (lookup-markup-command-aux
 	       (string->symbol (format #f "~a-markup" code)))))
     (and proc (markup-function? proc)
-	 (cons proc (markup-command-keyword proc)))))
+	 (cons proc (markup-command-signature proc)))))
 
 (define-public (lookup-markup-list-command code)
   (let ((proc (lookup-markup-command-aux
 	       (string->symbol (format #f "~a-markup-list" code)))))
      (and proc (markup-list-function? proc)
-	  (cons proc (markup-command-keyword proc)))))
+	  (cons proc (markup-command-signature proc)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; used in parser.yy to map a list of markup commands on markup arguments
@@ -507,10 +468,10 @@ a markup list function and its arguments."
            (markup-argument-list? (markup-command-signature (car arg))
                                   (cdr arg)))))
 
-;; 
-;; 
 ;;
-;; 
+;;
+;;
+;;
 (define (markup-thrower-typecheck arg)
   "typecheck, and throw an error when something amiss.
 
@@ -528,7 +489,7 @@ Uncovered - cheap-markup? is used."
 
 ;;
 ;; good enough if you only  use make-XXX-markup functions.
-;; 
+;;
 (define (cheap-markup? x)
   (or (string? x)
       (and (pair? x)
@@ -536,7 +497,7 @@ Uncovered - cheap-markup? is used."
 
 ;;
 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
-;; 
+;;
 (define-public markup? cheap-markup?)
 
 ;; utility
@@ -568,7 +529,7 @@ Uncovered - cheap-markup? is used."
   "DOCME"
   (if (and (pair? stencils)
 	   (ly:stencil? (car stencils)))
-      
+
       (if (and (pair? (cdr stencils))
 	       (ly:stencil? (cadr stencils)))
           (let* ((tail (stack-stencil-line space (cdr stencils)))