scm/ly-syntax-constructors.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2006--2015 Erik Sandberg <mandolaerik@gmail.com>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (define ly-syntax-module (resolve-module '(ly-syntax)))
  19
  20 (defmacro define-ly-syntax (args . body)
  21   (if (pair? args)
  22       `(module-define! ,ly-syntax-module ',(car args)
  23                        (lambda ,(cdr args) ,@body))
  24       `(module-define! ,ly-syntax-module ',args ,@body)))
  25
  26 ;; A ly-syntax constructor can access location data as (*location*).
  27 ;; This is mainly used for reporting errors and warnings. This
  28 ;; function is a syntactic sugar which uses (*location*) to set the
  29 ;; origin of the returned music object; this behaviour is usually
  30 ;; desired.
  31 (defmacro define-ly-syntax-loc (args . body)
  32   `(define-ly-syntax ,args
  33      (let ((m ,(cons 'begin body)))
  34        (set! (ly:music-property m 'origin) (*location*))
  35        m)))
  36
  37 (define (music-function-call-error fun m)
  38   (let* ((sig (ly:music-function-signature fun))
  39          (pred (if (pair? (car sig)) (caar sig) (car sig))))
  40     (ly:parser-error
  41      (format #f (_ "~a function cannot return ~a")
  42              (type-name pred)
  43              (value->lily-string m))
  44      (*location*))
  45     (and (pair? (car sig)) (cdar sig))))
  46
  47 (define-ly-syntax music-function-call-error music-function-call-error)
  48
  49 ;; Music function: Apply function and check return value.
  50 ;; args are in reverse order, rest may specify additional ones
  51 ;;
  52 ;; If args is not a proper list, an error has been flagged earlier
  53 ;; and no fallback value had been available.  In this case,
  54 ;; we don't call the function but rather return the general
  55 ;; fallback.
  56 (define-ly-syntax (music-function fun args . rest)
  57   (let* ((sig (ly:music-function-signature fun))
  58          (pred (if (pair? (car sig)) (caar sig) (car sig)))
  59          (good (proper-list? args))
  60          (m (and good (apply (ly:music-function-extract fun)
  61                              (reverse! args rest)))))
  62     (if (and good (pred m))
  63         (begin
  64           (if (ly:music? m)
  65               (set! (ly:music-property m 'origin) (*location*)))
  66           m)
  67         (if good
  68             (music-function-call-error fun m)
  69             (and (pair? (car sig)) (cdar sig))))))
  70
  71 (define-ly-syntax (argument-error n pred arg)
  72   (ly:parser-error
  73    (format #f
  74            (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
  75            n (type-name pred) (music->make-music arg))
  76    (*location*)))
  77
  78 (define-ly-syntax-loc (void-music)
  79   (make-music 'Music))
  80
  81 (define-ly-syntax-loc (sequential-music mlist)
  82   (make-sequential-music mlist))
  83
  84 (define-ly-syntax-loc (simultaneous-music mlist)
  85   (make-simultaneous-music mlist))
  86
  87 (define-ly-syntax-loc (event-chord mlist)
  88   (make-music 'EventChord
  89               'elements mlist))
  90
  91 (define-ly-syntax-loc (unrelativable-music mus)
  92   (make-music 'UnrelativableMusic
  93               'element mus))
  94
  95 (define-ly-syntax-loc (context-change type id)
  96   (make-music 'ContextChange
  97               'change-to-type type
  98               'change-to-id id))
  99
 100 (define-ly-syntax (tempo text . rest)
 101   (let* ((unit (and (pair? rest)
 102                     (car rest)))
 103          (count (and unit
 104                      (cadr rest)))
 105          (range-tempo? (pair? count))
 106          (tempo-change (make-music 'TempoChangeEvent
 107                                    'origin (*location*)
 108                                    'text text
 109                                    'tempo-unit unit
 110                                    'metronome-count count))
 111          (tempo-set
 112           (and unit
 113                (context-spec-music
 114                 (make-property-set 'tempoWholesPerMinute
 115                                    (ly:moment-mul
 116                                     (ly:make-moment
 117                                      (if range-tempo?
 118                                          (round (/ (+ (car count) (cdr count))
 119                                                    2))
 120                                          count)
 121                                      1)
 122                                     (ly:duration-length unit)))
 123                 'Score))))
 124
 125     (if tempo-set
 126         (make-sequential-music (list tempo-change tempo-set))
 127         tempo-change)))
 128
 129 (define-ly-syntax-loc (repeat type num body alts)
 130   (make-repeat type num body alts))
 131
 132 (define (script-to-mmrest-text music)
 133   "Extract @code{'direction} and @code{'text} from @var{music}, and transform
 134 into a @code{MultiMeasureTextEvent}."
 135
 136   (if (music-is-of-type? music 'script-event)
 137       (make-music 'MultiMeasureTextEvent music)
 138       music))
 139
 140 (define-ly-syntax-loc (multi-measure-rest duration articulations)
 141   (make-music 'MultiMeasureRestMusic
 142               'articulations (map script-to-mmrest-text articulations)
 143               'duration duration))
 144
 145 (define-ly-syntax-loc (repetition-chord duration articulations)
 146   (make-music 'EventChord
 147               'duration duration
 148               'elements articulations))
 149
 150 (define-ly-syntax-loc (context-specification type id ops create-new mus)
 151   (let ((csm (context-spec-music mus type id)))
 152     (set! (ly:music-property csm 'property-operations) ops)
 153     (if create-new (set! (ly:music-property csm 'create-new) #t))
 154     csm))
 155
 156 (define-ly-syntax (composed-markup-list commands markups)
 157   ;; `markups' being a list of markups, eg (markup1 markup2 markup3),
 158   ;; and `commands' a list of commands with their scheme arguments, in reverse order,
 159   ;; eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 160   ;;  ((bold (raise 4 (italic markup1)))
 161   ;;   (bold (raise 4 (italic markup2)))
 162   ;;   (bold (raise 4 (italic markup3))))
 163
 164   (define (compose arg)
 165     (fold
 166      (lambda (cmd prev) (append cmd (list prev)))
 167      arg
 168      commands))
 169   (let loop ((markups markups) (completed '()))
 170     (cond ((null? markups) (reverse! completed))
 171           ((markup? (car markups))
 172            (loop (cdr markups)
 173                  (cons (compose (car markups)) completed)))
 174           (else
 175            (call-with-values
 176                (lambda () (break! markup? markups))
 177              (lambda (complex rest)
 178                (loop rest
 179                      (reverse!
 180                       (make-map-markup-commands-markup-list
 181                        compose complex) completed))))))))
 182
 183 (define-ly-syntax (property-operation ctx music-type symbol . args)
 184   (let* ((props (case music-type
 185                   ((PropertySet) (list 'value (car args)))
 186                   ((PropertyUnset) '())
 187                   ((OverrideProperty) (list 'grob-value (car args)
 188                                             'grob-property-path (if (list? (cadr args))
 189                                                                     (cadr args)
 190                                                                     (cdr args))
 191                                             'pop-first #t))
 192                   ((RevertProperty)
 193                    (if (list? (car args))
 194                        (list 'grob-property-path (car args))
 195                        (list 'grob-property-path args)))
 196                   (else (ly:error (_ "Invalid property operation ~a") music-type))))
 197          (m (apply make-music music-type
 198                    'symbol symbol
 199                    'origin (*location*)
 200                    props)))
 201     (make-music 'ContextSpeccedMusic
 202                 'element m
 203                 'context-type ctx
 204                 'origin (*location*))))
 205
 206 (define (get-first-context-id! mus)
 207   "Find the name of a ContextSpeccedMusic, possibly naming it"
 208   (let ((id (ly:music-property mus 'context-id)))
 209     (if (eq? (ly:music-property mus 'name) 'ContextSpeccedMusic)
 210         (if (and (string? id)
 211                  (not (string-null? id)))
 212             id
 213             ;; We may reliably give a new context a unique name, but
 214             ;; not an existing one
 215             (if (ly:music-property mus 'create-new #f)
 216                 (let ((id (get-next-unique-voice-name)))
 217                   (set! (ly:music-property mus 'context-id) id)
 218                   id)
 219                 '()))
 220         '())))
 221
 222 (define unique-counter -1)
 223 (define (get-next-unique-voice-name)
 224   (set! unique-counter (1+ unique-counter))
 225   (call-with-output-string (lambda (p) (format p "uniqueContext~s" unique-counter))))
 226
 227 (define-ly-syntax-loc (lyric-event text duration)
 228   (make-lyric-event text duration))
 229
 230 (define (lyric-combine-music sync sync-type music loc)
 231   ;; CompletizeExtenderEvent is added following the last lyric in MUSIC
 232   ;; to signal to the Extender_engraver that any pending extender should
 233   ;; be completed if the lyrics end before the associated voice.
 234   (append! (ly:music-property music 'elements)
 235            (list (make-music 'CompletizeExtenderEvent)))
 236   (make-music 'LyricCombineMusic
 237               'element music
 238               'associated-context sync
 239               'associated-context-type sync-type
 240               'origin loc))
 241
 242 (define-ly-syntax (lyric-combine voice typ music)
 243   (lyric-combine-music voice typ music (*location*)))
 244
 245 (define-ly-syntax (add-lyrics music addlyrics-list)
 246   (let* ((existing-voice-name (get-first-context-id! music))
 247          (voice-name (if (string? existing-voice-name)
 248                          existing-voice-name
 249                          (get-next-unique-voice-name)))
 250          (voice (if (string? existing-voice-name)
 251                     music
 252                     (make-music 'ContextSpeccedMusic
 253                                 'element music
 254                                 'context-type 'Voice
 255                                 'context-id voice-name
 256                                 'origin (ly:music-property music 'origin))))
 257          (voice-type (ly:music-property voice 'context-type))
 258          (lyricstos (map (lambda (mus)
 259                            (let* ((loc (ly:music-property mus 'origin))
 260                                   (lyr (lyric-combine-music
 261                                         voice-name voice-type mus loc)))
 262                              (make-music 'ContextSpeccedMusic
 263                                          'create-new #t
 264                                          'context-type 'Lyrics
 265                                          'element lyr
 266                                          'origin loc)))
 267                          addlyrics-list)))
 268     (make-simultaneous-music (cons voice lyricstos))))