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