scm/markup.scm

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