-;;;; 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--2006 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
+;;;; 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.
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.
print object).
-To add a function, use the define-markup-command utility.
+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\"
The command is now available in markup mode, e.g.
-
\\markup { .... \\MYCOMMAND #1 argument ... }
" ; "
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; markup definer utilities
-(defmacro-public in-module-define-variable (module-name symbol value)
- "Define a variable in a module and export its name.
- (in-module-define-variable (some module) symbol value)"
- (let ((gmodule (gensym "module")))
- `(let ((,gmodule (resolve-module ',module-name)))
- (module-define! ,gmodule ',symbol ,value)
- (module-export! ,gmodule '(,symbol)))))
-
-(defmacro-public in-module-define-function
- (module-name function-name+arg-list . body)
- "Define a public function in a module:
- (in-module-define-function (some module) (function-name . args)
- ..body..)"
- `(in-module-define-variable
- ,module-name
- ,(car function-name+arg-list)
- (let ((proc (lambda ,(cdr function-name+arg-list)
- ,@body)))
- (set-procedure-property! proc
- 'name
- ',(car function-name+arg-list))
- proc)))
-
-;;; `define-markup-command' can be used both for built-in markup
-;;; definitions and user defined markups.
-(defmacro-public define-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-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-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))
+ (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))))
- `(let ((lily-module (resolve-module '(lily))))
- ;; define the COMMAND-markup procedure in (lily) module
- ,(if (pair? command-and-args)
- ;; two cases:
- ;; 1/ (define (COMMAND-markup layout props arg1 arg2 ...)
- ;; ..command body))
- `(in-module-define-function (lily) (,command-name ,@(cdr command-and-args))
- ,@body)
- ;; 2/ (define COMMAND-markup function)
- `(in-module-define-variable (lily) ,command-name ,(car body)))
- (let ((command-proc (module-ref lily-module ',command-name)))
- ;; register its command signature
- (set! (markup-command-signature command-proc)
- (list ,@signature))
- ;; add the COMMAND-markup procedure to the list of markup functions
- (if (not (member command-proc markup-function-list))
- (set! markup-function-list (cons command-proc markup-function-list)))
- ;; define the make-COMMAND-markup procedure in (lily) module
- (in-module-define-function (lily) (,make-markup-name . args)
- (make-markup command-proc
- ,(symbol->string make-markup-name)
- (list ,@signature)
- args))))))
+ (while (and (pair? body) (keyword? (car body)))
+ (set! body (cddr body)))
+ `(begin
+ ;; define the COMMAND-markup 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
+ (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)
+ `(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))))))
+
+(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
+ ,(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)
+ ;; 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
+ (define-public (,make-markup-name . args)
+ (let ((sig (list ,@signature)))
+ (list (make-markup ,command-name
+ ,(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))
- (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.
- #:COMMAND is used instead of \\COMMAND
- - #:lines ( ... ) is used instead of { ... }
- - #:center-align ( ... ) is used instead of \\center-align < ... >
+ - #:line ( ... ) is used instead of \\line { ... }
- etc.
Example:
\\markup { foo
\\raise #0.2 \\hbracket \\bold bar
\\override #'(baseline-skip . 4)
- \\bracket \\column < baz bazr bla >
+ \\bracket \\column { baz bazr bla }
}
<==>
(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 \\notes block."
-
+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)
(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)))
;;;;;;;;;;;;;;;
;;; Utilities for storing and accessing markup commands signature
-;;; and keyword.
;;; Examples:
;;;
;;; (set! (markup-command-signature raise-markup) (list number? markup?))
-;;; ==> ((#<primitive-procedure number?> #<procedure markup? (obj)>) . scheme0-markup1)
+;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
;;;
;;; (markup-command-signature raise-markup)
;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
;;;
-;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
-;;;
-
-(define markup-command-signatures (make-hash-table 50))
-
-(define (markup-command-signature-ref markup-command)
- "Return markup-command's signature, e.g. (number? markup?).
-markup-command may be a procedure."
- (let ((sig-key (hashq-ref markup-command-signatures
- markup-command)))
- (if sig-key (car sig-key) #f)))
-
-(define-public (markup-command-keyword markup-command)
- "Return markup-command's keyword, e.g. \"scheme0markup1\".
-markup-command may be a procedure."
- (let ((sig-key (hashq-ref markup-command-signatures
- markup-command)))
- (if sig-key (cdr sig-key) #f)))
-
-(define (markup-command-signatureset! markup-command signature)
- "Set markup-command's signature. markup-command must be a named procedure.
-Also set markup-signature and markup-keyword object properties."
- (hashq-set! markup-command-signatures
- markup-command
- (cons signature (markup-signature-to-keyword signature)))
- ;; these object properties are still in use somewhere
+
+(define-public (markup-command-signature-ref markup-command)
+ "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 @var{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-signatureset!))
-
-(define (markup-symbol-to-proc markup-sym)
- "Return the markup command procedure which name is `markup-sym', if any."
- (hash-fold (lambda (key val prev)
- (or prev
- (if (eqv? (procedure-name key) markup-sym) key #f)))
- #f
- markup-command-signatures))
-
-(define-public markup-function-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)
- "-"))))
+ (make-procedure-with-setter markup-command-signature-ref
+ markup-command-signature-set!))
+
+(define (lookup-markup-command-aux symbol)
+ (let ((proc (catch 'misc-error
+ (lambda ()
+ (module-ref (current-module) symbol))
+ (lambda (key . args) #f))))
+ (and (procedure? proc) proc)))
(define-public (lookup-markup-command code)
- (let ((proc (markup-symbol-to-proc (string->symbol (string-append code "-markup")))))
- (and proc (cons proc (markup-command-keyword proc)))))
+ (let ((proc (lookup-markup-command-aux
+ (string->symbol (format #f "~a-markup" code)))))
+ (and proc (markup-function? 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-signature proc)))))
;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
;;; markup type predicates
(define (markup-function? x)
- (not (not (markup-command-signature x))))
+ (and (markup-command-signature x)
+ (not (object-property x 'markup-list-command))))
+
+(define (markup-list-function? x)
+ (and (markup-command-signature x)
+ (object-property x 'markup-list-command)))
+
+(define-public (markup-command-list? x)
+ "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 @code{#t} if @var{x} is a list of markups or markup command lists."
(define (markup-list-inner? lst)
(or (null? lst)
- (and (markup? (car lst)) (markup-list-inner? (cdr lst)))))
- (and (list? arg) (markup-list-inner? arg)))
+ (and (or (markup? (car lst)) (markup-command-list? (car lst)))
+ (markup-list-inner? (cdr lst)))))
+ (not (not (and (list? arg) (markup-list-inner? arg)))))
(define (markup-argument-list? signature arguments)
"Typecheck argument list."
(markup-argument-list? (markup-command-signature (car arg))
(cdr arg)))))
-;;
-;; typecheck, and throw an error when something amiss.
-;;
+;;
+;;
+;;
+;;
(define (markup-thrower-typecheck arg)
+ "typecheck, and throw an error when something amiss.
+
+Uncovered - cheap-markup? is used."
+
(cond ((string? arg) #t)
((not (pair? arg))
(throw 'markup-format "Not a pair" arg))
;;
;; good enough if you only use make-XXX-markup functions.
-;;
+;;
(define (cheap-markup? x)
(or (string? x)
(and (pair? x)
;;
;; replace by markup-thrower-typecheck for more detailed diagnostics.
-;;
+;;
(define-public markup? cheap-markup?)
;; utility
(define-public interpret-markup ly:text-interface::interpret-markup)
+
+(define-public (interpret-markup-list layout props markup-list)
+ (let ((stencils (list)))
+ (for-each (lambda (m)
+ (set! stencils
+ (if (markup-command-list? m)
+ (append! (reverse! (apply (car m) layout props (cdr m)))
+ stencils)
+ (cons (interpret-markup layout props m) stencils))))
+ markup-list)
+ (reverse! stencils)))
+
(define-public (prepend-alist-chain key val chain)
(cons (acons key val (car chain)) (cdr chain)))
"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)))
projects / lilypond.git / blobdiff