X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=14a007a95bb27f8a89da2aeb51a607695af40068;hb=HEAD;hp=108751e22f590156d607365d69c0a44f0e9e6def;hpb=2613eed0a13ce118cb11f83057d9d79fc6973a4e;p=lilypond.git

diff --git a/scm/markup.scm b/scm/markup.scm
index 108751e22f..14a007a95b 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--2011 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2015 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
@@ -15,227 +15,6 @@
 ;;;; 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.
-
-  (FUNCTION ARG1 ARG2 ... )
-
-When the markup is formatted, then FUNCTION is called as follows
-
-  (FUNCTION GROB PROPS ARG1 ARG2 ... )
-
-GROB is the current grob, PROPS is a list of alists, and ARG1.. are
-the rest of the arguments.
-
-The function should return a stencil (i.e. a formatted, ready to
-print object).
-
-
-To add a markup command, use the define-markup-command utility.
-
-  (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
-
-;; 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,
-
-* add COMMAND-markup to markup-functions-by-category,
-
-* sets COMMAND-markup markup-signature object property,
-
-* define a make-COMMAND-markup function.
-
-Syntax:
-  (define-markup-command (COMMAND layout props . arguments)
-                                 argument-types
-                                 [ #:properties properties ]
-    \"documentation string\"
-    ...command body...)
-
-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 (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
-       ;; 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))
-       ;; 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)
-	 (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 @var{markup-function} and @var{args}.
-Typecheck against @var{signature}, reporting @var{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)))
-    (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
-	(ly:error (string-append make-name ": "
-		   (_ "Wrong number of arguments.  Expect: ~A, found ~A: ~S"))
-		  siglen arglen args))
-    (if error-msg
-	(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.
-
-(use-modules (ice-9 receive))
-
 (defmacro*-public markup (#:rest body)
   "The `markup' macro provides a lilypond-like syntax for building markups.
 
@@ -253,257 +32,10 @@ Example:
   (markup \"foo\"
           #:raise 0.2 #:hbracket #:bold \"bar\"
           #:override '(baseline-skip . 4)
-          #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
-Use `markup*' in a \\notemode context."
+          #:bracket #:column (\"baz\" \"bazr\" \"bla\"))"
 
   (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)
-  ===>
-  ((make-COMMAND1-markup arg11 arg12)
-   (make-COMMAND2-markup arg21 arg22 arg23) ...)"
-  (do ((rest expr rest)
-       (markps '() markps))
-      ((null? rest) (reverse markps))
-    (receive (m r) (compile-markup-expression rest)
-             (set! markps (cons m markps))
-             (set! rest r))))
-
-(define (keyword->make-markup key)
-  "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
-  (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."
-  (cond ((and (pair? expr)
-              (keyword? (car expr)))
-         ;; expr === (#:COMMAND arg1 ...)
-         (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)))
-         ;; expr === ((#:COMMAND arg1 ...) ...)
-         (receive (m r) (compile-markup-expression (car expr))
-                  (values m (cdr expr))))
-        ((and (pair? expr)
-              (string? (car expr))) ;; expr === ("string" ...)
-         (values `(make-simple-markup ,(car expr)) (cdr expr)))
-        (else
-         ;; expr === (symbol ...) or ((funcall ...) ...)
-         (values (car expr)
-                 (cdr expr)))))
-
-(define (compile-all-markup-args expr)
-  "Transform `expr' into markup arguments"
-  (do ((rest expr rest)
-       (args '() args))
-      ((null? rest) (reverse args))
-    (receive (a r) (compile-markup-arg rest)
-             (set! args (cons a args))
-             (set! rest r))))
-
-(define (compile-markup-arg expr)
-  "Return two values: the desired markup argument, and the rest arguments"
-  (cond ((null? expr)
-         ;; no more args
-         (values '() '()))
-        ((keyword? (car expr))
-         ;; expr === (#:COMMAND ...)
-         ;; ==> build and return the whole markup expression
-         (compile-markup-expression expr))
-        ((and (pair? (car expr))
-              (keyword? (caar expr)))
-         ;; expr === ((#:COMMAND ...) ...)
-         ;; ==> build and return the whole markup expression(s)
-         ;; found in (car expr)
-         (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
-                  (if (null? rest-expr)
-                      (values markup-expr (cdr expr))
-                      (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
-                              (cdr expr)))))
-        ((and (pair? (car expr))
-              (pair? (caar expr)))
-         ;; expr === (((foo ...) ...) ...)
-         (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
-        (else (values (car expr) (cdr expr)))))
-
-;;;;;;;;;;;;;;;
-;;; Utilities for storing and accessing markup commands signature
-;;; Examples:
-;;;
-;;; (set! (markup-command-signature raise-markup) (list number? markup?))
-;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
-;;;
-;;; (markup-command-signature raise-markup)
-;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
-;;;
-
-(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)
-  signature)
-
-(define-public markup-command-signature
-  (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)
-  (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)
-  "@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)
-                                (set! result (append cmd (list result))))
-                              commands)
-                    result))
-                markups))
-
-;;;;;;;;;;;;;;;;;;;;;;
-;;; markup type predicates
-
-(define (markup-function? 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)
-  "Return @code{#t} if @var{x} is a list of markups or markup command lists."
-  (define (markup-list-inner? lst)
-    (or (null? lst)
-	(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."
-  (if (and (pair? signature) (pair? arguments))
-      (and ((car signature) (car arguments))
-           (markup-argument-list? (cdr signature) (cdr arguments)))
-      (and (null? signature) (null? arguments))))
-
-
-(define (markup-argument-list-error signature arguments number)
-  "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
-#f is no error found.
-"
-  (if (and (pair? signature) (pair? arguments))
-      (if (not ((car signature) (car arguments)))
-          (list number (type-name (car signature)) (car arguments))
-          (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
-      #f))
-
-;;
-;; full recursive typecheck.
-;;
-(define (markup-typecheck? arg)
-  (or (string? arg)
-      (and (pair? arg)
-           (markup-function? (car arg))
-           (markup-argument-list? (markup-command-signature (car arg))
-                                  (cdr 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))
-        ((not (markup-function? (car arg)))
-         (throw 'markup-format "Not a markup function " (car arg)))
-        ((not (markup-argument-list? (markup-command-signature (car arg))
-                                     (cdr arg)))
-         (throw 'markup-format "Arguments failed  typecheck for " arg)))
-  #t)
-
-;;
-;; good enough if you only  use make-XXX-markup functions.
-;;
-(define (cheap-markup? x)
-  (or (string? x)
-      (and (pair? x)
-           (markup-function? (car x)))))
-
-;;
-;; replace by markup-thrower-typecheck for more detailed diagnostics.
-;;
-(define-public markup? cheap-markup?)
-
 ;; utility
 
 (define (markup-join markups sep)
@@ -516,31 +48,128 @@ Uncovered - cheap-markup? is used."
 (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)))
+  (fold-right
+   (lambda (m prev)
+     (if (markup-command-list? m)
+         (append (apply (car m) layout props (cdr m)) prev)
+         (cons (interpret-markup layout props m) prev)))
+   '()
+   markup-list))
 
 (define-public (prepend-alist-chain key val chain)
   (cons (acons key val (car chain)) (cdr chain)))
 
 (define-public (stack-stencil-line space stencils)
-  "DOCME"
-  (if (and (pair? stencils)
-	   (ly:stencil? (car stencils)))
+  "Adjoin a list of @var{stencils} along the X axis, leaving
+@var{space} between the end of each stencil and the beginning of the
+following stencil.  Stencils with empty Y extent are not given
+@var{space} before them and don't avoid overlapping other stencils."
+  (stack-stencils X RIGHT space (filter ly:stencil? stencils)))
 
-      (if (and (pair? (cdr stencils))
-	       (ly:stencil? (cadr stencils)))
-          (let* ((tail (stack-stencil-line space (cdr stencils)))
-                 (head (car stencils))
-                 (xoff (+ space (cdr (ly:stencil-extent head X)))))
-            (ly:stencil-add head
-                             (ly:stencil-translate-axis tail xoff X)))
-          (car stencils))
-      (ly:make-stencil '() '(0 . 0) '(0 . 0))))
+;;;; convert a full markup object to an approximate pure string representation
 
+;; We ignore `page-ref-markup', because we don't want to get the
+;; `gauge'- and `default'-string
+;;
+;; TODO:
+;; - we would be interested in the computed result of `replace-markup' and
+;;   `first-visible-markup', don't know how to get this, though
+;;   For now all (not computed) arguments are caught.
+;; - Other markup-commands to ignore?
+(define markup-commands-to-ignore
+  '(page-ref-markup))
+
+(define-public (markup->string m . argscopes)
+  (let* ((scopes (if (pair? argscopes) (car argscopes) '())))
+
+    (define all-relevant-markup-commands
+      ;; Returns a list containing the names of all markup-commands and
+      ;; markup-list-commands with predicate @code{cheap-markup?} or
+      ;; @code{markup-list?} in their @code{markup-command-signature}.
+      ;; @code{table-of-contents} is not caught, same for user-defined commands.
+      ;; markup-commands from @code{markup-commands-to-ignore} are removed.
+      (lset-difference eq?
+        (map car
+          (filter
+            (lambda (x)
+              (let* ((predicates (markup-command-signature (cdr x))))
+                (and predicates
+                     (not
+                       (null?
+                         (lset-intersection eq?
+                           '(cheap-markup? markup-list?)
+                           (map procedure-name predicates)))))))
+            (ly:module->alist (resolve-module '(lily)))))
+        markup-commands-to-ignore))
+
+    ;; helper functions to handle string cons like string lists
+    (define (markup-cons->string-cons c scopes)
+      (if (not (pair? c)) (markup->string c scopes)
+          (cons
+            (markup->string (car c) scopes)
+            (markup-cons->string-cons (cdr c) scopes))))
+    (define (string-cons-join c)
+      (if (not (pair? c)) c
+          (string-join (list (car c) (string-cons-join (cdr c))) "")))
+
+    ;; We let the following line in for future debugging
+    ;; (display-scheme-music (sort all-relevant-markup-commands symbol<?))
+
+
+    ;;;; Remark: below only works, if markup?- or markup-list? arguments are the
+    ;;;;         last listed arguments in the commands definition
+    ;;;; TODO: which other markup-(list)-commands should be special cased or
+    ;;;;       completely excluded?
+    (cond
+     ((string? m) m)
+     ((null? m) "")
+     ((not (pair? m)) "")
+
+     ;;;; special cases: \concat, \put-adjacent, \fill-with-pattern and
+     ;;;;                \fromproperty-markup
+     ;;;;
+     ;;;; TODO do we really want a string-joined return-value for \concat and
+     ;;;; \put-adjacent?
+     ;;;; \overlay or \combine will return a string with spaces
+
+     ;; handle \concat (string-join without spaces)
+     ((and (pair? m) (equal? (car m) concat-markup))
+      (string-cons-join (markup-cons->string-cons (cadr m) scopes)))
+
+     ;; handle \put-adjacent (string-join without spaces)
+     ((and (pair? m) (equal? (car m) put-adjacent-markup))
+      (string-cons-join (markup-cons->string-cons (take-right m 2) scopes)))
+
+     ;; handle \fill-with-pattern (ignore the filling markup)
+     ((and (pair? m) (equal? (car m) fill-with-pattern-markup))
+      (markup->string (take-right m 2) scopes))
+
+     ;; fromproperty-markup reads property values from the header block:
+     ((equal? (car m) fromproperty-markup)
+      (let* ((varname (symbol->string (cadr m)))
+             ;; cut off the header: prefix from the variable name:
+             (newvarname (if (string-prefix? "header:" varname)
+                             (substring varname 7)
+                             varname))
+             (var (string->symbol newvarname))
+             (mod (make-module 1)))
+        ;; Prevent loops by temporarily clearing the variable we have just looked up
+        (module-define! mod var "")
+        (markup->string (ly:modules-lookup scopes var) (cons mod scopes))))
+
+     ((member (car m)
+              (primitive-eval (cons 'list all-relevant-markup-commands)))
+      (markup->string
+        (if (> (length (last-pair m)) 1)
+            (last-pair m)
+            (car (last-pair m)))
+        scopes))
+
+     ;; ignore all other markup functions
+     ((markup-function? (car m)) "")
+
+     ;; handle markup lists
+     ((list? m)
+      (string-join (map (lambda (mm) (markup->string mm scopes)) m) " "))
+
+     (else "ERROR, unable to extract string from markup"))))