diff options
| -rw-r--r-- | module/vcomponent.scm | 142 | ||||
| -rw-r--r-- | module/vcomponent/parse.scm | 76 |
2 files changed, 112 insertions, 106 deletions
diff --git a/module/vcomponent.scm b/module/vcomponent.scm index add08775..cb01d1f1 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -78,73 +78,75 @@ (define* (parse-calendar path) - (let ((root (parse-cal-path path))) - (let* ((component - (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) - ;; == Single ICS file == - ;; Remove the abstract ROOT component, - ;; returning the wanted VCALENDAR component - ((file) - ;; TODO test this when an empty file is given. - (car (children root))) - - ;; == Assume vdir == - ;; Also removes the abstract ROOT component, but also - ;; merges all VCALENDAR's children into the a newly - ;; created VCALENDAR component, and return that component. - ;; - ;; TODO the other VCALENDAR components might not get thrown away, - ;; this since I protect them from the GC in the C code. - ((vdir) - (let ((accum (make-vcomponent 'VCALENDAR)) - (ch (children root))) - - ;; Copy attributes from our parsed VCALENDAR - ;; to our newly created one. - (unless (null? ch) - (for key in (attributes (car ch)) - (set! (attr accum key) (attr (car ch) key)))) - - ;; Merge all children - (let ((tz '())) - (for cal in ch - (for component in (children cal) - (case (type component) - ((VTIMEZONE) - ;; (set! tz (cons component tz)) - (unless (find (lambda (o) (and (eq? 'VTIMEZONE (type o)) - (string=? (attr o "TZID") - (attr component "TZID")))) - (children accum)) - (add-child! accum component))) - ((VEVENT) - (add-child! accum component) - ) - (else => (lambda (type) - (format (current-error-port) - "Got unexpected component of type ~a~%" type)) - #; (add-child! accum component) - )))) - - (unless (null? tz) - (add-child! accum (car tz))) - ) - ;; return - accum)) - - ((no-type) (error 'no-type))))) - - (parse-dates! component) - - (unless (attr component "NAME") - (set! (attr component "NAME") - (or (attr component "X-WR-CALNAME") - (attr root "NAME") - "[NAMELESS]"))) - - (unless (attr component "COLOR") - (set! (attr component "COLOR") - (attr root "COLOR"))) - - ;; return - component))) + (let ((component (parse-cal-path path))) + ;; let* + #; + ((component + (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) + ;; == Single ICS file == + ;; Remove the abstract ROOT component, + ;; returning the wanted VCALENDAR component + ((file) + ;; TODO test this when an empty file is given. + (car (children root))) + + ;; == Assume vdir == + ;; Also removes the abstract ROOT component, but also + ;; merges all VCALENDAR's children into the a newly + ;; created VCALENDAR component, and return that component. + ;; + ;; TODO the other VCALENDAR components might not get thrown away, + ;; this since I protect them from the GC in the C code. + ((vdir) + (let ((accum (make-vcomponent 'VCALENDAR)) + (ch (children root))) + + ;; Copy attributes from our parsed VCALENDAR + ;; to our newly created one. + (unless (null? ch) + (for key in (attributes (car ch)) + (set! (attr accum key) (attr (car ch) key)))) + + ;; Merge all children + (let ((tz '())) + (for cal in ch + (for component in (children cal) + (case (type component) + ((VTIMEZONE) + ;; (set! tz (cons component tz)) + (unless (find (lambda (o) (and (eq? 'VTIMEZONE (type o)) + (string=? (attr o "TZID") + (attr component "TZID")))) + (children accum)) + (add-child! accum component))) + ((VEVENT) + (add-child! accum component) + ) + (else => (lambda (type) + (format (current-error-port) + "Got unexpected component of type ~a~%" type)) + #; (add-child! accum component) + )))) + + (unless (null? tz) + (add-child! accum (car tz))) + ) + ;; return + accum)) + + ((no-type) (error 'no-type))))) + + (parse-dates! component) + + (unless (attr component "NAME") + (set! (attr component "NAME") + (or (attr component "X-WR-CALNAME") + "[NAMELESS]"))) + + #; + (unless (attr component "COLOR") + (set! (attr component "COLOR") + (attr root "COLOR"))) + + ;; return + component)) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index f862b18a..29537a5e 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,6 +1,7 @@ (define-module (vcomponent parse) :use-module ((rnrs io ports) :select (get-u8)) :use-module (rnrs bytevectors) + :use-module (srfi srfi-1) :use-module (srfi srfi-9) :use-module ((ice-9 rdelim) :select (read-line)) :use-module ((ice-9 textual-ports) :select (unget-char)) @@ -11,6 +12,8 @@ :use-module (vcomponent base) ) +(use-modules ((rnrs base) #:select (assert))) + @@ -200,48 +203,49 @@ row ~a column ~a ctx = ~a -(define-public (read-vcalendar path) +(define (parse-vdir path) + (let ((/ (lambda args (string-join args file-name-separator-string 'infix)))) + (let ((color + (catch 'system-error + (lambda () (call-with-input-file (/ path "color") read-line)) + (const "#FFFFFF"))) + (name + (catch 'system-error + (lambda () (call-with-input-file (/ path "displayname") read-line)) + (const (basename path "/"))))) + + (reduce (lambda (item calendar) + (assert (eq? 'VCALENDAR (type calendar))) + (assert (eq? 'VCALENDAR (type item))) + (for child in (children item) + (assert (memv (type child) '(VTIMEZONE VEVENT))) + (add-child! calendar child)) + calendar) + (make-vcomponent) + (map (lambda (fname) + (let ((fullname (/ path fname))) + (let ((cal (call-with-input-file fullname + parse-calendar))) + (set! (attr cal 'COLOR) color + (attr cal 'NAME) name) + cal))) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3)))))))))) + +(define-public (parse-cal-path path) (define st (stat path)) (case (stat:type st) - [(regular) (let ((comp (call-with-input-file path parse-calendar))) - (set! (attr comp 'X-HNH-SOURCETYPE) "file") - (list comp))] + [(regular) + (let ((comp (call-with-input-file path parse-calendar))) + (set! (attr comp 'X-HNH-SOURCETYPE) "file") + comp) ] [(directory) - - (let ((/ (lambda args (string-join args file-name-separator-string 'infix)))) - (let ((color - (catch 'system-error - (lambda () (call-with-input-file (/ path "color") read-line)) - (const "#FFFFFF"))) - (name - (catch 'system-error - (lambda () (call-with-input-file (/ path "displayname") read-line)) - (const (basename path))))) - - (map (lambda (fname) - (let ((fullname (/ path fname))) - (let ((cal (call-with-input-file fullname - parse-calendar))) - (set! (attr cal 'COLOR) color - (attr cal 'NAME) name) - cal))) - (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) - (string= "ics" (string-take-right s 3))))))))] + (let ((comp (parse-vdir path))) + (set! (attr comp 'X-HNH-SOURCETYPE) "vdir") + comp)] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (error "Can't parse file of type " t))])) - -(define-public (parse-cal-path path) - (let ((parent (make-vcomponent))) - (for-each (lambda (child) (add-child! parent child)) - (read-vcalendar path)) - (set! (attr parent 'X-HNH-SOURCETYPE) - (if (null? (children parent)) - "vdir" - (or (attr (car (children parent)) - 'X-HNH-SOURCETYPE) - "vdir"))) - parent)) (define-public (read-tree path) |