-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2003--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
-
-"
-Internally markup is stored as lists, whose head is a function.
-
- (FUNCTION ARG1 ARG2 ... )
-
-When the markup is formatted, then FUNCTION is called as follows
-
- (FUNCTION GROB PROPS ARG1 ARG2 ... )
-
-GROB is the current grob, PROPS is a list of alists, and ARG1.. are
-the rest of the arguments.
-
-The function should return a stencil (i.e. a formatted, ready to
-print object).
-
-
-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).
-
- (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
-
-(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,
-
-* add COMMAND-markup to markup-function-list,
-
-* sets COMMAND-markup markup-signature and markup-keyword object properties,
-
-* define a make-COMMAND-markup function.
-
-Syntax:
- (define-builtin-markup-command (COMMAND layout props arg1 arg2 ...)
- (arg1-type? arg2-type? ...)
- \"documentation string\"
- ...command body...)
- or:
- (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) '()))
- (command-name (string->symbol (format #f "~a-markup" command)))
- (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
- `(begin
- ;; 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))
- ;; 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)))
- ;; 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 . 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.
-"
- (let* ((arglen (length args))
- (siglen (length signature))
- (error-msg (if (and (> siglen 0) (> arglen 0))
- (markup-argument-list-error signature args 1)
- #f)))
- (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
- (ly:error (string-append make-name ": "
- (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S"))
- siglen arglen args))
- (if error-msg
- (ly:error
- (string-append
- make-name ": "
- (_ "Invalid argument in position ~A. Expect: ~A, found: ~S.")
- error-msg))
- (cons markup-function args))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; markup constructors
-;;; lilypond-like syntax for markup construction in scheme.
-
-(use-modules (ice-9 optargs)
- (ice-9 receive))