Cleanup modules.

Primarly this moves all vcompenent input and output code to clearly
labeled modules, instead of being spread out. At the same time it also
removes a handfull of unused procedures.

1 files changed, 336 insertions, 0 deletions

diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm
new file mode 100644
index 00000000..d76044a3
--- /dev/null
+++ b/module/vcomponent/formats/ical/parse.scm
@@ -0,0 +1,336 @@
+(define-module (vcomponent formats ical parse)
+  :use-module ((ice-9 rdelim) :select (read-line))
+  :use-module (calp util exceptions)
+  :use-module (calp util)
+  :use-module (datetime)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-26)
+  :use-module (srfi srfi-9 gnu)
+  :use-module (vcomponent base)
+  :use-module (vcomponent geo)
+  :use-module (vcomponent formats common types)
+ )
+
+(define string->symbol
+  (let ((ht (make-hash-table 1000)))
+    (lambda (str)
+      (or (hash-ref ht str)
+          (let ((symb ((@ (guile) string->symbol) str)))
+            (hash-set! ht str symb)
+            symb)))))
+
+;; TODO rename to parse-vcomponent, or parse-ical (?).
+(define-public (parse-calendar port)
+  (parse (map tokenize (read-file port))))
+
+(define-immutable-record-type <line>
+  (make-line string file line)
+  line?
+  (string get-string)
+  (file get-file)
+  (line get-line))
+
+
+;; port → (list <line>)
+(define (read-file port)
+  (define fname (port-filename port))
+  (let loop ((line-number 1) (done '()))
+    (let ((ostr (open-output-string)))
+      (define ret
+        (let loop ((line (read-line port)))
+          (if (eof-object? line)
+              'eof
+              (let ((line (string-trim-right line #\return)))
+               (let ((next (peek-char port)))
+                 (display line ostr)
+                 (cond ((eof-object? next)
+                        'final-line)
+                       ;; Line Wrapping
+                       ;; If the first character on a line is space (whitespace?)
+                       ;; then it's a continuation line, and should be merged
+                       ;; with the one preceeding it.
+                       ;; TODO if the line is split inside a unicode character
+                       ;; then this produces multiple broken unicode characters.
+                       ;; It could be solved by checking the start of the new line,
+                       ;; and the tail of the old line for broken char
+                       ;; TODO what about other leading whitespace?
+                       ((char=? next #\space)
+                        (read-char port) ; discard leading whitespace
+                        (loop (read-line port)))
+                       (else
+                        ;; (unread-char next)
+                        'line)))))))
+      (case ret
+        ((line)
+         (let ((str (get-output-string ostr)))
+           (close-port ostr)
+           (loop (1+ line-number)
+                 (cons (make-line str fname line-number)
+                       done))))
+        ((eof)
+         (close-port ostr)
+         (reverse! done))
+        ((final-line)
+         (let ((str (get-output-string ostr)))
+           (close-port ostr)
+           (reverse! (cons (make-line str fname line-number)
+                           done))))))))
+
+(define-immutable-record-type <tokens>
+  (make-tokens metadata data)
+  tokens?
+  (metadata get-metadata) ; <line>
+  (data get-data) ; (key kv ... value)
+  )
+
+;; <line> → <tokens>
+(define (tokenize line-obj)
+  (define line (get-string line-obj))
+  (define colon-idx (string-index line #\:))
+  (define semi-idxs
+    (let loop ((idx 0))
+      (aif (string-index line #\; idx colon-idx)
+           (cons it (loop (1+ it)))
+           (list colon-idx (string-length line)))))
+  (make-tokens
+   line-obj
+   (map (lambda (start end)
+          (substring line (1+ start) end))
+        (cons -1 semi-idxs)
+        semi-idxs)))
+
+
+#;
+'(ATTACH ATTENDEE CATEGORIES
+         COMMENT CONTACT EXDATE
+         REQUEST-STATUS RELATED-TO
+         RESOURCES RDATE
+         ;; x-prop
+         ;; iana-prop
+         )
+
+(define (list-parser symbol)
+  (let ((parser (get-parser symbol)))
+    (lambda (params value)
+      (map (lambda (v) (parser params v))
+           (string-split value #\,)))))
+
+(define* (enum-parser enum optional: (allow-other #t))
+  (let ((parser (compose car (get-parser 'TEXT))))
+    (lambda (params value)
+      (let ((vv (parser params value)))
+        (when (list? vv)
+          (throw 'parse-error "List in enum field"))
+        (let ((v (string->symbol vv)))
+          (unless (memv v enum)
+            (warning "~a ∉ { ~{~a~^, ~} }"
+                     v enum))
+          v)))))
+
+;; params could be made optional, with an empty hashtable as default
+(define (build-vline key value params)
+  (let ((parser
+         (cond
+          [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser]
+
+          [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE
+                              CREATED DTSTAMP LAST-MODIFIED
+                              ;; only on VALARM
+                              ACKNOWLEDGED
+                              ))
+           (get-parser 'DATE-TIME)]
+
+          [(memv key '(EXDATE))
+           (list-parser 'DATE-TIME)]
+
+          [(memv key '(TRIGGER DURATION))
+           (get-parser 'DURATION)]
+
+          [(memv key '(FREEBUSY))
+           (list-parser 'PERIOD)]
+
+          [(memv key '(CALSCALE METHOD PRODID  COMMENT DESCRIPTION
+                             LOCATION SUMMARY TZID TZNAME
+                             CONTACT RELATED-TO UID))
+           (lambda (params value)
+             (let ((v ((get-parser 'TEXT) params value)))
+               (unless (= 1 (length v))
+                 (warning "List in non-list field: ~s" v))
+               (string-join v ",")))]
+
+          ;; TEXT, but allow a list
+          [(memv key '(CATEGORIES RESOURCES))
+           ;; TODO An empty value should lead to an empty set
+           ;; currently it seems to lead to '("")
+           (get-parser 'TEXT)]
+
+          [(memv key '(VERSION))
+           (lambda (params value)
+             (let ((v (car ((get-parser 'TEXT) params value))))
+               (unless (and (string? v) (string=? "2.0" v))
+                 #f
+                 ;; (warning "File of unsuported version. Proceed with caution")
+                 )
+               v))]
+
+          [(memv key '(TRANSP))
+           (enum-parser '(OPAQUE TRANSPARENT) #f)]
+
+          [(memv key '(CLASS))
+           (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))]
+
+          [(memv key '(PARTSTAT))
+           (enum-parser '(NEEDS-ACTION
+                          ACCEPTED DECLINED
+                          TENTATIVE DELEGATED
+                          IN-PROCESS))]
+
+          [(memv key '(STATUS))
+           (enum-parser '(TENTATIVE
+                          CONFIRMED CANCELLED
+                          NEEDS-ACTION COMPLETED IN-PROCESS
+                          DRAFT FINAL CANCELED))]
+
+          [(memv key '(REQUEST-STATUS))
+           (throw 'parse-error "TODO Implement REQUEST-STATUS")]
+
+          [(memv key '(ACTION))
+           (enum-parser '(AUDIO DISPLAY EMAIL
+                                NONE    ; I don't know where NONE is from
+                                        ; but it appears to be prevelant.
+                                ))]
+
+          [(memv key '(TZOFFSETFROM TZOFFSETTO))
+           (get-parser 'UTC-OFFSET)]
+
+          [(memv key '(ATTACH TZURL URL))
+           (get-parser 'URI)]
+
+          [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE))
+           (get-parser 'INTEGER)]
+
+          [(memv key '(GEO))
+           ;; two semicolon sepparated floats
+           (lambda (params value)
+             (let* (((left right) (string-split value #\;)))
+               (make-geo ((get-parser 'FLOAT) params left)
+                         ((get-parser 'FLOAT) params right))))]
+
+          [(memv key '(RRULE))
+           (get-parser 'RECUR)]
+
+          [(memv key '(ORGANIZER ATTENDEE))
+           (get-parser 'CAL-ADDRESS)]
+
+          [(x-property? key)
+           (compose car (get-parser 'TEXT))]
+
+          [else
+           (warning "Unknown key ~a" key)
+           (compose car (get-parser 'TEXT))])))
+
+    ;; If we produced a list create multiple VLINES from it.
+    ;; NOTE that the created vlines share parameter tables.
+    ;; TODO possibly allow vlines to reference each other, to
+    ;; indicate that all these vlines are the same.
+    (let ((parsed (parser params value)))
+      (if (list? parsed)
+          (apply values
+                 (map (lambda (p) (make-vline key p params))
+                      parsed))
+       (make-vline key parsed params)))))
+
+;; (parse-itemline '("DTEND"  "20200407T130000"))
+;; => DTEND
+;; => "20200407T130000"
+;; => #<hash-table 7f76b5f82a60 0/31>
+(define (parse-itemline itemline)
+  (define key (string->symbol (car itemline)))
+  (define parameters (make-hash-table))
+  (let loop ((rem (cdr itemline)))
+    (if (null? (cdr rem))
+        (values key (car rem) parameters )
+        (let* ((kv (car rem))
+               (idx (string-index kv #\=)))
+          ;; TODO lists in parameters
+          (hashq-set! parameters (string->symbol (substring kv 0 idx))
+                      (substring kv (1+ idx)))
+          (loop (cdr rem))))))
+
+
+;; (list <tokens>) → <vcomponent>
+(define (parse lst)
+  (let loop ((lst lst)
+             (stack '()))
+    (if (null? lst)
+        stack
+        (let* ((head* (car lst))
+               (head (get-data head*)))
+          (catch 'parse-error
+            (lambda ()
+             (parameterize
+                 ((warning-handler
+                   (lambda (fmt . args)
+                     (let ((linedata (get-metadata head*)))
+                       (format
+                        #f "WARNING parse error around ~a
+  ~?
+  line ~a ~a~%"
+                        (get-string linedata)
+                        fmt args
+                        (get-line linedata)
+                        (get-file linedata)
+                        )))))
+               (cond [(string=? "BEGIN" (car head))
+                      (loop (cdr lst)
+                            (cons (make-vcomponent (string->symbol (cadr head)))
+                                  stack))]
+                     [(string=? "END" (car head))
+                      (loop (cdr lst)
+                            (if (null? (cdr stack))
+                                ;; return
+                                (car stack)
+                                (begin (add-child! (cadr stack) (car stack))
+                                       (cdr stack))))]
+                     [else
+                      (let* ((key value params (parse-itemline head)))
+                        (call-with-values (lambda () (build-vline key value params))
+                          (lambda vlines
+                            (for vline in vlines
+                                 (define key (vline-key vline))
+
+                                 (set! (vline-source vline)
+                                   (get-metadata head*))
+
+                                 ;; See RFC 5545 p.53 for list of all repeating types
+                                 ;; (for vcomponent)
+                                 (if (memv key '(ATTACH ATTENDEE CATEGORIES
+                                                     COMMENT CONTACT EXDATE
+                                                     REQUEST-STATUS RELATED-TO
+                                                     RESOURCES RDATE
+                                                     ;; x-prop
+                                                     ;; iana-prop
+                                                     ))
+                                     (aif (prop* (car stack) key)
+                                          (set! (prop* (car stack) key) (cons vline it))
+                                          (set! (prop* (car stack) key) (list vline)))
+                                     ;; else
+                                     (set! (prop* (car stack) key) vline))))))
+
+                      (loop (cdr lst) stack)])))
+            (lambda (err fmt . args)
+              (let ((linedata (get-metadata head*)))
+                (display (format
+                          #f "ERROR parse error around ~a
+  ~?
+  line ~a ~a
+  Defaulting to string~%"
+                          (get-string linedata)
+                          fmt args
+                          (get-line linedata)
+                          (get-file linedata))
+                         (current-error-port))
+                (let* ((key value params (parse-itemline head)))
+                  (set! (prop* (car stack) key)
+                    (make-vline key value params))
+                  (loop (cdr lst) stack)))))))))