Properly specify as-list and with-parameters interaction.

2 files changed, 104 insertions, 23 deletions

diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm
index ebf845fe..d332a2c2 100644
--- a/module/vcomponent/create.scm
+++ b/module/vcomponent/create.scm
@@ -6,9 +6,10 @@
   :use-module (srfi srfi-17)
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)
-  :use-module ((hnh util table) :select (alist->table))
+  :use-module ((hnh util table) :select (alist->table table?))
   :use-module ((hnh util) :select (swap init+last kvlist->assq ->))
   :use-module (hnh util object)
+  :use-module (hnh util type)
   :export (with-parameters
            as-list
            vcomponent
@@ -16,8 +17,6 @@
            vtimezone standard daylight
            ))
 
-;; TODO allow parameters and list values at same time
-
 
 
 ;; Convert a scheme keyword to a symbol suitable for us
@@ -41,22 +40,34 @@
 
 
 
-(define (with-parameters . args)
-  (define-values (parameters value)
-    (init+last args))
-  (vline
-   key: 'PLACEHOLDER
-   vline-value: value
-   vline-parameters:
-   (-> parameters
-       kvlist->assq
-       upcase-keys
-       alist->table)))
+(define (kvlist->parameter-table kvs)
+  (-> kvs kvlist->assq upcase-keys alist->table))
+
+(define-type (parameterized)
+  parameterized:value
+  (parameterized:parameters type: table?))
+
+;;; This is implemented as a macro, with an external typecheck, due to
+;;; how *when* Guile interprets different things. The check for list-value?
+;;; fails since Guile thinks it's a syntax deffinition at this point.
+;;; This setup waits with actually looking up list-value?, meaning that the
+;;; symbol is a procedure when the code is actually ran.
+(define-syntax with-parameters
+  (syntax-rules ()
+    ((_ kvs ... value)
+     (begin
+       (typecheck value (not (or list-value?
+                                 parameterized?
+                                 vline?)))
+       (parameterized
+        parameterized:value: value
+        parameterized:parameters: (kvlist->parameter-table (list kvs ...)))))))
+
 
 
 
 (define-type (list-value)
-  (list-value-value))
+  (list-value-value type: (list-of (not list-value?))))
 
 (define (as-list arg)
   (list-value list-value-value: arg))
@@ -64,20 +75,46 @@
 
 
 (define (vcomponent type . attrs*)
+  ;; Split the subforms into attributes and children
   (define-values (attrs children)
     (cond ((null? attrs*)          (values '() '()))
           ((even? (length attrs*)) (values attrs* '()))
           (else                    (init+last attrs*))))
 
+  (define (value->vline key value)
+    (cond
+     ((vline? value)
+      (scm-error 'misc-error "vcomponent"
+                 "Explicit VLines should never appear when creating components: ~s"
+                 (list value) #f))
+
+     ((list-value? value)
+      (scm-error 'misc-error "vcomponent"
+                 "As-list can only be used at top level. key: ~s, value: ~s"
+                 (list key value) #f))
+
+     ((parameterized? value)
+      (vline key: key
+             vline-value: (parameterized:value value)
+             vline-parameters: (parameterized:parameters value)))
+
+     ;; A raw value was given, embed it into a vline
+     (else (vline key: key vline-value: value))))
+
+  ;; For a given (symbol, value) pair, attach it to the given component
   (define (attach-property pair component)
     (let ((k value (car+cdr pair)))
-      (prop* component k
-             (cond ((vline? value)
-                    (key value k))
-                   ((list-value? value)
-                    (map (lambda (value) (vline key: k vline-value: value))
-                         (list-value-value value)))
-                   (else (vline key: k vline-value: value))))))
+      (cond
+       ((and (list-value? value) (null? (list-value-value value)))
+        component)
+
+       ((list-value? value)
+        (prop* component k
+               (map (lambda (v) (value->vline k v))
+                    (list-value-value value))))
+
+       (else
+        (prop* component k (value->vline k value))))))
 
   ;; TODO add-child requires a UID on the child
   ;; Possibly just genenerate one here if missing
diff --git a/tests/unit/vcomponent/create.scm b/tests/unit/vcomponent/create.scm
index 8137d723..05c56438 100644
--- a/tests/unit/vcomponent/create.scm
+++ b/tests/unit/vcomponent/create.scm
@@ -1,9 +1,12 @@
 (define-module (test create)
   :use-module ((srfi srfi-1) :select (every))
   :use-module (srfi srfi-64)
+  :use-module (srfi srfi-64 test-error)
   :use-module (srfi srfi-88)
   :use-module ((hnh util) :select (-> sort*))
+  :use-module ((hnh util table) :select (alist->table))
   :use-module ((vcomponent base) :select (vcomponent?))
+  :use-module (vcomponent)
   :use-module ((vcomponent create)
                :select (vcomponent
                         with-parameters
@@ -91,7 +94,48 @@
     (test-equal 3 (length (prop* ev 'PROP)))
     (test-assert (every vline? (prop* ev 'PROP)))))
 
-;; (test-group "Parameters and lists" )
+(test-group "List and parameters"
+  (let ((ev
+         (vevent
+          prop: (as-list
+                 (list
+                  "One"
+                  (with-parameters lang: "sv" "Två")
+                  (with-parameters numeric: "3" "Three"))))))
+    (test-equal 3 (length (prop* ev 'PROP)))
+    (test-equal '("One" "Två" "Three") (prop ev 'PROP))
+    (test-assert (every vline? (prop* ev 'PROP)))
+    (test-equal (list (vline key: 'PROP
+                             vline-value: "One")
+                      (vline key: 'PROP
+                             vline-value: "Två"
+                             vline-parameters:
+                             (alist->table '((LANG . "sv"))))
+                      (vline key: 'PROP
+                             vline-value: "Three"
+                             vline-parameters:
+                             (alist->table '((NUMERIC . "3")))))
+      (prop* ev 'PROP))))
+
+
+(test-error "Fail on nested with-parameters"
+  'wrong-type-arg
+  (vevent prop: (with-parameters a: "1"
+                                 (with-parameters b: "2"
+                                                  "3"))))
+
+(test-group "An empty as-list is effectively the same as not having the property"
+  (let ((ev (vevent prop: (as-list '()))))
+    (test-equal '() (properties ev))))
+
+(test-error "Fail on nested as-list"
+  'wrong-type-arg
+  (vevent prop: (as-list (list (as-list '())))))
+
+(test-error "Fail on as-list inside with-parameters"
+  'wrong-type-arg
+  (vevent prop: (with-parameters a: "1"
+                                 (as-list '()))))
 
 
 (test-assert (vcomponent? (vcalendar)))