Print out header fields as PDF metadata; Add simple markup->string function

[lilypond.git] / scm / markup.scm

diff --git a/scm/markup.scm b/scm/markup.scm
index 108751e22f590156d607365d69c0a44f0e9e6def..6bd9fd6236c687950ff450b09ee2184badda92e8 100644 (file)
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -544,3 +544,63 @@ Uncovered - cheap-markup? is used."
           (car stencils))
       (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")))