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