Xcal output cleanup.

2 files changed, 55 insertions, 29 deletions

diff --git a/module/output/html.scm b/module/output/html.scm
index 94377255..9cdd874a 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -197,7 +197,7 @@
                     (data-tipped-options ,(format #f "inline: '~a'" popup-id)))))
             ,(when (debug)
                `(script (@ (type "application/calendar+xml"))
-                        ,((@ (output xcal) vcomponent->sxml) ev)))
+                        ,((@ (output xcal) vcomponent->sxcal) ev)))
             ,(when (attr ev 'RRULE)
                `(span (@ (class "repeating")) "↺"))
             ,((get-config 'summary-filter) ev (attr ev 'SUMMARY))
diff --git a/module/output/xcal.scm b/module/output/xcal.scm
index fc2a30b0..b5eda1df 100644
--- a/module/output/xcal.scm
+++ b/module/output/xcal.scm
@@ -8,6 +8,7 @@
   :use-module (output common)
   :use-module (datetime)
   :use-module (datetime util)
+  :use-module (srfi srfi-1)
   )
 
 
@@ -75,35 +76,60 @@
 
   (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline)))
 
-(define-public (vcomponent->sxml component)
-  `(,(downcase-symbol (type component))
-    (properties
-     ,@(hash-map->list
-        (match-lambda*
-          [(? (compose internal-field? car)) '()]
-
-          ;; TODO parameters
-
-          [(key (vlines ...))
-           `(,(downcase-symbol key)
-             #;
-             ,(unless (null? (properties vline))
-                `(parameters
-                  ,@(map vline->value-tag (properties vline))))
-             ,@(for vline in vlines
-                    (vline->value-tag vline)))]
-
-          [(key vline)
-           `(,(downcase-symbol key)
-             #;
-             ,(unless (null? (properties vline))
-                `(parameters
-                  ,@(map vline->value-tag (properties vline))))
-             ,(vline->value-tag vline))])
-        (attributes component)))
-    (components ,@(map vcomponent->sxml (children component)))))
+(define (property->value-tag tag . values)
+  (if (or (eq? tag 'VALUE)
+          (internal-field? tag))
+      #f
+      `(,(downcase-symbol tag)
+        ,@(map (lambda (v)
+                 ;; TODO parameter types!!!! (rfc6321 3.5.)
+                 `(text ,(->string v)))
+               values))))
+
+;; ((key value ...) ...) -> `(parameters , ... )
+(define (parameters-tag properties)
+  (define outprops (filter-map
+                    (lambda (x) (apply property->value-tag x))
+                    properties))
+
+  (unless (null? outprops)
+    `(parameters ,@outprops)))
+
+(define-public (vcomponent->sxcal component)
+
+  (define tagsymb (downcase-symbol (type component)))
+
+
+  (remove null?
+   `(,tagsymb
+     ;; TODO only have <properties> when it's non-empty.
+     ;; This becomes MUCH easier once attributes stop returning
+     ;; a hash-map...
+     (properties
+      ,@(filter
+         identity
+         (hash-map->list
+          (match-lambda*
+            [(? (compose internal-field? car)) #f]
+
+            [(key (vlines ...))
+             (remove null?
+                     `(,(downcase-symbol key)
+                       ,(parameters-tag (reduce assq-merge
+                                                '() (map properties vlines)))
+                       ,@(for vline in vlines
+                              (vline->value-tag vline))))]
+
+            [(key vline)
+             (remove null?
+                     `(,(downcase-symbol key)
+                       ,(parameters-tag (properties vline))
+                       ,(vline->value-tag vline)))])
+          (attributes component))))
+     ,(unless (null? (children component))
+        `(components ,@(map vcomponent->sxcal (children component)))))))
 
 (define-public (main calendar)
   `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
           (icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0"))
-                     ,(vcomponent->sxml calendar))))
+                     ,(vcomponent->sxcal calendar))))