Issue 5167/1: Reorganize markup commands to use object properties

This loosens the ties between the actual markup function and its
calling methods.

diff --git a/lily/include/lily-imports.hh b/lily/include/lily-imports.hh
index 1b63a537179a5a20f8922f008102d2692d7731a6..a22da30f66350bb7766d37a06ebbf4386db2cbd7 100644 (file)
--- a/lily/include/lily-imports.hh
+++ b/lily/include/lily-imports.hh
@@ -87,6 +87,7 @@ namespace Lily {
   extern Variable make_span_event;
   extern Variable markup_p;
   extern Variable markup_command_signature;
+  extern Variable markup_list_function_p;
   extern Variable markup_list_p;
   extern Variable midi_program;
 #if !GUILEV2

diff --git a/lily/lexer.ll b/lily/lexer.ll
index 21d2fc1acc16bc32cd224c1e0013fcf93151db4f..dde8fc00dc98a9050bd6fb766b0e28d175ec6cc4 100644 (file)
--- a/lily/lexer.ll
+++ b/lily/lexer.ll
@@ -424,8 +424,7 @@ BOM_UTF8    \357\273\277
                {
                        yylval = sval;
                        int token = MARKUP_FUNCTION;
-                       if (scm_is_true (scm_object_property
-                                        (sval, ly_symbol2scm ("markup-list-command"))))
+                       if (scm_is_true (Lily::markup_list_function_p (sval)))
                                token = MARKUP_LIST_FUNCTION;
                        push_markup_predicates (sig);
                        return token;

diff --git a/lily/lily-imports.cc b/lily/lily-imports.cc
index f3cd3b1ab244b6287fec83edaa75b1f8f2b84334..699b0850e7fc0eeb84bdb753b61cf6574963895f 100644 (file)
--- a/lily/lily-imports.cc
+++ b/lily/lily-imports.cc
@@ -81,6 +81,7 @@ namespace Lily {
   Variable make_span_event ("make-span-event");
   Variable markup_p ("markup?");
   Variable markup_command_signature ("markup-command-signature");
+  Variable markup_list_function_p ("markup-list-function?");
   Variable markup_list_p ("markup-list?");
   Variable midi_program ("midi-program");
 #if !GUILEV2

diff --git a/lily/text-interface.cc b/lily/text-interface.cc
index bad6d50281f626ccce966a8e15200b9a4f80ea8d..fc797073734cbc405183f42cd112fc0f607619e2 100644 (file)
--- a/lily/text-interface.cc
+++ b/lily/text-interface.cc
@@ -210,14 +210,9 @@ Text_interface::is_markup (SCM x)
 {
   return scm_is_string (x)
     || (scm_is_pair (x)
-        && scm_is_true
-        (scm_object_property (scm_car (x),
-                              ly_symbol2scm ("markup-signature")))
-        && scm_is_false
-        (scm_object_property (scm_car (x),
-                              ly_symbol2scm ("markup-list-command"))));
+        && scm_is_true (Lily::markup_command_signature (scm_car (x)))
+        && scm_is_false (Lily::markup_list_function_p (scm_car (x))));
 }
-
 bool
 Text_interface::is_markup_list (SCM x)
 {

diff --git a/scm/document-markup.scm b/scm/document-markup.scm
index 35347ae15083c0fac3c47c416c05857f88d4b37b..bbc8939e0281943478a32bfb2e7eed3fc1c8ba70 100644 (file)
--- a/scm/document-markup.scm
+++ b/scm/document-markup.scm
@@ -18,7 +18,7 @@
 
 
 (define (doc-markup-function-properties func)
-  (let ((properties (hashq-ref markup-functions-properties func))
+  (let ((properties (markup-function-properties func))
         (prop-strings (list)))
     (for-each (lambda (prop-spec)
                 (set! prop-strings
@@ -41,16 +41,17 @@
               (or properties (list)))
     prop-strings))
 
-(define (doc-markup-function func)
-  (let* ((full-doc (procedure-documentation func))
+(define (doc-markup-function func-pair)
+  (let* ((f-name (symbol->string (car func-pair)))
+         (func (cdr func-pair))
+         (full-doc (procedure-documentation func))
          (match-args (and full-doc (string-match "^\\([^)]*\\)\n" full-doc)))
          (arg-names (if match-args
                         (with-input-from-string (match:string match-args) read)
                         (circular-list "arg")))
          (doc-str (if match-args (match:suffix match-args) full-doc))
-         (f-name (symbol->string (procedure-name  func)))
          (c-name (regexp-substitute/global #f "-markup(-list)?$" f-name  'pre "" 'post))
-         (sig (object-property func 'markup-signature))
+         (sig (markup-command-signature func))
          (sig-type-names (map type-name sig))
          (signature-str
           (string-join
@@ -73,19 +74,41 @@
                           (string-concatenate prop-strings)
                           "@end itemize\n"))))))
 
-(define (markup-function<? a b)
-  (ly:string-ci<? (symbol->string (procedure-name a)) (symbol->string (procedure-name b))))
+(define (markup-name<? a b)
+  (ly:string-ci<? (symbol->string (car a)) (symbol->string (car b))))
+
+(define all-markup-commands '())
+(define all-markup-list-commands '())
+
+(for-each
+ (lambda (m)
+   (module-for-each (lambda (sym var)
+                      (let ((val (variable-ref var)))
+                        (cond ((markup-function? val)
+                               (set! all-markup-commands
+                                     (acons sym val all-markup-commands)))
+                              ((markup-list-function? val)
+                               (set! all-markup-list-commands
+                                     (acons sym val all-markup-list-commands))))))
+                    (module-public-interface m)))
+ (cons (current-module) (map resolve-module '((lily) (scm accreg)))))
+
+(set! all-markup-commands (sort! all-markup-commands markup-name<?))
+(set! all-markup-list-commands (sort! all-markup-list-commands markup-name<?))
 
 (define (markup-category-doc-node category)
   (let* ((category-string (symbol->string category))
          (category-name (string-capitalize
                          (regexp-substitute/global
                           #f "-" category-string 'pre " " 'post)))
-         (markup-functions (hash-fold (lambda (markup-function dummy functions)
-                                        (cons markup-function functions))
-                                      '()
-                                      (hashq-ref markup-functions-by-category
-                                                 category))))
+         (markup-functions (filter
+                            (lambda (fun)
+                              (let ((cats (markup-function-category (cdr fun))))
+                                (if (pair? cats)
+                                    (memq category cats)
+                                    (eq? category cats))))
+                            all-markup-commands)))
+
     (make <texi-node>
       #:appendix #t
       #:name category-name
@@ -93,8 +116,7 @@
       #:text (string-append
               "@table @asis"
               (string-concatenate
-               (map doc-markup-function
-                    (sort markup-functions markup-function<?)))
+               (map doc-markup-function markup-functions))
               "\n@end table"))))
 
 (define (markup-doc-node)
@@ -105,24 +127,26 @@
     #:text "The following commands can all be used inside @code{\\markup @{ @}}."
     #:children (let* (;; when a new category is defined, update `ordered-categories'
                       (ordered-categories '(font align graphic music instrument-specific-markup accordion-registers other))
-                      (raw-categories (hash-fold (lambda (category functions categories)
-                                                   (cons category categories))
-                                                 (list)
-                                                 markup-functions-by-category))
+                      (raw-categories
+                       (fold (lambda (next union)
+                               (let ((cat (markup-function-category next)))
+                                 (cond ((pair? cat)
+                                        (lset-union eq? cat union))
+                                       ((symbol? cat)
+                                        (lset-adjoin eq? cat union))
+                                       (else union))))
+                             '()
+                             all-markup-commands))
                       (categories (append ordered-categories
-                                          (filter (lambda (cat)
-                                                    (not (memq cat ordered-categories)))
-                                                  raw-categories))))
+                                          (sort (lset-difference eq?
+                                                                 raw-categories
+                                                                 ordered-categories)
+                                                symbol<?))))
                  (map markup-category-doc-node categories))))
 
 (define (markup-list-doc-string)
   (string-append
    "@table @asis"
    (string-concatenate
-    (map doc-markup-function
-         (sort (hash-fold (lambda (markup-list-function dummy functions)
-                            (cons markup-list-function functions))
-                          '()
-                          markup-list-functions)
-               markup-function<?)))
+    (map doc-markup-function all-markup-list-commands))
    "\n@end table"))

diff --git a/scm/markup-macros.scm b/scm/markup-macros.scm
index 6c50ec51280e614796229fd565401b9474d16d07..a55e8c45e90621ed6e211a135cf423d9ccdf2012 100644 (file)
--- a/scm/markup-macros.scm
+++ b/scm/markup-macros.scm
@@ -47,12 +47,10 @@ The command is now available in markup mode, e.g.
 ;;; markup definer utilities
 
 ;; For documentation purposes
-;; category -> markup functions
-(define-public markup-functions-by-category (make-hash-table 150))
+;; markup function -> categories
+(define-public markup-function-category (make-object-property))
 ;; markup function -> used properties
-(define-public markup-functions-properties (make-weak-key-hash-table 151))
-;; List of markup list functions
-(define-public markup-list-functions (make-weak-key-hash-table 151))
+(define-public markup-function-properties (make-object-property))
 
 (use-modules (ice-9 optargs))
 
@@ -64,9 +62,9 @@ The command is now available in markup mode, e.g.
 * Define a COMMAND-markup function after command-and-args and body,
 register COMMAND-markup and its signature,
 
-* add COMMAND-markup to markup-functions-by-category,
+* add categories to markup-function-category,
 
-* sets COMMAND-markup markup-signature object property,
+* sets the markup-signature object property,
 
 * define a make-COMMAND-markup function.
 
@@ -94,7 +92,7 @@ After `argument-types', you may also specify
                                  [ #:category category ]
 where:
   `category' is either a symbol or a symbol list specifying the
-             category for this markup command in the docs.
+             categories for this markup command in the docs.
 
 As an element of the `properties' list, you may directly use a
 COMMANDx-markup symbol instead of a `(prop value)' list to indicate
@@ -129,28 +127,17 @@ command.  There is no protection against circular definitions.
                ,@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)))
+       (set! (markup-function-category ,command-name) ',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)))))
+       (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)
          (let ((sig (list ,@signature)))
@@ -186,23 +173,18 @@ interpreted, returns a list of stencils instead of a single one"
                         (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)))))
+       (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-object-property! ,command-name 'markup-list-command #t)
+       (set! (markup-list-function? ,command-name) #t)
        ;; define the make-COMMAND-markup-list function
        (define-public (,make-markup-name . args)
          (let ((sig (list ,@signature)))
@@ -220,29 +202,16 @@ interpreted, returns a list of stencils instead of a single one"
 ;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
 ;;;
 
-(define-public (markup-command-signature-ref markup-command)
-  "Return markup-command's signature (the 'markup-signature object property)"
-  (object-property markup-command 'markup-signature))
-
-(define-public (markup-command-signature-set! markup-command signature)
-  "Set markup-command's signature (as object property)"
-  (set-object-property! markup-command 'markup-signature signature)
-  signature)
-
-(define-public markup-command-signature
-  (make-procedure-with-setter markup-command-signature-ref
-                              markup-command-signature-set!))
+(define-public markup-command-signature (make-object-property))
 
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; markup type predicates
 
 (define-public (markup-function? x)
   (and (markup-command-signature x)
-       (not (object-property x 'markup-list-command))))
+       (not (markup-list-function? x))))
 
-(define-public (markup-list-function? x)
-  (and (markup-command-signature x)
-       (object-property x 'markup-list-command)))
+(define-public markup-list-function? (make-object-property))
 
 (define-public (markup-command-list? x)
   "Determine if `x' is a markup command list, ie. a list composed of