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.

3 files changed, 0 insertions, 691 deletions

diff --git a/module/vcomponent/ical/output.scm b/module/vcomponent/ical/output.scm
deleted file mode 100644
index bcc6bb1d..00000000
--- a/module/vcomponent/ical/output.scm
+++ /dev/null
@@ -1,260 +0,0 @@
-(define-module (vcomponent ical output)
-  :use-module (ice-9 format)
-  :use-module (ice-9 match)
-  :use-module (calp util)
-  :use-module (calp util exceptions)
-  :use-module (vcomponent)
-  :use-module (vcomponent datetime)
-  :use-module (srfi srfi-1)
-  :use-module (datetime)
-  :use-module (srfi srfi-41)
-  :use-module (srfi srfi-41 util)
-  :use-module (datetime zic)
-  :use-module (glob)
-  :use-module (vcomponent recurrence)
-  :use-module (vcomponent geo)
-  :use-module (vcomponent ical types)
-  :autoload (vcomponent instance) (global-event-object)
-  :use-module ((datetime instance) :select (zoneinfo))
-  )
-
-(define (prodid)
-  (format #f "-//hugo//calp ~a//EN"
-          (@ (calp) version)))
-
-
-;; Format value depending on key type.
-;; Should NOT emit the key.
-(define (value-format key vline)
-
-  (define writer
-    ;; fields which can hold lists need not be considered here,
-    ;; since they are split into multiple vlines when we parse them.
-    (cond
-     ;; TODO parameters return? One or many‽
-     [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer]
-     [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID
-                         CREATED DTSTAMP LAST-MODIFIED
-                         ACKNOWLEDGED EXDATE))
-      (get-writer 'DATE-TIME)]
-
-     [(memv key '(TRIGGER DURATION))
-      (get-writer 'DURATION)]
-
-     [(memv key '(FREEBUSY))
-      (get-writer 'PERIOD)]
-
-     [(memv key '(CATEGORIES RESOURCES))
-      (lambda (p v)
-        (string-join (map (lambda (v) ((get-writer 'TEXT) p v))
-                          v)
-                     ","))]
-
-     [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION
-                        LOCATION SUMMARY TZID TZNAME
-                        CONTACT RELATED-TO UID
-
-                        VERSION))
-      (get-writer 'TEXT)]
-
-     [(memv key '(TRANSP
-               CLASS
-               PARTSTAT
-               STATUS
-               ACTION))
-      (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))]
-
-     [(memv key '(TZOFFSETFROM TZOFFSETTO))
-      (get-writer 'UTC-OFFSET)]
-
-     [(memv key '(ATTACH TZURL URL))
-      (get-writer 'URI)]
-
-     [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE))
-      (get-writer 'INTEGER)]
-
-     [(memv key '(GEO))
-      (lambda (_ v)
-        (define fl (get-writer 'FLOAT))
-        (format #f "~a:~a"
-                (fl (geo-latitude v))
-                (fl (geo-longitude v))))]
-
-     [(memv key '(RRULE))
-      (get-writer 'RECUR)]
-
-     [(memv key '(ORGANIZER ATTENDEE))
-      (get-writer 'CAL-ADDRESS)]
-
-     [(x-property? key)
-      (get-writer 'TEXT)]
-
-     [else
-      (warning "Unknown key ~a" key)
-      (get-writer 'TEXT)]))
-
-  (catch #t #; 'wrong-type-arg
-    (lambda ()
-      (writer ((@@ (vcomponent base) get-vline-parameters) vline)
-              (value vline)))
-    (lambda (err caller fmt args call-args)
-      (define fallback-string
-        (with-output-to-string (lambda () (display value))))
-      (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s"
-               key caller call-args fmt args
-               fallback-string)
-      fallback-string)))
-
-
-;; Fold long lines to limit width.
-;; Since this works in characters, but ics works in bytes
-;; this will overshoot when faced with multi-byte characters.
-;; But since the line wrapping is mearly a recomendation it's
-;; not a problem.
-;; Setting the wrap-len to slightly lower than allowed also help
-;; us not overshoot.
-(define* (ical-line-fold string #:key (wrap-len 70))
-  (cond [(< wrap-len (string-length string))
-         (format #f "~a\r\n ~a"
-                 (string-take string wrap-len)
-                 (ical-line-fold (string-drop string wrap-len)))]
-        [else string]))
-
-
-
-(define (vline->string vline)
-  (define key (vline-key vline))
-  (ical-line-fold
-   ;; Expected output: key;p1=v;p3=10:value
-   (string-append
-    (symbol->string key)
-    (string-concatenate
-     (map (match-lambda
-            [(? (compose internal-field? car)) ""]
-            [(key values ...)
-             (string-append
-              ";" (symbol->string key) "="
-              (string-join (map (compose escape-chars ->string) values)
-                           "," 'infix))])
-          (parameters vline)))
-    ":" (value-format key vline))))
-
-(define-public (component->ical-string component)
-  (format #t "BEGIN:~a\r\n" (type component))
-  (for-each
-   ;; Special cases depending on key.
-   ;; Value formatting is handled in @code{value-format}.
-   (match-lambda
-
-     [(? (compose internal-field? car)) 'noop]
-
-     [(key vlines ...)
-      (for vline in vlines
-           (display (vline->string vline))
-           (display "\r\n"))]
-
-     [(key . vline)
-      (display (vline->string vline))
-      (display "\r\n")])
-   (properties component))
-  (for-each component->ical-string (children component))
-  (format #t "END:~a\r\n" (type component))
-
-  ;; If we have alternatives, splice them in here.
-  (cond [(prop component '-X-HNH-ALTERNATIVES)
-         => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp))
-                                      alts))]))
-
-;; TODO tzid param on dtstart vs tz field in datetime object
-;; TODO remove this, replace with methods from (output vdir)
-;; how do we keep these two in sync?
-(define (write-event-to-file event calendar-path)
-  (define cal (make-vcomponent 'VCALENDAR))
-
-  (set! (prop cal 'PRODID) (prodid)
-        (prop cal 'VERSION) "2.0"
-        (prop cal 'CALSCALE) "GREGORIAN")
-
-  (add-child! cal event)
-
-  (awhen (and (provided? 'zoneinfo) 
-              (param (prop* event 'DTSTART) 'TZID))
-         ;; TODO this is broken
-         (add-child! cal (zoneinfo->vtimezone (zoneinfo) it)))
-
-  (unless (prop event 'UID)
-    (set! (prop event 'UID)
-      (uuidgen)))
-
-  (with-output-to-file (glob (format #f "~a/~a.ics"
-                                     calendar-path
-                                     (prop event 'UID)))
-    (lambda () (component->ical-string cal))))
-
-
-
-(define (print-header)
-  (format #t
-"BEGIN:VCALENDAR\r
-PRODID:~a\r
-VERSION:2.0\r
-CALSCALE:GREGORIAN\r
-" (prodid)
-))
-
-
-(define (print-footer)
-  (format #t "END:VCALENDAR\r\n"))
-
-(define (get-tz-names events)
-  (lset-difference
-   equal? (lset-union
-           equal? '("dummy")
-           (filter-map
-            (lambda (vline) (and=> (param vline 'TZID) car))
-            (filter-map (extract* 'DTSTART)
-                        events)))
-   '("dummy" "local")))
-
-
-(define-public (print-components-with-fake-parent events)
-
-  ;; The events are probably sorted before, but until I can guarantee
-  ;; that we sort them again here. We need them sorted from earliest
-  ;; and up to send the earliest to zoneinfo->vtimezone
-  (set! events (sort* events date/-time<=? (extract 'DTSTART)))
-
-  (print-header)
-
-  (when (provided? 'zoneinfo)
-    (let ((tz-names (get-tz-names events)))
-      (for-each component->ical-string
-                ;; TODO we realy should send the earliest event from each timezone here,
-                ;; instead of just the first.
-                (map (lambda (name) (zoneinfo->vtimezone
-                                      (zoneinfo)
-                                      name (car events)))
-                     tz-names))))
-
-  (for-each component->ical-string events)
-
-  (print-footer))
-
-
-(define-public (print-all-events)
-  (print-components-with-fake-parent
-   (append (get-fixed-events global-event-object)
-           ;; TODO RECCURENCE-ID exceptions
-           ;; We just dump all repeating objects, since it's much cheaper to do
-           ;; it this way than to actually figure out which are applicable for
-           ;; the given date range.
-           (get-repeating-events global-event-object))))
-
-(define-public (print-events-in-interval start end)
-  (print-components-with-fake-parent
-   (append (fixed-events-in-range start end)
-           ;; TODO RECCURENCE-ID exceptions
-           ;; We just dump all repeating objects, since it's much cheaper to do
-           ;; it this way than to actually figure out which are applicable for
-           ;; the given date range.
-           (get-repeating-events global-event-object))))
diff --git a/module/vcomponent/ical/parse.scm b/module/vcomponent/ical/parse.scm
deleted file mode 100644
index b67ae593..00000000
--- a/module/vcomponent/ical/parse.scm
+++ /dev/null
@@ -1,336 +0,0 @@
-(define-module (vcomponent ical parse)
-  :use-module (calp util)
-  :use-module (calp util exceptions)
-  :use-module ((ice-9 rdelim) :select (read-line))
-  :use-module (vcomponent base)
-  :use-module (datetime)
-  :use-module (srfi srfi-1)
-  :use-module (srfi srfi-9 gnu)
-  :use-module (srfi srfi-26)
-  :use-module (vcomponent parse types)
-  :use-module (vcomponent geo)
- )
-
-(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)))))))))
diff --git a/module/vcomponent/ical/types.scm b/module/vcomponent/ical/types.scm
deleted file mode 100644
index 1ec9d0bd..00000000
--- a/module/vcomponent/ical/types.scm
+++ /dev/null
@@ -1,95 +0,0 @@
-;; see (vcomponent parse types)
-(define-module (vcomponent ical types)
-  :use-module (calp util)
-  :use-module (calp util exceptions)
-  :use-module (base64)
-  :use-module (datetime))
-
-
-(define (write-binary _ value)
-  (bytevector->base64-string value))
-
-(define (write-boolean _ value)
-  (if value "TRUE" "FALSE"))
-
-(define (write-date _ value)
-  (date->string value "~Y~m~d"))
-
-(define (write-datetime param value)
-  ;; NOTE We really should output TZID from param here, but
-  ;; we first need to change so these writers can output
-  ;; parameters.
-  (datetime->string (hashq-ref param '-X-HNH-ORIGINAL value)
-                    "~Y~m~dT~H~M~S~Z"))
-
-(define (write-duration _ value)
-  ((@ (vcomponent duration) format-duration) value))
-
-(define (write-float _ value)
-  (number->string value))
-
-(define (write-integer _ value)
-  (number->string value))
-
-;; TODO
-(define (write-period _ value)
-  (warning "PERIOD writer not yet implemented")
-  (with-output-to-string
-    (lambda () (write value))))
-
-(define (write-recur _ value)
-  ((@ (vcomponent recurrence internal)
-      recur-rule->rrule-string) value))
-
-(define-public (escape-chars str)
-  (define (escape char)
-    (string #\\ char))
-  (string-concatenate
-   (map (lambda (c)
-          (case c
-            ((#\newline) "\\n")
-            ((#\, #\; #\\) => escape)
-            (else => string)))
-        (string->list str))))
-
-(define (write-text _ value)
-  (escape-chars value))
-
-(define (write-time _ value)
-  (time->string value "~H~M~S"))
-
-(define (write-uri _ value)
-  value)
-
-
-(use-modules (datetime timespec))
-
-(define (write-utc-offset _ value)
-  (with-output-to-string
-    (lambda ()
-      (display (if (time-zero? (timespec-time value))
-                   '+ (timespec-sign value)))
-      (display (time->string (timespec-time value) "~H~M"))
-      (when (not (zero? (second (timespec-time value))))
-        (display (time->string (timespec-time value) "~S"))))))
-
-
-(define type-writers (make-hash-table))
-(hashq-set! type-writers 'BINARY write-binary)
-(hashq-set! type-writers 'BOOLEAN write-boolean)
-(hashq-set! type-writers 'CAL-ADDRESS write-uri)
-(hashq-set! type-writers 'DATE write-date)
-(hashq-set! type-writers 'DATE-TIME write-datetime)
-(hashq-set! type-writers 'DURATION write-duration)
-(hashq-set! type-writers 'FLOAT write-float)
-(hashq-set! type-writers 'INTEGER write-integer)
-(hashq-set! type-writers 'PERIOD write-period)
-(hashq-set! type-writers 'RECUR write-recur)
-(hashq-set! type-writers 'TEXT write-text)
-(hashq-set! type-writers 'TIME write-time)
-(hashq-set! type-writers 'URI write-uri)
-(hashq-set! type-writers 'UTC-OFFSET write-utc-offset)
-
-(define-public (get-writer type)
-  (or (hashq-ref type-writers type #f)
-      (error "No writer for type" type)))