X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fly-syntax-constructors.scm;h=0a12672095701cf1844cef2ba881010afe2be0de;hb=HEAD;hp=ccf24e0abf74130519a39adaff1a65098b2eeaf5;hpb=812de25cf07823766143b7407bade88b5bb5e13f;p=lilypond.git diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm index ccf24e0abf..0a12672095 100644 --- a/scm/ly-syntax-constructors.scm +++ b/scm/ly-syntax-constructors.scm @@ -50,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)))))) @@ -63,22 +63,23 @@ ;; Used for chaining several music functions together. `final' ;; contains the last argument and still needs typechecking. -(define (music-function-chain fun args final) - (let* ((siglast (last (ly:music-function-signature fun))) +(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 args)) + (music-function fun (cons final (cdr call))) (begin - (argument-error (1+ (length args)) pred? final) + (argument-error (length call) pred? final) ;; call music function just for the error return value (music-function fun #f))))) -(define-public (partial-music-function fun-list arg-list) - (let* ((good (every list? arg-list)) - (sig (ly:music-function-signature (car fun-list)))) +(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 (car arg-list)))) + (cons (car sig) (list-tail sig (length (car call-list)))) (lambda rest ;; Every time we use music-function, it destructively ;; reverses its list of arguments. Changing the calling @@ -89,11 +90,11 @@ ;; 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 ((arg-list (ly:music-deep-copy arg-list (*location*)))) + (let ((call-list (ly:music-deep-copy call-list (*location*)))) (fold music-function-chain - (music-function (car fun-list) - (reverse! rest (car arg-list))) - (cdr fun-list) (cdr arg-list)))))))) + (music-function (caar call-list) + (reverse! rest (cdar call-list))) + (cdr call-list)))))))) (define-public (void-music) (ly:set-origin! (make-music 'Music))) @@ -202,36 +203,70 @@ into a @code{MultiMeasureTextEvent}." (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 arg) + (define (compose rest) (fold (lambda (cmd prev) (append cmd (list prev))) - arg - commands)) - (let ((chain (lambda (layout props arg) - (interpret-markup layout props (compose arg))))) - (set-object-property! chain 'markup-signature (list markup?)) + (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-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 (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" @@ -278,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))))