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 297f850b3c736e2fbdc0f4294182d1eb0351a29f..46bae0c51d701e2e74233f514e21b433c269c280 100644 (file)
--- 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: