scm/markup.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2011 Han-Wen Nienhuys <hanwen@xs4all.nl>
   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 "
  19 Internally markup is stored as lists, whose head is a function.
  20
  21   (FUNCTION ARG1 ARG2 ... )
  22
  23 When the markup is formatted, then FUNCTION is called as follows
  24
  25   (FUNCTION GROB PROPS ARG1 ARG2 ... )
  26
  27 GROB is the current grob, PROPS is a list of alists, and ARG1.. are
  28 the rest of the arguments.
  29
  30 The function should return a stencil (i.e. a formatted, ready to
  31 print object).
  32
  33
  34 To add a markup command, use the define-markup-command utility.
  35
  36   (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
  37     \"my command usage and description\"
  38     ...function body...)
  39
  40 The command is now available in markup mode, e.g.
  41
  42   \\markup { .... \\MYCOMMAND #1 argument ... }
  43
  44 " ; "
  45
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47 ;;; markup definer utilities
  48
  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))
  56
  57 (use-modules (ice-9 optargs))
  58
  59 (defmacro*-public define-markup-command
  60   (command-and-args signature
  61    #:key (category '()) (properties '())
  62    #:rest body)
  63   "
  64 * Define a COMMAND-markup function after command-and-args and body,
  65 register COMMAND-markup and its signature,
  66
  67 * add COMMAND-markup to markup-functions-by-category,
  68
  69 * sets COMMAND-markup markup-signature object property,
  70
  71 * define a make-COMMAND-markup function.
  72
  73 Syntax:
  74   (define-markup-command (COMMAND layout props . arguments)
  75                                  argument-types
  76                                  [ #:properties properties ]
  77     \"documentation string\"
  78     ...command body...)
  79
  80 where:
  81   `argument-types' is a list of type predicates for arguments
  82   `properties' a list of (property default-value) lists
  83
  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.
  89
  90 The autogenerated documentation makes use of some optional
  91 specifications that are otherwise ignored:
  92
  93 After `argument-types', you may also specify
  94                                  [ #:category category ]
  95 where:
  96   `category' is either a symbol or a symbol list specifying the
  97              category for this markup command in the docs.
  98
  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.
 104 "
 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)))
 111     `(begin
 112        ;; define the COMMAND-markup function
 113        ,(let* ((documentation (if (string? (car body))
 114                                   (list (car body))
 115                                   '()))
 116                (real-body (if (or (null? documentation)
 117                                   (null? (cdr body)))
 118                               body (cdr body))))
 119           `(define-public (,command-name ,@args)
 120              ,@documentation
 121              (let ,(map (lambda (prop-spec)
 122                           (let ((prop (car prop-spec))
 123                                 (default-value (if (null? (cdr prop-spec))
 124                                                    #f
 125                                                    (cadr prop-spec)))
 126                                 (props (cadr args)))
 127                             `(,prop (chain-assoc-get ',prop ,props ,default-value))))
 128                         (filter pair? properties))
 129                ,@real-body)))
 130        (set! (markup-command-signature ,command-name) (list ,@signature))
 131        ;; Register the new function, for markup documentation
 132        ,@(map (lambda (category)
 133                 `(hashq-set!
 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
 137                                     hash)
 138                         hash))
 139                   ,command-name #t))
 140               (if (list? category) category (list category)))
 141        ;; Used properties, for markup documentation
 142        (hashq-set! markup-functions-properties
 143                    ,command-name
 144                    (list ,@(map (lambda (prop-spec)
 145                                   (cond ((symbol? prop-spec)
 146                                          prop-spec)
 147                                          ((not (null? (cdr prop-spec)))
 148                                           `(list ',(car prop-spec) ,(cadr prop-spec)))
 149                                          (else
 150                                           `(list ',(car prop-spec)))))
 151                                 (if (pair? args)
 152                                     properties
 153                                     (list)))))
 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))))))
 158
 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)))
 169     `(begin
 170        ;; define the COMMAND-markup-list function
 171        ,(let* ((documentation (if (string? (car body))
 172                                   (list (car body))
 173                                   '()))
 174                (real-body (if (or (null? documentation)
 175                                   (null? (cdr body)))
 176                               body (cdr body))))
 177           `(define-public (,command-name ,@args)
 178              ,@documentation
 179              (let ,(map (lambda (prop-spec)
 180                           (let ((prop (car prop-spec))
 181                                 (default-value (if (null? (cdr prop-spec))
 182                                                    #f
 183                                                    (cadr prop-spec)))
 184                                 (props (cadr args)))
 185                             `(,prop (chain-assoc-get ',prop ,props ,default-value))))
 186                         (filter pair? properties))
 187                ,@real-body)))
 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
 193                    ,command-name
 194                    (list ,@(map (lambda (prop-spec)
 195                                   (cond ((symbol? prop-spec)
 196                                          prop-spec)
 197                                          ((not (null? (cdr prop-spec)))
 198                                           `(list ',(car prop-spec) ,(cadr prop-spec)))
 199                                          (else
 200                                           `(list ',(car prop-spec)))))
 201                                 (if (pair? args)
 202                                     properties
 203                                     (list)))))
 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)))))))
 211
 212 (define-public (make-markup markup-function make-name signature args)
 213   "Construct a markup object from @var{markup-function} and @var{args}.
 214 Typecheck against @var{signature}, reporting @var{make-name} as the
 215 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)
 220                         #f)))
 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"))
 224                   siglen arglen args))
 225     (if error-msg
 226         (ly:error
 227          (string-append
 228           make-name ": "
 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))))
 232
 233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 234 ;;; markup constructors
 235 ;;; lilypond-like syntax for markup construction in scheme.
 236
 237 (use-modules (ice-9 receive))
 238
 239 (defmacro*-public markup (#:rest body)
 240   "The `markup' macro provides a lilypond-like syntax for building markups.
 241
 242  - #:COMMAND is used instead of \\COMMAND
 243  - #:line ( ... ) is used instead of \\line { ... }
 244  - etc.
 245
 246 Example:
 247   \\markup { foo
 248             \\raise #0.2 \\hbracket \\bold bar
 249             \\override #'(baseline-skip . 4)
 250             \\bracket \\column { baz bazr bla }
 251   }
 252          <==>
 253   (markup \"foo\"
 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."
 258
 259   (car (compile-all-markup-expressions `(#:line ,body))))
 260
 261 (defmacro*-public markup* (#:rest body)
 262   "Same as `markup', for use in a \\notes block."
 263   `(ly:export (markup ,@body)))
 264
 265
 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)
 269   ===>
 270   ((make-COMMAND1-markup arg11 arg12)
 271    (make-COMMAND2-markup arg21 arg22 arg23) ...)"
 272   (do ((rest expr rest)
 273        (markps '() markps))
 274       ((null? rest) (reverse markps))
 275     (receive (m r) (compile-markup-expression rest)
 276              (set! markps (cons m markps))
 277              (set! rest r))))
 278
 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")))
 282
 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)))
 296               (do ((i 0 (1+ i))
 297                    (args '() args)
 298                    (rest (cdr expr) rest))
 299                   ((>= i sig-len)
 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)))
 305                       (else
 306                        ;; pick up one arg in `rest'
 307                        (receive (a r) (compile-markup-arg rest)
 308                          (set! args (cons a args))
 309                          (set! rest r))))))))
 310         ((and (pair? expr)
 311               (pair? (car expr))
 312               (keyword? (caar expr)))
 313          ;; expr === ((#:COMMAND arg1 ...) ...)
 314          (receive (m r) (compile-markup-expression (car expr))
 315                   (values m (cdr expr))))
 316         ((and (pair? expr)
 317               (string? (car expr))) ;; expr === ("string" ...)
 318          (values `(make-simple-markup ,(car expr)) (cdr expr)))
 319         (else
 320          ;; expr === (symbol ...) or ((funcall ...) ...)
 321          (values (car expr)
 322                  (cdr expr)))))
 323
 324 (define (compile-all-markup-args expr)
 325   "Transform `expr' into markup arguments"
 326   (do ((rest expr rest)
 327        (args '() args))
 328       ((null? rest) (reverse args))
 329     (receive (a r) (compile-markup-arg rest)
 330              (set! args (cons a args))
 331              (set! rest r))))
 332
 333 (define (compile-markup-arg expr)
 334   "Return two values: the desired markup argument, and the rest arguments"
 335   (cond ((null? expr)
 336          ;; no more args
 337          (values '() '()))
 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))
 351                               (cdr expr)))))
 352         ((and (pair? (car expr))
 353               (pair? (caar expr)))
 354          ;; expr === (((foo ...) ...) ...)
 355          (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
 356         (else (values (car expr) (cdr expr)))))
 357
 358 ;;;;;;;;;;;;;;;
 359 ;;; Utilities for storing and accessing markup commands signature
 360 ;;; Examples:
 361 ;;;
 362 ;;; (set! (markup-command-signature raise-markup) (list number? markup?))
 363 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 364 ;;;
 365 ;;; (markup-command-signature raise-markup)
 366 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 367 ;;;
 368
 369 (define-public (markup-command-signature-ref markup-command)
 370   "Return @var{markup-command}'s signature (the @code{'markup-signature}
 371 object property)."
 372   (object-property markup-command 'markup-signature))
 373
 374 (define-public (markup-command-signature-set! markup-command signature)
 375   "Set @var{markup-command}'s signature (as object property)."
 376   (set-object-property! markup-command 'markup-signature signature)
 377   signature)
 378
 379 (define-public markup-command-signature
 380   (make-procedure-with-setter markup-command-signature-ref
 381                               markup-command-signature-set!))
 382
 383 (define (lookup-markup-command-aux symbol)
 384   (let ((proc (catch 'misc-error
 385                 (lambda ()
 386                   (module-ref (current-module) symbol))
 387                 (lambda (key . args) #f))))
 388     (and (procedure? proc) proc)))
 389
 390 (define-public (lookup-markup-command code)
 391   (let ((proc (lookup-markup-command-aux
 392                (string->symbol (format #f "~a-markup" code)))))
 393     (and proc (markup-function? proc)
 394          (cons proc (markup-command-signature proc)))))
 395
 396 (define-public (lookup-markup-list-command code)
 397   (let ((proc (lookup-markup-command-aux
 398                (string->symbol (format #f "~a-markup-list" code)))))
 399      (and proc (markup-list-function? proc)
 400           (cons proc (markup-command-signature proc)))))
 401
 402 ;;;;;;;;;;;;;;;;;;;;;;
 403 ;;; used in parser.yy to map a list of markup commands on markup arguments
 404 (define-public (map-markup-command-list commands markups)
 405   "@var{markups} being a list of markups, for example
 406 @code{(markup1 markup2 markup3)}, and @var{commands} a list of commands with
 407 their scheme arguments, in reverse order, for example
 408 @code{((italic) (raise 4) (bold))}, map the commands on each markup argument,
 409 for example
 410 @example
 411 ((bold (raise 4 (italic markup1)))
 412  (bold (raise 4 (italic markup2)))
 413  (bold (raise 4 (italic markup3))))
 414 @end example"
 415   (map-in-order (lambda (arg)
 416                   (let ((result arg))
 417                     (for-each (lambda (cmd)
 418                                 (set! result (append cmd (list result))))
 419                               commands)
 420                     result))
 421                 markups))
 422
 423 ;;;;;;;;;;;;;;;;;;;;;;
 424 ;;; markup type predicates
 425
 426 (define (markup-function? x)
 427   (and (markup-command-signature x)
 428        (not (object-property x 'markup-list-command))))
 429
 430 (define (markup-list-function? x)
 431   (and (markup-command-signature x)
 432        (object-property x 'markup-list-command)))
 433
 434 (define-public (markup-command-list? x)
 435   "Determine whether @var{x} is a markup command list, i.e. a list
 436 composed of a markup list function and its arguments."
 437   (and (pair? x) (markup-list-function? (car x))))
 438
 439 (define-public (markup-list? arg)
 440   "Return @code{#t} if @var{x} is a list of markups or markup command lists."
 441   (define (markup-list-inner? lst)
 442     (or (null? lst)
 443         (and (or (markup? (car lst)) (markup-command-list? (car lst)))
 444              (markup-list-inner? (cdr lst)))))
 445   (not (not (and (list? arg) (markup-list-inner? arg)))))
 446
 447 (define (markup-argument-list? signature arguments)
 448   "Typecheck argument list."
 449   (if (and (pair? signature) (pair? arguments))
 450       (and ((car signature) (car arguments))
 451            (markup-argument-list? (cdr signature) (cdr arguments)))
 452       (and (null? signature) (null? arguments))))
 453
 454
 455 (define (markup-argument-list-error signature arguments number)
 456   "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
 457 #f is no error found.
 458 "
 459   (if (and (pair? signature) (pair? arguments))
 460       (if (not ((car signature) (car arguments)))
 461           (list number (type-name (car signature)) (car arguments))
 462           (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
 463       #f))
 464
 465 ;;
 466 ;; full recursive typecheck.
 467 ;;
 468 (define (markup-typecheck? arg)
 469   (or (string? arg)
 470       (and (pair? arg)
 471            (markup-function? (car arg))
 472            (markup-argument-list? (markup-command-signature (car arg))
 473                                   (cdr arg)))))
 474
 475 ;;
 476 ;;
 477 ;;
 478 ;;
 479 (define (markup-thrower-typecheck arg)
 480   "typecheck, and throw an error when something amiss.
 481
 482 Uncovered - cheap-markup? is used."
 483
 484   (cond ((string? arg) #t)
 485         ((not (pair? arg))
 486          (throw 'markup-format "Not a pair" arg))
 487         ((not (markup-function? (car arg)))
 488          (throw 'markup-format "Not a markup function " (car arg)))
 489         ((not (markup-argument-list? (markup-command-signature (car arg))
 490                                      (cdr arg)))
 491          (throw 'markup-format "Arguments failed  typecheck for " arg)))
 492   #t)
 493
 494 ;;
 495 ;; good enough if you only  use make-XXX-markup functions.
 496 ;;
 497 (define (cheap-markup? x)
 498   (or (string? x)
 499       (and (pair? x)
 500            (markup-function? (car x)))))
 501
 502 ;;
 503 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 504 ;;
 505 (define-public markup? cheap-markup?)
 506
 507 ;; utility
 508
 509 (define (markup-join markups sep)
 510   "Return line-markup of MARKUPS, joining them with markup SEP"
 511   (if (pair? markups)
 512       (make-line-markup (list-insert-separator markups sep))
 513       empty-markup))
 514
 515
 516 (define-public interpret-markup ly:text-interface::interpret-markup)
 517
 518 (define-public (interpret-markup-list layout props markup-list)
 519   (let ((stencils (list)))
 520     (for-each (lambda (m)
 521                 (set! stencils
 522                       (if (markup-command-list? m)
 523                           (append! (reverse! (apply (car m) layout props (cdr m)))
 524                                    stencils)
 525                           (cons (interpret-markup layout props m) stencils))))
 526               markup-list)
 527     (reverse! stencils)))
 528
 529 (define-public (prepend-alist-chain key val chain)
 530   (cons (acons key val (car chain)) (cdr chain)))
 531
 532 (define-public (stack-stencil-line space stencils)
 533   "DOCME"
 534   (if (and (pair? stencils)
 535            (ly:stencil? (car stencils)))
 536
 537       (if (and (pair? (cdr stencils))
 538                (ly:stencil? (cadr stencils)))
 539           (let* ((tail (stack-stencil-line space (cdr stencils)))
 540                  (head (car stencils))
 541                  (xoff (+ space (cdr (ly:stencil-extent head X)))))
 542             (ly:stencil-add head
 543                              (ly:stencil-translate-axis tail xoff X)))
 544           (car stencils))
 545       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 546