-;;;; 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 <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; 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 <http://www.gnu.org/licenses/>.
"
Internally markup is stored as lists, whose head is a function.
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\"
;; category -> markup functions
(define-public markup-functions-by-category (make-hash-table 150))
;; markup function -> used properties
-(define-public markup-functions-properties (make-hash-table 150))
+(define-public markup-functions-properties (make-weak-key-hash-table 151))
;; List of markup list functions
-(define-public markup-list-function-list (list))
+(define-public markup-list-functions (make-weak-key-hash-table 151))
+
+(use-modules (ice-9 optargs))
-(define-macro (define-builtin-markup-command command-and-args signature
- category properties-or-copied-function . body)
+(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,
* define a make-COMMAND-markup function.
Syntax:
- (define-builtin-markup-command (COMMAND layout props . arguments)
+ (define-markup-command (COMMAND layout props . arguments)
argument-types
- category
- properties
+ [ #:category category ]
+ [ #:properties properties ]
\"documentation string\"
...command body...)
or:
- (define-builtin-markup-command COMMAND
+ (define-markup-command COMMAND
argument-types
- category
+ [ #:category category ]
function)
where:
properties a list of (property default-value) lists or COMMANDx-markup elements
(when a COMMANDx-markup is found, the properties of the said commandx are
added instead). No check is performed against cyclical references!
+
+ The specified properties are available as let-bound variables in the
+ command body.
"
(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" 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)
- (let ((documentation (car body))
- (real-body (cdr body))
- (properties properties-or-copied-function))
+ (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
+ ,@documentation
(let ,(filter identity
(map (lambda (prop-spec)
(if (pair? prop-spec)
properties))
,@real-body)))
(let ((args (gensym "args"))
- (markup-command properties-or-copied-function))
+ (markup-command (car body)))
`(define-public (,command-name . ,args)
,(format #f "Copy of the ~a command." markup-command)
(apply ,markup-command ,args))))
(set! (markup-command-signature ,command-name) (list ,@signature))
;; Register the new function, for markup documentation
,@(map (lambda (category)
- `(hashq-set! markup-functions-by-category ',category
- (cons ,command-name
- (or (hashq-ref markup-functions-by-category ',category)
- (list)))))
- (if (list? category) category (list 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
(else
`(list ',(car prop-spec)))))
(if (pair? args)
- properties-or-copied-function
+ 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
- properties . body)
- "Same as `define-builtin-markup-command, but defines a command that, when
+(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 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))))
+ (while (and (pair? body) (keyword? (car body)))
+ (set! body (cddr body)))
`(begin
;; define the COMMAND-markup-list function
,(if (pair? args)
- (let ((documentation (car body))
- (real-body (cdr body)))
+ (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
+ ,@documentation
(let ,(filter identity
(map (lambda (prop-spec)
(if (pair? prop-spec)
`(,prop (chain-assoc-get ',prop ,props ,default-value)))
#f))
properties))
- ,@body)))
+ ,@real-body)))
(let ((args (gensym "args"))
(markup-command (car body)))
`(define-public (,command-name . ,args)
(apply ,markup-command ,args))))
(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
(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.
projects / lilypond.git / blobdiff