+;;;
+;;; A scheme music pretty printer
+;;;
+(define (markup-expression->make-markup markup-expression)
+ "Transform `markup-expression' into an equivalent, hopefuly readable, scheme expression.
+For instance,
+ \\markup \\bold \\italic hello
+==>
+ (markup #:line (#:bold (#:italic (#:simple \"hello\"))))"
+ (define (proc->command-keyword proc)
+ "Return a keyword, eg. `#:bold', from the `proc' function, eg. #<procedure bold-markup (layout props arg)>"
+ (let ((cmd-markup (symbol->string (procedure-name proc))))
+ (symbol->keyword (string->symbol (substring cmd-markup 0 (- (string-length cmd-markup)
+ (string-length "-markup")))))))
+ (define (transform-arg arg)
+ (cond ((and (pair? arg) (markup? (car arg))) ;; a markup list
+ (apply append (map inner-markup->make-markup arg)))
+ ((and (not (string? arg)) (markup? arg)) ;; a markup
+ (inner-markup->make-markup arg))
+ (else ;; scheme arg
+ arg)))
+ (define (inner-markup->make-markup mrkup)
+ (if (string? mrkup)
+ `(#:simple ,mrkup)
+ (let ((cmd (proc->command-keyword (car mrkup)))
+ (args (map transform-arg (cdr mrkup))))
+ `(,cmd ,@args))))
+ ;; body:
+ (if (string? markup-expression)
+ markup-expression
+ `(markup ,@(inner-markup->make-markup markup-expression))))
+
+(define-public (music->make-music obj)
+ "Generate a expression that, once evaluated, may return an object equivalent to `obj',
+that is, for a music expression, a (make-music ...) form."
+ (cond (;; markup expression
+ (markup? obj)
+ (markup-expression->make-markup obj))
+ (;; music expression
+ (ly:music? obj)
+ `(make-music
+ ',(ly:music-property obj 'name)
+ ,@(apply append (map (lambda (prop)
+ `(',(car prop)
+ ,(music->make-music (cdr prop))))
+ (remove (lambda (prop)
+ (eqv? (car prop) 'origin))
+ (ly:music-mutable-properties obj))))))
+ (;; moment
+ (ly:moment? obj)
+ `(ly:make-moment ,(ly:moment-main-numerator obj)
+ ,(ly:moment-main-denominator obj)
+ ,(ly:moment-grace-numerator obj)
+ ,(ly:moment-grace-denominator obj)))
+ (;; note duration
+ (ly:duration? obj)
+ `(ly:make-duration ,(ly:duration-log obj)
+ ,(ly:duration-dot-count obj)
+ ,(car (ly:duration-factor obj))
+ ,(cdr (ly:duration-factor obj))))
+ (;; note pitch
+ (ly:pitch? obj)
+ `(ly:make-pitch ,(ly:pitch-octave obj)
+ ,(ly:pitch-notename obj)
+ ,(ly:pitch-alteration obj)))
+ (;; scheme procedure
+ (procedure? obj)
+ (or (procedure-name obj) obj))
+ (;; a symbol (avoid having an unquoted symbol)
+ (symbol? obj)
+ `',obj)
+ (;; an empty list (avoid having an unquoted empty list)
+ (null? obj)
+ `'())
+ (;; a proper list
+ (list? obj)
+ `(list ,@(map music->make-music obj)))
+ (;; a pair
+ (pair? obj)
+ `(cons ,(music->make-music (car obj))
+ ,(music->make-music (cdr obj))))
+ (else
+ obj)))
+
+(use-modules (ice-9 pretty-print))
+(define*-public (display-scheme-music obj #:optional (port (current-output-port)))
+ "Displays `obj', typically a music expression, in a friendly fashion,
+which often can be read back in order to generate an equivalent expression.
+
+Returns `obj'.
+"
+ (pretty-print (music->make-music obj) port)
+ (newline)
+ obj)