Restore announce files for 2.0 - 2.12.

[lilypond.git] / scm / lily-library.scm

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 9673c7b3e44eb634b4a2daff6d557d10483cb0d3..91ece1e476a360785b81614f636d59e79d9123d7 100644 (file)
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -157,31 +157,31 @@
   (ly:make-score music))
 
 
   (ly:make-score music))
 
 

-(define (get-current-filename parser)
+(define (get-current-filename parser book)

   "return any suffix value for output filename allowing for settings by
 calls to bookOutputName function"
   "return any suffix value for output filename allowing for settings by
 calls to bookOutputName function"

-  (let ((book-filename (ly:parser-lookup parser 'book-filename)))
+  (let ((book-filename (paper-variable parser book 'output-filename)))

     (if (not book-filename)
        (ly:parser-output-name parser)
        book-filename)))
 
     (if (not book-filename)
        (ly:parser-output-name parser)
        book-filename)))
 

-(define (get-current-suffix parser)
+(define (get-current-suffix parser book)

   "return any suffix value for output filename allowing for settings by calls to
 bookoutput function"
   "return any suffix value for output filename allowing for settings by calls to
 bookoutput function"

-  (let ((book-output-suffix (ly:parser-lookup parser 'book-output-suffix)))
+  (let ((book-output-suffix (paper-variable parser book 'output-suffix)))

     (if (not (string? book-output-suffix))
        (ly:parser-lookup parser 'output-suffix)
        book-output-suffix)))
 
 (define-public current-outfile-name #f)  ; for use by regression tests
 
     (if (not (string? book-output-suffix))
        (ly:parser-lookup parser 'output-suffix)
        book-output-suffix)))
 
 (define-public current-outfile-name #f)  ; for use by regression tests
 

-(define (get-outfile-name parser)
+(define (get-outfile-name parser 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
   "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 parser))
-        (output-suffix (get-current-suffix parser))
+  (let* ((base-name (get-current-filename parser book))
+        (output-suffix (get-current-suffix parser book))

         (alist-key (format #f "~a~a" base-name output-suffix))
         (counter-alist (ly:parser-lookup parser 'counter-alist))
         (output-count (assoc-get alist-key counter-alist 0))
         (alist-key (format #f "~a~a" base-name output-suffix))
         (counter-alist (ly:parser-lookup parser 'counter-alist))
         (output-count (assoc-get alist-key counter-alist 0))


@@ -209,7 +209,7 @@ bookoutput function"
 (define (print-book-with parser book process-procedure)
   (let* ((paper (ly:parser-lookup parser '$defaultpaper))
         (layout (ly:parser-lookup parser '$defaultlayout))
 (define (print-book-with parser book process-procedure)
   (let* ((paper (ly:parser-lookup parser '$defaultpaper))
         (layout (ly:parser-lookup parser '$defaultlayout))

-        (outfile-name (get-outfile-name parser)))
+        (outfile-name (get-outfile-name parser book)))

     (process-procedure book paper layout outfile-name)))
 
 (define-public (print-book-with-defaults parser book)
     (process-procedure book paper layout outfile-name)))
 
 (define-public (print-book-with-defaults parser book)


@@ -230,6 +230,24 @@ bookoutput function"
       (else
           ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
 
       (else
           ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
 

+(define-public paper-variable
+  (let
+      ((get-papers
+       (lambda (parser book)
+         (append (if (and book (ly:output-def? (ly:book-paper book)))
+                     (list (ly:book-paper book))
+                     '())
+                 (ly:parser-lookup parser '$papers)
+                 (list (ly:parser-lookup parser '$defaultpaper))))))
+    (make-procedure-with-setter
+     (lambda (parser book symbol)
+       (any (lambda (p) (ly:output-def-lookup p symbol #f))
+           (get-papers parser book)))
+     (lambda (parser book symbol value)
+       (ly:output-def-set-variable!
+       (car (get-papers parser book))
+       symbol value)))))
+

 (define-public (add-text parser text)
   (add-score parser (list text)))
 
 (define-public (add-text parser text)
   (add-score parser (list text)))
 


@@ -239,6 +257,115 @@ bookoutput function"
                      parser
                     music))
 
                      parser
                     music))
 

+(define-public (context-mod-from-music parser music)
+  (let ((warn #t) (mods (ly:make-context-mod)))
+    (let loop ((m music) (context #f))
+      (if (music-is-of-type? m 'layout-instruction-event)
+         (let ((symbol (cons context (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)
+                      (ly:music-property m 'grob-property-path)))
+              ((RevertProperty)
+               (cons* 'pop
+                      symbol
+                      (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)
+                  (ly:music-property m 'context-type)))
+           (else
+            (let ((callback (ly:music-property m 'elements-callback)))
+              (if (procedure? callback)
+                  (fold loop context (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))))))))
+      context)
+    mods))
+
+(define-public (context-defs-from-music parser 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)
+                    (ly:music-property m 'grob-property-path)))
+            ((RevertProperty)
+             (cons* 'pop
+                    (ly:music-property m 'symbol)
+                    (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)))
+

 
 ;;;;;;;;;;;;;;;;
 ;; alist
 
 ;;;;;;;;;;;;;;;;
 ;; alist