scm/markup-macros.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2015 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 ;; markup function -> categories
  51 (define-public markup-function-category (make-object-property))
  52 ;; markup function -> used properties
  53 (define-public markup-function-properties (make-object-property))
  54
  55 (use-modules (ice-9 optargs))
  56
  57 (defmacro*-public define-markup-command
  58   (command-and-args signature
  59                     #:key (category '()) (properties '())
  60                     #:rest body)
  61   "
  62 * Define a COMMAND-markup function after command-and-args and body,
  63 register COMMAND-markup and its signature,
  64
  65 * add categories to markup-function-category,
  66
  67 * sets the markup-signature object property,
  68
  69 * define a make-COMMAND-markup function.
  70
  71 Syntax:
  72   (define-markup-command (COMMAND layout props . arguments)
  73                                  argument-types
  74                                  [ #:properties properties ]
  75     \"documentation string\"
  76     ...command body...)
  77
  78 where:
  79   `argument-types' is a list of type predicates for arguments
  80   `properties' a list of (property default-value) lists
  81
  82 The specified properties are available as let-bound variables in the
  83 command body, using the respective `default-value' as fallback in case
  84 `property' is not found in `props'.  `props' itself is left unchanged:
  85 if you want defaults specified in that manner passed down into other
  86 markup functions, you need to adjust `props' yourself.
  87
  88 The autogenerated documentation makes use of some optional
  89 specifications that are otherwise ignored:
  90
  91 After `argument-types', you may also specify
  92                                  [ #:category category ]
  93 where:
  94   `category' is either a symbol or a symbol list specifying the
  95              categories for this markup command in the docs.
  96
  97 As an element of the `properties' list, you may directly use a
  98 COMMANDx-markup symbol instead of a `(prop value)' list to indicate
  99 that this markup command is called by the newly defined command,
 100 adding its properties to the documented properties of the new
 101 command.  There is no protection against circular definitions.
 102 "
 103   (let* ((command (car command-and-args))
 104          (args (cdr command-and-args))
 105          (command-name (string->symbol (format #f "~a-markup" command)))
 106          (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
 107     (while (and (pair? body) (keyword? (car body)))
 108            (set! body (cddr body)))
 109     `(begin
 110        ;; define the COMMAND-markup function
 111        ,(let* ((documentation
 112                 (format #f "~a\n~a" (cddr args)
 113                         (if (string? (car body)) (car body) "")))
 114                (real-body (if (or (not (string? (car body)))
 115                                   (null? (cdr body)))
 116                               body (cdr body))))
 117           `(define-public (,command-name ,@args)
 118              ,documentation
 119              (let ,(map (lambda (prop-spec)
 120                           (let ((prop (car prop-spec))
 121                                 (default-value (if (null? (cdr prop-spec))
 122                                                    #f
 123                                                    (cadr prop-spec)))
 124                                 (props (cadr args)))
 125                             `(,prop (chain-assoc-get ',prop ,props ,default-value))))
 126                         (filter pair? properties))
 127                ,@real-body)))
 128        (set! (markup-command-signature ,command-name) (list ,@signature))
 129        ;; Register the new function, for markup documentation
 130        (set! (markup-function-category ,command-name) ',category)
 131        ;; Used properties, for markup documentation
 132        (set! (markup-function-properties ,command-name)
 133              (list ,@(map (lambda (prop-spec)
 134                             (cond ((symbol? prop-spec)
 135                                    prop-spec)
 136                                   ((not (null? (cdr prop-spec)))
 137                                    `(list ',(car prop-spec) ,(cadr prop-spec)))
 138                                   (else
 139                                    `(list ',(car prop-spec)))))
 140                           properties)))
 141        ;; define the make-COMMAND-markup function
 142        (define-public (,make-markup-name . args)
 143          (,make-markup ,command-name ,(symbol->string make-markup-name) args)))))
 144
 145 (defmacro*-public define-markup-list-command
 146   (command-and-args signature #:key (properties '()) #:rest body)
 147   "Same as `define-markup-command', but defines a command that, when
 148 interpreted, returns a list of stencils instead of a single one"
 149   (let* ((command (car command-and-args))
 150          (args (cdr command-and-args))
 151          (command-name (string->symbol (format #f "~a-markup-list" command)))
 152          (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
 153     (while (and (pair? body) (keyword? (car body)))
 154            (set! body (cddr body)))
 155     `(begin
 156        ;; define the COMMAND-markup-list function
 157        ,(let* ((documentation
 158                 (format #f "~a\n~a" (cddr args)
 159                         (if (string? (car body)) (car body) "")))
 160                (real-body (if (or (not (string? (car body)))
 161                                   (null? (cdr body)))
 162                               body (cdr body))))
 163           `(define-public (,command-name ,@args)
 164              ,documentation
 165              (let ,(map (lambda (prop-spec)
 166                           (let ((prop (car prop-spec))
 167                                 (default-value (if (null? (cdr prop-spec))
 168                                                    #f
 169                                                    (cadr prop-spec)))
 170                                 (props (cadr args)))
 171                             `(,prop (chain-assoc-get ',prop ,props ,default-value))))
 172                         (filter pair? properties))
 173                ,@real-body)))
 174        (set! (markup-command-signature ,command-name) (list ,@signature))
 175        ;; Used properties, for markup documentation
 176        (set! (markup-function-properties ,command-name)
 177              (list ,@(map (lambda (prop-spec)
 178                             (cond ((symbol? prop-spec)
 179                                    prop-spec)
 180                                   ((not (null? (cdr prop-spec)))
 181                                    `(list ',(car prop-spec) ,(cadr prop-spec)))
 182                                   (else
 183                                    `(list ',(car prop-spec)))))
 184                           properties)))
 185        ;; it's a markup-list command:
 186        (set! (markup-list-function? ,command-name) #t)
 187        ;; define the make-COMMAND-markup-list function
 188        (define-public (,make-markup-name . args)
 189          (list (,make-markup ,command-name
 190                              ,(symbol->string make-markup-name) args))))))
 191
 192 ;;;;;;;;;;;;;;;
 193 ;;; Utilities for storing and accessing markup commands signature
 194 ;;; Examples:
 195 ;;;
 196 ;;; (set! (markup-command-signature raise-markup) (list number? markup?))
 197 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 198 ;;;
 199 ;;; (markup-command-signature raise-markup)
 200 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 201 ;;;
 202
 203 (define-public markup-command-signature (make-object-property))
 204
 205 ;;;;;;;;;;;;;;;;;;;;;;
 206 ;;; markup type predicates
 207
 208 (define-public (markup-function? x)
 209   (and (markup-command-signature x)
 210        (not (markup-list-function? x))))
 211
 212 (define-public markup-list-function? (make-object-property))
 213
 214 (define-public (markup-command-list? x)
 215   "Determine if `x' is a markup command list, ie. a list composed of
 216 a markup list function and its arguments."
 217   (and (pair? x) (markup-list-function? (car x))))
 218
 219 (define-public (markup-list? arg)
 220   "Return a true value if `x' is a list of markups or markup command lists."
 221   (define (markup-list-inner? lst)
 222     (or (null? lst)
 223         (and (or (markup? (car lst)) (markup-command-list? (car lst)))
 224              (markup-list-inner? (cdr lst)))))
 225   (not (not (and (list? arg) (markup-list-inner? arg)))))
 226
 227 (define (markup-argument-list? signature arguments)
 228   "Typecheck argument list."
 229   (if (and (pair? signature) (pair? arguments))
 230       (and ((car signature) (car arguments))
 231            (markup-argument-list? (cdr signature) (cdr arguments)))
 232       (and (null? signature) (null? arguments))))
 233
 234
 235 (define (markup-argument-list-error signature arguments number)
 236   "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
 237 #f is no error found.
 238 "
 239   (if (and (pair? signature) (pair? arguments))
 240       (if (not ((car signature) (car arguments)))
 241           (list number (type-name (car signature)) (car arguments))
 242           (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
 243       #f))
 244
 245 ;;
 246 ;; full recursive typecheck.
 247 ;;
 248 (define (markup-typecheck? arg)
 249   (or (string? arg)
 250       (and (pair? arg)
 251            (markup-function? (car arg))
 252            (markup-argument-list? (markup-command-signature (car arg))
 253                                   (cdr arg)))))
 254
 255 ;;
 256 ;;
 257 ;;
 258 ;;
 259 (define (markup-thrower-typecheck arg)
 260   "typecheck, and throw an error when something amiss.
 261
 262 Uncovered - cheap-markup? is used."
 263
 264   (cond ((string? arg) #t)
 265         ((not (pair? arg))
 266          (throw 'markup-format "Not a pair" arg))
 267         ((not (markup-function? (car arg)))
 268          (throw 'markup-format "Not a markup function " (car arg)))
 269         ((not (markup-argument-list? (markup-command-signature (car arg))
 270                                      (cdr arg)))
 271          (throw 'markup-format "Arguments failed  typecheck for " arg)))
 272   #t)
 273
 274 ;;
 275 ;; good enough if you only  use make-XXX-markup functions.
 276 ;;
 277 (define (cheap-markup? x)
 278   (or (string? x)
 279       (and (pair? x)
 280            (markup-function? (car x)))))
 281
 282 ;;
 283 ;; replace by markup-thrower-typecheck for more detailed diagnostics.
 284 ;;
 285 (define-public markup? cheap-markup?)
 286
 287 (define (make-markup markup-function make-name args)
 288   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
 289 against signature, reporting MAKE-NAME as the user-invoked function.
 290 "
 291   (let* ((arglen (length args))
 292          (signature (or (markup-command-signature markup-function)
 293                         (ly:error (_ "~S: Not a markup (list) function: ~S")
 294                                   make-name markup-function)))
 295          (siglen (length signature))
 296          (error-msg (if (and (> siglen 0) (> arglen 0))
 297                         (markup-argument-list-error signature args 1)
 298                         #f)))
 299     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
 300         (ly:error (string-append make-name ": "
 301                                  (_ "Wrong number of arguments.  Expect: ~A, found ~A: ~S"))
 302                   siglen arglen args))
 303     (if error-msg
 304         (ly:error
 305          (string-append
 306           make-name ": "
 307           (_ "Invalid argument in position ~A.  Expect: ~A, found: ~S."))
 308          (car error-msg) (cadr error-msg)(caddr error-msg))
 309         (cons markup-function args))))
 310
 311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 312 ;;; markup constructors
 313 ;;; lilypond-like syntax for markup construction in scheme.
 314
 315 (use-modules (ice-9 receive))
 316
 317 (define (compile-all-markup-expressions expr)
 318   "Return a list of canonical markups expressions, e.g.:
 319   (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
 320   ===>
 321   ((make-COMMAND1-markup arg11 arg12)
 322    (make-COMMAND2-markup arg21 arg22 arg23) ...)"
 323   (do ((rest expr rest)
 324        (markps '() markps))
 325       ((null? rest) (reverse markps))
 326     (receive (m r) (compile-markup-expression rest)
 327              (set! markps (cons m markps))
 328              (set! rest r))))
 329
 330 (define (keyword->make-markup key)
 331   "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
 332   (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
 333
 334 (define (compile-markup-expression expr)
 335   "Return two values: the first complete canonical markup expression
 336    found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...),
 337    and the rest expression."
 338   (cond ((and (pair? expr)
 339               (keyword? (car expr)))
 340          ;; expr === (#:COMMAND arg1 ...)
 341          (let ((command (symbol->string (keyword->symbol (car expr)))))
 342            (if (not (pair? (lookup-markup-command command)))
 343                (ly:error (_ "Not a markup command: ~A") command))
 344            (let* ((sig (markup-command-signature
 345                         (car (lookup-markup-command command))))
 346                   (sig-len (length sig)))
 347              (do ((i 0 (1+ i))
 348                   (args '() args)
 349                   (rest (cdr expr) rest))
 350                  ((>= i sig-len)
 351                   (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
 352                (cond ((eqv? (list-ref sig i) markup-list?)
 353                       ;; (car rest) is a markup list
 354                       (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
 355                       (set! rest (cdr rest)))
 356                      (else
 357                       ;; pick up one arg in `rest'
 358                       (receive (a r) (compile-markup-arg rest)
 359                                (set! args (cons a args))
 360                                (set! rest r))))))))
 361         ((and (pair? expr)
 362               (pair? (car expr))
 363               (keyword? (caar expr)))
 364          ;; expr === ((#:COMMAND arg1 ...) ...)
 365          (receive (m r) (compile-markup-expression (car expr))
 366                   (values m (cdr expr))))
 367         ((and (pair? expr)
 368               (string? (car expr))) ;; expr === ("string" ...)
 369          (values `(make-simple-markup ,(car expr)) (cdr expr)))
 370         (else
 371          ;; expr === (symbol ...) or ((funcall ...) ...)
 372          (values (car expr)
 373                  (cdr expr)))))
 374
 375 (define (compile-all-markup-args expr)
 376   "Transform `expr' into markup arguments"
 377   (do ((rest expr rest)
 378        (args '() args))
 379       ((null? rest) (reverse args))
 380     (receive (a r) (compile-markup-arg rest)
 381              (set! args (cons a args))
 382              (set! rest r))))
 383
 384 (define (compile-markup-arg expr)
 385   "Return two values: the desired markup argument, and the rest arguments"
 386   (cond ((null? expr)
 387          ;; no more args
 388          (values '() '()))
 389         ((keyword? (car expr))
 390          ;; expr === (#:COMMAND ...)
 391          ;; ==> build and return the whole markup expression
 392          (compile-markup-expression expr))
 393         ((and (pair? (car expr))
 394               (keyword? (caar expr)))
 395          ;; expr === ((#:COMMAND ...) ...)
 396          ;; ==> build and return the whole markup expression(s)
 397          ;; found in (car expr)
 398          (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
 399                   (if (null? rest-expr)
 400                       (values markup-expr (cdr expr))
 401                       (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
 402                               (cdr expr)))))
 403         ((and (pair? (car expr))
 404               (pair? (caar expr)))
 405          ;; expr === (((foo ...) ...) ...)
 406          (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
 407         (else (values (car expr) (cdr expr)))))
 408
 409 (define (lookup-markup-command-aux symbol)
 410   (let ((proc (catch 'misc-error
 411                      (lambda ()
 412                        (module-ref (current-module) symbol))
 413                      (lambda (key . args) #f))))
 414     (and (procedure? proc) proc)))
 415
 416 (define-public (lookup-markup-command code)
 417   (let ((proc (lookup-markup-command-aux
 418                (string->symbol (format #f "~a-markup" code)))))
 419     (and proc (markup-function? proc)
 420          (cons proc (markup-command-signature proc)))))
 421
 422 (define-public (lookup-markup-list-command code)
 423   (let ((proc (lookup-markup-command-aux
 424                (string->symbol (format #f "~a-markup-list" code)))))
 425     (and proc (markup-list-function? proc)
 426          (cons proc (markup-command-signature proc)))))