- `(let ((lily-module (resolve-module '(lily))))
- ;; define the COMMAND-markup procedure in (lily) module
- ,(if (pair? command-and-args)
- ;; two cases:
- ;; 1/ (define (COMMAND-markup layout props arg1 arg2 ...)
- ;; ..command body))
- `(in-module-define-function (lily) (,command-name ,@(cdr command-and-args))
- ,@body)
- ;; 2/ (define COMMAND-markup function)
- `(in-module-define-variable (lily) ,command-name ,(car body)))
- (let ((command-proc (module-ref lily-module ',command-name)))
- ;; register its command signature
- (set! (markup-command-signature command-proc)
- (list ,@signature))
- ;; add the COMMAND-markup procedure to the list of markup functions
- (if (not (member command-proc markup-function-list))
- (set! markup-function-list (cons command-proc markup-function-list)))
- ;; define the make-COMMAND-markup procedure in (lily) module
- (in-module-define-function (lily) (,make-markup-name . args)
- (make-markup command-proc
- ,(symbol->string make-markup-name)
- (list ,@signature)
- args))))))
+ (while (and (pair? body) (keyword? (car body)))
+ (set! body (cddr body)))
+ `(begin
+ ;; define the COMMAND-markup function
+ ,(let* ((documentation (if (string? (car body))
+ (list (car body))
+ '()))
+ (real-body (if (or (null? documentation)
+ (null? (cdr body)))
+ body (cdr body))))
+ `(define-public (,command-name ,@args)
+ ,@documentation
+ (let ,(map (lambda (prop-spec)
+ (let ((prop (car prop-spec))
+ (default-value (if (null? (cdr prop-spec))
+ #f
+ (cadr prop-spec)))
+ (props (cadr args)))
+ `(,prop (chain-assoc-get ',prop ,props ,default-value))))
+ (filter pair? properties))
+ ,@real-body)))
+ (set! (markup-command-signature ,command-name) (list ,@signature))
+ ;; Register the new function, for markup documentation
+ ,@(map (lambda (category)
+ `(hashq-set!
+ (or (hashq-ref markup-functions-by-category ',category)
+ (let ((hash (make-weak-key-hash-table 151)))
+ (hashq-set! markup-functions-by-category ',category
+ hash)
+ hash))
+ ,command-name #t))
+ (if (list? category) category (list category)))
+ ;; Used properties, for markup documentation
+ (hashq-set! markup-functions-properties
+ ,command-name
+ (list ,@(map (lambda (prop-spec)
+ (cond ((symbol? prop-spec)
+ prop-spec)
+ ((not (null? (cdr prop-spec)))
+ `(list ',(car prop-spec) ,(cadr prop-spec)))
+ (else
+ `(list ',(car prop-spec)))))
+ (if (pair? args)
+ properties
+ (list)))))
+ ;; define the make-COMMAND-markup function
+ (define-public (,make-markup-name . args)
+ (let ((sig (list ,@signature)))
+ (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
+
+(defmacro*-public define-markup-list-command
+ (command-and-args signature #:key (properties '()) #:rest body)
+ "Same as `define-markup-command', but defines a command that, when
+interpreted, returns a list of stencils instead of a single one"
+ (let* ((command (car command-and-args))
+ (args (cdr command-and-args))
+ (command-name (string->symbol (format #f "~a-markup-list" command)))
+ (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
+ (while (and (pair? body) (keyword? (car body)))
+ (set! body (cddr body)))
+ `(begin
+ ;; define the COMMAND-markup-list function
+ ,(let* ((documentation (if (string? (car body))
+ (list (car body))
+ '()))
+ (real-body (if (or (null? documentation)
+ (null? (cdr body)))
+ body (cdr body))))
+ `(define-public (,command-name ,@args)
+ ,@documentation
+ (let ,(map (lambda (prop-spec)
+ (let ((prop (car prop-spec))
+ (default-value (if (null? (cdr prop-spec))
+ #f
+ (cadr prop-spec)))
+ (props (cadr args)))
+ `(,prop (chain-assoc-get ',prop ,props ,default-value))))
+ (filter pair? properties))
+ ,@real-body)))
+ (set! (markup-command-signature ,command-name) (list ,@signature))
+ ;; add the command to markup-list-function-list, for markup documentation
+ (hashq-set! markup-list-functions ,command-name #t)
+ ;; Used properties, for markup documentation
+ (hashq-set! markup-functions-properties
+ ,command-name
+ (list ,@(map (lambda (prop-spec)
+ (cond ((symbol? prop-spec)
+ prop-spec)
+ ((not (null? (cdr prop-spec)))
+ `(list ',(car prop-spec) ,(cadr prop-spec)))
+ (else
+ `(list ',(car prop-spec)))))
+ (if (pair? args)
+ properties
+ (list)))))
+ ;; it's a markup-list command:
+ (set-object-property! ,command-name 'markup-list-command #t)
+ ;; define the make-COMMAND-markup-list function
+ (define-public (,make-markup-name . args)
+ (let ((sig (list ,@signature)))
+ (list (make-markup ,command-name
+ ,(symbol->string make-markup-name) sig args)))))))