;;;;
;;;; source file of the GNU LilyPond music typesetter
;;;;
-;;;; (c) 2003--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; (c) 2003--2006 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 function, use the define-markup-command utility.
- (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...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
+(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)
"
* Define a COMMAND-markup function after command-and-args and body,
* define a make-COMMAND-markup function.
Syntax:
- (def-markup-command (COMMAND layout props arg1 arg2 ...) (arg1-type? arg2-type? ...)
+ (define-markup-command (COMMAND layout props arg1 arg2 ...) (arg1-type? arg2-type? ...)
\"documentation string\"
...command body...)
- or:
- (def-markup-command COMMAND (arg1-type? arg2-type? ...)
- function)
+or:
+ (define-markup-command COMMAND (arg1-type? arg2-type? ...) function)
"
- (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)))))
- `(begin
- (define-public ,(if (pair? args)
- (cons command-name args)
- command-name)
- ,@body)
- (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)))
- (define-public (,make-markup-name . args)
- (let ((sig (list ,@signature)))
- (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
+ (let* ((command (if (pair? command-and-args)
+ (car command-and-args)
+ 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))))))
(define-public (make-markup markup-function make-name signature args)
" Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
(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
(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 (markup-command-signature
+ (car (lookup-markup-command command))))
(sig-len (length sig)))
(do ((i 0 (1+ i))
(args '() args)
(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.
(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)))
+ (or prev
+ (if (eqv? (procedure-name key) markup-sym) key #f)))
#f
markup-command-signatures))
(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 (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