+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parser <-> output hooks.
+
+(define-public (collect-bookpart-for-book book-part)
+ "Toplevel book-part handler."
+ (define (add-bookpart book-part)
+ (ly:parser-define! 'toplevel-bookparts
+ (cons book-part (ly:parser-lookup 'toplevel-bookparts))))
+ ;; If toplevel scores have been found before this \bookpart,
+ ;; add them first to a dedicated bookpart
+ (if (pair? (ly:parser-lookup 'toplevel-scores))
+ (begin
+ (add-bookpart (ly:make-book-part
+ (ly:parser-lookup 'toplevel-scores)))
+ (ly:parser-define! 'toplevel-scores (list))))
+ (add-bookpart book-part))
+
+(define-public (collect-scores-for-book score)
+ (ly:parser-define! 'toplevel-scores
+ (cons score (ly:parser-lookup 'toplevel-scores))))
+
+(define-public (collect-music-aux score-handler music)
+ (define (music-property symbol)
+ (ly:music-property music symbol #f))
+ (cond ((music-property 'page-marker)
+ ;; a page marker: set page break/turn permissions or label
+ (let ((label (music-property 'page-label)))
+ (if (symbol? label)
+ (score-handler (ly:make-page-label-marker label))))
+ (for-each (lambda (symbol)
+ (let ((permission (music-property symbol)))
+ (if (symbol? permission)
+ (score-handler
+ (ly:make-page-permission-marker symbol
+ (if (eq? 'forbid permission)
+ '()
+ permission))))))
+ '(line-break-permission page-break-permission
+ page-turn-permission)))
+ ((not (music-property 'void))
+ ;; a regular music expression: make a score with this music
+ ;; void music is discarded
+ (score-handler (scorify-music music)))))
+
+(define-public (collect-music-for-book music)
+ "Top-level music handler."
+ (collect-music-aux (lambda (score)
+ (collect-scores-for-book score))
+ music))
+
+(define-public (collect-book-music-for-book book music)
+ "Book music handler."
+ (collect-music-aux (lambda (score)
+ (ly:book-add-score! book score))
+ music))
+
+(define-public (scorify-music music)
+ "Preprocess @var{music}."
+ (ly:make-score
+ (fold (lambda (f m) (f m))
+ music
+ toplevel-music-functions)))
+
+(define (get-current-filename book)
+ "return any suffix value for output filename allowing for settings by
+calls to bookOutputName function"
+ (or (paper-variable book 'output-filename)
+ (ly:parser-output-name)))
+
+(define (get-current-suffix book)
+ "return any suffix value for output filename allowing for settings by calls to
+bookoutput function"
+ (let ((book-output-suffix (paper-variable book 'output-suffix)))
+ (if (not (string? book-output-suffix))
+ (ly:parser-lookup 'output-suffix)
+ book-output-suffix)))
+
+(define-public current-outfile-name #f) ; for use by regression tests
+
+(define (get-outfile-name book)
+ "return current filename for generating backend output files"
+ ;; user can now override the base file name, so we have to use
+ ;; the file-name concatenated with any potential output-suffix value
+ ;; as the key to out internal a-list
+ (let* ((base-name (get-current-filename book))
+ (output-suffix (get-current-suffix book))
+ (alist-key (format #f "~a~a" base-name output-suffix))
+ (counter-alist (ly:parser-lookup 'counter-alist))
+ (output-count (assoc-get alist-key counter-alist 0))
+ (result base-name))
+ ;; Allow all ASCII alphanumerics, including accents
+ (if (string? output-suffix)
+ (set! result
+ (format #f "~a-~a"
+ result
+ (string-regexp-substitute
+ "[^-[:alnum:]]"
+ "_"
+ output-suffix))))
+
+ ;; assoc-get call will always have returned a number
+ (if (> output-count 0)
+ (set! result (format #f "~a-~a" result output-count)))
+
+ (ly:parser-define! 'counter-alist
+ (assoc-set! counter-alist alist-key (1+ output-count)))
+ (set! current-outfile-name result)
+ result))
+
+(define (print-book-with book process-procedure)
+ (let* ((paper (ly:parser-lookup '$defaultpaper))
+ (layout (ly:parser-lookup '$defaultlayout))
+ (outfile-name (get-outfile-name book)))
+ (process-procedure book paper layout outfile-name)))
+
+(define-public (print-book-with-defaults book)
+ (print-book-with book ly:book-process))
+
+(define-public (print-book-with-defaults-as-systems book)
+ (print-book-with book ly:book-process-to-systems))
+
+;; Add a score to the current bookpart, book or toplevel
+(define-public (add-score score)
+ (cond
+ ((ly:parser-lookup '$current-bookpart)
+ ((ly:parser-lookup 'bookpart-score-handler)
+ (ly:parser-lookup '$current-bookpart) score))
+ ((ly:parser-lookup '$current-book)
+ ((ly:parser-lookup 'book-score-handler)
+ (ly:parser-lookup '$current-book) score))
+ (else
+ ((ly:parser-lookup 'toplevel-score-handler) score))))
+
+(define-public paper-variable
+ (let
+ ((get-papers
+ (lambda (book)
+ (append (if (and book (ly:output-def? (ly:book-paper book)))
+ (list (ly:book-paper book))
+ '())
+ (ly:parser-lookup '$papers)
+ (list (ly:parser-lookup '$defaultpaper))))))
+ (make-procedure-with-setter
+ (lambda (book symbol)
+ (any (lambda (p) (ly:output-def-lookup p symbol #f))
+ (get-papers book)))
+ (lambda (book symbol value)
+ (ly:output-def-set-variable!
+ (car (get-papers book))
+ symbol value)))))
+
+(define-public (add-text text)
+ (add-score (list text)))
+
+(define-public (add-music music)
+ (collect-music-aux (lambda (score)
+ (add-score score))
+ music))
+
+(define-public (context-mod-from-music music)
+ (let ((warn #t) (mods (ly:make-context-mod)))
+ (let loop ((m music))
+ (if (music-is-of-type? m 'layout-instruction-event)
+ (let ((symbol (ly:music-property m 'symbol)))
+ (ly:add-context-mod
+ mods
+ (case (ly:music-property m 'name)
+ ((PropertySet)
+ (list 'assign
+ symbol
+ (ly:music-property m 'value)))
+ ((PropertyUnset)
+ (list 'unset symbol))
+ ((OverrideProperty)
+ (cons* 'push
+ symbol
+ (ly:music-property m 'grob-value)
+ (cond
+ ((ly:music-property m 'grob-property #f) => list)
+ (else
+ (ly:music-property m 'grob-property-path)))))
+ ((RevertProperty)
+ (cons* 'pop
+ symbol
+ (cond
+ ((ly:music-property m 'grob-property #f) => list)
+ (else
+ (ly:music-property m 'grob-property-path))))))))
+ (case (ly:music-property m 'name)
+ ((ApplyContext)
+ (ly:add-context-mod mods
+ (list 'apply
+ (ly:music-property m 'procedure))))
+ ((ContextSpeccedMusic)
+ (loop (ly:music-property m 'element)))
+ (else
+ (let ((callback (ly:music-property m 'elements-callback)))
+ (if (procedure? callback)
+ (for-each loop (callback m))
+ (if (and warn (ly:duration? (ly:music-property m 'duration)))
+ (begin
+ (ly:music-warning
+ music
+ (_ "Music unsuitable for context-mod"))
+ (set! warn #f)))))))))
+ mods))
+
+(define-public (context-defs-from-music output-def music)
+ (let ((warn #t))
+ (let loop ((m music) (mods #f))
+ ;; The parser turns all sets, overrides etc into something
+ ;; wrapped in ContextSpeccedMusic. If we ever get a set,
+ ;; override etc that is not wrapped in ContextSpeccedMusic, the
+ ;; user has created it in Scheme himself without providing the
+ ;; required wrapping. In that case, using #f in the place of a
+ ;; context modification results in a reasonably recognizable
+ ;; error.
+ (if (music-is-of-type? m 'layout-instruction-event)
+ (ly:add-context-mod
+ mods
+ (case (ly:music-property m 'name)
+ ((PropertySet)
+ (list 'assign
+ (ly:music-property m 'symbol)
+ (ly:music-property m 'value)))
+ ((PropertyUnset)
+ (list 'unset
+ (ly:music-property m 'symbol)))
+ ((OverrideProperty)
+ (cons* 'push
+ (ly:music-property m 'symbol)
+ (ly:music-property m 'grob-value)
+ (cond
+ ((ly:music-property m 'grob-property #f) => list)
+ (else
+ (ly:music-property m 'grob-property-path)))))
+ ((RevertProperty)
+ (cons* 'pop
+ (ly:music-property m 'symbol)
+ (cond
+ ((ly:music-property m 'grob-property #f) => list)
+ (else
+ (ly:music-property m 'grob-property-path)))))))
+ (case (ly:music-property m 'name)
+ ((ApplyContext)
+ (ly:add-context-mod mods
+ (list 'apply
+ (ly:music-property m 'procedure))))
+ ((ContextSpeccedMusic)
+ ;; Use let* here to let defs catch up with modifications
+ ;; to the context defs made in the recursion
+ (let* ((mods (loop (ly:music-property m 'element)
+ (ly:make-context-mod)))
+ (defs (ly:output-find-context-def
+ output-def (ly:music-property m 'context-type))))
+ (if (null? defs)
+ (ly:music-warning
+ music
+ (ly:format (_ "Cannot find context-def \\~a")
+ (ly:music-property m 'context-type)))
+ (for-each
+ (lambda (entry)
+ (ly:output-def-set-variable!
+ output-def (car entry)
+ (ly:context-def-modify (cdr entry) mods)))
+ defs))))
+ (else
+ (let ((callback (ly:music-property m 'elements-callback)))
+ (if (procedure? callback)
+ (fold loop mods (callback m))
+ (if (and warn (ly:duration? (ly:music-property m 'duration)))
+ (begin
+ (ly:music-warning
+ music
+ (_ "Music unsuitable for output-def"))
+ (set! warn #f))))))))
+ mods)))