From: David Kastrup Date: Fri, 28 Jul 2017 14:57:17 +0000 (+0200) Subject: Issue 5167/3: Split off `markup-lambda' from `define-markup-command' X-Git-Url: https://git.donarmstrong.com/lilypond.git?p=lilypond.git;a=commitdiff_plain;h=d2199b0163c33bcb7504c87e57eefbea93e08c88 Issue 5167/3: Split off `markup-lambda' from `define-markup-command' Also `markup-list-lambda' from `define-markup-list-command'. --- diff --git a/scm/markup-macros.scm b/scm/markup-macros.scm index 297f850b3c..46bae0c51d 100644 --- a/scm/markup-macros.scm +++ b/scm/markup-macros.scm @@ -54,13 +54,9 @@ The command is now available in markup mode, e.g. (use-modules (ice-9 optargs)) -(defmacro*-public define-markup-command - (command-and-args signature - #:key (category '()) (properties '()) - #:rest body) +(defmacro-public define-markup-command (command-and-args . definition) " -* Define a COMMAND-markup function after command-and-args and body, -register COMMAND-markup and its signature, +* Define a COMMAND-markup function after command-and-args and body * add categories to markup-function-category, @@ -70,13 +66,13 @@ register COMMAND-markup and its signature, Syntax: (define-markup-command (COMMAND layout props . arguments) - argument-types + signature [ #:properties properties ] \"documentation string\" ...command body...) where: - `argument-types' is a list of type predicates for arguments + `signature' is a list of type predicates for arguments `properties' a list of (property default-value) lists The specified properties are available as let-bound variables in the @@ -88,7 +84,7 @@ markup functions, you need to adjust `props' yourself. The autogenerated documentation makes use of some optional specifications that are otherwise ignored: -After `argument-types', you may also specify +After `signature', you may also specify [ #:category category ] where: `category' is either a symbol or a symbol list specifying the @@ -100,95 +96,95 @@ that this markup command is called by the newly defined command, adding its properties to the documented properties of the new command. There is no protection against circular definitions. " - (let* ((command (car command-and-args)) - (args (cdr command-and-args)) + (let* ((command (if (pair? command-and-args) + (car command-and-args) + command-and-args)) + (args (and (pair? command-and-args) (cdr command-and-args))) (command-name (string->symbol (format #f "~a-markup" command))) (make-markup-name (string->symbol (format #f "make-~a-markup" command)))) - (while (and (pair? body) (keyword? (car body))) - (set! body (cddr body))) `(begin - ;; define the COMMAND-markup function - ,(let* ((documentation - (format #f "~a\n~a" (cddr args) - (if (string? (car body)) (car body) ""))) - (real-body (if (or (not (string? (car body))) - (null? (cdr body))) - body (cdr body)))) - `(define-public (,command-name ,@args) + ,(if args + `(define-public ,command-name (markup-lambda ,args ,@definition)) + `(define-public ,command-name ,@definition)) + (define-public (,make-markup-name . args) + (,make-markup ,command-name ,(symbol->string make-markup-name) args))))) + + +(defmacro*-public markup-lambda + (args signature + #:key (category '()) (properties '()) + #:rest body) + "Defines and returns an anonymous markup command. Other than +not registering the markup command, this is identical to +`define-markup-command`" + (while (and (pair? body) (keyword? (car body))) + (set! body (cddr body))) + ;; define the COMMAND-markup function + (let* ((documentation + (format #f "~a\n~a" (cddr args) + (if (string? (car body)) (car body) ""))) + (real-body (if (or (not (string? (car body))) + (null? (cdr body))) + body (cdr body))) + (result + `(lambda ,args ,documentation (let ,(map (lambda (prop-spec) (let ((prop (car prop-spec)) - (default-value (if (null? (cdr prop-spec)) - #f - (cadr prop-spec))) + (default-value (and (pair? (cdr prop-spec)) + (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 - (set! (markup-function-category ,command-name) ',category) - ;; Used properties, for markup documentation - (set! (markup-function-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))))) - properties))) - ;; define the make-COMMAND-markup function - (define-public (,make-markup-name . args) - (,make-markup ,command-name ,(symbol->string make-markup-name) args))))) - -(defmacro*-public define-markup-list-command - (command-and-args signature #:key (properties '()) #:rest body) + ,@real-body)))) + (define (markup-lambda-worker command signature properties category) + (set! (markup-command-signature command) signature) + ;; Register the new function, for markup documentation + (set! (markup-function-category command) category) + ;; Used properties, for markup documentation + (set! (markup-function-properties command) properties) + command) + `(,markup-lambda-worker + ,result + (list ,@signature) + (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))))) + properties)) + ',category))) + +(defmacro-public define-markup-list-command + (command-and-args . definition) "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)) + (let* ((command (if (pair? command-and-args) + (car command-and-args) + command-and-args)) + (args (and (pair? command-and-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 - (format #f "~a\n~a" (cddr args) - (if (string? (car body)) (car body) ""))) - (real-body (if (or (not (string? (car body))) - (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)) - ;; Used properties, for markup documentation - (set! (markup-function-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))))) - properties))) - ;; it's a markup-list command: - (set! (markup-list-function? ,command-name) #t) - ;; define the make-COMMAND-markup-list function + ,(if args + `(define-public ,command-name (markup-list-lambda ,args ,@definition)) + `(define-public ,command-name ,@definition)) (define-public (,make-markup-name . args) (list (,make-markup ,command-name ,(symbol->string make-markup-name) args)))))) +(defmacro*-public markup-list-lambda + (arg signature #:key (properties '()) #:rest body) + "Same as `markup-lambda' but defines a markup list command that, when +interpreted, returns a list of stencils instead of a single one" + (let () ; Guile 1.8 defmacro* workaround + (define (markup-lambda-listify fun) + (set! (markup-list-function? fun) #t) + fun) + (list markup-lambda-listify (cons* 'markup-lambda arg signature body)))) + ;;;;;;;;;;;;;;; ;;; Utilities for storing and accessing markup commands signature ;;; Examples: