;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; Copyright (C) 2003--2014 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;; markup definer utilities
;; For documentation purposes
-;; category -> markup functions
-(define-public markup-functions-by-category (make-hash-table 150))
+;; markup function -> categories
+(define-public markup-function-category (make-object-property))
;; markup function -> used properties
-(define-public markup-functions-properties (make-weak-key-hash-table 151))
-;; List of markup list functions
-(define-public markup-list-functions (make-weak-key-hash-table 151))
+(define-public markup-function-properties (make-object-property))
(use-modules (ice-9 optargs))
-(defmacro*-public define-markup-command
- (command-and-args signature
- #:key (category '()) (properties '())
- #:rest body)
+(defmacro-public define-markup-command (command-and-args . definition)
"
-* 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
-* add COMMAND-markup to markup-functions-by-category,
+* add categories to markup-function-category,
-* sets COMMAND-markup markup-signature object property,
+* sets the markup-signature object property,
* define a make-COMMAND-markup function.
Syntax:
(define-markup-command (COMMAND layout props . arguments)
- argument-types
+ signature
[ #:properties properties ]
\"documentation string\"
...command body...)
where:
- `argument-types' is a list of type predicates for arguments
+ `signature' is a list of type predicates for arguments
`properties' a list of (property default-value) lists
The specified properties are available as let-bound variables in the
The autogenerated documentation makes use of some optional
specifications that are otherwise ignored:
-After `argument-types', you may also specify
+After `signature', you may also specify
[ #:category category ]
where:
`category' is either a symbol or a symbol list specifying the
- category for this markup command in the docs.
+ categories for this markup command in the docs.
As an element of the `properties' list, you may directly use a
COMMANDx-markup symbol instead of a `(prop value)' list to indicate
adding its properties to the documented properties of the new
command. There is no protection against circular definitions.
"
- (let* ((command (car command-and-args))
- (args (cdr command-and-args))
+ (let* ((command (if (pair? command-and-args)
+ (car command-and-args)
+ command-and-args))
+ (args (and (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))))
- (while (and (pair? body) (keyword? (car body)))
- (set! body (cddr body)))
`(begin
- ;; define the COMMAND-markup function
- ,(let* ((documentation (if (string? (car body))
- (list (car body))
- '()))
- (real-body (if (or (null? documentation)
- (null? (cdr body)))
- body (cdr body))))
- `(define-public (,command-name ,@args)
- ,@documentation
+ ,(if args
+ `(define-public ,command-name (markup-lambda ,args ,@definition))
+ `(define-public ,command-name ,@definition))
+ (define-public (,make-markup-name . args)
+ (,make-markup ,command-name ,(symbol->string make-markup-name) args)))))
+
+
+(defmacro*-public markup-lambda
+ (args signature
+ #:key (category '()) (properties '())
+ #:rest body)
+ "Defines and returns an anonymous markup command. Other than
+not registering the markup command, this is identical to
+`define-markup-command`"
+ (while (and (pair? body) (keyword? (car body)))
+ (set! body (cddr body)))
+ ;; define the COMMAND-markup function
+ (let* ((documentation
+ (format #f "~a\n~a" (cddr args)
+ (if (string? (car body)) (car body) "")))
+ (real-body (if (or (not (string? (car body)))
+ (null? (cdr body)))
+ body (cdr body)))
+ (result
+ `(lambda ,args
+ ,documentation
(let ,(map (lambda (prop-spec)
(let ((prop (car prop-spec))
- (default-value (if (null? (cdr prop-spec))
- #f
- (cadr prop-spec)))
+ (default-value (and (pair? (cdr prop-spec))
+ (cadr prop-spec)))
(props (cadr args)))
`(,prop (chain-assoc-get ',prop ,props ,default-value))))
(filter pair? properties))
- ,@real-body)))
- (set! (markup-command-signature ,command-name) (list ,@signature))
- ;; Register the new function, for markup documentation
- ,@(map (lambda (category)
- `(hashq-set!
- (or (hashq-ref markup-functions-by-category ',category)
- (let ((hash (make-weak-key-hash-table 151)))
- (hashq-set! markup-functions-by-category ',category
- hash)
- hash))
- ,command-name #t))
- (if (list? category) category (list category)))
- ;; Used properties, for markup documentation
- (hashq-set! markup-functions-properties
- ,command-name
- (list ,@(map (lambda (prop-spec)
- (cond ((symbol? prop-spec)
- prop-spec)
- ((not (null? (cdr prop-spec)))
- `(list ',(car prop-spec) ,(cadr prop-spec)))
- (else
- `(list ',(car prop-spec)))))
- (if (pair? args)
- properties
- (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))))))
-
-(defmacro*-public define-markup-list-command
- (command-and-args signature #:key (properties '()) #:rest body)
+ ,@real-body))))
+ (define (markup-lambda-worker command signature properties category)
+ (set! (markup-command-signature command) signature)
+ ;; Register the new function, for markup documentation
+ (set! (markup-function-category command) category)
+ ;; Used properties, for markup documentation
+ (set! (markup-function-properties command) properties)
+ command)
+ `(,markup-lambda-worker
+ ,result
+ (list ,@signature)
+ (list ,@(map (lambda (prop-spec)
+ (cond ((symbol? prop-spec)
+ prop-spec)
+ ((not (null? (cdr prop-spec)))
+ `(list ',(car prop-spec) ,(cadr prop-spec)))
+ (else
+ `(list ',(car prop-spec)))))
+ properties))
+ ',category)))
+
+(defmacro-public define-markup-list-command
+ (command-and-args . definition)
"Same as `define-markup-command', but defines a command that, when
interpreted, returns a list of stencils instead of a single one"
- (let* ((command (car command-and-args))
- (args (cdr command-and-args))
+ (let* ((command (if (pair? command-and-args)
+ (car command-and-args)
+ command-and-args))
+ (args (and (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))))
- (while (and (pair? body) (keyword? (car body)))
- (set! body (cddr body)))
`(begin
- ;; define the COMMAND-markup-list function
- ,(let* ((documentation (if (string? (car body))
- (list (car body))
- '()))
- (real-body (if (or (null? documentation)
- (null? (cdr body)))
- body (cdr body))))
- `(define-public (,command-name ,@args)
- ,@documentation
- (let ,(map (lambda (prop-spec)
- (let ((prop (car prop-spec))
- (default-value (if (null? (cdr prop-spec))
- #f
- (cadr prop-spec)))
- (props (cadr args)))
- `(,prop (chain-assoc-get ',prop ,props ,default-value))))
- (filter pair? properties))
- ,@real-body)))
- (set! (markup-command-signature ,command-name) (list ,@signature))
- ;; add the command to markup-list-function-list, for markup documentation
- (hashq-set! markup-list-functions ,command-name #t)
- ;; Used properties, for markup documentation
- (hashq-set! markup-functions-properties
- ,command-name
- (list ,@(map (lambda (prop-spec)
- (cond ((symbol? prop-spec)
- prop-spec)
- ((not (null? (cdr prop-spec)))
- `(list ',(car prop-spec) ,(cadr prop-spec)))
- (else
- `(list ',(car prop-spec)))))
- (if (pair? args)
- properties
- (list)))))
- ;; it's a markup-list command:
- (set-object-property! ,command-name 'markup-list-command #t)
- ;; define the make-COMMAND-markup-list function
+ ,(if args
+ `(define-public ,command-name (markup-list-lambda ,args ,@definition))
+ `(define-public ,command-name ,@definition))
(define-public (,make-markup-name . args)
- (let ((sig (list ,@signature)))
- (list (make-markup ,command-name
- ,(symbol->string make-markup-name) sig args)))))))
+ (list (,make-markup ,command-name
+ ,(symbol->string make-markup-name) args))))))
+
+(defmacro*-public markup-list-lambda
+ (arg signature #:key (properties '()) #:rest body)
+ "Same as `markup-lambda' but defines a markup list command that, when
+interpreted, returns a list of stencils instead of a single one"
+ (let () ; Guile 1.8 defmacro* workaround
+ (define (markup-lambda-listify fun)
+ (set! (markup-list-function? fun) #t)
+ fun)
+ (list markup-lambda-listify (cons* 'markup-lambda arg signature body))))
;;;;;;;;;;;;;;;
;;; Utilities for storing and accessing markup commands signature
;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
;;;
-(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 (as object property)"
- (set-object-property! markup-command 'markup-signature signature)
- signature)
-
-(define-public markup-command-signature
- (make-procedure-with-setter markup-command-signature-ref
- markup-command-signature-set!))
+(define-public markup-command-signature (make-object-property))
;;;;;;;;;;;;;;;;;;;;;;
;;; markup type predicates
-(define (markup-function? x)
+(define-public (markup-function? x)
(and (markup-command-signature x)
- (not (object-property x 'markup-list-command))))
+ (not (markup-list-function? x))))
-(define (markup-list-function? x)
- (and (markup-command-signature x)
- (object-property x 'markup-list-command)))
+(define-public markup-list-function? (make-object-property))
(define-public (markup-command-list? x)
"Determine if `x' is a markup command list, ie. a list composed of
;;
(define-public markup? cheap-markup?)
-(define-public (make-markup markup-function make-name signature args)
+(define (make-markup markup-function make-name args)
" Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
-against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
+against signature, reporting MAKE-NAME as the user-invoked function.
"
(let* ((arglen (length args))
+ (signature (or (markup-command-signature markup-function)
+ (ly:error (_ "~S: Not a markup (list) function: ~S")
+ make-name markup-function)))
(siglen (length signature))
(error-msg (if (and (> siglen 0) (> arglen 0))
(markup-argument-list-error signature args 1)
projects / lilypond.git / blobdiff