X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fly-syntax-constructors.scm;h=0a12672095701cf1844cef2ba881010afe2be0de;hb=90e4d7057f3857da049dfda3d130017d4719bd6b;hp=c595755e5a96c7628196c8f584f03f69f3de7a47;hpb=8499cabe34365c7160ff32f777d3db428b8f8200;p=lilypond.git diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm index c595755e5a..0a12672095 100644 --- a/scm/ly-syntax-constructors.scm +++ b/scm/ly-syntax-constructors.scm @@ -17,41 +17,42 @@ (define-module (scm ly-syntax-constructors) #:use-module (lily) - #:use-module (srfi srfi-1)) - -;; Sets music origin to (*location*) -(define (here! m) - (set! (ly:music-property m 'origin) (*location*)) - m) + #:use-module (srfi srfi-1) + #:use-module (scm display-lily)) (define-public (music-function-call-error fun m) - (let* ((sig (ly:music-function-signature fun)) - (pred (if (pair? (car sig)) (caar sig) (car sig)))) + (let* ((sigcar (car (ly:music-function-signature fun))) + (pred? (if (pair? sigcar) (car sigcar) sigcar))) (ly:parser-error (format #f (_ "~a function cannot return ~a") - (type-name pred) + (type-name pred?) (value->lily-string m)) (*location*)) - (and (pair? (car sig)) (cdar sig)))) + (and (pair? sigcar) + (if (ly:music? (cdr sigcar)) + (ly:music-deep-copy (cdr sigcar) (*location*)) + (cdr sigcar))))) ;; Music function: Apply function and check return value. -;; args are in reverse order, rest may specify additional ones +;; args are in reverse order. ;; ;; If args is not a proper list, an error has been flagged earlier ;; and no fallback value had been available. In this case, ;; we don't call the function but rather return the general ;; fallback. -(define-public (music-function fun args . rest) - (let* ((sig (ly:music-function-signature fun)) - (pred (if (pair? (car sig)) (caar sig) (car sig))) - (good (proper-list? args)) - (m (and good (apply (ly:music-function-extract fun) - (reverse! args rest))))) - (if (and good (pred m)) - (if (ly:music? m) (here! m) m) - (if good - (music-function-call-error fun m) - (and (pair? (car sig)) (cdar sig)))))) +(define-public (music-function fun args) + (let* ((sigcar (car (ly:music-function-signature fun))) + (pred? (if (pair? sigcar) (car sigcar) sigcar)) + (good (list? args)) + (m (and good (apply (ly:music-function-extract fun) (reverse! args))))) + (if good + (if (pred? m) + (if (ly:music? m) (ly:set-origin! m) m) + (music-function-call-error fun m)) + (and (pair? sigcar) + (if (ly:music? (cdr sigcar)) + (ly:music-deep-copy (cdr sigcar) (*location*)) + (cdr sigcar)))))) (define-public (argument-error n pred arg) (ly:parser-error @@ -60,27 +61,62 @@ n (type-name pred) (music->make-music arg)) (*location*))) +;; 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 sig (length (car call-list)))) + (lambda 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) - (here! (make-music 'Music))) + (ly:set-origin! (make-music 'Music))) (define-public (sequential-music mlist) - (here! (make-sequential-music mlist))) + (ly:set-origin! (make-sequential-music mlist))) (define-public (simultaneous-music mlist) - (here! (make-simultaneous-music mlist))) + (ly:set-origin! (make-simultaneous-music mlist))) (define-public (event-chord mlist) - (here! (make-music 'EventChord - 'elements mlist))) + (ly:set-origin! (make-music 'EventChord + 'elements mlist))) (define-public (unrelativable-music mus) - (here! (make-music 'UnrelativableMusic - 'element mus))) + (ly:set-origin! (make-music 'UnrelativableMusic + 'element mus))) (define-public (context-change type id) - (here! (make-music 'ContextChange - 'change-to-type type - 'change-to-id id))) + (ly:set-origin! (make-music 'ContextChange + 'change-to-type type + 'change-to-id id))) (define-public (tempo text . rest) (let* ((unit (and (pair? rest) @@ -88,10 +124,10 @@ (count (and unit (cadr rest))) (range-tempo? (pair? count)) - (tempo-change (here! (make-music 'TempoChangeEvent - 'text text - 'tempo-unit unit - 'metronome-count count))) + (tempo-change (ly:set-origin! (make-music 'TempoChangeEvent + 'text text + 'tempo-unit unit + 'metronome-count count))) (tempo-set (and unit (context-spec-music @@ -111,7 +147,7 @@ tempo-change))) (define-public (repeat type num body alts) - (here! (make-repeat type num body alts))) + (ly:set-origin! (make-repeat type num body alts))) (define (script-to-mmrest-text music) "Extract @code{'direction} and @code{'text} from @var{music}, and transform @@ -122,20 +158,20 @@ into a @code{MultiMeasureTextEvent}." music)) (define-public (multi-measure-rest duration articulations) - (here! (make-music 'MultiMeasureRestMusic - 'articulations (map script-to-mmrest-text articulations) - 'duration duration))) + (ly:set-origin! (make-music 'MultiMeasureRestMusic + 'articulations (map script-to-mmrest-text articulations) + 'duration duration))) (define-public (repetition-chord duration articulations) - (here! (make-music 'EventChord - 'duration duration - 'elements articulations))) + (ly:set-origin! (make-music 'EventChord + 'duration duration + 'elements articulations))) (define-public (context-specification type id ops create-new mus) (let ((csm (context-spec-music mus type id))) (set! (ly:music-property csm 'property-operations) ops) (if create-new (set! (ly:music-property csm 'create-new) #t)) - (here! csm))) + (ly:set-origin! csm))) (define-public (composed-markup-list commands markups) ;; `markups' being a list of markups, eg (markup1 markup2 markup3), @@ -164,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 (here! (apply make-music music-type - 'symbol symbol - props)))) - (here! (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" @@ -202,7 +285,7 @@ into a @code{MultiMeasureTextEvent}." '()))) (define-public (lyric-event text duration) - (here! (make-lyric-event text duration))) + (ly:set-origin! (make-lyric-event text duration))) (define-public (lyric-combine sync sync-type music) ;; CompletizeExtenderEvent is added following the last lyric in MUSIC @@ -210,7 +293,7 @@ into a @code{MultiMeasureTextEvent}." ;; be completed if the lyrics end before the associated voice. (append! (ly:music-property music 'elements) (list (make-music 'CompletizeExtenderEvent))) - (here! + (ly:set-origin! (make-music 'LyricCombineMusic 'element music 'associated-context sync @@ -230,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) - (here! (make-music 'ContextSpeccedMusic - 'create-new #t - 'context-type 'Lyrics - 'element - (lyric-combine - voice-name voice-type mus))))) + (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 + (car mus+mods)))))) addlyrics-list))) (make-simultaneous-music (cons voice lyricstos))))