7 files changed, 522 insertions, 0 deletions
diff --git a/module/vcomponent/util/control.scm b/module/vcomponent/util/control.scm
new file mode 100644
index 00000000..4cb6c708
--- /dev/null
+++ b/module/vcomponent/util/control.scm
@@ -0,0 +1,36 @@
+(define-module (vcomponent util control)
+  #:use-module (calp util)
+  #:use-module (vcomponent)
+  #:export (with-replaced-properties))
+
+
+(eval-when (expand load)                ; No idea why I must have load here.
+  (define href (make-procedure-with-setter hash-ref hash-set!))
+
+  (define (set-temp-values! table component kvs)
+    (for-each (lambda (kv)
+                (let* (((key val) kv))
+                  (when (prop component key)
+                    (set! (href table key) (prop component key))
+                    (set! (prop component key) val))))
+              kvs))
+
+  (define (restore-values! table component keys)
+    (for-each (lambda (key)
+                (and=> (href table key)
+                       (lambda (val)
+                         (set! (prop component key) val))))
+              keys)))
+
+;; TODO what is this even used for?
+(define-syntax with-replaced-properties
+  (syntax-rules ()
+    [(_ (component (key val) ...)
+        body ...)
+
+     (let ((htable (make-hash-table 10)))
+       (dynamic-wind
+         (lambda () (set-temp-values! htable component (quote ((key val) ...))))  ; In guard
+         (lambda () body ...)
+         (lambda () (restore-values! htable component (quote (key ...))))))]))  ; Out guard
+
diff --git a/module/vcomponent/util/describe.scm b/module/vcomponent/util/describe.scm
new file mode 100644
index 00000000..5c3afd30
--- /dev/null
+++ b/module/vcomponent/util/describe.scm
@@ -0,0 +1,44 @@
+(define-module (vcomponent util describe)
+  :use-module (calp util)
+  :use-module (vcomponent base)
+  :use-module (text util))
+
+(define*-public (describe vcomponent optional: (indent 0))
+  (define ii (make-string indent #\space))
+  (define iii (make-string (1+ indent) #\space))
+
+  (define maxlen (find-max (map
+                            (lambda (a) (string-length (symbol->string a)))
+                            (map car (properties vcomponent)))))
+
+  (format #t "~aBEGIN ~a~%" ii (type vcomponent))
+
+  (for-each (lambda (kv)
+              (let* (((key . values) kv))
+                (define (out vline)
+                  (format #t "~a~a = ~a"
+                          iii
+                          (trim-to-width (symbol->string key) maxlen)
+                          (trim-to-width
+                           (format #f "~a" (value vline))
+                           (- 80 indent maxlen)))
+                  (awhen (vline-source vline)
+                         (display ((@@ (vcomponent formats ical parse) get-line) it)))
+                  (unless (null? (parameters vline))
+                    (display " ;")
+                    (for (key value) in (parameters vline)
+                         (format #t " ~a=~a" key value)))
+                  (newline))
+                (if (list? values)
+                    (for-each out values)
+                    (out values))))
+            (sort* (properties vcomponent)
+                   string<?
+                   ;; TODO is key always a symbol?
+                   (compose symbol->string car)))
+
+  (for child in (children vcomponent)
+
+       (describe child (+ indent 2)))
+
+  (format #t "~aEND   ~a~%" ii (type vcomponent)))
diff --git a/module/vcomponent/util/group.scm b/module/vcomponent/util/group.scm
new file mode 100644
index 00000000..f328cd18
--- /dev/null
+++ b/module/vcomponent/util/group.scm
@@ -0,0 +1,71 @@
+(define-module (vcomponent util group)
+  #:use-module (vcomponent)
+  #:use-module (vcomponent datetime)
+  #:use-module (datetime)
+  #:use-module (srfi srfi-41)
+  #:use-module (srfi srfi-41 util)
+  #:export (group-stream get-groups-between))
+
+;; TODO templetize this
+(define-stream (group-stream in-stream)
+  (define (ein? day) (lambda (e) (event-contains? e day)))
+
+  (if (stream-null? in-stream)
+      stream-null
+      (let loop ((days (day-stream (as-date (prop (stream-car in-stream) 'DTSTART))))
+                 (stream in-stream))
+        (let* ((day (stream-car days))
+               (tomorow (stream-car (stream-cdr days))))
+
+          (let ((head (stream-take-while (ein? day) stream))
+                (tail
+                 ;; This is a filter, instead of a stream-span together with head,
+                 ;; since events can span multiple days.
+                 ;; This starts with taking everything which end after the beginning
+                 ;; of tommorow, and finishes with the rest when it finds the first
+                 ;; object which begins tomorow (after midnight, exclusize).
+                 (filter-sorted-stream*
+                  (lambda (e) (date/-time<? tomorow
+                                       (or (prop e 'DTEND)
+                                           (if (date? (prop e 'DTSTART))
+                                               (date+ (prop e 'DTSTART) (date day: 1))
+                                               (prop e 'DTSTART)))))
+                  (lambda (e) (date/-time<=? tomorow (prop e 'DTSTART)))
+                  stream)))
+
+
+            (stream-cons (cons day head)
+                         (loop (stream-cdr days)
+                               tail)))))))
+
+(define (get-groups-between groups start-date end-date)
+
+  (define good-part
+    (filter-sorted-stream
+     (compose (in-date-range? start-date end-date)
+              car)
+     groups))
+
+  ;; NOTE slightly ugly hack. The first element in the return of group-stream shares
+  ;; it's date component with the lowest dtstart in the event set. This means that a
+  ;; group set might start after our start- (and end-!) date.
+  ;; To combat this I simple create a bunch of dummy groups below.
+
+  (cond [(stream-null? good-part)
+         (list->stream
+          (map (lambda (d) (cons d stream-null))
+               (date-range start-date end-date)))]
+        [(car (stream-car good-part))
+         (lambda (d) (date< start-date d))
+         => (lambda (d)
+              (stream-append
+               (list->stream
+                (map (lambda (d) (cons d stream-null))
+                     (date-range start-date
+                                 (date- d (date day: 1)))))
+               good-part))]
+        [else good-part]))
+
+
+(define-public (group->event-list group)
+  (stream->list (cdr group)))
diff --git a/module/vcomponent/util/instance.scm b/module/vcomponent/util/instance.scm
new file mode 100644
index 00000000..15c020b1
--- /dev/null
+++ b/module/vcomponent/util/instance.scm
@@ -0,0 +1,22 @@
+(define-module (vcomponent util instance)
+  :use-module (calp util)
+  :use-module ((calp util config) :select (get-config))
+  :use-module ((oop goops) :select (make))
+  :export (global-event-object)
+)
+
+
+
+
+
+;; TODO this is loaded on compile, meaning that Guile's auto-compiler may
+;; evaluate this to early.
+(define-once global-event-object
+  (make (@@ (vcomponent util instance methods) <events>)
+    calendar-files: (get-config 'calendar-files)))
+
+(define-public (reload)
+  (let ((new-value (make (@@ (vcomponent util instance methods) <events>)
+                     calendar-files: (get-config 'calendar-files))))
+    (display "Reload done\n" (current-error-port))
+    (set! global-event-object new-value)))
diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm
new file mode 100644
index 00000000..37aef3bc
--- /dev/null
+++ b/module/vcomponent/util/instance/methods.scm
@@ -0,0 +1,139 @@
+(define-module (vcomponent util instance methods)
+  :use-module (calp util)
+  :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 util parse-cal-path) :select (parse-cal-path))
+  :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
+
+           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))
+
+
+(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~%")
+  (for calendar in (slot-ref this 'calendar-files)
+       (format (current-error-port) "  - ~a~%" calendar))
+
+  (slot-set! this 'calendars (load-calendars (slot-ref this 'calendar-files)))
+
+
+  (let* ((groups
+          (group-by
+           type (concatenate
+                 (map children (slot-ref this 'calendars)))))
+         (events (awhen (assoc-ref groups 'VEVENT)
+                        (car it)))
+         (removed remaining (partition (extract 'X-HNH-REMOVED) events)))
+
+    ;; TODO figure out what to do with removed events
+
+    (slot-set! this 'events (append #|removed|# remaining)))
+
+  (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)
+  ;; cons #f so delq1! can delete the first element
+
+  (delq1! event (cons #f (slot-ref this 'events)))
+
+  (let ((slot-name (if (repeating? event) 'repeating-events 'fixed-events)))
+    (delq1! event (cons #f (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))
+
diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm
new file mode 100644
index 00000000..94c0c6ed
--- /dev/null
+++ b/module/vcomponent/util/parse-cal-path.scm
@@ -0,0 +1,35 @@
+(define-module (vcomponent util parse-cal-path)
+  :use-module (calp util)
+  :use-module ((calp util time) :select (report-time!))
+  :use-module (vcomponent base)
+  :use-module ((vcomponent formats ical parse)
+               :select (parse-calendar))
+  :use-module ((vcomponent formats vdir parse)
+               :select (parse-vdir)))
+
+
+;; Parse a vdir or ics file at the given path.
+(define-public (parse-cal-path path)
+  ;; TODO check (access? path R_OK) ?
+  (define st (stat path))
+  (define cal
+    (case (stat:type st)
+      [(regular)
+       (let ((comp (call-with-input-file path parse-calendar)))
+         (set! (prop comp '-X-HNH-SOURCETYPE) 'file)
+         comp) ]
+      [(directory)
+       (report-time! "Parsing ~a" path)
+       (let ((comp (parse-vdir path)))
+         (set! (prop comp '-X-HNH-SOURCETYPE) 'vdir
+               (prop comp '-X-HNH-DIRECTORY) path)
+         comp)]
+      [(block-special char-special fifo socket unknown symlink)
+       => (lambda (t) (error "Can't parse file of type " t))]))
+
+  (unless (prop cal "NAME")
+    (set! (prop cal "NAME")
+      (or (prop cal "X-WR-CALNAME")
+          (string-append "[" (basename path) "]"))))
+
+  cal)
diff --git a/module/vcomponent/util/search.scm b/module/vcomponent/util/search.scm
new file mode 100644
index 00000000..fb395022
--- /dev/null
+++ b/module/vcomponent/util/search.scm
@@ -0,0 +1,175 @@
+;;; Commentary:
+
+;; Procedures for searching in a (possibly) infinite stream. Everything is general,
+;; with the exception of @var{build-query-proc}, which is tailored for searches on
+;; sets on vcomponents.
+
+;; > TODO since most of this module is generic, break it out and only have the
+;; > vcomponent-specific parts here.
+
+;; A search isn't guaranteed to include all available objects, since each object
+;; only has a limited time to get found. This is mostly a problem if the matches
+;; are /really/ far from one another.
+;; NOTE a system of continuations to allow a search to be resumed with a higher
+;; timeout would be cool to have.
+
+;; Currently all searches is assumed to go through prepare-query and the paginator
+;; interface. It shouldn't however be a problem to work with the flat result-set
+;; returned by @var{execute-query} directly.
+
+;; @var{<paginator>} isn't strictly necessary even for paginated queries, since the
+;; evaluation time and pagination is baked into the stream. It is however useful
+;; for keeping track of the number of available pages, and if we have found the
+;; "final" element.
+
+;;; Code:
+
+(define-module (vcomponent util search)
+  :use-module (calp util)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-9)
+  :use-module (srfi srfi-41)
+  :use-module (srfi srfi-41 util)
+  :use-module ((ice-9 sandbox)
+               :select (make-sandbox-module
+                        all-pure-bindings)))
+
+
+;; Takes a string and appends closing parenthese until all parenthese are
+;; closed.
+(define (close-parenthese str)
+  (define missing-parenthesis-count
+    (string-fold (lambda (char count)
+                   (case char
+                     ((#\() (1+ count))
+                     ((#\)) (1- count))
+                     (else count)))
+                 0 str))
+  (string-append str (make-string missing-parenthesis-count #\))))
+
+;; Prepares a string to be sent to build-query-proc
+;; sexp-like string -> sexp
+(define-public (prepare-string str)
+  (call-with-input-string (close-parenthese str) read))
+
+;; TODO place this in a proper module
+(define (bindings-for module-name)
+  ;; Wrapping list so we can later export sub-modules.
+  (list (cons module-name
+              (module-map (lambda (a . _) a)
+                          (resolve-interface module-name)))))
+
+;; Evaluates the given expression in a sandbox.
+;; NOTE Should maybe be merged inte prepare-query. The argument against is that
+;; eval-in-sandbox is possibly slow, and that would prevent easy caching by the
+;; caller.
+;; sexp -> (event → bool)
+(define-public (build-query-proc . expressions)
+  ;; TODO does this eval help? Or will the body of the procedure
+  ;; be evalutade later?
+  (eval `(lambda (event) ,@expressions)
+        (make-sandbox-module
+         `(
+           ((vcomponent base) prop param children type parent)
+           ((ice-9 regex) string-match)
+           ,@(bindings-for '(datetime))
+           ,@all-pure-bindings)
+         )))
+
+
+;; Returns a new stream which is the result of filtering the input set with the
+;; query procedure.
+;; (a → bool), (stream a) → (stream a)
+(define-public (execute-query query-proc event-set)
+  (stream-timeslice-limit
+   (stream-filter query-proc event-set)
+   ;; .5s, tested on my laptop. .1s sometimes doesn't get to events on
+   ;; 2020-08-10, where the first event is on 1974-12-02.
+   0.5))
+
+;; Creates a prepared query wrappend in a paginator.
+;; (event → bool), (stream event) → <paginator>
+(define*-public (prepare-query query-proc event-set optional: (page-size 10))
+  (make-paginator (stream-paginate (execute-query query-proc event-set)
+                                   page-size)))
+
+(define-record-type <paginator>
+  (make-paginator% query max-page true-max-page?)
+  paginator?
+  (query get-query) ; (paginated-stream event)
+  (max-page get-max-page set-max-page!) ; int
+  (true-max-page? true-max-page? %set-true-max-page!))
+
+(define (set-true-max-page! paginator)
+  (%set-true-max-page! paginator #t))
+
+(define (unset-true-max-page! paginator)
+  (%set-true-max-page! paginator #f))
+
+(export paginator? get-query get-max-page true-max-page?)
+
+(define (make-paginator query)
+  (make-paginator% query 0 #f))
+
+;; a fancy version of 1+ which caps at max page
+;; <paginator>, int → int
+(define*-public (next-page paginator optional: (page (get-max-page paginator)))
+  (if (true-max-page? paginator)
+      (min (1+ page) (get-max-page paginator))
+      (1+ page)))
+
+(define-public (paginator->list paginator proc tail-proc)
+  (if (true-max-page? paginator)
+      (map proc (iota (1+ (get-max-page paginator))))
+      (append (map proc (iota (1+ (get-max-page paginator))))
+              (list (tail-proc (next-page paginator))))))
+
+
+(define*-public (paginator->sub-list paginator current-page proc
+                                     key: head-proc tail-proc
+                                     (ahead 5) (behind 5)
+                                     )
+
+  (let ((start (max 0 (- current-page behind)))
+        (end (min (+ current-page ahead)
+                  (get-max-page paginator))))
+
+    (display (head-proc start))
+    (for-each proc (iota (1+ (- end start)) start))
+    (display (tail-proc end)))
+
+  )
+
+;; returns the contents of the requested page, or throws 'max-page with the
+;; highest known available page.
+;; <paginator>, int → (list event) throws ('max-page <int>)
+(define-public (get-page paginator page)
+  (catch 'wrong-type-arg
+    (lambda () (let ((q (get-query paginator)))
+            (if (stream-null? q)
+                (begin
+                  (set-true-max-page! paginator)
+                  '())
+                (let ((result (stream->list
+                               (stream-ref (get-query paginator) page))))
+                  ;; This check isn't strictly necessary, but without it
+                  ;; we always needs to force the next page. And since this
+                  ;; page is "incomplete" we already know that this is the
+                  ;; final page.
+                  (when (> 10 (length result))
+                    (set-true-max-page! paginator))
+
+                  (set-max-page! paginator (max page (get-max-page paginator)))
+                  result))))
+    (lambda (err proc fmt args data)
+      ;; NOTE This is mostly a hack to see that we
+      ;; actually check for the correct error.
+      (unless (string=? fmt "beyond end of stream")
+        (scm-error err proc fmt args data))
+
+      (set-max-page! paginator (get-max-page paginator))
+      (set-true-max-page! paginator)
+      (throw 'max-page (get-max-page paginator))
+      )))
+
+