Add (vcomponent create).

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" )