scm/markup.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2010 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  or:
  80   (define-markup-command COMMAND
  81                                  argument-types
  82                                  [ #:category category ]
  83                                  function)
  84
  85 where:
  86   `argument-types' is a list of type predicates for arguments
  87   `properties' a list of (property default-value) lists
  88
  89 The specified properties are available as let-bound variables in the
  90 command body, using the respective `default-value' as fallback in case
  91 `property' is not found in `props'.  `props' itself is left unchanged:
  92 if you want defaults specified in that manner passed down into other
  93 markup functions, you need to adjust `props' yourself.
  94
  95 The autogenerated documentation makes use of some optional
  96 specifications that are otherwise ignored:
  97
  98 After `argument-types', you may also specify
  99                                  [ #:category category ]
 100 where:
 101   `category' is either a symbol or a symbol list specifying the
 102              category for this markup command in the docs.
 103
 104 As an element of the `properties' list, you may directly use a
 105 COMMANDx-markup symbol instead of a `(prop value)' list to indicate
 106 that this markup command is called by the newly defined command,
 107 adding its properties to the documented properties of the new
 108 command.  There is no protection against circular definitions.
 109 "
 110   (let* ((command (if (pair? command-and-args) (car command-and-args) command-and-args))
 111          (args (if (pair? command-and-args) (cdr command-and-args) '()))
 112          (command-name (string->symbol (format #f "~a-markup" command)))
 113          (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
 114     (while (and (pair? body) (keyword? (car body)))
 115            (set! body (cddr body)))
 116     `(begin
 117        ;; define the COMMAND-markup function
 118        ,(if (pair? args)
 119             (let* ((documentation (if (string? (car body))
 120                                       (list (car body))
 121                                       '()))
 122                    (real-body (if (or (null? documentation)
 123                                       (null? (cdr body)))
 124                                   body (cdr body))))
 125               `(define-public (,command-name ,@args)
 126                  ,@documentation
 127                  (let ,(map (lambda (prop-spec)
 128                               (let ((prop (car prop-spec))
 129                                     (default-value (if (null? (cdr prop-spec))
 130                                                        #f
 131                                                        (cadr prop-spec)))
 132                                     (props (cadr args)))
 133                                 `(,prop (chain-assoc-get ',prop ,props ,default-value))))
 134                             (filter pair? properties))
 135                    ,@real-body)))
 136             (let ((args (gensym "args"))
 137                   (markup-command (car body)))
 138               `(define-public (,command-name . ,args)
 139                  ,(format #f "Copy of the ~a command." markup-command)
 140                  (apply ,markup-command ,args))))
 141        (set! (markup-command-signature ,command-name) (list ,@signature))
 142        ;; Register the new function, for markup documentation
 143        ,@(map (lambda (category)
 144                 `(hashq-set!
 145                   (or (hashq-ref markup-functions-by-category ',category)
 146                       (let ((hash (make-weak-key-hash-table 151)))
 147                         (hashq-set! markup-functions-by-category ',category
 148                                     hash)
 149                         hash))
 150                   ,command-name #t))
 151               (if (list? category) category (list category)))
 152        ;; Used properties, for markup documentation
 153        (hashq-set! markup-functions-properties
 154                    ,command-name
 155                    (list ,@(map (lambda (prop-spec)
 156                                   (cond ((symbol? prop-spec)
 157                                          prop-spec)
 158                                          ((not (null? (cdr prop-spec)))
 159                                           `(list ',(car prop-spec) ,(cadr prop-spec)))
 160                                          (else
 161                                           `(list ',(car prop-spec)))))
 162                                 (if (pair? args)
 163                                     properties
 164                                     (list)))))
 165        ;; define the make-COMMAND-markup function
 166        (define-public (,make-markup-name . args)
 167          (let ((sig (list ,@signature)))
 168            (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
 169
 170 (defmacro*-public define-markup-list-command
 171   (command-and-args signature #:key (properties '()) #:rest body)
 172   "Same as `define-markup-command', but defines a command that, when
 173 interpreted, returns a list of stencils instead of a single one"
 174   (let* ((command (if (pair? command-and-args) (car command-and-args) command-and-args))
 175          (args (if (pair? command-and-args) (cdr command-and-args) '()))
 176          (command-name (string->symbol (format #f "~a-markup-list" command)))
 177          (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
 178     (while (and (pair? body) (keyword? (car body)))
 179            (set! body (cddr body)))
 180     `(begin
 181        ;; define the COMMAND-markup-list function
 182        ,(if (pair? args)
 183             (let* ((documentation (if (string? (car body))
 184                                       (list (car body))
 185                                       '()))
 186                    (real-body (if (or (null? documentation)
 187                                       (null? (cdr body)))
 188                                   body (cdr body))))
 189               `(define-public (,command-name ,@args)
 190                  ,@documentation
 191                  (let ,(map (lambda (prop-spec)
 192                               (let ((prop (car prop-spec))
 193                                     (default-value (if (null? (cdr prop-spec))
 194                                                        #f
 195                                                        (cadr prop-spec)))
 196                                     (props (cadr args)))
 197                                 `(,prop (chain-assoc-get ',prop ,props ,default-value))))
 198                             (filter pair? properties))
 199                    ,@real-body)))
 200             (let ((args (gensym "args"))
 201                   (markup-command (car body)))
 202             `(define-public (,command-name . ,args)
 203                ,(format #f "Copy of the ~a command." markup-command)
 204                (apply ,markup-command ,args))))
 205        (set! (markup-command-signature ,command-name) (list ,@signature))
 206        ;; add the command to markup-list-function-list, for markup documentation
 207        (hashq-set! markup-list-functions ,command-name #t)
 208        ;; Used properties, for markup documentation
 209        (hashq-set! markup-functions-properties
 210                    ,command-name
 211                    (list ,@(map (lambda (prop-spec)
 212                                   (cond ((symbol? prop-spec)
 213                                          prop-spec)
 214                                          ((not (null? (cdr prop-spec)))
 215                                           `(list ',(car prop-spec) ,(cadr prop-spec)))
 216                                          (else
 217                                           `(list ',(car prop-spec)))))
 218                                 (if (pair? args)
 219                                     properties
 220                                     (list)))))
 221        ;; it's a markup-list command:
 222        (set-object-property! ,command-name 'markup-list-command #t)
 223        ;; define the make-COMMAND-markup-list function
 224        (define-public (,make-markup-name . args)
 225          (let ((sig (list ,@signature)))
 226            (list (make-markup ,command-name
 227                               ,(symbol->string make-markup-name) sig args)))))))
 228
 229 (define-public (make-markup markup-function make-name signature args)
 230   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
 231 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 232 "
 233   (let* ((arglen (length args))
 234          (siglen (length signature))
 235          (error-msg (if (and (> siglen 0) (> arglen 0))
 236                         (markup-argument-list-error signature args 1)
 237                         #f)))
 238     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
 239         (ly:error (string-append make-name ": "
 240                    (_ "Wrong number of arguments.  Expect: ~A, found ~A: ~S"))
 241                   siglen arglen args))
 242     (if error-msg
 243         (ly:error
 244          (string-append
 245           make-name ": "
 246           (_ "Invalid argument in position ~A.  Expect: ~A, found: ~S."))
 247           (car error-msg) (cadr error-msg)(caddr error-msg))
 248         (cons markup-function args))))
 249
 250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 251 ;;; markup constructors
 252 ;;; lilypond-like syntax for markup construction in scheme.
 253
 254 (use-modules (ice-9 receive))
 255
 256 (defmacro*-public markup (#:rest body)
 257   "The `markup' macro provides a lilypond-like syntax for building markups.
 258
 259  - #:COMMAND is used instead of \\COMMAND
 260  - #:line ( ... ) is used instead of \\line { ... }
 261  - etc.
 262
 263 Example:
 264   \\markup { foo
 265             \\raise #0.2 \\hbracket \\bold bar
 266             \\override #'(baseline-skip . 4)
 267             \\bracket \\column { baz bazr bla }
 268   }
 269          <==>
 270   (markup \"foo\"
 271           #:raise 0.2 #:hbracket #:bold \"bar\"
 272           #:override '(baseline-skip . 4)
 273           #:bracket #:column (\"baz\" \"bazr\" \"bla\"))
 274 Use `markup*' in a \\notemode context."
 275
 276   (car (compile-all-markup-expressions `(#:line ,body))))
 277
 278 (defmacro*-public markup* (#:rest body)
 279   "Same as `markup', for use in a \\notes block."
 280   `(ly:export (markup ,@body)))
 281
 282
 283 (define (compile-all-markup-expressions expr)
 284   "Return a list of canonical markups expressions, e.g.:
 285   (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
 286   ===>
 287   ((make-COMMAND1-markup arg11 arg12)
 288    (make-COMMAND2-markup arg21 arg22 arg23) ...)"
 289   (do ((rest expr rest)
 290        (markps '() markps))
 291       ((null? rest) (reverse markps))
 292     (receive (m r) (compile-markup-expression rest)
 293              (set! markps (cons m markps))
 294              (set! rest r))))
 295
 296 (define (keyword->make-markup key)
 297   "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
 298   (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
 299
 300 (define (compile-markup-expression expr)
 301   "Return two values: the first complete canonical markup expression
 302    found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...),
 303    and the rest expression."
 304   (cond ((and (pair? expr)
 305               (keyword? (car expr)))
 306          ;; expr === (#:COMMAND arg1 ...)
 307          (let ((command (symbol->string (keyword->symbol (car expr)))))
 308             (if (not (pair? (lookup-markup-command command)))
 309                 (ly:error (_ "Not a markup command: ~A") command))
 310             (let* ((sig (markup-command-signature
 311                          (car (lookup-markup-command command))))
 312                    (sig-len (length sig)))
 313               (do ((i 0 (1+ i))
 314                    (args '() args)
 315                    (rest (cdr expr) rest))
 316                   ((>= i sig-len)
 317                    (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
 318                 (cond ((eqv? (list-ref sig i) markup-list?)
 319                        ;; (car rest) is a markup list
 320                        (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
 321                        (set! rest (cdr rest)))
 322                       (else
 323                        ;; pick up one arg in `rest'
 324                        (receive (a r) (compile-markup-arg rest)
 325                          (set! args (cons a args))
 326                          (set! rest r))))))))
 327         ((and (pair? expr)
 328               (pair? (car expr))
 329               (keyword? (caar expr)))
 330          ;; expr === ((#:COMMAND arg1 ...) ...)
 331          (receive (m r) (compile-markup-expression (car expr))
 332                   (values m (cdr expr))))
 333         ((and (pair? expr)
 334               (string? (car expr))) ;; expr === ("string" ...)
 335          (values `(make-simple-markup ,(car expr)) (cdr expr)))
 336         (else
 337          ;; expr === (symbol ...) or ((funcall ...) ...)
 338          (values (car expr)
 339                  (cdr expr)))))
 340
 341 (define (compile-all-markup-args expr)
 342   "Transform `expr' into markup arguments"
 343   (do ((rest expr rest)
 344        (args '() args))
 345       ((null? rest) (reverse args))
 346     (receive (a r) (compile-markup-arg rest)
 347              (set! args (cons a args))
 348              (set! rest r))))
 349
 350 (define (compile-markup-arg expr)
 351   "Return two values: the desired markup argument, and the rest arguments"
 352   (cond ((null? expr)
 353          ;; no more args
 354          (values '() '()))
 355         ((keyword? (car expr))
 356          ;; expr === (#:COMMAND ...)
 357          ;; ==> build and return the whole markup expression
 358          (compile-markup-expression expr))
 359         ((and (pair? (car expr))
 360               (keyword? (caar expr)))
 361          ;; expr === ((#:COMMAND ...) ...)
 362          ;; ==> build and return the whole markup expression(s)
 363          ;; found in (car expr)
 364          (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
 365                   (if (null? rest-expr)
 366                       (values markup-expr (cdr expr))
 367                       (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
 368                               (cdr expr)))))
 369         ((and (pair? (car expr))
 370               (pair? (caar expr)))
 371          ;; expr === (((foo ...) ...) ...)
 372          (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
 373         (else (values (car expr) (cdr expr)))))
 374
 375 ;;;;;;;;;;;;;;;
 376 ;;; Utilities for storing and accessing markup commands signature
 377 ;;; Examples:
 378 ;;;
 379 ;;; (set! (markup-command-signature raise-markup) (list number? markup?))
 380 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 381 ;;;
 382 ;;; (markup-command-signature raise-markup)
 383 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 384 ;;;
 385
 386 (define-public (markup-command-signature-ref markup-command)
 387   "Return markup-command's signature (the 'markup-signature object property)"
 388   (object-property markup-command 'markup-signature))
 389
 390 (define-public (markup-command-signature-set! markup-command signature)
 391   "Set markup-command's signature (as object property)"
 392   (set-object-property! markup-command 'markup-signature signature)
 393   signature)
 394
 395 (define-public markup-command-signature
 396   (make-procedure-with-setter markup-command-signature-ref
 397                               markup-command-signature-set!))
 398
 399 (define (lookup-markup-command-aux symbol)
 400   (let ((proc (catch 'misc-error
 401                 (lambda ()
 402                   (module-ref (current-module) symbol))
 403                 (lambda (key . args) #f))))
 404     (and (procedure? proc) proc)))
 405
 406 (define-public (lookup-markup-command code)
 407   (let ((proc (lookup-markup-command-aux
 408                (string->symbol (format #f "~a-markup" code)))))
 409     (and proc (markup-function? proc)
 410          (cons proc (markup-command-signature proc)))))
 411
 412 (define-public (lookup-markup-list-command code)
 413   (let ((proc (lookup-markup-command-aux
 414                (string->symbol (format #f "~a-markup-list" code)))))
 415      (and proc (markup-list-function? proc)
 416           (cons proc (markup-command-signature proc)))))
 417
 418 ;;;;;;;;;;;;;;;;;;;;;;
 419 ;;; used in parser.yy to map a list of markup commands on markup arguments
 420 (define-public (map-markup-command-list commands markups)
 421   "`markups' being a list of markups, eg (markup1 markup2 markup3),
 422 and `commands' a list of commands with their scheme arguments, in reverse order,
 423 eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 424  ((bold (raise 4 (italic markup1)))
 425   (bold (raise 4 (italic markup2)))
 426   (bold (raise 4 (italic markup3))))
 427 "
 428   (map-in-order (lambda (arg)
 429                   (let ((result arg))
 430                     (for-each (lambda (cmd)
 431                                 (set! result (append cmd (list result))))
 432                               commands)
 433                     result))
 434                 markups))
 435
 436 ;;;;;;;;;;;;;;;;;;;;;;
 437 ;;; markup type predicates
 438
 439 (define (markup-function? x)
 440   (and (markup-command-signature x)
 441        (not (object-property x 'markup-list-command))))
 442
 443 (define (markup-list-function? x)
 444   (and (markup-command-signature x)
 445        (object-property x 'markup-list-command)))
 446
 447 (define-public (markup-command-list? x)
 448   "Determine if `x' is a markup command list, ie. a list composed of
 449 a markup list function and its arguments."
 450   (and (pair? x) (markup-list-function? (car x))))
 451
 452 (define-public (markup-list? arg)
 453   "Return a true value if `x' is a list of markups or markup command lists."
 454   (define (markup-list-inner? lst)
 455     (or (null? lst)
 456         (and (or (markup? (car lst)) (markup-command-list? (car lst)))
 457              (markup-list-inner? (cdr lst)))))
 458   (not (not (and (list? arg) (markup-list-inner? arg)))))
 459
 460 (define (markup-argument-list? signature arguments)
 461   "Typecheck argument list."
 462   (if (and (pair? signature) (pair? arguments))
 463       (and ((car signature) (car arguments))
 464            (markup-argument-list? (cdr signature) (cdr arguments)))
 465       (and (null? signature) (null? arguments))))
 466
 467
 468 (define (markup-argument-list-error signature arguments number)
 469   "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
 470 #f is no error found.
 471 "
 472   (if (and (pair? signature) (pair? arguments))
 473       (if (not ((car signature) (car arguments)))
 474           (list number (type-name (car signature)) (car arguments))
 475           (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
 476       #f))
 477
 478 ;;
 479 ;; full recursive typecheck.
 480 ;;
 481 (define (markup-typecheck? arg)
 482   (or (string? arg)
 483       (and (pair? arg)
 484            (markup-function? (car arg))
 485            (markup-argument-list? (markup-command-signature (car arg))
 486                                   (cdr arg)))))
 487
 488 ;;
 489 ;;
 490 ;;
 491 ;;
 492 (define (markup-thrower-typecheck arg)
 493   "typecheck, and throw an error when something amiss.
 494
 495 Uncovered - cheap-markup? is used."
 496
 497   (cond ((string? arg) #t)
 498         ((not (pair? arg))
 499          (throw 'markup-format "Not a pair" arg))
 500         ((not (markup-function? (car arg)))
 501          (throw 'markup-format "Not a markup function " (car arg)))
 502         ((not (markup-argument-list? (markup-command-signature (car arg))
 503                                      (cdr arg)))
 504          (throw 'markup-format "Arguments failed  typecheck for " arg)))
 505   #t)
 506
 507 ;;
 508 ;; good enough if you only  use make-XXX-markup functions.
 509 ;;
 510 (define (cheap-markup? x)
 511   (or (string? x)
 512       (and (pair? x)
 513            (markup-function? (car x)))))
 514
 515 ;;
 516 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 517 ;;
 518 (define-public markup? cheap-markup?)
 519
 520 ;; utility
 521
 522 (define (markup-join markups sep)
 523   "Return line-markup of MARKUPS, joining them with markup SEP"
 524   (if (pair? markups)
 525       (make-line-markup (list-insert-separator markups sep))
 526       empty-markup))
 527
 528
 529 (define-public interpret-markup ly:text-interface::interpret-markup)
 530
 531 (define-public (interpret-markup-list layout props markup-list)
 532   (let ((stencils (list)))
 533     (for-each (lambda (m)
 534                 (set! stencils
 535                       (if (markup-command-list? m)
 536                           (append! (reverse! (apply (car m) layout props (cdr m)))
 537                                    stencils)
 538                           (cons (interpret-markup layout props m) stencils))))
 539               markup-list)
 540     (reverse! stencils)))
 541
 542 (define-public (prepend-alist-chain key val chain)
 543   (cons (acons key val (car chain)) (cdr chain)))
 544
 545 (define-public (stack-stencil-line space stencils)
 546   "DOCME"
 547   (if (and (pair? stencils)
 548            (ly:stencil? (car stencils)))
 549
 550       (if (and (pair? (cdr stencils))
 551                (ly:stencil? (cadr stencils)))
 552           (let* ((tail (stack-stencil-line space (cdr stencils)))
 553                  (head (car stencils))
 554                  (xoff (+ space (cdr (ly:stencil-extent head X)))))
 555             (ly:stencil-add head
 556                              (ly:stencil-translate-axis tail xoff X)))
 557           (car stencils))
 558       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 559