Merge branch 'master' of /home/lilycvs/git/lily/

[lilypond.git] / scm / markup.scm

diff --git a/scm/markup.scm b/scm/markup.scm
index 3a679b24167d834451d439c4a3f642e6859c7e3d..5daba8d9321a38166355d78a457b91a8b1965313 100644 (file)
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -2,7 +2,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 

-;;;; (c) 2003--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; (c) 2003--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>

 
 "
 Internally markup is stored as lists, whose head is a function.
 
 "
 Internally markup is stored as lists, whose head is a function.


@@ -20,27 +20,25 @@ The function should return a stencil (i.e. a formatted, ready to
 print object).
 
 
 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.
 
     \"my command usage and description\"
     ...function body...)
 
 The command is now available in markup mode, e.g.
 

-

   \\markup { .... \\MYCOMMAND #1 argument ... }
 
 " ; "
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; markup definer utilities
   \\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)
+(define-macro (define-builtin-markup-command command-and-args signature . body)

   "
   "

-

 * Define a COMMAND-markup function after command-and-args and body,
 register COMMAND-markup and its signature,
 
 * Define a COMMAND-markup function after command-and-args and body,
 register COMMAND-markup and its signature,
 


@@ -51,29 +49,67 @@ register COMMAND-markup and its signature,
 * define a make-COMMAND-markup function.
 
 Syntax:
 * 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 arg1 arg2 ...)
+                                 (arg1-type? arg2-type? ...)

     \"documentation string\"
     ...command body...)
  or:
     \"documentation string\"
     ...command body...)
  or:

-  (def-markup-command COMMAND (arg1-type? arg2-type? ...)
+  (define-builtin-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) '()))
     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)))))
+         (command-name (string->symbol (format #f "~a-markup" command)))
+         (make-markup-name (string->symbol (format #f "make-~a-markup" command))))

     `(begin
     `(begin

-       (define-public ,(if (pair? args)
-                           (cons command-name args)
-                           command-name)
-         ,@body)
+       ;; define the COMMAND-markup 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))
        (set! (markup-command-signature ,command-name) (list ,@signature))

+       ;; add the command to markup-function-list, for markup documentation

        (if (not (member ,command-name markup-function-list))
            (set! markup-function-list (cons ,command-name markup-function-list)))
        (if (not (member ,command-name markup-function-list))
            (set! markup-function-list (cons ,command-name markup-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-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 . 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.
 (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.


@@ -106,22 +142,21 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
   "The `markup' macro provides a lilypond-like syntax for building markups.
 
  - #:COMMAND is used instead of \\COMMAND
   "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)
  - 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\"))
   }
          <==>
   (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))))
 
   
   (car (compile-all-markup-expressions `(#:line ,body))))
 


@@ -154,24 +189,26 @@ Use `markup*' in a \\notes block."
   (cond ((and (pair? expr)
               (keyword? (car expr)))
          ;; expr === (#:COMMAND arg1 ...)
   (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)))
         ((and (pair? expr)
               (pair? (car expr))
               (keyword? (caar expr)))


@@ -220,43 +257,6 @@ Use `markup*' in a \\notes block."
          (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
         (else (values (car expr) (cdr 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.
 ;;;;;;;;;;;;;;;
 ;;; Utilities for storing and accessing markup commands signature
 ;;; and keyword.


@@ -271,44 +271,29 @@ Use `markup*' in a \\notes block."
 ;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
 ;;; 
 
 ;;; (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-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!))
+  (set-object-property! markup-command 'markup-keyword 
+                        (markup-signature-to-keyword signature))
+  signature)

 
 

-(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-command-signature
+  (make-procedure-with-setter markup-command-signature-ref
+                              markup-command-signature-set!))

 
 

-(define-public markup-function-list '())
+;; 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 "
 
 (define-public (markup-signature-to-keyword sig)
   " (A B C) -> a0-b1-c2 "


@@ -330,9 +315,24 @@ Also set markup-signature and markup-keyword object properties."
                                     sig)
                          "-"))))
 
                                     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)
 (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
 
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; used in parser.yy to map a list of markup commands on markup arguments


@@ -356,13 +356,25 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 ;;; markup type predicates
 
 (define (markup-function? x)
 ;;; 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)
 
 (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)
   (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."
 
 (define (markup-argument-list? signature arguments)
   "Typecheck argument list."


@@ -393,9 +405,14 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
                                   (cdr arg)))))
 
 ;; 
                                   (cdr arg)))))
 
 ;; 

-;; typecheck, and throw an error when something amiss.
+;; 
+;;

 ;; 
 (define (markup-thrower-typecheck arg)
 ;; 
 (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))
   (cond ((string? arg) #t)
         ((not (pair? arg))
          (throw 'markup-format "Not a pair" arg))


@@ -428,7 +445,19 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
       empty-markup))
 
 
       empty-markup))
 
 

-(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)))
 
 (define-public (prepend-alist-chain key val chain)
   (cons (acons key val (car chain)) (cdr chain)))
 


@@ -439,7 +468,7 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
       
       (if (and (pair? (cdr stencils))
               (ly:stencil? (cadr stencils)))
       
       (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
                  (head (car stencils))
                  (xoff (+ space (cdr (ly:stencil-extent head X)))))
             (ly:stencil-add head


@@ -447,9 +476,3 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
           (car stencils))
       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 
           (car stencils))
       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 

-
-
-
-
-
-