From: David Kastrup Date: Sat, 22 Jul 2017 20:08:13 +0000 (+0200) Subject: Issue 5167/1: Reorganize markup commands to use object properties X-Git-Url: https://git.donarmstrong.com/?p=lilypond.git;a=commitdiff_plain;h=8659a99f233f5c4684292728e7ad4206669b35b0 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 1b63a53717..a22da30f66 100644 --- 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 21d2fc1acc..dde8fc00dc 100644 --- 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 f3cd3b1ab2..699b0850e7 100644 --- 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 bad6d50281..fc79707373 100644 --- 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 35347ae150..bbc8939e02 100644 --- 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-functionstring (procedure-name a)) (symbol->string (procedure-name b)))) +(define (markup-namestring (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-namestring 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 #: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 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" ;;; ==> (# #) ;;; -(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