X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=5daba8d9321a38166355d78a457b91a8b1965313;hb=2f996385b21b9d5006c7369c2c496ccbee001e97;hp=c786c16890f1b64bbf7c80d3d9d7a131165a31b5;hpb=87eedcd59f4082cb0841528ad5bc82cb1d1191e3;p=lilypond.git diff --git a/scm/markup.scm b/scm/markup.scm index c786c16890..5daba8d932 100644 --- a/scm/markup.scm +++ b/scm/markup.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2003--2006 Han-Wen Nienhuys +;;;; (c) 2003--2007 Han-Wen Nienhuys " Internally markup is stored as lists, whose head is a function. @@ -69,7 +69,7 @@ Syntax: (let ((args (gensym "args")) (markup-command (car body))) `(define-public (,command-name . ,args) - ,(format #f "Copy of the ~a command" markup-command) + ,(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-function-list, for markup documentation @@ -80,6 +80,36 @@ Syntax: (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 . 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) + `(define-public (,command-name ,@args) + ,@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))) + ;; 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. @@ -159,24 +189,26 @@ Use `markup*' in a \\notemode context." (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))) @@ -261,6 +293,7 @@ Use `markup*' in a \\notemode context." ;; For documentation purposes (define-public markup-function-list (list)) +(define-public markup-list-function-list (list)) (define-public (markup-signature-to-keyword sig) " (A B C) -> a0-b1-c2 " @@ -282,14 +315,24 @@ Use `markup*' in a \\notemode context." sig) "-")))) -(define-public (lookup-markup-command code) +(define (lookup-markup-command-aux symbol) (let ((proc (catch 'misc-error (lambda () - (module-ref (current-module) - (string->symbol (format #f "~a-markup" code)))) + (module-ref (current-module) symbol)) (lambda (key . args) #f)))) - (and (procedure? proc) - (cons proc (markup-command-keyword proc))))) + (and (procedure? proc) proc))) + +(define-public (lookup-markup-command code) + (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 @@ -313,13 +356,25 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: ;;; 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." @@ -350,9 +405,14 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: (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)) @@ -386,6 +446,18 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: (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)))