Remove (util app).

13 files changed, 219 insertions, 217 deletions

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 <app>
-  (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-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)))
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)