;;;;
;;;; source file of the GNU LilyPond music typesetter
;;;;
-;;;; (c) 2003--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; (c) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
"
Internally markup is stored as lists, whose head is a function.
print object).
-To add a function, use the def-markup-command utility.
+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).
- (def-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
+ (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
\"my command usage and description\"
...function body...)
The command is now available in markup mode, e.g.
-
\\markup { .... \\MYCOMMAND #1 argument ... }
" ; "
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; markup definer utilities
-;;; `def-markup-command' can be used both for built-in markup
-;;; definitions and user defined markups.
-(defmacro-public def-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-hash-table 150))
+;; List of markup list functions
+(define-public markup-list-function-list (list))
+(define-macro (define-builtin-markup-command command-and-args signature
+ category properties-or-copied-function . 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,
* define a make-COMMAND-markup function.
Syntax:
- (def-markup-command (COMMAND layout props arg1 arg2 ...) (arg1-type? arg2-type? ...)
+ (define-builtin-markup-command (COMMAND layout props . arguments)
+ argument-types
+ category
+ properties
\"documentation string\"
...command body...)
or:
- (def-markup-command COMMAND (arg1-type? arg2-type? ...)
- function)
+ (define-builtin-markup-command COMMAND
+ argument-types
+ category
+ function)
+
+where:
+ argument-types is a list of type predicates for arguments
+ category is either a symbol or a symbol list
+ 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!
"
(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 (string-append (symbol->string command) "-markup")))
- (make-markup-name (string->symbol (string-append "make-" (symbol->string command-name)))))
+ (command-name (string->symbol (format #f "~a-markup" command)))
+ (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
`(begin
- (define-public ,(if (pair? args)
- (cons command-name args)
- command-name)
- ,@body)
+ ;; define the COMMAND-markup function
+ ,(if (pair? args)
+ (let ((documentation (car body))
+ (real-body (cdr body))
+ (properties properties-or-copied-function))
+ `(define-public (,command-name ,@args)
+ ,documentation
+ (let ,(filter identity
+ (map (lambda (prop-spec)
+ (if (pair? 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)))
+ #f))
+ properties))
+ ,@real-body)))
+ (let ((args (gensym "args"))
+ (markup-command properties-or-copied-function))
+ `(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))
- (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! markup-functions-by-category ',category
+ (cons ,command-name
+ (or (hashq-ref markup-functions-by-category ',category)
+ (list)))))
+ (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-or-copied-function
+ (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
+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))))
+ `(begin
+ ;; define the COMMAND-markup-list function
+ ,(if (pair? args)
+ (let ((documentation (car body))
+ (real-body (cdr body)))
+ `(define-public (,command-name ,@args)
+ ,documentation
+ (let ,(filter identity
+ (map (lambda (prop-spec)
+ (if (pair? 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)))
+ #f))
+ properties))
+ ,@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))))
+ (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)))
+ ;; 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.
(markup-argument-list-error signature args 1)
#f)))
(if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
- (scm-error 'markup-format make-name
- "Expect ~A arguments for ~A. Found ~A: ~S"
- (list siglen make-name arglen args)
- #f))
+ (ly:error (string-append make-name ": "
+ (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S"))
+ siglen arglen args))
(if error-msg
- (scm-error 'markup-format make-name
- "Invalid argument in position ~A\nExpect: ~A\nFound: ~S."
- error-msg #f)
- (cons markup-function args))))
+ (ly:error
+ (string-append
+ make-name ": "
+ (_ "Invalid argument in position ~A. Expect: ~A, found: ~S.")
+ error-msg))
+ (cons markup-function args))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; markup constructors
"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)
#:bracket #:column (\"baz\" \"bazr\" \"bla\"))
-Use `markup*' in a \\notes block."
+Use `markup*' in a \\notemode context."
(car (compile-all-markup-expressions `(#:line ,body))))
(string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
(define (compile-markup-expression expr)
- "Return two values: the first complete canonical markup expression found in `expr',
-e.g. (make-COMMAND-markup arg1 arg2 ...), and the rest expression."
+ "Return two values: the first complete canonical markup expression
+ found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...),
+ and the rest expression."
(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)))
(values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
(else (values (car expr) (cdr expr)))))
-;;;;;;;;;;;;;;;
-;;; Debugging utilities: print markup expressions in a friendly fashion
-
-(use-modules (ice-9 format))
-(define (markup->string markup-expr)
- "Return a string describing, in LilyPond syntax, the given markup expression."
- (define (proc->command proc)
- (let ((cmd-markup (symbol->string (procedure-name proc))))
- (substring cmd-markup 0 (- (string-length cmd-markup)
- (string-length "-markup")))))
- (define (arg->string arg)
- (cond ((and (pair? arg) (pair? (car arg))) ;; markup list
- (format #f "~{ ~a~}" (map markup->string arg)))
- ((pair? arg) ;; markup
- (markup->string arg))
- ((string? arg) ;; scheme string argument
- (format #f "#\"~a\"" arg))
- (else ;; other scheme arg
- (format #f "#~a" arg))))
- (let ((cmd (car markup-expr))
- (args (cdr markup-expr)))
- (cond ((eqv? cmd simple-markup) ;; a simple string
- (format #f "\"~a\"" (car args)))
- ((eqv? cmd line-markup) ;; { ... }
- (format #f "{~a}" (arg->string (car args))))
- ((eqv? cmd center-align-markup) ;; \center < ... >
- (format #f "\\center-align <~a>" (arg->string (car args))))
- ((eqv? cmd column-markup) ;; \column < ... >
- (format #f "\\column <~a>" (arg->string (car args))))
- (else ;; \command ...
- (format #f "\\~a~{ ~a~} " (proc->command cmd) (map arg->string args))))))
-
-(define-public (display-markup markup-expr)
- "Print a LilyPond-syntax equivalent for the given markup expression."
- (display "\\markup ")
- (display (markup->string markup-expr)))
-
;;;;;;;;;;;;;;;
;;; Utilities for storing and accessing markup commands signature
;;; and keyword.
;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
;;;
-(define markup-command-signatures (make-hash-table 50))
+(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 (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-signature-ref markup-command)
+ "Return markup-command's signature (the 'markup-signature object property)"
+ (object-property markup-command 'markup-signature))
-(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-set! markup-command signature)
+ "Set markup-command's signature and keyword (as object properties)"
(set-object-property! markup-command 'markup-signature signature)
- (set-object-property! markup-command 'markup-keyword (markup-signature-to-keyword 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))
+ (set-object-property! markup-command 'markup-keyword
+ (markup-signature-to-keyword signature))
+ signature)
-(define-public markup-function-list '())
+(define-public markup-command-signature
+ (make-procedure-with-setter markup-command-signature-ref
+ markup-command-signature-set!))
(define-public (markup-signature-to-keyword sig)
" (A B C) -> a0-b1-c2 "
sig)
"-"))))
+(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-keyword 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)))))
;;;;;;;;;;;;;;;;;;;;;;
;;; used in parser.yy to map a list of markup commands on markup arguments
;;; 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 if `x' is a markup command list, ie. 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."
(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."
(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))
(make-line-markup (list-insert-separator markups sep))
empty-markup))
-;; unused?
-;;(define-public brew-markup-stencil Text_interface::print)
-(define-public interpret-markup Text_interface::interpret_markup)
+(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)))
(if (and (pair? (cdr stencils))
(ly:stencil? (cadr stencils)))
- (let* ((tail (stack-stencil-line space (cdr stencils)))
+ (let* ((tail (stack-stencil-line space (cdr stencils)))
(head (car stencils))
(xoff (+ space (cdr (ly:stencil-extent head X)))))
(ly:stencil-add head
(car stencils))
(ly:make-stencil '() '(0 . 0) '(0 . 0))))
-
-
-
-
-
-
projects / lilypond.git / blobdiff