X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=beeed698388c0a26f861f85280da9271f6b32869;hb=8dd6a19768114c9af63d7b110426d6720669599a;hp=c47cb4a6c3685206678ef8ad9fd54111a8c28b9e;hpb=17098f34eace028d047ee7f9cd6f81a84e0e7537;p=lilypond.git diff --git a/scm/markup.scm b/scm/markup.scm index c47cb4a6c3..beeed69838 100644 --- a/scm/markup.scm +++ b/scm/markup.scm @@ -1,8 +1,19 @@ -;;;; markup.scm -- Implement a user extensible markup scheme. +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 2003--2007 Han-Wen Nienhuys +;;;; Copyright (C) 2003--2011 Han-Wen Nienhuys +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . " Internally markup is stored as lists, whose head is a function. @@ -11,7 +22,7 @@ Internally markup is stored as lists, whose head is a function. When the markup is formatted, then FUNCTION is called as follows - (FUNCTION GROB PROPS ARG1 ARG2 ... ) + (FUNCTION GROB PROPS ARG1 ARG2 ... ) GROB is the current grob, PROPS is a list of alists, and ARG1.. are the rest of the arguments. @@ -20,9 +31,7 @@ The function should return a stencil (i.e. a formatted, ready to print object). -To add a builtin markup command, use the define-builtin-markup-command -utility. In a user file, the define-markup-command macro shall be used -(see ly/markup-init.ly). +To add a markup command, use the define-markup-command utility. (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...) \"my command usage and description\" @@ -37,71 +46,161 @@ The command is now available in markup mode, e.g. ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; markup definer utilities -(define-macro (define-builtin-markup-command command-and-args signature . body) +;; For documentation purposes +;; category -> markup functions +(define-public markup-functions-by-category (make-hash-table 150)) +;; 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)) + +(use-modules (ice-9 optargs)) + +(defmacro*-public define-markup-command + (command-and-args signature + #:key (category '()) (properties '()) + #:rest body) " * Define a COMMAND-markup function after command-and-args and body, register COMMAND-markup and its signature, -* add COMMAND-markup to markup-function-list, +* add COMMAND-markup to markup-functions-by-category, -* sets COMMAND-markup markup-signature and markup-keyword object properties, +* sets COMMAND-markup markup-signature object property, * define a make-COMMAND-markup function. Syntax: - (define-builtin-markup-command (COMMAND layout props arg1 arg2 ...) - (arg1-type? arg2-type? ...) + (define-markup-command (COMMAND layout props . arguments) + argument-types + [ #:properties properties ] \"documentation string\" ...command body...) - or: - (define-builtin-markup-command COMMAND (arg1-type? arg2-type? ...) - function) + +where: + `argument-types' 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 +command body, using the respective `default-value' as fallback in case +`property' is not found in `props'. `props' itself is left unchanged: +if you want defaults specified in that manner passed down into other +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 + [ #:category category ] +where: + `category' is either a symbol or a symbol list specifying the + category 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 +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 (if (pair? command-and-args) (car command-and-args) command-and-args)) - (args (if (pair? command-and-args) (cdr command-and-args) '())) + (let* ((command (car command-and-args)) + (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 - ,(if (pair? args) - `(define-public (,command-name ,@args) - ,@body) - (let ((args (gensym "args")) - (markup-command (car body))) - `(define-public (,command-name . ,args) - ,(format #f "Copy of the ~a command." markup-command) - (apply ,markup-command ,args)))) + ,(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-function-list, for markup documentation - (if (not (member ,command-name markup-function-list)) - (set! markup-function-list (cons ,command-name markup-function-list))) + ;; 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)))))) - -(define-macro (define-builtin-markup-list-command command-and-args signature . body) - "Same as `define-builtin-markup-command, but defines a command that, when -interpreted, returns a list of stencils instead os a single one" - (let* ((command (if (pair? command-and-args) (car command-and-args) command-and-args)) - (args (if (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)))) + (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 - ,(if (pair? args) - `(define-public (,command-name ,@args) - ,@body) - (let ((args (gensym "args")) - (markup-command (car body))) - `(define-public (,command-name . ,args) - ,(format #f "Copy of the ~a command." markup-command) - (apply ,markup-command ,args)))) + ,(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 - (if (not (member ,command-name markup-list-function-list)) - (set! markup-list-function-list (cons ,command-name - markup-list-function-list))) + (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 @@ -115,28 +214,27 @@ interpreted, returns a list of stencils instead os a single one" against SIGNATURE, reporting MAKE-NAME as the user-invoked function. " (let* ((arglen (length args)) - (siglen (length signature)) - (error-msg (if (and (> siglen 0) (> arglen 0)) - (markup-argument-list-error signature args 1) - #f))) + (siglen (length signature)) + (error-msg (if (and (> siglen 0) (> arglen 0)) + (markup-argument-list-error signature args 1) + #f))) (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0)) - (ly:error (string-append make-name ": " - (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S")) + (ly:error (string-append make-name ": " + (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S")) siglen arglen args)) (if error-msg - (ly:error + (ly:error (string-append make-name ": " - (_ "Invalid argument in position ~A. Expect: ~A, found: ~S.") - error-msg)) + (_ "Invalid argument in position ~A. Expect: ~A, found: ~S.")) + (car error-msg) (cadr error-msg)(caddr error-msg)) (cons markup-function args)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; markup constructors ;;; lilypond-like syntax for markup construction in scheme. -(use-modules (ice-9 optargs) - (ice-9 receive)) +(use-modules (ice-9 receive)) (defmacro*-public markup (#:rest body) "The `markup' macro provides a lilypond-like syntax for building markups. @@ -154,17 +252,17 @@ Example: <==> (markup \"foo\" #:raise 0.2 #:hbracket #:bold \"bar\" - #:override '(baseline-skip . 4) + #:override '(baseline-skip . 4) #:bracket #:column (\"baz\" \"bazr\" \"bla\")) Use `markup*' in a \\notemode context." - + (car (compile-all-markup-expressions `(#:line ,body)))) (defmacro*-public markup* (#:rest body) "Same as `markup', for use in a \\notes block." `(ly:export (markup ,@body))) - - + + (define (compile-all-markup-expressions expr) "Return a list of canonical markups expressions, e.g.: (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23) @@ -189,24 +287,26 @@ Use `markup*' in a \\notemode context." (cond ((and (pair? expr) (keyword? (car expr))) ;; expr === (#:COMMAND arg1 ...) - (let* ((command (symbol->string (keyword->symbol (car expr)))) - (sig (markup-command-signature - (car (lookup-markup-command command)))) - (sig-len (length sig))) - (do ((i 0 (1+ i)) - (args '() args) - (rest (cdr expr) rest)) - ((>= i sig-len) - (values (cons (keyword->make-markup (car expr)) (reverse args)) rest)) - (cond ((eqv? (list-ref sig i) markup-list?) - ;; (car rest) is a markup list - (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args)) - (set! rest (cdr rest))) - (else - ;; pick up one arg in `rest' - (receive (a r) (compile-markup-arg rest) - (set! args (cons a args)) - (set! rest r))))))) + (let ((command (symbol->string (keyword->symbol (car expr))))) + (if (not (pair? (lookup-markup-command command))) + (ly:error (_ "Not a markup command: ~A") command)) + (let* ((sig (markup-command-signature + (car (lookup-markup-command command)))) + (sig-len (length sig))) + (do ((i 0 (1+ i)) + (args '() args) + (rest (cdr expr) rest)) + ((>= i sig-len) + (values (cons (keyword->make-markup (car expr)) (reverse args)) rest)) + (cond ((eqv? (list-ref sig i) markup-list?) + ;; (car rest) is a markup list + (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args)) + (set! rest (cdr rest))) + (else + ;; pick up one arg in `rest' + (receive (a r) (compile-markup-arg rest) + (set! args (cons a args)) + (set! rest r)))))))) ((and (pair? expr) (pair? (car expr)) (keyword? (caar expr))) @@ -257,62 +357,28 @@ Use `markup*' in a \\notemode context." ;;;;;;;;;;;;;;; ;;; Utilities for storing and accessing markup commands signature -;;; and keyword. ;;; Examples: ;;; ;;; (set! (markup-command-signature raise-markup) (list number? markup?)) -;;; ==> ((# #) . scheme0-markup1) +;;; ==> (# #) ;;; ;;; (markup-command-signature raise-markup) ;;; ==> (# #) ;;; -;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1" -;;; - -(define-public (markup-command-keyword markup-command) - "Return markup-command's argument keyword, ie a string describing the command - arguments, eg. \"scheme0markup1\"" - (object-property markup-command 'markup-keyword)) (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 and keyword (as object properties)" + "Set markup-command's signature (as object property)" (set-object-property! markup-command 'markup-signature signature) - (set-object-property! markup-command 'markup-keyword - (markup-signature-to-keyword signature)) signature) (define-public markup-command-signature (make-procedure-with-setter markup-command-signature-ref markup-command-signature-set!)) -;; For documentation purposes -(define-public markup-function-list (list)) -(define-public markup-list-function-list (list)) - -(define-public (markup-signature-to-keyword sig) - " (A B C) -> a0-b1-c2 " - (if (null? sig) - 'empty - (string->symbol (string-join (map - (let* ((count 0)) - (lambda (func) - (set! count (+ count 1)) - (string-append - ;; for reasons I don't get, - ;; (case func ((markup?) .. ) - ;; doesn't work. - (cond - ((eq? func markup?) "markup") - ((eq? func markup-list?) "markup-list") - (else "scheme")) - (number->string (- count 1))))) - sig) - "-")))) - (define (lookup-markup-command-aux symbol) (let ((proc (catch 'misc-error (lambda () @@ -324,13 +390,13 @@ Use `markup*' in a \\notemode context." (let ((proc (lookup-markup-command-aux (string->symbol (format #f "~a-markup" code))))) (and proc (markup-function? proc) - (cons proc (markup-command-keyword proc))))) + (cons proc (markup-command-signature proc))))) (define-public (lookup-markup-list-command code) (let ((proc (lookup-markup-command-aux (string->symbol (format #f "~a-markup-list" code))))) (and proc (markup-list-function? proc) - (cons proc (markup-command-keyword proc))))) + (cons proc (markup-command-signature proc))))) ;;;;;;;;;;;;;;;;;;;;;; ;;; used in parser.yy to map a list of markup commands on markup arguments @@ -402,10 +468,10 @@ a markup list function and its arguments." (markup-argument-list? (markup-command-signature (car arg)) (cdr arg))))) -;; -;; ;; -;; +;; +;; +;; (define (markup-thrower-typecheck arg) "typecheck, and throw an error when something amiss. @@ -423,7 +489,7 @@ Uncovered - cheap-markup? is used." ;; ;; good enough if you only use make-XXX-markup functions. -;; +;; (define (cheap-markup? x) (or (string? x) (and (pair? x) @@ -431,7 +497,7 @@ Uncovered - cheap-markup? is used." ;; ;; replace by markup-thrower-typecheck for more detailed diagnostics. -;; +;; (define-public markup? cheap-markup?) ;; utility @@ -463,7 +529,7 @@ Uncovered - cheap-markup? is used." "DOCME" (if (and (pair? stencils) (ly:stencil? (car stencils))) - + (if (and (pair? (cdr stencils)) (ly:stencil? (cadr stencils))) (let* ((tail (stack-stencil-line space (cdr stencils)))