MIDI: in #'staff mapping mode, keep to one channel. Fixes #1620.

[lilypond.git] / scm / markup.scm

diff --git a/scm/markup.scm b/scm/markup.scm
index 103c2e6e7d8cb94d9095804645fb1e3128d75d0e..6bd9fd6236c687950ff450b09ee2184badda92e8 100644 (file)
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -1,8 +1,19 @@
-;;;; markup.scm -- Implement a user extensible markup scheme.
+;;;; This file is part of LilyPond, the GNU music typesetter.

 ;;;;
 ;;;;

-;;;;  source file of the GNU LilyPond music typesetter
-;;;; 
-;;;; (c) 2003--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; Copyright (C) 2003--2011 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
+;;;; 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 <http://www.gnu.org/licenses/>.

 
 "
 Internally markup is stored as lists, whose head is a function.
 
 "
 Internally markup is stored as lists, whose head is a function.


@@ -11,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
 
 
 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.
 
 GROB is the current grob, PROPS is a list of alists, and ARG1.. are
 the rest of the arguments.


@@ -20,115 +31,238 @@ The function should return a stencil (i.e. a formatted, ready to
 print object).
 
 
 print object).
 
 

-To add a function, use the def-markup-command utility.
+To add a markup command, use the define-markup-command utility.

 
 

-  (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.
 
     \"my command usage and description\"
     ...function body...)
 
 The command is now available in markup mode, e.g.
 

-

   \\markup { .... \\MYCOMMAND #1 argument ... }
 
 " ; "
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; markup definer utilities
   \\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-weak-key-hash-table 151))
+;; List of markup list functions
+(define-public markup-list-functions (make-weak-key-hash-table 151))
+
+(use-modules (ice-9 optargs))

 
 

+(defmacro*-public define-markup-command
+  (command-and-args signature
+   #:key (category '()) (properties '())
+   #:rest body)
+  "

 * Define a COMMAND-markup function after command-and-args and body,
 register COMMAND-markup and its signature,
 
 * 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,
+* sets COMMAND-markup markup-signature object property,

 
 * define a make-COMMAND-markup function.
 
 Syntax:
 
 * define a make-COMMAND-markup function.
 
 Syntax:

-  (def-markup-command (COMMAND layout props arg1 arg2 ...) (arg1-type? arg2-type? ...)
+  (define-markup-command (COMMAND layout props . arguments)
+                                 argument-types
+                                 [ #:properties properties ]

     \"documentation string\"
     ...command body...)
     \"documentation string\"
     ...command body...)

- or:
-  (def-markup-command COMMAND (arg1-type? arg2-type? ...)
-    function)
+
+where:
+  `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) '()))
-         (command-name (string->symbol (string-append (symbol->string command) "-markup")))
-         (make-markup-name (string->symbol (string-append "make-" (symbol->string command-name)))))
+  (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
+       ,(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)
+               `(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)))
+       ;; 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)))))
+       ;; 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))))))
+
+(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 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
     `(begin

-       (define-public ,(if (pair? args)
-                           (cons command-name args)
-                           command-name)
-         ,@body)
+       ;; define the COMMAND-markup-list function
+       ,(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))
        (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)))
+       ;; 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)))))
+       ;; 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)
        (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)))
+          (list (make-markup ,command-name
+                             ,(symbol->string make-markup-name) sig args)))))))

 
 (define-public (make-markup markup-function make-name signature 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.
-"
+  "Construct a markup object from @var{markup-function} and @var{args}.
+Typecheck against @var{signature}, reporting @var{make-name} as the
+user-invoked function."

   (let* ((arglen (length args))
   (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))
     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))

-        (scm-error 'markup-format make-name
-                   "Expect ~A arguments for ~A. Found ~A: ~S"
-                   (list siglen make-name arglen args)
-                   #f))
+       (ly:error (string-append make-name ": "
+                  (_ "Wrong number of arguments.  Expect: ~A, found ~A: ~S"))
+                 siglen arglen args))

     (if error-msg
     (if error-msg

-        (scm-error 'markup-format make-name
-                   "Invalid argument in position ~A\nExpect: ~A\nFound: ~S."
-                   error-msg #f)
-        (cons markup-function args))))
+       (ly:error
+        (string-append
+         make-name ": "
+         (_ "Invalid argument in position ~A.  Expect: ~A, found: ~S."))
+         (car error-msg) (cadr error-msg)(caddr error-msg))
+       (cons markup-function args))))

 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; markup constructors
 ;;; lilypond-like syntax for markup construction in scheme.
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; markup constructors
 ;;; lilypond-like syntax for markup construction in scheme.
 

-(use-modules (ice-9 optargs)
-             (ice-9 receive))
+(use-modules (ice-9 receive))

 
 (defmacro*-public markup (#:rest body)
   "The `markup' macro provides a lilypond-like syntax for building markups.
 
  - #:COMMAND is used instead of \\COMMAND
 
 (defmacro*-public markup (#:rest body)
   "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)
  - 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\"
   }
          <==>
   (markup \"foo\"
           #:raise 0.2 #:hbracket #:bold \"bar\"

-          #:override '(baseline-skip . 4) 
+          #:override '(baseline-skip . 4)

           #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
           #:bracket #:column (\"baz\" \"bazr\" \"bla\"))

-Use `markup*' in a \\notes block."
-  
+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)))
   (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)
 (define (compile-all-markup-expressions expr)
   "Return a list of canonical markups expressions, e.g.:
   (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)


@@ -147,28 +281,32 @@ Use `markup*' in a \\notes block."
   (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
 
 (define (compile-markup-expression expr)
   (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 ...)
   (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)))
         ((and (pair? expr)
               (pair? (car expr))
               (keyword? (caar expr)))


@@ -217,130 +355,63 @@ 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)))))
 
          (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
 ;;;;;;;;;;;;;;;
 ;;; Utilities for storing and accessing markup commands signature

-;;; and keyword.

 ;;; Examples:
 ;;;
 ;;; (set! (markup-command-signature raise-markup) (list number? markup?))
 ;;; 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-signature raise-markup)
 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 ;;;

-;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
-;;; 
-
-(define markup-command-signatures (make-hash-table 50))
-
-(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-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-ref markup-command)
+  "Return @var{markup-command}'s signature (the @code{'markup-signature}
+object property)."
+  (object-property markup-command 'markup-signature))
+
+(define-public (markup-command-signature-set! markup-command signature)
+  "Set @var{markup-command}'s signature (as object property)."

   (set-object-property! markup-command 'markup-signature signature)
   (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
 (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))
-
-(define-public markup-function-list '())
-
-(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)
-                         "-"))))
+  (make-procedure-with-setter markup-command-signature-ref
+                              markup-command-signature-set!))
+
+(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)
 
 (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-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-signature proc)))))

 
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; used in parser.yy to map a list of markup commands on markup arguments
 (define-public (map-markup-command-list commands markups)
 
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; used in parser.yy to map a list of markup commands on markup arguments
 (define-public (map-markup-command-list commands markups)

-  "`markups' being a list of markups, eg (markup1 markup2 markup3),
-and `commands' a list of commands with their scheme arguments, in reverse order,
-eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
- ((bold (raise 4 (italic markup1)))
-  (bold (raise 4 (italic markup2)))
-  (bold (raise 4 (italic markup3))))
-"
+  "@var{markups} being a list of markups, for example
+@code{(markup1 markup2 markup3)}, and @var{commands} a list of commands with
+their scheme arguments, in reverse order, for example
+@code{((italic) (raise 4) (bold))}, map the commands on each markup argument,
+for example
+@example
+((bold (raise 4 (italic markup1)))
+ (bold (raise 4 (italic markup2)))
+ (bold (raise 4 (italic markup3))))
+@end example"

   (map-in-order (lambda (arg)
                   (let ((result arg))
                     (for-each (lambda (cmd)
   (map-in-order (lambda (arg)
                   (let ((result arg))
                     (for-each (lambda (cmd)


@@ -353,13 +424,25 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 ;;; markup type predicates
 
 (define (markup-function? x)
 ;;; 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 whether @var{x} is a markup command list, i.e. a list
+composed of a markup list function and its arguments."
+  (and (pair? x) (markup-list-function? (car x))))

 
 (define-public (markup-list? arg)
 
 (define-public (markup-list? arg)

+  "Return @code{#t} if @var{x} is a list of markups or markup command lists."

   (define (markup-list-inner? lst)
     (or (null? lst)
   (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."
 
 (define (markup-argument-list? signature arguments)
   "Typecheck argument list."


@@ -389,10 +472,15 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
            (markup-argument-list? (markup-command-signature (car arg))
                                   (cdr arg)))))
 
            (markup-argument-list? (markup-command-signature (car arg))
                                   (cdr arg)))))
 

-;; 
-;; typecheck, and throw an error when something amiss.
-;; 
+;;
+;;
+;;
+;;

 (define (markup-thrower-typecheck arg)
 (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))
   (cond ((string? arg) #t)
         ((not (pair? arg))
          (throw 'markup-format "Not a pair" arg))


@@ -405,7 +493,7 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 
 ;;
 ;; good enough if you only  use make-XXX-markup functions.
 
 ;;
 ;; good enough if you only  use make-XXX-markup functions.

-;; 
+;;

 (define (cheap-markup? x)
   (or (string? x)
       (and (pair? x)
 (define (cheap-markup? x)
   (or (string? x)
       (and (pair? x)


@@ -413,7 +501,7 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 
 ;;
 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 
 ;;
 ;; replace by markup-thrower-typecheck for more detailed diagnostics.

-;; 
+;;

 (define-public markup? cheap-markup?)
 
 ;; utility
 (define-public markup? cheap-markup?)
 
 ;; utility


@@ -424,10 +512,20 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
       (make-line-markup (list-insert-separator markups sep))
       empty-markup))
 
       (make-line-markup (list-insert-separator markups sep))
       empty-markup))
 

-;; unused?
-;;(define-public brew-markup-stencil Text_interface::print)

 
 

-(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)))
 
 (define-public (prepend-alist-chain key val chain)
   (cons (acons key val (car chain)) (cdr chain)))
 


@@ -435,10 +533,10 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
   "DOCME"
   (if (and (pair? stencils)
           (ly:stencil? (car stencils)))
   "DOCME"
   (if (and (pair? stencils)
           (ly:stencil? (car stencils)))

-      
+

       (if (and (pair? (cdr stencils))
               (ly:stencil? (cadr stencils)))
       (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
                  (head (car stencils))
                  (xoff (+ space (cdr (ly:stencil-extent head X)))))
             (ly:stencil-add head


@@ -447,8 +545,62 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 
 
       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 
 

-
-
-
-
-
+;;; convert a full markup object to an approximate pure string representation
+
+(define-public (markup->string m)
+  ;; markup commands with one markup argument, formatting ignored
+  (define markups-first-argument '(list
+    bold-markup box-markup caps-markup dynamic-markup finger-markup
+    fontCaps-markup huge-markup italic-markup large-markup larger-markup
+    medium-markup normal-size-sub-markup normal-size-super-markup
+    normal-text-markup normalsize-markup number-markup roman-markup
+    sans-markup simple-markup small-markup smallCaps-markup smaller-markup
+    sub-markup super-markup teeny-markup text-markup tiny-markup
+    typewriter-markup underline-markup upright-markup bracket-markup
+    circle-markup hbracket-markup parenthesize-markup rounded-box-markup
+
+    center-align-markup center-column-markup column-markup dir-column-markup
+    fill-line-markup justify-markup justify-string-markup left-align-markup
+    left-column-markup line-markup right-align-markup right-column-markup
+    vcenter-markup wordwrap-markup wordwrap-string-markup ))
+
+  ;; markup commands with markup as second argument, first argument
+  ;; specifies some formatting and is ignored
+  (define markups-second-argument '(list
+    abs-fontsize-markup fontsize-markup magnify-markup lower-markup
+    pad-around-markup pad-markup-markup pad-x-markup raise-markup
+    halign-markup hcenter-in-markup rotate-markup translate-markup
+    translate-scaled-markup with-url-markup scale-markup ))
+
+  ;; helper functions to handle string cons like string lists
+  (define (markup-cons->string-cons c)
+    (if (not (pair? c)) (markup->string c)
+      (cons (markup->string (car c)) (markup-cons->string-cons (cdr c)))))
+  (define (string-cons-join c)
+    (if (not (pair? c)) c
+        (string-join (list (car c) (string-cons-join (cdr c))) "")))
+
+  (cond
+    ((string? m) m)
+    ((null? m) "")
+
+    ;; handle \concat (string-join without spaces)
+    ((and (pair? m) (equal? (car m) concat-markup))
+        (string-cons-join (markup-cons->string-cons (cadr m))) )
+
+    ;; markup functions with the markup as first arg
+    ((member (car m) (primitive-eval markups-first-argument))
+        (markup->string (cadr m)))
+
+    ;; markup functions with markup as second arg
+    ((member (car m) (primitive-eval markups-second-argument))
+        (markup->string (cddr m)))
+
+    ;; ignore all other markup functions
+    ((markup-function? (car m)) "")
+
+    ;; handle markup lists
+    ((list? m)
+        (string-join (map markup->string m) " "))
+
+    (else "ERROR, unable to extract string from markup")))