diff options
Diffstat (limited to '')
-rw-r--r-- | module/vcomponent.scm | 111 | ||||
-rw-r--r-- | module/vcomponent/instance.scm | 157 |
2 files changed, 157 insertions, 111 deletions
diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 2e13f1c8..bcadbd97 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,15 +1,8 @@ (define-module (vcomponent) :use-module (util) - :use-module (util app) :use-module (util config) - :use-module (srfi srfi-1) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - :use-module (datetime) :use-module (vcomponent base) :use-module (vcomponent parse) - :use-module ((vcomponent recurrence) :select (generate-recurrence-set repeating?)) - :use-module ((vcomponent datetime) :select (ev-time<?)) :re-export (make-vcomponent parse-cal-path parse-calendar)) @@ -22,107 +15,3 @@ [(string? v) ((@ (glob) glob) v)] [else #f]))) -(define-public (load-calendars calendar-files) - (map parse-cal-path calendar-files)) - - -(define-method (init-app calendar-files) - (setf 'calendars (load-calendars calendar-files)) - - (setf 'events - (concatenate - ;; TODO does this drop events? - (map (lambda (cal) (remove - (extract 'X-HNH-REMOVED) - (filter (lambda (o) (eq? 'VEVENT (type o))) - (children cal)))) - (getf 'calendars)))) - - (let* ((repeating regular (partition repeating? (getf 'events)))) - (setf 'fixed-events (sort*! regular date/-time<? (extract 'DTSTART))) - (setf 'repeating-events (sort*! repeating date/-time<? (extract 'DTSTART)))) - - - (setf 'event-set - (interleave-streams - ev-time<? - (cons (list->stream (getf 'fixed-events)) - (map generate-recurrence-set (getf 'repeating-events))))) - - (setf 'uid-map - (let ((ht (make-hash-table))) - (for-each (lambda (event) (hash-set! ht (prop event 'UID) event)) (getf 'events)) - ht))) - -(define-method (fixed-events-in-range start end) - (filter-sorted (lambda (ev) ((in-date-range? start end) - (as-date (prop ev 'DTSTART)))) - (getf 'fixed-events))) - -(define-method (get-event-by-uid uid) - (hash-ref (getf 'uid-map) uid)) - - - - -;;; TODO both add- and remove-event sometimes crash with -;;;;; Warning: Unwind-only `stack-overflow' exception; skipping pre-unwind handler. -;;; I belive this is due to how getf and setf work. - - -;;; TODO what should happen when an event with that UID already exists -;;; in the calendar? Fail? Overwrite? Currently it adds a second element -;;; with the same UID, which is BAD. -(define-public (add-event calendar event) - - (add-child! calendar event) - - (unless (prop event 'UID) - (set! (prop event 'UID) (uuidgen))) - - (let ((events (getf 'events))) - (setf 'events (cons event events))) - - (if (repeating? event) - (let ((repeating (getf 'repeating-events))) - (setf 'repeating-events (insert-ordered event repeating ev-time<?))) - (let ((regular (getf 'fixed-events))) - (setf 'fixed-events (insert-ordered event regular ev-time<?)))) - - (let ((event-set (getf 'event-set))) - (setf 'event-set - (interleave-streams - ev-time<? - (list (if (repeating? event) - (generate-recurrence-set event) - (stream event)) - event-set)))) - - (hash-set! (getf 'uid-map) (prop event 'UID) - event) - - (prop event 'UID)) - - -(define-public (remove-event event) - (let ((events (delete event (getf 'events)))) - (setf 'events events)) - - (if (repeating? event) - (let ((repeating (delete event (getf 'repeating-events)))) - (setf 'repeating-events repeating)) - (let ((regular (delete event (getf 'fixed-events)))) - (setf 'fixed-events regular))) - - (let ((event-set - (stream-remove - (lambda (ev) - (equal? (prop ev 'UID) - (prop event 'UID))) - (getf 'event-set)))) - (setf 'event-set event-set)) - - (hash-set! (getf 'uid-map) (prop event 'UID) - #f)) - - diff --git a/module/vcomponent/instance.scm b/module/vcomponent/instance.scm new file mode 100644 index 00000000..555395cf --- /dev/null +++ b/module/vcomponent/instance.scm @@ -0,0 +1,157 @@ +(define-module (vcomponent instance) + :use-module (util) + :use-module (util config) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (datetime) + :use-module (vcomponent base) + :use-module (vcomponent parse) + :use-module ((vcomponent recurrence) :select (generate-recurrence-set repeating?)) + :use-module ((vcomponent datetime) :select (ev-time<?)) + :use-module (oop goops) + :export (add-event remove-event + + global-event-object + + get-event-by-uid + fixed-events-in-range + + get-event-set get-calendars + get-fixed-events get-repeating-events + )) + +(define-public (load-calendars calendar-files) + (map parse-cal-path calendar-files)) + + + + +;;; TODO both add- and remove-event sometimes crash with +;;;;; Warning: Unwind-only `stack-overflow' exception; skipping pre-unwind handler. +;;; I belive this is due to how getf and setf work. + + + +;; == vcomponent == +;; - calendar +;; - events +;; - repeating-events +;; - fixed-events +;; - event-set +;; - uid-map + + + +(define-class <events> () + (calendar-files init-keyword: calendar-files:) + (calendars getter: get-calendars) + (events getter: get-events) + (repeating-events getter: get-repeating-events) + (fixed-events getter: get-fixed-events) + (event-set getter: get-event-set) + uid-map + ) + + +(define-method (get-event-by-uid (this <events>) uid) + (hash-ref (slot-ref this 'uid-map) uid)) + + + +(define-method (fixed-events-in-range (this <events>) start end) + (filter-sorted (lambda (ev) ((in-date-range? start end) + (as-date (prop ev 'DTSTART)))) + (slot-ref this 'fixed-events))) + + +(define-method (initialize (this <events>) args) + (next-method) + + (format (current-error-port) "Building <events> from ~a~%" + (slot-ref this 'calendar-files)) + + (slot-set! this 'calendars (load-calendars (slot-ref this 'calendar-files))) + + (slot-set! this 'events + (concatenate + (map (lambda (cal) (remove + (extract 'X-HNH-REMOVED) + (filter (lambda (o) (eq? 'VEVENT (type o))) + (children cal)))) + (slot-ref this 'calendars)))) + + (let* ((repeating regular (partition repeating? (slot-ref this 'events)))) + (slot-set! this 'fixed-events (sort*! regular date/-time<? (extract 'DTSTART))) + (slot-set! this 'repeating-events (sort*! repeating date/-time<? (extract 'DTSTART)))) + + + (slot-set! this 'event-set + (interleave-streams + ev-time<? + (cons (list->stream (slot-ref this 'fixed-events)) + (map generate-recurrence-set (slot-ref this 'repeating-events))))) + + (slot-set! this 'uid-map + (let ((ht (make-hash-table))) + (for-each (lambda (event) (hash-set! ht (prop event 'UID) event)) + (slot-ref this 'events)) + ht))) + +;;; TODO what should happen when an event with that UID already exists +;;; in the calendar? Fail? Overwrite? Currently it adds a second element +;;; with the same UID, which is BAD. +(define-method (add-event (this <events>) calendar event) + + (add-child! calendar event) + (unless (prop event 'UID) + (set! (prop event 'UID) (uuidgen))) + + + + + (slot-set! this 'events + (cons event (slot-ref this 'events))) + + (let* ((slot-name + (if (repeating? event) + 'repeating-events 'fixed-events)) + (events (slot-ref this slot-name))) + (slot-set! this slot-name (insert-ordered event events ev-time<?))) + + (slot-set! this 'event-set + (interleave-streams + ev-time<? + (list (if (repeating? event) + (generate-recurrence-set event) + (stream event)) + (slot-ref this 'event-set)))) + + (hash-set! (slot-ref this 'uid-map) (prop event 'UID) + event) + + (prop event 'UID)) + + + + +(define-method (remove-event (this <events>) event) + (slot-set! this 'events (delete event (slot-ref this 'events))) + + (let ((slot-name (if (repeating? event) 'repeating-events 'fixed-events))) + (slot-set! this slot-name + (delete event (slot-ref this slot-name)))) + + (slot-set! this 'event-set + (stream-remove + (lambda (ev) + (equal? (prop ev 'UID) + (prop event 'UID))) + (slot-ref this 'event-set))) + + (hash-set! (slot-ref this 'uid-map) (prop event 'UID) + #f)) + + +(define-once global-event-object + (make <events> calendar-files: (get-config 'calendar-files))) |