-(define (keyword->make-markup key)
- "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
- (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."
- (cond ((and (pair? expr)
- (keyword? (car expr)))
- ;; expr === (#:COMMAND arg1 ...)
- (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)))
- ;; expr === ((#:COMMAND arg1 ...) ...)
- (receive (m r) (compile-markup-expression (car expr))
- (values m (cdr expr))))
- ((and (pair? expr)
- (string? (car expr))) ;; expr === ("string" ...)
- (values `(make-simple-markup ,(car expr)) (cdr expr)))
- (else
- ;; expr === (symbol ...) or ((funcall ...) ...)
- (values (car expr)
- (cdr expr)))))
-
-(define (compile-all-markup-args expr)
- "Transform `expr' into markup arguments"
- (do ((rest expr rest)
- (args '() args))
- ((null? rest) (reverse args))
- (receive (a r) (compile-markup-arg rest)
- (set! args (cons a args))
- (set! rest r))))
-
-(define (compile-markup-arg expr)
- "Return two values: the desired markup argument, and the rest arguments"
- (cond ((null? expr)
- ;; no more args
- (values '() '()))
- ((keyword? (car expr))
- ;; expr === (#:COMMAND ...)
- ;; ==> build and return the whole markup expression
- (compile-markup-expression expr))
- ((and (pair? (car expr))
- (keyword? (caar expr)))
- ;; expr === ((#:COMMAND ...) ...)
- ;; ==> build and return the whole markup expression(s)
- ;; found in (car expr)
- (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
- (if (null? rest-expr)
- (values markup-expr (cdr expr))
- (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
- (cdr expr)))))
- ((and (pair? (car expr))
- (pair? (caar expr)))
- ;; expr === (((foo ...) ...) ...)
- (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
- (else (values (car expr) (cdr expr)))))
-
-;;;;;;;;;;;;;;;
-;;; Utilities for storing and accessing markup commands signature
-;;; and keyword.
-;;; Examples:
-;;;
-;;; (set! (markup-command-signature raise-markup) (list number? markup?))
-;;; ==> ((#<primitive-procedure number?> #<procedure markup? (obj)>) . scheme0-markup1)
-;;;
-;;; (markup-command-signature raise-markup)
-;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
-;;;
-;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
-;;;
-
-(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-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-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-keyword
- (markup-signature-to-keyword signature))
- signature)
-
-(define-public markup-command-signature
- (make-procedure-with-setter markup-command-signature-ref
- markup-command-signature-set!))
-
-(define-public (markup-signature-to-keyword sig)
- " (A B C) -> a0-b1-c2 "
- (if (null? sig)
- 'empty
- (string->symbol (string-join (map
- (let* ((count 0))
- (lambda (func)
- (set! count (+ count 1))
- (string-append
- ;; for reasons I don't get,
- ;; (case func ((markup?) .. )
- ;; doesn't work.
- (cond
- ((eq? func markup?) "markup")
- ((eq? func markup-list?) "markup-list")
- (else "scheme"))
- (number->string (- count 1)))))
- 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)
- (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
-(define-public (map-markup-command-list commands markups)
- "`markups' being a list of markups, eg (markup1 markup2 markup3),
-and `commands' a list of commands with their scheme arguments, in reverse order,
-eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
- ((bold (raise 4 (italic markup1)))
- (bold (raise 4 (italic markup2)))
- (bold (raise 4 (italic markup3))))
-"
- (map-in-order (lambda (arg)
- (let ((result arg))
- (for-each (lambda (cmd)
- (set! result (append cmd (list result))))
- commands)
- result))
- markups))
-
-;;;;;;;;;;;;;;;;;;;;;;
-;;; markup type predicates
-
-(define (markup-function? 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 (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."
- (if (and (pair? signature) (pair? arguments))
- (and ((car signature) (car arguments))
- (markup-argument-list? (cdr signature) (cdr arguments)))
- (and (null? signature) (null? arguments))))
-
-
-(define (markup-argument-list-error signature arguments number)
- "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
-#f is no error found.
-"
- (if (and (pair? signature) (pair? arguments))
- (if (not ((car signature) (car arguments)))
- (list number (type-name (car signature)) (car arguments))
- (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
- #f))
-
-;;
-;; full recursive typecheck.
-;;
-(define (markup-typecheck? arg)
- (or (string? arg)
- (and (pair? arg)
- (markup-function? (car arg))
- (markup-argument-list? (markup-command-signature (car arg))
- (cdr 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))
- ((not (markup-function? (car arg)))
- (throw 'markup-format "Not a markup function " (car arg)))
- ((not (markup-argument-list? (markup-command-signature (car arg))
- (cdr arg)))
- (throw 'markup-format "Arguments failed typecheck for " arg)))
- #t)
-
-;;
-;; good enough if you only use make-XXX-markup functions.
-;;
-(define (cheap-markup? x)
- (or (string? x)
- (and (pair? x)
- (markup-function? (car x)))))
-
-;;
-;; replace by markup-thrower-typecheck for more detailed diagnostics.
-;;
-(define-public markup? cheap-markup?)