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