Start moving stuff out from output.

1 files changed, 0 insertions, 157 deletions

diff --git a/module/vcomponent/parse/xcal.scm b/module/vcomponent/parse/xcal.scm
deleted file mode 100644
index 2c8b7fe8..00000000
--- a/module/vcomponent/parse/xcal.scm
+++ /dev/null
@@ -1,157 +0,0 @@
-(define-module (vcomponent parse xcal)
-  :use-module (util)
-  :use-module (util exceptions)
-  :use-module (util base64)
-  :use-module (ice-9 match)
-  :use-module (sxml match)
-  :use-module (vcomponent)
-  :use-module (vcomponent geo)
-  :use-module (vcomponent parse types)
-  :use-module (datetime)
-  :use-module (srfi srfi-1)
-  )
-
-;; symbol, ht, (list a) -> non-list
-(define (handle-value type props value)
-  (case type
-
-    [(binary)
-     ;; rfc6321 allows whitespace in binary
-     (base64-string->bytevector
-      (string-delete char-set:whitespace (car value)))]
-
-    [(boolean) (string=? "true" (car value))]
-
-    ;; TODO possibly trim whitespace on text fields
-    [(cal-address uri text unknown) (car value)]
-
-    [(date) (parse-iso-date (car value))]
-
-    [(date-time) (parse-iso-datetime (car value))]
-
-    [(duration)
-     ((get-parser 'DURATION) props value)]
-
-    [(float integer) ; (3.0)
-     (string->number (car value))]
-
-    [(period)
-     (sxml-match
-      (cons 'period value)
-      [(period (start ,start-dt) (end ,end-dt))
-       (cons (parse-iso-datetime start-dt)
-             (parse-iso-datetime end-dt))]
-      [(period (start ,start-dt) (duration ,duration))
-       (cons (parse-iso-datetime start-dt)
-             ((@ (vcomponent duration) parse-duration) duration))])]
-
-    [(recur)
-     (apply (@ (vcomponent recurrence internal) make-recur-rule)
-            (for (k v) in value
-                 (list (symbol->keyword k) v)))]
-
-    [(time) (parse-iso-time (car value))]
-
-    [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))]
-
-    [(geo) ; ((long 1) (lat 2))
-     (sxml-match
-      (cons 'geo value)
-      [(geo (latitude ,x) (longitude ,y))
-       ((@ (vcomponent geo) make-geo) x y)])]))
-
-(define (symbol-upcase symb)
-  (-> symb
-      symbol->string
-      string-upcase
-      string->symbol))
-
-(define (handle-parameters parameters)
-
-  (define ht (make-hash-table))
-
-  (for param in parameters
-       (match param
-         [(ptag (ptype pvalue ...) ...)
-          ;; TODO parameter type (rfc6321 3.5.)
-          ;; TODO multi-valued parameters!!!
-          (hashq-set! ht (symbol-upcase ptag) (car (concatenate pvalue)))]))
-  ht)
-
-(define* (parse-enum str enum optional: (allow-other #t))
-  (let ((symb (string->symbol str)))
-    (unless (memv symb enum)
-      (warning "~a ∉ { ~{~a~^, ~} }" symb enum))
-    symb))
-
-
-;; symbol non-list -> non-list
-(define (handle-tag tag-name data)
-  (case tag-name
-    [(request-status)
-     ;; TODO
-     (warning "Request status not yet implemented")
-     #f]
-
-    ((transp) (parse-enum
-               data '(OPAQUE TRANSPARENT) #f))
-    ((class) (parse-enum
-              data '(PUBLIC PRIVATE CONFIDENTIAL)))
-    ((partstat) (parse-enum
-                 data '(NEEDS-ACTION ACCEPTED DECLINED TENTATIVE
-                                     DELEGATED IN-PROCESS)))
-    ((status) (parse-enum
-               data '(TENTATIVE CONFIRMED CANCELLED NEEDS-ACTION COMPLETED
-                                IN-PROCESS DRAFT FINAL CANCELED)))
-    ((action) (parse-enum
-               data '(AUDIO DISPLAY EMAIL NONE)))
-    [else data]))
-
-(define-public (sxcal->vcomponent sxcal)
-  (define type (symbol-upcase (car sxcal)))
-  (define component (make-vcomponent type))
-
-  (awhen (assoc-ref sxcal 'properties)
-         ;; Loop over multi valued fields, creating one vline
-         ;; for every value. So
-         ;;     KEY;p=1:a,b
-         ;; would be expanded into
-         ;;     KEY;p=1:a
-         ;;     KEY;p=1:b
-         (for property in it
-              (match property
-                ;; TODO request-status
-
-                [(tag ('parameters parameters ...)
-                      (type value ...) ...)
-                 (let ((params (handle-parameters parameters))
-                       (tag* (symbol-upcase tag)))
-                   (for (type value) in (zip type value)
-                        ;; ignore empty fields
-                        ;; mostly for <text/>
-                        (unless (null? value)
-                          (set! (prop* component tag*)
-                            (make-vline tag*
-                                        (handle-tag
-                                          tag (handle-value type params value))
-                                        params)))))]
-
-                [(tag (type value ...) ...)
-                 (for (type value) in (zip type value)
-                      ;; ignore empty fields
-                      ;; mostly for <text/>
-                      (unless (null? value)
-                        (let ((params (make-hash-table))
-                              (tag* (symbol-upcase tag)))
-                          (set! (prop* component tag*)
-                            (make-vline tag*
-                                        (handle-tag
-                                          tag (handle-value type params value))
-                                        params)))))])))
-
-  ;; children
-  (awhen (assoc-ref sxcal 'components)
-         (for child in (map sxcal->vcomponent it)
-              (add-child! component child)))
-
-  component)