Use module-introspection more.

1 files changed, 119 insertions, 0 deletions

diff --git a/scripts/generate-test-data.scm b/scripts/generate-test-data.scm
new file mode 100755
index 00000000..076558e4
--- /dev/null
+++ b/scripts/generate-test-data.scm
@@ -0,0 +1,119 @@
+#!/usr/bin/guile \
+-e main -s
+!#
+(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module"))
+
+(use-modules (vcomponent)
+             ((vcomponent recurrence parse) :select (parse-recurrence-rule))
+             ((vcomponent formats xcal output) :select (vcomponent->sxcal ns-wrap))
+             ((vcomponent formats ical output) :select (component->ical-string))
+             (vcomponent datetime)
+             (datetime)
+             ((datetime instance) :select (zoneinfo))
+             (hnh util)
+             (hnh util uuid)
+             (ice-9 format)
+             (ice-9 popen)
+             (ice-9 threads)
+             ((srfi srfi-88) :select (keyword->string))
+             (sxml simple)
+             )
+
+(define (vevent . rest)
+  (define v (make-vcomponent 'VEVENT))
+
+  (let loop ((rem rest))
+    (unless (null? rem)
+      (let ((symb (-> (car rem)
+                      keyword->string
+                      string-upcase
+                      string->symbol)))
+        (set! (prop v symb)
+          (case symb
+            ;; [(DTSTART EXDATE) (parse-ics-datetime (cadr rem))]
+            [(RRULE) (parse-recurrence-rule (cadr rem))]
+            [else (cadr rem)]))
+        ;; hack for multi valued fields
+        (when (eq? symb 'EXDATE)
+          (set! (prop* v symb) = list)))
+      (loop (cddr rem))))
+
+  v)
+
+(define ev
+  (vevent
+    summary: "Test Event #1"
+    uid: (uuid)
+    dtstart: #2021-12-21T10:30:00
+    dtend: #2021-12-21T11:45:00
+    dtstamp: (current-datetime)
+    ))
+
+(set!
+  (param (prop* ev 'DTSTART) 'TZID) "Europe/Stockholm"
+  (param (prop* ev 'DTEND)   'TZID) "Europe/Stockholm")
+
+(define zoneinfo
+  (zoneinfo->vtimezone (zoneinfo '("tzdata/europe"))
+                       "Europe/Stockholm" ev))
+
+(define cal (make-vcomponent 'VCALENDAR))
+
+(set!
+  (prop cal 'PRODID) "-//hugo//calp TEST//EN"
+  (prop cal 'VERSION) "2.0")
+
+(add-child! cal zoneinfo)
+(add-child! cal ev)
+
+(define sxcal
+  `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
+          ,(ns-wrap (vcomponent->sxcal cal))))
+
+(define (main args)
+  (for-each (lambda (fmt)
+              (define parts (map string->symbol (string-split fmt #\:)))
+              (case (car parts)
+                ((sxcal)
+                 (if (memv 'pretty (cdr parts))
+                   (format #t "~y" sxcal)
+                   (begin (write sxcal) (newline))))
+                ((ical) (component->ical-string cal))
+                ((xml)
+                 (let ((pipe (open-output-pipe
+                               (string-join
+                                 (append '("cat")
+                                         (if (memv 'pretty (cdr parts)) '("xmllint --format -") '())
+                                         (if (memv 'color (cdr parts))  '("highlight -Oansi --syntax=xml") '()))
+                                 "|"))))
+                 (sxml->xml sxcal pipe)
+                 (close-pipe pipe)
+                 (newline)))
+                ((newline) (newline))
+                (else (format #t "Unknown mode [~a]~%" (car parts)))))
+              (cdr args)))
+
+;; (write sxcal)
+;;
+;; (newline)
+;; (newline)
+;;
+;; (format #t "~y" sxcal)
+;;
+;; (newline)
+;;
+;; (let ((pipe (open-pipe* OPEN_WRITE "highlight" "-Oansi" "--syntax=xml")))
+;;   ((@ (sxml simple) sxml->xml) sxcal pipe)
+;;   (close-pipe pipe))
+;; (newline)
+;;
+;; (let ((pipe (open-pipe "xmllint --format - | highlight -Oansi --syntax=xml"
+;;                        OPEN_WRITE
+;;                        )))
+;;   (sxml->xml sxcal pipe)
+;;   (close-pipe pipe))
+;; (newline)
+;;
+;;
+;; (newline)
+;; (component->ical-string cal)