From daad014dea1243daf0c57dde1815fbabcb5d4f8c Mon Sep 17 00:00:00 2001
From: David Kastrup <dak@gnu.org>
Date: Fri, 22 Mar 2013 09:25:05 +0100
Subject: [PATCH] Allow markup lists to be composed at run-time

Using a markup command on a markup list generated by a markup list
command was not previously possible.  Now things like

  \with-color #red { \column-lines { x y z } }

work as well.
---
 scm/define-markup-commands.scm | 37 ++++++++++++++++++++++++++++++++++
 scm/ly-syntax-constructors.scm | 34 +++++++++++++++++--------------
 2 files changed, 56 insertions(+), 15 deletions(-)

diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm
index 98047b5741..ff977b2bfb 100755
--- a/scm/define-markup-commands.scm
+++ b/scm/define-markup-commands.scm
@@ -4277,3 +4277,40 @@ where @var{X} is the number of staff spaces."
   (pair? markup-list?)
   "Like @code{\\override}, for markup lists."
   (interpret-markup-list layout (cons (list new-prop) props) args))
+
+(define-markup-list-command (map-markup-commands layout props compose args)
+  (procedure? markup-list?)
+  "This applies the function @var{compose} to every markup in
+@var{args} (including elements of markup list command calls) in order
+to produce a new markup list.  Since the return value from a markup
+list command call is not a markup list but rather a list of stencils,
+this requires passing those stencils off as the results of individual
+markup calls.  That way, the results should work out as long as no
+markups rely on side effects."
+  (let ((key (make-symbol "key")))
+    (catch
+     key
+     (lambda ()
+       ;; if `compose' does not actually interpret its markup
+       ;; argument, we still need to return a list of stencils,
+       ;; created from the single returned stencil
+       (list
+        (interpret-markup layout props
+                          (compose
+                           (make-on-the-fly-markup
+                            (lambda (layout props m)
+                              ;; here all effects of `compose' on the
+                              ;; properties should be visible, so we
+                              ;; call interpret-markup-list at this
+                              ;; point of time and harvest its
+                              ;; stencils
+                              (throw key
+                                     (interpret-markup-list
+                                      layout props args)))
+                            (make-null-markup))))))
+     (lambda (key stencils)
+       (map
+        (lambda (sten)
+          (interpret-markup layout props
+                            (compose (make-stencil-markup sten))))
+        stencils)))))
diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm
index 3fdf698727..7817ec25c5 100644
--- a/scm/ly-syntax-constructors.scm
+++ b/scm/ly-syntax-constructors.scm
@@ -18,7 +18,7 @@
 ;; TODO: use separate module for syntax
 ;; constructors. Also create wrapper around the constructor?
 (defmacro define-ly-syntax (args . body)
-  `(define-public ,args ,(cons 'begin body)))
+  `(define-public ,args ,@body))
 
 ;; A ly-syntax constructor takes two extra parameters, parser and
 ;; location. These are mainly used for reporting errors and
@@ -172,20 +172,24 @@ into a @code{MultiMeasureTextEvent}."
 ;;   (bold (raise 4 (italic markup2)))
 ;;   (bold (raise 4 (italic markup3))))
 
-  (map (lambda (arg)
-         (fold
-          (lambda (cmd prev) (append cmd (list prev)))
-          arg
-          commands))
-       (if (every markup? markups)
-           markups
-           (begin
-             (ly:parser-error parser
-                              (format #f
-                                      (_ "uncomposable markup list elements ~a")
-                                      (remove markup? markups))
-                              location)
-             (filter markup? markups)))))
+  (define (compose arg)
+    (fold
+     (lambda (cmd prev) (append cmd (list prev)))
+     arg
+     commands))
+  (let loop ((markups markups) (completed '()))
+    (cond ((null? markups) (reverse! completed))
+          ((markup? (car markups))
+           (loop (cdr markups)
+                 (cons (compose (car markups)) completed)))
+          (else
+           (call-with-values
+               (lambda () (break! markup? markups))
+             (lambda (complex rest)
+               (loop rest
+                     (reverse!
+                      (make-map-markup-commands-markup-list
+                       compose complex) completed))))))))
 
 (define-ly-syntax (property-operation parser location ctx music-type symbol . args)
   (let* ((props (case music-type
-- 
2.39.5