1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2003--2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
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.
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.
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/>.
19 Internally markup is stored as lists, whose head is a function.
21 (FUNCTION ARG1 ARG2 ... )
23 When the markup is formatted, then FUNCTION is called as follows
25 (FUNCTION GROB PROPS ARG1 ARG2 ... )
27 GROB is the current grob, PROPS is a list of alists, and ARG1.. are
28 the rest of the arguments.
30 The function should return a stencil (i.e. a formatted, ready to
34 To add a markup command, use the define-markup-command utility.
36 (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
37 \"my command usage and description\"
40 The command is now available in markup mode, e.g.
42 \\markup { .... \\MYCOMMAND #1 argument ... }
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 ;;; markup definer utilities
49 ;; For documentation purposes
50 ;; category -> markup functions
51 (define-public markup-functions-by-category (make-hash-table 150))
52 ;; markup function -> used properties
53 (define-public markup-functions-properties (make-weak-key-hash-table 151))
54 ;; List of markup list functions
55 (define-public markup-list-functions (make-weak-key-hash-table 151))
57 (use-modules (ice-9 optargs))
59 (defmacro*-public define-markup-command
60 (command-and-args signature
61 #:key (category '()) (properties '())
64 * Define a COMMAND-markup function after command-and-args and body,
65 register COMMAND-markup and its signature,
67 * add COMMAND-markup to markup-functions-by-category,
69 * sets COMMAND-markup markup-signature object property,
71 * define a make-COMMAND-markup function.
74 (define-markup-command (COMMAND layout props . arguments)
76 [ #:properties properties ]
77 \"documentation string\"
81 `argument-types' is a list of type predicates for arguments
82 `properties' a list of (property default-value) lists
84 The specified properties are available as let-bound variables in the
85 command body, using the respective `default-value' as fallback in case
86 `property' is not found in `props'. `props' itself is left unchanged:
87 if you want defaults specified in that manner passed down into other
88 markup functions, you need to adjust `props' yourself.
90 The autogenerated documentation makes use of some optional
91 specifications that are otherwise ignored:
93 After `argument-types', you may also specify
94 [ #:category category ]
96 `category' is either a symbol or a symbol list specifying the
97 category for this markup command in the docs.
99 As an element of the `properties' list, you may directly use a
100 COMMANDx-markup symbol instead of a `(prop value)' list to indicate
101 that this markup command is called by the newly defined command,
102 adding its properties to the documented properties of the new
103 command. There is no protection against circular definitions.
105 (let* ((command (car command-and-args))
106 (args (cdr command-and-args))
107 (command-name (string->symbol (format #f "~a-markup" command)))
108 (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
109 (while (and (pair? body) (keyword? (car body)))
110 (set! body (cddr body)))
112 ;; define the COMMAND-markup function
113 ,(let* ((documentation (if (string? (car body))
116 (real-body (if (or (null? documentation)
119 `(define-public (,command-name ,@args)
121 (let ,(map (lambda (prop-spec)
122 (let ((prop (car prop-spec))
123 (default-value (if (null? (cdr prop-spec))
127 `(,prop (chain-assoc-get ',prop ,props ,default-value))))
128 (filter pair? properties))
130 (set! (markup-command-signature ,command-name) (list ,@signature))
131 ;; Register the new function, for markup documentation
132 ,@(map (lambda (category)
134 (or (hashq-ref markup-functions-by-category ',category)
135 (let ((hash (make-weak-key-hash-table 151)))
136 (hashq-set! markup-functions-by-category ',category
140 (if (list? category) category (list category)))
141 ;; Used properties, for markup documentation
142 (hashq-set! markup-functions-properties
144 (list ,@(map (lambda (prop-spec)
145 (cond ((symbol? prop-spec)
147 ((not (null? (cdr prop-spec)))
148 `(list ',(car prop-spec) ,(cadr prop-spec)))
150 `(list ',(car prop-spec)))))
154 ;; define the make-COMMAND-markup function
155 (define-public (,make-markup-name . args)
156 (let ((sig (list ,@signature)))
157 (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
159 (defmacro*-public define-markup-list-command
160 (command-and-args signature #:key (properties '()) #:rest body)
161 "Same as `define-markup-command', but defines a command that, when
162 interpreted, returns a list of stencils instead of a single one"
163 (let* ((command (car command-and-args))
164 (args (cdr command-and-args))
165 (command-name (string->symbol (format #f "~a-markup-list" command)))
166 (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
167 (while (and (pair? body) (keyword? (car body)))
168 (set! body (cddr body)))
170 ;; define the COMMAND-markup-list function
171 ,(let* ((documentation (if (string? (car body))
174 (real-body (if (or (null? documentation)
177 `(define-public (,command-name ,@args)
179 (let ,(map (lambda (prop-spec)
180 (let ((prop (car prop-spec))
181 (default-value (if (null? (cdr prop-spec))
185 `(,prop (chain-assoc-get ',prop ,props ,default-value))))
186 (filter pair? properties))
188 (set! (markup-command-signature ,command-name) (list ,@signature))
189 ;; add the command to markup-list-function-list, for markup documentation
190 (hashq-set! markup-list-functions ,command-name #t)
191 ;; Used properties, for markup documentation
192 (hashq-set! markup-functions-properties
194 (list ,@(map (lambda (prop-spec)
195 (cond ((symbol? prop-spec)
197 ((not (null? (cdr prop-spec)))
198 `(list ',(car prop-spec) ,(cadr prop-spec)))
200 `(list ',(car prop-spec)))))
204 ;; it's a markup-list command:
205 (set-object-property! ,command-name 'markup-list-command #t)
206 ;; define the make-COMMAND-markup-list function
207 (define-public (,make-markup-name . args)
208 (let ((sig (list ,@signature)))
209 (list (make-markup ,command-name
210 ,(symbol->string make-markup-name) sig args)))))))
212 (define-public (make-markup markup-function make-name signature args)
213 " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
214 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
216 (let* ((arglen (length args))
217 (siglen (length signature))
218 (error-msg (if (and (> siglen 0) (> arglen 0))
219 (markup-argument-list-error signature args 1)
221 (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
222 (ly:error (string-append make-name ": "
223 (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S"))
229 (_ "Invalid argument in position ~A. Expect: ~A, found: ~S."))
230 (car error-msg) (cadr error-msg)(caddr error-msg))
231 (cons markup-function args))))
233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
234 ;;; markup constructors
235 ;;; lilypond-like syntax for markup construction in scheme.
237 (use-modules (ice-9 receive))
239 (defmacro*-public markup (#:rest body)
240 "The `markup' macro provides a lilypond-like syntax for building markups.
242 - #:COMMAND is used instead of \\COMMAND
243 - #:line ( ... ) is used instead of \\line { ... }
248 \\raise #0.2 \\hbracket \\bold bar
249 \\override #'(baseline-skip . 4)
250 \\bracket \\column { baz bazr bla }
254 #:raise 0.2 #:hbracket #:bold \"bar\"
255 #:override '(baseline-skip . 4)
256 #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
257 Use `markup*' in a \\notemode context."
259 (car (compile-all-markup-expressions `(#:line ,body))))
261 (defmacro*-public markup* (#:rest body)
262 "Same as `markup', for use in a \\notes block."
263 `(ly:export (markup ,@body)))
266 (define (compile-all-markup-expressions expr)
267 "Return a list of canonical markups expressions, e.g.:
268 (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
270 ((make-COMMAND1-markup arg11 arg12)
271 (make-COMMAND2-markup arg21 arg22 arg23) ...)"
272 (do ((rest expr rest)
274 ((null? rest) (reverse markps))
275 (receive (m r) (compile-markup-expression rest)
276 (set! markps (cons m markps))
279 (define (keyword->make-markup key)
280 "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
281 (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
283 (define (compile-markup-expression expr)
284 "Return two values: the first complete canonical markup expression
285 found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...),
286 and the rest expression."
287 (cond ((and (pair? expr)
288 (keyword? (car expr)))
289 ;; expr === (#:COMMAND arg1 ...)
290 (let ((command (symbol->string (keyword->symbol (car expr)))))
291 (if (not (pair? (lookup-markup-command command)))
292 (ly:error (_ "Not a markup command: ~A") command))
293 (let* ((sig (markup-command-signature
294 (car (lookup-markup-command command))))
295 (sig-len (length sig)))
298 (rest (cdr expr) rest))
300 (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
301 (cond ((eqv? (list-ref sig i) markup-list?)
302 ;; (car rest) is a markup list
303 (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
304 (set! rest (cdr rest)))
306 ;; pick up one arg in `rest'
307 (receive (a r) (compile-markup-arg rest)
308 (set! args (cons a args))
312 (keyword? (caar expr)))
313 ;; expr === ((#:COMMAND arg1 ...) ...)
314 (receive (m r) (compile-markup-expression (car expr))
315 (values m (cdr expr))))
317 (string? (car expr))) ;; expr === ("string" ...)
318 (values `(make-simple-markup ,(car expr)) (cdr expr)))
320 ;; expr === (symbol ...) or ((funcall ...) ...)
324 (define (compile-all-markup-args expr)
325 "Transform `expr' into markup arguments"
326 (do ((rest expr rest)
328 ((null? rest) (reverse args))
329 (receive (a r) (compile-markup-arg rest)
330 (set! args (cons a args))
333 (define (compile-markup-arg expr)
334 "Return two values: the desired markup argument, and the rest arguments"
338 ((keyword? (car expr))
339 ;; expr === (#:COMMAND ...)
340 ;; ==> build and return the whole markup expression
341 (compile-markup-expression expr))
342 ((and (pair? (car expr))
343 (keyword? (caar expr)))
344 ;; expr === ((#:COMMAND ...) ...)
345 ;; ==> build and return the whole markup expression(s)
346 ;; found in (car expr)
347 (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
348 (if (null? rest-expr)
349 (values markup-expr (cdr expr))
350 (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
352 ((and (pair? (car expr))
354 ;; expr === (((foo ...) ...) ...)
355 (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
356 (else (values (car expr) (cdr expr)))))
359 ;;; Utilities for storing and accessing markup commands signature
362 ;;; (set! (markup-command-signature raise-markup) (list number? markup?))
363 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
365 ;;; (markup-command-signature raise-markup)
366 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
369 (define-public (markup-command-signature-ref markup-command)
370 "Return markup-command's signature (the 'markup-signature object property)"
371 (object-property markup-command 'markup-signature))
373 (define-public (markup-command-signature-set! markup-command signature)
374 "Set markup-command's signature (as object property)"
375 (set-object-property! markup-command 'markup-signature signature)
378 (define-public markup-command-signature
379 (make-procedure-with-setter markup-command-signature-ref
380 markup-command-signature-set!))
382 (define (lookup-markup-command-aux symbol)
383 (let ((proc (catch 'misc-error
385 (module-ref (current-module) symbol))
386 (lambda (key . args) #f))))
387 (and (procedure? proc) proc)))
389 (define-public (lookup-markup-command code)
390 (let ((proc (lookup-markup-command-aux
391 (string->symbol (format #f "~a-markup" code)))))
392 (and proc (markup-function? proc)
393 (cons proc (markup-command-signature proc)))))
395 (define-public (lookup-markup-list-command code)
396 (let ((proc (lookup-markup-command-aux
397 (string->symbol (format #f "~a-markup-list" code)))))
398 (and proc (markup-list-function? proc)
399 (cons proc (markup-command-signature proc)))))
401 ;;;;;;;;;;;;;;;;;;;;;;
402 ;;; used in parser.yy to map a list of markup commands on markup arguments
403 (define-public (map-markup-command-list commands markups)
404 "`markups' being a list of markups, eg (markup1 markup2 markup3),
405 and `commands' a list of commands with their scheme arguments, in reverse order,
406 eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
407 ((bold (raise 4 (italic markup1)))
408 (bold (raise 4 (italic markup2)))
409 (bold (raise 4 (italic markup3))))
411 (map-in-order (lambda (arg)
413 (for-each (lambda (cmd)
414 (set! result (append cmd (list result))))
419 ;;;;;;;;;;;;;;;;;;;;;;
420 ;;; markup type predicates
422 (define (markup-function? x)
423 (and (markup-command-signature x)
424 (not (object-property x 'markup-list-command))))
426 (define (markup-list-function? x)
427 (and (markup-command-signature x)
428 (object-property x 'markup-list-command)))
430 (define-public (markup-command-list? x)
431 "Determine if `x' is a markup command list, ie. a list composed of
432 a markup list function and its arguments."
433 (and (pair? x) (markup-list-function? (car x))))
435 (define-public (markup-list? arg)
436 "Return a true value if `x' is a list of markups or markup command lists."
437 (define (markup-list-inner? lst)
439 (and (or (markup? (car lst)) (markup-command-list? (car lst)))
440 (markup-list-inner? (cdr lst)))))
441 (not (not (and (list? arg) (markup-list-inner? arg)))))
443 (define (markup-argument-list? signature arguments)
444 "Typecheck argument list."
445 (if (and (pair? signature) (pair? arguments))
446 (and ((car signature) (car arguments))
447 (markup-argument-list? (cdr signature) (cdr arguments)))
448 (and (null? signature) (null? arguments))))
451 (define (markup-argument-list-error signature arguments number)
452 "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
453 #f is no error found.
455 (if (and (pair? signature) (pair? arguments))
456 (if (not ((car signature) (car arguments)))
457 (list number (type-name (car signature)) (car arguments))
458 (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
462 ;; full recursive typecheck.
464 (define (markup-typecheck? arg)
467 (markup-function? (car arg))
468 (markup-argument-list? (markup-command-signature (car arg))
475 (define (markup-thrower-typecheck arg)
476 "typecheck, and throw an error when something amiss.
478 Uncovered - cheap-markup? is used."
480 (cond ((string? arg) #t)
482 (throw 'markup-format "Not a pair" arg))
483 ((not (markup-function? (car arg)))
484 (throw 'markup-format "Not a markup function " (car arg)))
485 ((not (markup-argument-list? (markup-command-signature (car arg))
487 (throw 'markup-format "Arguments failed typecheck for " arg)))
491 ;; good enough if you only use make-XXX-markup functions.
493 (define (cheap-markup? x)
496 (markup-function? (car x)))))
499 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
501 (define-public markup? cheap-markup?)
505 (define (markup-join markups sep)
506 "Return line-markup of MARKUPS, joining them with markup SEP"
508 (make-line-markup (list-insert-separator markups sep))
512 (define-public interpret-markup ly:text-interface::interpret-markup)
514 (define-public (interpret-markup-list layout props markup-list)
515 (let ((stencils (list)))
516 (for-each (lambda (m)
518 (if (markup-command-list? m)
519 (append! (reverse! (apply (car m) layout props (cdr m)))
521 (cons (interpret-markup layout props m) stencils))))
523 (reverse! stencils)))
525 (define-public (prepend-alist-chain key val chain)
526 (cons (acons key val (car chain)) (cdr chain)))
528 (define-public (stack-stencil-line space stencils)
530 (if (and (pair? stencils)
531 (ly:stencil? (car stencils)))
533 (if (and (pair? (cdr stencils))
534 (ly:stencil? (cadr stencils)))
535 (let* ((tail (stack-stencil-line space (cdr stencils)))
536 (head (car stencils))
537 (xoff (+ space (cdr (ly:stencil-extent head X)))))
539 (ly:stencil-translate-axis tail xoff X)))
541 (ly:make-stencil '() '(0 . 0) '(0 . 0))))