diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-21 16:17:28 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-22 22:58:30 +0100 |
commit | d00fea566004e67161ee45246b239fff5d416b0e (patch) | |
tree | 5641c0c0d0e78b046b6045ed2440512f12259560 /module/vcomponent/util | |
parent | Complete rewrite of use2dot (diff) | |
download | calp-d00fea566004e67161ee45246b239fff5d416b0e.tar.gz calp-d00fea566004e67161ee45246b239fff5d416b0e.tar.xz |
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.
Diffstat (limited to 'module/vcomponent/util')
-rw-r--r-- | module/vcomponent/util/control.scm | 36 | ||||
-rw-r--r-- | module/vcomponent/util/describe.scm | 44 | ||||
-rw-r--r-- | module/vcomponent/util/group.scm | 71 | ||||
-rw-r--r-- | module/vcomponent/util/instance.scm | 22 | ||||
-rw-r--r-- | module/vcomponent/util/instance/methods.scm | 139 | ||||
-rw-r--r-- | module/vcomponent/util/parse-cal-path.scm | 35 | ||||
-rw-r--r-- | module/vcomponent/util/search.scm | 175 |
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)) + ))) + + |