From 5188fb2251e02b32fd017dc7ba8cd6d0ce892c75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 2 Aug 2020 23:25:56 +0200 Subject: Remove (util app). --- module/datetime/app.scm | 18 ----- module/datetime/instance.scm | 19 +++++ module/entry-points/benchmark.scm | 10 ++- module/entry-points/import.scm | 9 ++- module/entry-points/server.scm | 15 ++-- module/main.scm | 5 +- module/output/html.scm | 15 ++-- module/output/ical.scm | 17 +++-- module/output/terminal.scm | 7 +- module/util/app.scm | 52 ------------- module/vcomponent.scm | 111 --------------------------- module/vcomponent/instance.scm | 157 ++++++++++++++++++++++++++++++++++++++ tests/datetime.scm | 1 + 13 files changed, 219 insertions(+), 217 deletions(-) delete mode 100644 module/datetime/app.scm create mode 100644 module/datetime/instance.scm delete mode 100644 module/util/app.scm create mode 100644 module/vcomponent/instance.scm diff --git a/module/datetime/app.scm b/module/datetime/app.scm deleted file mode 100644 index 9797ee39..00000000 --- a/module/datetime/app.scm +++ /dev/null @@ -1,18 +0,0 @@ -(define-module (datetime app) - :use-module (util) - :use-module (util app) - :use-module (ice-9 rdelim) - :use-module (datetime zic)) - -(define-method (init-app) - (setf 'zoneinfo - (let* ((pipe - (-> (@ (global) basedir) - dirname - (string-append "/tzget") - ((@ (ice-9 popen) open-input-pipe)))) - (path (read-line pipe)) - (names (string-split (read-line pipe) #\space))) - (read-zoneinfo - (map (lambda (s) (string-append path file-name-separator-string s)) - names))))) diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm new file mode 100644 index 00000000..fa5f96d6 --- /dev/null +++ b/module/datetime/instance.scm @@ -0,0 +1,19 @@ +(define-module (datetime instance) + :use-module (util) + :use-module (ice-9 rdelim) + :use-module (datetime zic) + :export (zoneinfo)) + + +(define-once + zoneinfo + (let* ((pipe + (-> (@ (global) basedir) + dirname + (string-append "/tzget") + ((@ (ice-9 popen) open-input-pipe)))) + (path (read-line pipe)) + (names (string-split (read-line pipe) #\space))) + (read-zoneinfo + (map (lambda (s) (string-append path file-name-separator-string s)) + names)))) diff --git a/module/entry-points/benchmark.scm b/module/entry-points/benchmark.scm index ae55aa26..a8507fb9 100644 --- a/module/entry-points/benchmark.scm +++ b/module/entry-points/benchmark.scm @@ -4,7 +4,7 @@ :use-module (ice-9 getopt-long) :use-module (util options) :use-module (util) - :use-module (util app) + :use-module (srfi srfi-41) ) @@ -32,6 +32,8 @@ (unless field (throw 'argument-error "Field `field' required.")) - (aif (option-ref opts 'enable-output #f) - (write (getf field app: (current-app))) - (getf field app: (current-app)))) + (let ((strm ((@ (vcomponent instance) get-event-set) + (@ (vcomponent instance) global-event-object)))) + (if (option-ref opts 'enable-output #f) + (write (stream->list 1000 strm)) + (stream->list 1000 strm)))) diff --git a/module/entry-points/import.scm b/module/entry-points/import.scm index 8b2c9008..9e8e3d7b 100644 --- a/module/entry-points/import.scm +++ b/module/entry-points/import.scm @@ -1,13 +1,14 @@ (define-module (entry-points import) :export (main) :use-module (util) - :use-module (util app) :use-module (util options) :use-module (ice-9 getopt-long) :use-module (ice-9 rdelim) :use-module (vcomponent) :use-module (srfi srfi-1) - :use-module (output vdir)) + :use-module (output vdir) + :autoload (vcomponent instance) (get-calendars global-event-object) + ) (define options '((calendar (value #t) (single-char #\c) @@ -27,11 +28,11 @@ (print-arg-help options) (throw 'return)) - (let* ((calendars (getf 'calendars)) + (let* ((calendars (get-calendars global-event-object)) (calendar (and cal-name (find (lambda (c) (string=? cal-name (prop c 'NAME))) - (getf 'calendars))))) + (get-calendars global-event-object))))) (unless calendar (format (current-error-port) "No calendar named ~s~%" cal-name) diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 5c3108cc..fd322c7d 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -1,6 +1,5 @@ (define-module (entry-points server) :use-module (util) - :use-module (util app) :use-module (util config) :use-module (util options) :use-module (util exceptions) @@ -34,6 +33,8 @@ :use-module (output html) :use-module (output ical) + :autoload (vcomponent instance) (get-calendars global-event-object) + :export (main) ) @@ -59,7 +60,7 @@ (cdr (scandir dir)))))) -(define-method (make-make-routes) +(define (make-make-routes) (make-routes ;; Manual redirect to not reserve root. @@ -77,8 +78,8 @@ (return `((content-type application/xhtml+xml)) (with-output-to-string (lambda () - (html-generate calendars: (getf 'calendars) - events: (getf 'event-set) + (html-generate calendars: (get-calendars global-event-object) + events: (get-event-set global-event-object) start-date: start-date end-date: (date+ start-date (date day: 6)) next-start: (lambda (d) (date+ d (date day: 7))) @@ -93,8 +94,8 @@ (return '((content-type application/xhtml+xml)) (with-output-to-string (lambda () - (html-generate calendars: (getf 'calendars) - events: (getf 'event-set) + (html-generate calendars: (get-calendars global-event-object) + events: (get-event-set global-event-object) start-date: start-date end-date: (date- (month+ start-date) (date day: 1)) @@ -144,7 +145,7 @@ ;; also, the default output gives everything. (let ((calendar (find (lambda (c) (string=? cal (prop c 'NAME))) - (getf 'calendars)))) + (get-calendars global-event-object)))) (unless calendar (return (build-response code: 400) diff --git a/module/main.scm b/module/main.scm index 720b31ff..cd1285d0 100644 --- a/module/main.scm +++ b/module/main.scm @@ -13,7 +13,6 @@ (util) (util io) (util time) - (util app) (util config) (util options) ((util hooks) :select (shutdown-hook)) @@ -158,8 +157,8 @@ ) ;; (current-app (make-app)) - ((@ (vcomponent) init-app) (get-config 'calendar-files)) - ((@ (datetime app) init-app)) + ;; ((@ (vcomponent) init-app) (get-config 'calendar-files)) + ;; ((@ (datetime app) init-app)) (let ((ropt (ornull (option-ref opts '() '()) '("term")))) diff --git a/module/output/html.scm b/module/output/html.scm index 8877de95..6b09bebb 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -8,7 +8,6 @@ #:use-module (vcomponent datetime) #:use-module (vcomponent build) #:use-module (util) - #:use-module (util app) #:use-module (util exceptions) #:use-module (util config) #:use-module (util tree) @@ -20,6 +19,8 @@ #:use-module (text util) #:use-module (vcomponent datetime output) + #:autoload (vcomponent instance) (get-calendars get-event-set global-event-object) + #:use-module (git) ;; #:use-module (module config all) ) @@ -817,10 +818,10 @@ (unless (file-exists? link) (symlink "../static" link)))) -(define-method (html-chunked-main count start-date chunk-length) +(define (html-chunked-main count start-date chunk-length) - (define calendars (getf 'calendars)) - (define events (getf 'event-set)) + (define calendars (get-calendars global-event-object)) + (define events (get-event-set global-event-object)) ((@ (util time) report-time!) "html start") @@ -852,10 +853,10 @@ -(define-method (html-table-main count start-date) +(define (html-table-main count start-date) - (define calendars (getf 'calendars)) - (define events (getf 'event-set)) + (define calendars (get-calendars global-event-object)) + (define events (get-event-set global-event-object)) (create-files) diff --git a/module/output/ical.scm b/module/output/ical.scm index 69ba30ce..9ab80ffb 100644 --- a/module/output/ical.scm +++ b/module/output/ical.scm @@ -3,7 +3,6 @@ :use-module (ice-9 match) :use-module (util) :use-module (util exceptions) - :use-module (util app) :use-module (vcomponent) :use-module (vcomponent datetime) :use-module (srfi srfi-1) @@ -16,6 +15,8 @@ :use-module (vcomponent geo) :use-module (output types) :use-module (output common) + :autoload (vcomponent instance) (#|get-calendars get-event-set|# global-event-object) + :autoload (datetime instance) (zoneinfo) ) @@ -171,7 +172,7 @@ (awhen (param (prop* event 'DTSTART) 'TZID) ;; TODO this is broken - (add-child! cal (zoneinfo->vtimezone (getf 'zoneinfo) it))) + (add-child! cal (zoneinfo->vtimezone zoneinfo it))) (unless (prop event 'UID) (set! (prop event 'UID) @@ -212,7 +213,7 @@ CALSCALE:GREGORIAN\r (for-each component->ical-string ;; TODO we realy should send the earliest event from each timezone here, ;; instead of just the first. - (map (lambda (name) (zoneinfo->vtimezone (getf 'zoneinfo) name (car events))) + (map (lambda (name) (zoneinfo->vtimezone zoneinfo name (car events))) tz-names))) (for-each component->ical-string events) @@ -220,20 +221,20 @@ CALSCALE:GREGORIAN\r (print-footer)) -(define-method (print-all-events) +(define (print-all-events) (print-components-with-fake-parent - (append (getf 'fixed-events) + (append (get-fixed-events global-event-object) ;; TODO RECCURENCE-ID exceptions ;; We just dump all repeating objects, since it's much cheaper to do ;; it this way than to actually figure out which are applicable for ;; the given date range. - (getf 'repeating-events)))) + (get-repeating-events global-even-object)))) -(define-method (print-events-in-interval start end) +(define (print-events-in-interval start end) (print-components-with-fake-parent (append (fixed-events-in-range start end) ;; TODO RECCURENCE-ID exceptions ;; We just dump all repeating objects, since it's much cheaper to do ;; it this way than to actually figure out which are applicable for ;; the given date range. - (getf 'repeating-events)))) + (get-repeating-events global-event-object)))) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index f4f46272..b8c1b4ac 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -7,7 +7,6 @@ #:use-module (srfi srfi-41) #:use-module (srfi srfi-41 util) #:use-module (util) - #:use-module ((util app) :prefix app/) #:use-module (vulgar) #:use-module (vulgar info) #:use-module (vulgar color) @@ -30,6 +29,8 @@ #:use-module (oop goops) #:use-module (oop goops describe) + #:autoload (vcomponent instance) (#|get-calendars get-event-set|# global-event-object) + #:export (main-loop)) (define-values (height width) (get-terminal-size)) @@ -336,8 +337,8 @@ (cached-page this) #f)) (else (next-method)))) -(app/define-method (main-loop date) - (define state (list (day-view (app/getf 'event-set) date))) +(define-public (main-loop date) + (define state (list (day-view (get-event-set global-event-object) date))) (while #t (output (car state)) diff --git a/module/util/app.scm b/module/util/app.scm deleted file mode 100644 index 65aed562..00000000 --- a/module/util/app.scm +++ /dev/null @@ -1,52 +0,0 @@ -(define-module (util app) - :use-module (util) - :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-9 gnu) - :export (make-app current-app define-method getf setf) - ) - -(define-immutable-record-type - (make-app% ht) app? (ht get-ht)) - -(define-public (make-app) - (make-app% (make-hash-table))) - -(define current-app (make-parameter (make-app))) - -(define-syntax (define-method stx) - (with-syntax ((app (datum->syntax stx 'app))) - (syntax-case stx () - [(_ (name args ...) body ...) - - (let* ((pre post (break (lambda (s) (eqv? key: (syntax->datum s))) - #'(args ...)))) - #`(define*-public (name #,@pre #,@(if (null? post) '(key:) post) - (app (current-app))) - (parameterize ((current-app app)) - body ...)))]))) - - -(define-method (getf field) - (aif (hashq-ref (get-ht app) field) - (force it) - (error "No field" field))) - -(define-syntax setf% - (syntax-rules () - [(_ app field value) - (hashq-set! (get-ht (current-app)) field (delay value))])) - -;; TODO setting a field should invalidate the cache of all dependant -;; fields. Among other things allowing a full calendar reload by running -;; (setf 'calendars (load-calendars ...)) -(define-syntax setf - (syntax-rules () - ;; special case to use current app) - [(_ key value) - (setf (current-app) key value)] - - [(_ app) app] - [(_ app key value rest ...) - (begin (setf% app key value) - (setf app rest ...))])) 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-timestream (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 () + (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 ) uid) + (hash-ref (slot-ref this 'uid-map) uid)) + + + +(define-method (fixed-events-in-range (this ) 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 ) args) + (next-method) + + (format (current-error-port) "Building 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/-timestream (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 ) 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) 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 calendar-files: (get-config 'calendar-files))) diff --git a/tests/datetime.scm b/tests/datetime.scm index 463feb95..73b7ce65 100644 --- a/tests/datetime.scm +++ b/tests/datetime.scm @@ -6,6 +6,7 @@ datetime+ datetime<=? datetime-difference + datetime- leap-year? ) ((ice-9 format) format) -- cgit v1.2.3