X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=bd20798e91df98f8128447350e1dabbf8b20a0e5;hb=e9ebbcb96ce60902b2b6a4fd5a59476e309f84b4;hp=103c2e6e7d8cb94d9095804645fb1e3128d75d0e;hpb=e8d8cd2d45bc06046b85c81b3cd0ba5f55c9f462;p=lilypond.git diff --git a/scm/markup.scm b/scm/markup.scm index 103c2e6e7d..bd20798e91 100644 --- a/scm/markup.scm +++ b/scm/markup.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2003--2005 Han-Wen Nienhuys +;;;; (c) 2003--2006 Han-Wen Nienhuys " Internally markup is stored as lists, whose head is a function. @@ -20,9 +20,9 @@ The function should return a stencil (i.e. a formatted, ready to 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...) @@ -35,10 +35,33 @@ The command is now available in markup mode, e.g. ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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, @@ -51,28 +74,40 @@ register COMMAND-markup and its signature, * 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 @@ -84,15 +119,16 @@ 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 @@ -147,13 +183,15 @@ Use `markup*' in a \\notes block." (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) @@ -217,43 +255,6 @@ e.g. (make-COMMAND-markup arg1 arg2 ...), and the rest expression." (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. @@ -300,8 +301,8 @@ Also set markup-signature and markup-keyword object properties." (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)) @@ -424,10 +425,8 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: (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))) @@ -438,7 +437,7 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: (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 @@ -446,9 +445,3 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: (car stencils)) (ly:make-stencil '() '(0 . 0) '(0 . 0)))) - - - - - -