X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fly-syntax-constructors.scm;h=0a12672095701cf1844cef2ba881010afe2be0de;hb=6676553f94d1224a9956a43b4b5a3e4777bb47ce;hp=b53e0cb34e0a2bb479847e51ca553b5f5cabafb8;hpb=61c40c765eea03bc1029b596a2d31ab70f26d82c;p=lilypond.git diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm index b53e0cb34e..0a12672095 100644 --- a/scm/ly-syntax-constructors.scm +++ b/scm/ly-syntax-constructors.scm @@ -17,7 +17,8 @@ (define-module (scm ly-syntax-constructors) #:use-module (lily) - #:use-module (srfi srfi-1)) + #:use-module (srfi srfi-1) + #:use-module (scm display-lily)) (define-public (music-function-call-error fun m) (let* ((sigcar (car (ly:music-function-signature fun))) @@ -49,7 +50,7 @@ (if (ly:music? m) (ly:set-origin! m) m) (music-function-call-error fun m)) (and (pair? sigcar) - (if (ly:music (cdr sigcar)) + (if (ly:music? (cdr sigcar)) (ly:music-deep-copy (cdr sigcar) (*location*)) (cdr sigcar)))))) @@ -60,15 +61,40 @@ n (type-name pred) (music->make-music arg)) (*location*))) -(define-public (partial-music-function fun args) - (let* ((sig (ly:music-function-signature fun)) - (args (and (list args) (reverse! args)))) - (and args +;; Used for chaining several music functions together. `final' +;; contains the last argument and still needs typechecking. +(define (music-function-chain call final) + (let* ((fun (car call)) + (siglast (last (ly:music-function-signature fun))) + (pred? (if (pair? siglast) (car siglast) siglast))) + (if (pred? final) + (music-function fun (cons final (cdr call))) + (begin + (argument-error (length call) pred? final) + ;; call music function just for the error return value + (music-function fun #f))))) + +(define-public (partial-music-function call-list) + (let* ((good (every list? call-list)) + (sig (ly:music-function-signature (caar call-list)))) + (and good (ly:make-music-function - (cons (car sig) (list-tail (cdr sig) (length args))) + (cons (car sig) (list-tail sig (length (car call-list)))) (lambda rest - (apply (ly:music-function-extract fun) - (append args rest))))))) + ;; Every time we use music-function, it destructively + ;; reverses its list of arguments. Changing the calling + ;; convention would be non-trivial since we do error + ;; propagation to the reversed argument list by making it + ;; a non-proper list. So we just create a fresh copy of + ;; all argument lists for each call. We also want to + ;; avoid reusing any music expressions without copying and + ;; want to let them point to the location of the music + ;; function call rather than its definition. + (let ((call-list (ly:music-deep-copy call-list (*location*)))) + (fold music-function-chain + (music-function (caar call-list) + (reverse! rest (cdar call-list))) + (cdr call-list)))))))) (define-public (void-music) (ly:set-origin! (make-music 'Music))) @@ -174,26 +200,73 @@ into a @code{MultiMeasureTextEvent}." (make-map-markup-commands-markup-list compose complex) completed)))))))) -(define-public (property-operation ctx music-type symbol . args) - (let* ((props (case music-type - ((PropertySet) (list 'value (car args))) - ((PropertyUnset) '()) - ((OverrideProperty) (list 'grob-value (car args) - 'grob-property-path (if (list? (cadr args)) - (cadr args) - (cdr args)) - 'pop-first #t)) - ((RevertProperty) - (if (list? (car args)) - (list 'grob-property-path (car args)) - (list 'grob-property-path args))) - (else (ly:error (_ "Invalid property operation ~a") music-type)))) - (m (ly:set-origin! (apply make-music music-type - 'symbol symbol - props)))) - (ly:set-origin! (make-music 'ContextSpeccedMusic - 'element m - 'context-type ctx)))) +(define-public (partial-markup commands) + ;; Like composed-markup-list, except that the result is a single + ;; markup command that can be applied to one markup + (define (compose rest) + (fold + (lambda (cmd prev) (append cmd (list prev))) + (append (car commands) rest) + (cdr commands))) + (let ((chain (lambda (layout props . rest) + (interpret-markup layout props (compose rest))))) + (set! (markup-command-signature chain) + (list-tail + (markup-command-signature (caar commands)) + (length (cdar commands)))) + chain)) + +(define-public (property-set context property value) + (ly:set-origin! (context-spec-music + (ly:set-origin! + (make-music 'PropertySet + 'symbol property + 'value value)) + context))) + +(define-public (property-unset context property) + (ly:set-origin! (context-spec-music + (ly:set-origin! + (make-music 'PropertyUnset + 'symbol property)) + context))) + +(define-public (property-override context path value) + (ly:set-origin! (context-spec-music + (ly:set-origin! + (make-music 'OverrideProperty + 'symbol (car path) + 'grob-property-path (cdr path) + 'grob-value value + 'pop-first #t)) + context))) + +(define-public (property-revert context path) + (ly:set-origin! (context-spec-music + (ly:set-origin! + (make-music 'RevertProperty + 'symbol (car path) + 'grob-property-path (cdr path))) + context))) + +;; The signature here is slightly fishy since the "fallback return +;; value" is not actually music but #f. This used to be (void-music) +;; but triggered "Parsed object should be dead" warnings for music +;; objects outside of the current parser session/module. The called +;; functions always deliver music and are used from the parser in a +;; manner where only the last argument is provided from outside the +;; parser, and its predicate "scheme?" is always true. So the +;; fallback value will never get used and its improper type is no +;; issue. +(define-public property-override-function + (ly:make-music-function + (list (cons ly:music? #f) symbol? symbol-list? scheme?) + property-override)) + +(define-public property-set-function + (ly:make-music-function + (list (cons ly:music? #f) symbol? symbol? scheme?) + property-set)) (define (get-first-context-id! mus) "Find the name of a ContextSpeccedMusic, possibly naming it" @@ -240,14 +313,16 @@ into a @code{MultiMeasureTextEvent}." 'origin (ly:music-property music 'origin)))) (voice-type (ly:music-property voice 'context-type)) (lyricstos (map - (lambda (mus) + (lambda (mus+mods) (with-location - (ly:music-property mus 'origin) + (ly:music-property (car mus+mods) 'origin) (ly:set-origin! (make-music 'ContextSpeccedMusic 'create-new #t 'context-type 'Lyrics + 'property-operations (cdr mus+mods) 'element (lyric-combine - voice-name voice-type mus))))) + voice-name voice-type + (car mus+mods)))))) addlyrics-list))) (make-simultaneous-music (cons voice lyricstos))))