diff options
-rw-r--r-- | doc/ref/guile/vcomponent.texi | 39 | ||||
-rw-r--r-- | module/vcomponent/create.scm | 121 | ||||
-rw-r--r-- | tests/test/create.scm | 60 |
3 files changed, 220 insertions, 0 deletions
diff --git a/doc/ref/guile/vcomponent.texi b/doc/ref/guile/vcomponent.texi index 299ae1da..70af3ad3 100644 --- a/doc/ref/guile/vcomponent.texi +++ b/doc/ref/guile/vcomponent.texi @@ -115,3 +115,42 @@ Does symbol start with ``X-''? @defun internal-field? symb [prefix="-"] @end defun + +@node VComponent Create +@section (vcomponent create) + +Procedures for declarativly creating components (instead of the +primitive procedural API). + +@defun vcomponent type [key: prop] ... children +Creates a new vcomponent of @var{type}. Each kv-pair should contain a +keyword @var{key}, and a value which is either a direct value, or the +return value of @code{with-parameters} or +@code{as-list}. @var{children} should be a list of other vcomponent's. +@end defun + +@defun vcalendar +@defunx vevent +@defunx vtimezone +@defunx standard +@defunx daylight +Calls @code{vcomponent}, with type set to the procedure name (but +up-cased). +@end defun + +@defun with-parameters [key: param] ... value +Allows setting parameters for a property as created by @code{vcomponent}. + +@var{value} follows the same rules as in @code{vcomponent}. Multiple +@var{key}, @var{value} pairs can be given, where each key must be a keyword. +@end defun + +@defun as-list lst +Allows setting list values when using @code{vcomponent}. + +Without this a list value would be stored as a single value, while +with this a list of values is instead stored (as, for example, in EXDATE). + +A list of list types could be hard-coded, but even then this procedure +is needed since custom types might need it. +@end defun diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm new file mode 100644 index 00000000..0521b39b --- /dev/null +++ b/module/vcomponent/create.scm @@ -0,0 +1,121 @@ +(define-module (vcomponent create) + :use-module (vcomponent base) + :use-module ((srfi srfi-1) :select (last drop-right car+cdr)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-17) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((ice-9 hash-table) :select (alist->hashq-table)) + :use-module ((hnh util) :select (kvlist->assq ->)) + :export (with-parameters + as-list + vcomponent + vcalendar vevent + vtimezone standard daylight + )) + +;; TODO allow parameters and list values at same time + + + +;; Convert a scheme keyword to a symbol suitable for us +(define (keyword->key keyword) + (-> keyword + keyword->string + string-upcase + string->symbol)) + +(define (symbol-upcase symbol) + (-> symbol + symbol->string + string-upcase + string->symbol)) + +;; Upcase the keys in an association list. Keys must be symbols. +(define (upcase-keys alist) + (map (lambda (pair) (cons (symbol-upcase (car pair)) + (cdr pair))) + alist)) + + + +(define-immutable-record-type <almost-vline> + (make-almost-vline parameters value) + almost-vline? + (parameters almost-vline-parameters) + (value almost-vline-value)) + +(define (almost-vline->vline key almost-vline) + (make-vline key + (almost-vline-value almost-vline) + (almost-vline-parameters almost-vline))) + +(define (with-parameters . args*) + (define parameters (drop-right args* 1)) + (define value (last args*)) + (make-almost-vline + (-> parameters + kvlist->assq + upcase-keys + alist->hashq-table) + value)) + + + +(define-immutable-record-type <list-value> + (make-list-value value) + list-value? + (value list-value-value)) + +(define (as-list arg) + (make-list-value arg)) + + + +(define (vcomponent type . attrs*) + (define component (make-vcomponent type)) + (define attrs*-len (length attrs*)) + (unless (zero? attrs*-len) + (let ((attrs children + (if (and (list? (list-ref attrs* (- attrs*-len 1))) + (or (= 1 attrs*-len) + (not (keyword? (list-ref attrs* (- attrs*-len 2)))))) + (values (drop-right attrs* 1) + (last attrs*)) + (values attrs* '())))) + (for-each (lambda (pair) + (let ((key value (car+cdr pair))) + (cond + ((almost-vline? value) + (set! (prop* component key) + (almost-vline->vline key value))) + ((list-value? value) + (set! (prop* component key) + (map (lambda (value) + (make-vline key value (make-hash-table))) + (list-value-value value)))) + (else + (set! (prop component key) value))))) + (upcase-keys (kvlist->assq attrs))) + + ;; Attach children + (for-each (lambda (child) (add-child! component child)) + children))) + + component) + +(define (vcalendar . attrs) + (apply vcomponent 'VCALENDAR attrs)) + +(define (vevent . attrs) + (apply vcomponent 'VEVENT attrs)) + +(define (vtimezone . attrs) + (apply vcomponent 'VTIMEZONE attrs)) + +(define (standard . attrs) + (apply vcomponent 'STANDARD attrs)) + +(define (daylight . attrs) + (apply vcomponent 'DAYLIGHT attrs)) diff --git a/tests/test/create.scm b/tests/test/create.scm new file mode 100644 index 00000000..ca055df1 --- /dev/null +++ b/tests/test/create.scm @@ -0,0 +1,60 @@ +(define-module (test create) + :use-module ((srfi srfi-1) :select (every)) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (vcomponent create) + :use-module (vcomponent)) + +;; vevent, vcalendar, vtimezone, standard, and daylight all trivial +;; and therefore not tested + +(test-group "Empty component" + (let ((ev (vcomponent 'TEST))) + (test-equal 'TEST (type ev)) + (test-equal '() (children ev)) + (test-equal '() (properties ev)))) + +(test-group "Component with properties, but no children" + (let ((ev (vcomponent 'TEST + prop: "value"))) + (test-equal '(PROP) (map car (properties ev))) + (test-equal "value" (prop ev 'PROP)))) + +(test-group "Component with children, but no properties" + (let* ((child (vcomponent 'CHILD)) + (ev (vcomponent 'TEST + (list child)))) + (test-equal '() (properties ev)) + (test-equal 1 (length (children ev))) + (test-eq child (car (children ev))))) + +(test-group "Component with both children and properties" + (let* ((child (vcomponent 'CHILD)) + (ev (vcomponent 'TEST + prop: "VALUE" + (list child)))) + (test-equal '(PROP) (map car (properties ev))) + (test-equal "VALUE" (prop ev 'PROP)) + (test-equal 1 (length (children ev))) + (test-eq child (car (children ev))))) + +(test-group "Component with no children, where last elements value is a list" + (let ((ev (vcomponent 'TEST prop: (list 1 2 3)))) + (test-equal '() (children ev)) + (test-equal '(PROP) (map car (properties ev))) + (test-equal '(1 2 3) (prop ev 'PROP)))) + +(test-group "With parameters" + (let ((ev (vcomponent 'TEST + prop: (with-parameters param: 1 2)))) + (test-equal 2 (prop ev 'PROP)) + (test-equal '(1) (param (prop* ev 'PROP) 'PARAM)))) + +(test-group "As list" + (let ((ev (vcomponent 'TEST + prop: (as-list (list 1 2 3))))) + (test-equal '(1 2 3) (prop ev 'PROP)) + (test-equal 3 (length (prop* ev 'PROP))) + (test-assert (every vline? (prop* ev 'PROP))))) + +;; (test-group "Parameters and lists" ) |