X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=ceb6a86a245332109bf5b9af71f50fb54915be76;hb=8574d4349026c4ac5a15a27c50e264bf548e29fb;hp=9e48d7395a470dd84a93afacb5eba7997631618f;hpb=ea6d4c224d988252a9cff44776d0159b4c26a443;p=lilypond.git

diff --git a/scm/markup.scm b/scm/markup.scm
index 9e48d7395a..ceb6a86a24 100644
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -2,7 +2,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
-;;;; (c) 2003--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; (c) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 "
 Internally markup is stored as lists, whose head is a function.
@@ -20,60 +20,176 @@ The function should return a stencil (i.e. a formatted, ready to
 print object).
 
 
-To add a function, use the def-markup-command utility.
+To add a builtin markup command, use the define-builtin-markup-command
+utility. In a user file, the define-markup-command macro shall be used
+(see ly/markup-init.ly).
 
-  (def-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
+  (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
     \"my command usage and description\"
     ...function body...)
 
 The command is now available in markup mode, e.g.
 
-
   \\markup { .... \\MYCOMMAND #1 argument ... }
 
 " ; "
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; markup definer utilities
-;;; `def-markup-command' can be used both for built-in markup
-;;; definitions and user defined markups.
 
-(defmacro-public def-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:
-  (def-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:
-  (def-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) '()))
-         (command-name (string->symbol (string-append (symbol->string command) "-markup")))
-         (make-markup-name (string->symbol (string-append "make-" (symbol->string command-name)))))
+         (command-name (string->symbol (format #f "~a-markup" command)))
+         (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
     `(begin
-       (define-public ,(if (pair? args)
-                           (cons command-name args)
-                           command-name)
-         ,@body)
+       ;; define the COMMAND-markup function
+       ,(if (pair? args)
+            (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 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))
-       (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
+                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))))
+    `(begin
+       ;; define the COMMAND-markup-list function
+       ,(if (pair? 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)))
+       ;; 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)))))))
+
 (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.
@@ -91,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))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -106,22 +222,21 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
   "The `markup' macro provides a lilypond-like syntax for building markups.
 
  - #:COMMAND is used instead of \\COMMAND
- - #:lines ( ... ) is used instead of { ... }
- - #:center-align ( ... ) is used instead of \\center-align < ... >
+ - #:line ( ... ) is used instead of \\line { ... }
  - etc.
 
 Example:
   \\markup { foo
             \\raise #0.2 \\hbracket \\bold bar
             \\override #'(baseline-skip . 4)
-            \\bracket \\column < baz bazr bla >
+            \\bracket \\column { baz bazr bla }
   }
          <==>
   (markup \"foo\"
           #:raise 0.2 #:hbracket #:bold \"bar\"
           #:override '(baseline-skip . 4) 
           #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
-Use `markup*' in a \\notes block."
+Use `markup*' in a \\notemode context."
   
   (car (compile-all-markup-expressions `(#:line ,body))))
 
@@ -148,28 +263,32 @@ Use `markup*' in a \\notes block."
   (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
 
 (define (compile-markup-expression expr)
-  "Return two values: the first complete canonical markup expression found in `expr',
-e.g. (make-COMMAND-markup arg1 arg2 ...), and the rest expression."
+  "Return two values: the first complete canonical markup expression
+   found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...),
+   and the rest expression."
   (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)))
@@ -218,43 +337,6 @@ e.g. (make-COMMAND-markup arg1 arg2 ...), and the rest expression."
          (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
         (else (values (car expr) (cdr expr)))))
 
-;;;;;;;;;;;;;;;
-;;; Debugging utilities: print markup expressions in a friendly fashion
-
-(use-modules (ice-9 format))
-(define (markup->string markup-expr)
-  "Return a string describing, in LilyPond syntax, the given markup expression."
-  (define (proc->command proc)
-    (let ((cmd-markup (symbol->string (procedure-name proc))))
-      (substring cmd-markup 0 (- (string-length cmd-markup)
-                                 (string-length "-markup")))))
-  (define (arg->string arg)
-    (cond ((and (pair? arg) (pair? (car arg))) ;; markup list
-           (format #f "~{ ~a~}" (map markup->string arg)))
-          ((pair? arg)                         ;; markup
-           (markup->string arg))
-          ((string? arg)                       ;; scheme string argument
-           (format #f "#\"~a\"" arg))
-          (else                                ;; other scheme arg
-           (format #f "#~a" arg))))
-  (let ((cmd (car markup-expr))
-        (args (cdr markup-expr)))
-    (cond ((eqv? cmd simple-markup) ;; a simple string
-           (format #f "\"~a\"" (car args)))
-          ((eqv? cmd line-markup)   ;; { ... }
-           (format #f "{~a}" (arg->string (car args))))
-          ((eqv? cmd center-align-markup) ;; \center < ... >
-           (format #f "\\center-align <~a>" (arg->string (car args))))
-          ((eqv? cmd column-markup) ;; \column < ... >
-           (format #f "\\column <~a>" (arg->string (car args))))
-          (else                ;; \command ...
-           (format #f "\\~a~{ ~a~} " (proc->command cmd) (map arg->string args))))))
-
-(define-public (display-markup markup-expr)
-  "Print a LilyPond-syntax equivalent for the given markup expression."
-  (display "\\markup ")
-  (display (markup->string markup-expr)))
-
 ;;;;;;;;;;;;;;;
 ;;; Utilities for storing and accessing markup commands signature
 ;;; and keyword.
@@ -269,44 +351,25 @@ e.g. (make-COMMAND-markup arg1 arg2 ...), and the rest expression."
 ;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
 ;;; 
 
-(define markup-command-signatures (make-hash-table 50))
+(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 (markup-command-signature-ref markup-command)
-  "Return markup-command's signature, e.g. (number? markup?).
-markup-command may be a procedure."
-  (let ((sig-key (hashq-ref markup-command-signatures
-                            markup-command)))
-    (if sig-key (car sig-key) #f)))
+(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-keyword markup-command)
-  "Return markup-command's keyword, e.g. \"scheme0markup1\".
-markup-command may be a procedure."
-  (let ((sig-key (hashq-ref markup-command-signatures
-                            markup-command)))
-    (if sig-key (cdr sig-key) #f)))
-
-(define (markup-command-signatureset! markup-command signature)
-  "Set markup-command's signature. markup-command must be a named procedure.
-Also set markup-signature and markup-keyword object properties."
-  (hashq-set! markup-command-signatures
-              markup-command
-              (cons signature (markup-signature-to-keyword signature)))
-  ;; these object properties are still in use somewhere
+(define-public (markup-command-signature-set! markup-command signature)
+  "Set markup-command's signature and keyword (as object properties)"
   (set-object-property! markup-command 'markup-signature signature)
-  (set-object-property! markup-command 'markup-keyword (markup-signature-to-keyword signature)))
-  
-(define-public markup-command-signature
-  (make-procedure-with-setter markup-command-signature-ref markup-command-signatureset!))
-
-(define (markup-symbol-to-proc markup-sym)
-  "Return the markup command procedure which name is `markup-sym', if any."
-  (hash-fold (lambda (key val prev)
-                            (or prev
-                                (if (eqv? (procedure-name key) markup-sym) key #f)))
-             #f
-             markup-command-signatures))
+  (set-object-property! markup-command 'markup-keyword 
+                        (markup-signature-to-keyword signature))
+  signature)
 
-(define-public markup-function-list '())
+(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 "
@@ -328,9 +391,24 @@ Also set markup-signature and markup-keyword object properties."
                                     sig)
                          "-"))))
 
+(define (lookup-markup-command-aux symbol)
+  (let ((proc (catch 'misc-error
+                (lambda ()
+                  (module-ref (current-module) symbol))
+                (lambda (key . args) #f))))
+    (and (procedure? proc) proc)))
+
 (define-public (lookup-markup-command code)
-  (let ((proc (markup-symbol-to-proc (string->symbol (string-append code "-markup")))))
-    (and proc (cons proc (markup-command-keyword proc)))))
+  (let ((proc (lookup-markup-command-aux
+	       (string->symbol (format #f "~a-markup" code)))))
+    (and proc (markup-function? proc)
+	 (cons proc (markup-command-keyword 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)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; used in parser.yy to map a list of markup commands on markup arguments
@@ -354,13 +432,25 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 ;;; markup type predicates
 
 (define (markup-function? x)
-  (not (not (markup-command-signature x))))
+  (and (markup-command-signature x)
+       (not (object-property x 'markup-list-command))))
+
+(define (markup-list-function? x)
+  (and (markup-command-signature x)
+       (object-property x 'markup-list-command)))
+
+(define-public (markup-command-list? x)
+  "Determine if `x' is a markup command list, ie. a list composed of
+a markup list function and its arguments."
+  (and (pair? x) (markup-list-function? (car x))))
 
 (define-public (markup-list? arg)
+  "Return a true value if `x' is a list of markups or markup command lists."
   (define (markup-list-inner? lst)
     (or (null? lst)
-        (and (markup? (car lst)) (markup-list-inner? (cdr lst)))))
-  (and (list? arg) (markup-list-inner? arg)))
+	(and (or (markup? (car lst)) (markup-command-list? (car lst)))
+             (markup-list-inner? (cdr lst)))))
+  (not (not (and (list? arg) (markup-list-inner? arg)))))
 
 (define (markup-argument-list? signature arguments)
   "Typecheck argument list."
@@ -391,9 +481,14 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
                                   (cdr arg)))))
 
 ;; 
-;; typecheck, and throw an error when something amiss.
+;; 
+;;
 ;; 
 (define (markup-thrower-typecheck arg)
+  "typecheck, and throw an error when something amiss.
+
+Uncovered - cheap-markup? is used."
+
   (cond ((string? arg) #t)
         ((not (pair? arg))
          (throw 'markup-format "Not a pair" arg))
@@ -426,7 +521,19 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
       empty-markup))
 
 
-(define-public interpret-markup Text_interface::interpret_markup)
+(define-public interpret-markup ly:text-interface::interpret-markup)
+
+(define-public (interpret-markup-list layout props markup-list)
+  (let ((stencils (list)))
+    (for-each (lambda (m)
+		(set! stencils
+		      (if (markup-command-list? m)
+			  (append! (reverse! (apply (car m) layout props (cdr m)))
+				   stencils)
+			  (cons (interpret-markup layout props m) stencils))))
+	      markup-list)
+    (reverse! stencils)))
+
 (define-public (prepend-alist-chain key val chain)
   (cons (acons key val (car chain)) (cdr chain)))
 
@@ -437,7 +544,7 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
       
       (if (and (pair? (cdr stencils))
 	       (ly:stencil? (cadr stencils)))
-          (let* ((tail (stack-stencil-line  space (cdr stencils)))
+          (let* ((tail (stack-stencil-line space (cdr stencils)))
                  (head (car stencils))
                  (xoff (+ space (cdr (ly:stencil-extent head X)))))
             (ly:stencil-add head
@@ -445,9 +552,3 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
           (car stencils))
       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 
-
-
-
-
-
-