X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fly-syntax-constructors.scm;h=56322ff919823a198ec2a2bcfb1fa0ce2cc7c6dd;hb=9f3572d98bb948c9689cd1f75401a029451fa001;hp=23befc939e7b0605b556e465f4afed901cde5936;hpb=04265f11d1f21416ccebd2dcaa1d903dc781b36e;p=lilypond.git diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm index 23befc939e..56322ff919 100644 --- a/scm/ly-syntax-constructors.scm +++ b/scm/ly-syntax-constructors.scm @@ -4,186 +4,22 @@ ;;;; ;;;; (c) 2006 Erik Sandberg -;; TODO: use separate module for syntax -;; constructors. Also create wrapper around the constructor? +;; TODO: use separate module for parser. (define define-ly-syntax define-public) -;; A ly-syntax constructor takes two extra parameters, parser and -;; location. These are mainly used for reporting errors and -;; warnings. This function is a syntactic sugar which uses the -;; location arg to set the origin of the returned music object; this -;; behaviour is usually desired +;; This shorthand adds a location parameter, and uses it to set the +;; origin. It can be used for most music functions. (defmacro define-ly-syntax-loc (args . body) - (primitive-eval `(define-ly-syntax ,args - (let ((m ,(cons 'begin body))) - (set! (ly:music-property m 'origin) ,(third args)) - m)))) - -;; Like define-ly-syntax-loc, but adds parser and location -;; parameters. Useful for simple constructors that don't need to -;; report errors. -(defmacro define-ly-syntax-simple (args . body) - (primitive-eval `(define-ly-syntax ,(cons* (car args) - 'parser - 'location - (cdr args)) - (let ((m ,(cons 'begin body))) + (primitive-eval `(define-ly-syntax ,(cons* (car args) 'location (cdr args)) + (let ((m ((lambda ,(cdr args) . ,body) . ,(cdr args)))) (set! (ly:music-property m 'origin) location) m)))) -;; Music function: Apply function and check return value. -(define-ly-syntax-loc (music-function parser loc fun args) - (let ((m (apply fun (cons* parser loc args)))) - (if (ly:music? m) - m - (begin - (ly:parser-error parser (_ "Music head function must return Music object") loc) - (make-music 'Music))))) - -(define-ly-syntax-simple (void-music) - (make-music 'Music)) - -(define-ly-syntax-simple (sequential-music mlist) +(define-ly-syntax-loc (sequential-music mlist) (make-sequential-music mlist)) -(define-ly-syntax-simple (simultaneous-music mlist) +(define-ly-syntax-loc (simultaneous-music mlist) (make-simultaneous-music mlist)) -(define-ly-syntax-simple (event-chord mlist) - (make-music 'EventChord - 'elements mlist)) - -(define-ly-syntax-simple (unrelativable-music mus) - (make-music 'UnrelativableMusic - 'element mus)) - -(define-ly-syntax-simple (context-change type id) - (make-music 'ContextChange - 'change-to-type type - 'change-to-id id)) - -(define-ly-syntax-simple (voice-separator) - (make-music 'VoiceSeparator)) - -(define-ly-syntax-simple (bar-check) - (make-music 'BarCheck)) - -(define-ly-syntax-simple (time-scaled-music fraction music) - (make-music 'TimeScaledMusic - 'element (ly:music-compress music (ly:make-moment (car fraction) (cdr fraction))) - 'numerator (car fraction) - 'denominator (cdr fraction))) - -(define-ly-syntax-simple (transpose-music pitch music) - (make-music 'TransposedMusic - 'element (ly:music-transpose music pitch))) - -(define-ly-syntax-simple (tempo duration tempo) - (context-spec-music - (make-sequential-music - (list - (make-property-set 'tempoWholesPerMinute - (ly:moment-mul (ly:make-moment tempo 1) - (ly:duration-length duration))) - (make-property-set 'tempoUnitDuration duration) - (make-property-set 'tempoUnitCount tempo))) - 'Score)) - -(define-ly-syntax-simple (skip-music dur) - (make-music 'SkipMusic - 'duration dur)) - -(define-ly-syntax-simple (repeat type num body alts) +(define-ly-syntax-loc (repeat type num body alts) (make-repeat type num body alts)) - -(define (script-to-mmrest-text music) - "Extract 'direction and 'text from SCRIPT-MUSIC, and transform MultiMeasureTextEvent" - (if (memq 'script-event (ly:music-property music 'types)) - - (let ((dir (ly:music-property music 'direction)) - (p (make-music 'MultiMeasureTextEvent - 'text (ly:music-property music 'text)))) - (if (ly:dir? dir) - (set! (ly:music-property p 'direction) dir)) - p) - music)) - -(define-ly-syntax (multi-measure-rest parser location duration articulations) - (make-music 'MultiMeasureRestMusic - 'articulations (map script-to-mmrest-text articulations) - 'duration duration - 'origin location)) - -(define-ly-syntax-simple (context-specification type id mus ops create-new) - (let* ((type-sym (if (symbol? type) type (string->symbol type))) - (csm (context-spec-music mus type-sym id))) - (set! (ly:music-property csm 'property-operations) ops) - (if create-new (set! (ly:music-property csm 'create-new) #t)) - csm)) - -(define-ly-syntax (property-operation parser location once 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 (cdr args) - 'pop-first #t)) - ((RevertProperty) (list 'grob-property-path args)) - (else (ly:error (_ "Invalid property operation ~a") music-type)))) - (oprops (if once (cons* 'once once props) props)) - (m (apply make-music music-type - 'symbol symbol - 'origin location - oprops))) - (make-music 'ContextSpeccedMusic - 'element m - 'context-type ctx - 'origin location))) - -;; TODO: It seems that this function rarely returns anything useful. -(define (get-first-context-id type mus) - "Find the name of a ContextSpeccedMusic with given type" - (let ((id (ly:music-property mus 'context-id))) - (if (and (eq? (ly:music-property mus 'type) 'ContextSpeccedMusic) - (eq? (ly:music-property mus 'context-type) type) - (string? id) - (not (string-null? id))) - id - '()))) - -(define unique-counter -1) -(define (get-next-unique-voice-name) - (set! unique-counter (1+ unique-counter)) - (call-with-output-string (lambda (p) (format p "uniqueContext~s" unique-counter)))) - -(define (lyric-combine-music sync music loc) - (make-music 'LyricCombineMusic - 'element music - 'associated-context sync - 'origin loc)) - -(define-ly-syntax (lyric-combine parser location voice music) - (lyric-combine-music voice music location)) - -(define-ly-syntax (add-lyrics parser location music addlyrics-list) - (let* ((existing-voice-name (get-first-context-id 'Voice music)) - (voice-name (if (string? existing-voice-name) - existing-voice-name - (get-next-unique-voice-name))) - (voice (if (string? existing-voice-name) - (music) - (make-music 'ContextSpeccedMusic - 'element music - 'context-type 'Voice - 'context-id voice-name - 'origin (ly:music-property music 'origin)))) - (lyricstos (map (lambda (mus) - (let* ((loc (ly:music-property mus 'origin)) - (lyr (lyric-combine-music voice-name mus loc))) - (make-music 'ContextSpeccedMusic - 'create-new #t - 'context-type 'Lyrics - 'element lyr - 'origin loc))) - addlyrics-list))) - (make-simultaneous-music (cons voice lyricstos))))