;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; Copyright (C) 2003--2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2011 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
[ #:properties properties ]
\"documentation string\"
...command body...)
- or:
- (define-markup-command COMMAND
- argument-types
- [ #:category category ]
- function)
where:
`argument-types' is a list of type predicates for arguments
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)
- (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)))
- (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))
;; Register the new function, for markup documentation
,@(map (lambda (category)
(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 (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-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 (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)))
- (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
(hashq-set! markup-list-functions ,command-name #t)
,(symbol->string make-markup-name) sig args)))))))
(define-public (make-markup markup-function make-name signature args)
- " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
-against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
-"
+ "Construct a markup object from @var{markup-function} and @var{args}.
+Typecheck against @var{signature}, reporting @var{make-name} as the
+user-invoked function."
(let* ((arglen (length args))
(siglen (length signature))
(error-msg (if (and (> siglen 0) (> arglen 0))
;;;
(define-public (markup-command-signature-ref markup-command)
- "Return markup-command's signature (the 'markup-signature object property)"
+ "Return @var{markup-command}'s signature (the @code{'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 @var{markup-command}'s signature (as object property)."
(set-object-property! markup-command 'markup-signature signature)
signature)
;;;;;;;;;;;;;;;;;;;;;;
;;; used in parser.yy to map a list of markup commands on markup arguments
(define-public (map-markup-command-list commands markups)
- "`markups' being a list of markups, eg (markup1 markup2 markup3),
-and `commands' a list of commands with their scheme arguments, in reverse order,
-eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
- ((bold (raise 4 (italic markup1)))
- (bold (raise 4 (italic markup2)))
- (bold (raise 4 (italic markup3))))
-"
+ "@var{markups} being a list of markups, for example
+@code{(markup1 markup2 markup3)}, and @var{commands} a list of commands with
+their scheme arguments, in reverse order, for example
+@code{((italic) (raise 4) (bold))}, map the commands on each markup argument,
+for example
+@example
+((bold (raise 4 (italic markup1)))
+ (bold (raise 4 (italic markup2)))
+ (bold (raise 4 (italic markup3))))
+@end example"
(map-in-order (lambda (arg)
(let ((result arg))
(for-each (lambda (cmd)
(object-property x 'markup-list-command)))
(define-public (markup-command-list? x)
- "Determine if `x' is a markup command list, ie. a list composed of
-a markup list function and its arguments."
+ "Determine whether @var{x} is a markup command list, i.e. a list
+composed of a markup list function and its arguments."
(and (pair? x) (markup-list-function? (car x))))
(define-public (markup-list? arg)
- "Return a true value if `x' is a list of markups or markup command lists."
+ "Return @code{#t} if @var{x} is a list of markups or markup command lists."
(define (markup-list-inner? lst)
(or (null? lst)
(and (or (markup? (car lst)) (markup-command-list? (car lst)))
projects / lilypond.git / blobdiff