diff options
| author | Hugo Hörnquist <hugo@hornquist.se> | 2019-11-03 14:46:28 +0100 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-11-03 14:46:28 +0100 |
| commit | 0f65e75ec0f56d3067a15e3671d9250fd2c1637a (patch) | |
| tree | 40ddc24f08b42c767e02b6482133e9f7efe4b524 /module | |
| parent | Remove 'none' output. (diff) | |
| parent | Add descirption to strbuf. (diff) | |
| download | calp-0f65e75ec0f56d3067a15e3671d9250fd2c1637a.tar.gz calp-0f65e75ec0f56d3067a15e3671d9250fd2c1637a.tar.xz | |
Merge branch 'restruct'
Diffstat (limited to 'module')
| -rwxr-xr-x | module/main.scm | 19 | ||||
| -rw-r--r-- | module/output/html.scm | 1 | ||||
| -rw-r--r-- | module/output/ical.scm | 82 | ||||
| -rw-r--r-- | module/output/info.scm | 4 | ||||
| -rw-r--r-- | module/output/terminal.scm | 8 | ||||
| -rw-r--r-- | module/server/macro.scm | 10 | ||||
| -rw-r--r-- | module/srfi/srfi-19/util.scm | 6 | ||||
| -rw-r--r-- | module/srfi/srfi-41/util.scm | 14 | ||||
| -rw-r--r-- | module/util.scm | 12 | ||||
| -rw-r--r-- | module/util/strbuf.scm | 52 | ||||
| -rw-r--r-- | module/vcomponent.scm | 172 | ||||
| -rw-r--r-- | module/vcomponent/base.scm | 136 | ||||
| -rw-r--r-- | module/vcomponent/control.scm | 2 | ||||
| -rw-r--r-- | module/vcomponent/group.scm | 14 | ||||
| -rw-r--r-- | module/vcomponent/parse.scm | 264 | ||||
| -rw-r--r-- | module/vcomponent/primitive.scm | 19 | ||||
| -rw-r--r-- | module/vcomponent/recurrence/generate.scm | 13 | ||||
| -rw-r--r-- | module/vcomponent/timezone.scm | 34 |
18 files changed, 665 insertions, 197 deletions
diff --git a/module/main.scm b/module/main.scm index 29c7317a..242883ea 100755 --- a/module/main.scm +++ b/module/main.scm @@ -1,14 +1,7 @@ #!/bin/bash # -*- mode: scheme -*- -root=$(dirname $(dirname $(realpath $0))) - -GUILE_LOAD_PATH="$root/module:$GUILE_LOAD_PATH" -GUILE_LOAD_COMPILED_PATH="$root/obj/module:$GUILE_LOAD_COMPILED_PATH" -LD_LIBRARY_PATH="$root/lib:$LD_LIBRARY_PATH" - -export GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH LD_LIBRARY_PATH -export GUILE_AUTO_COMPILE=0 +. $(dirname $(dirname $(realpath $0)))/env exec guile -e main -s $0 "$@" !# @@ -29,6 +22,7 @@ exec guile -e main -s $0 "$@" (output text) (output import) (output info) + (output ical) (server) (ice-9 getopt-long) @@ -44,8 +38,12 @@ exec guile -e main -s $0 "$@" ;; ;; Given as a sepparate function from main to ease debugging. (define* (init proc #:key (calendar-files (calendar-files))) - (define calendars (map make-vcomponent calendar-files)) - (define events (concatenate (map (cut children <> 'VEVENT) calendars))) + (define calendars (map parse-calendar calendar-files)) + (define events (concatenate + ;; TODO does this drop events? + (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o))) + (children cal))) + calendars))) (let* ((repeating regular (partition repeating? events))) @@ -96,6 +94,7 @@ exec guile -e main -s $0 "$@" ((term) terminal-main) ((import) import-main) ((info) info-main) + ((ical) ical-main) ((server) server-main)) c e ropt))) calendar-files: (or (and=> (option-ref opts 'file #f) diff --git a/module/output/html.scm b/module/output/html.scm index e03be8d4..adbea85e 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -221,6 +221,7 @@ ;; (display "<!doctype HTML>") (newline) + ((@ (sxml simple) sxml->xml) `(html (@ (lang sv)) (head diff --git a/module/output/ical.scm b/module/output/ical.scm new file mode 100644 index 00000000..5eff7915 --- /dev/null +++ b/module/output/ical.scm @@ -0,0 +1,82 @@ +(define-module (output ical) + :use-module (ice-9 getopt-long) + :use-module (ice-9 format) + :use-module (vcomponent) + :use-module (srfi srfi-19) + :use-module (srfi srfi-19 util) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + ) + +(define opt-spec + '((from (value #t) (single-char #\f)) + (to (value #t) (single-char #\t)))) + +(define (value-format key value) + ;; TODO remove once key's are normalized to symbols. + (case (string->symbol key) + ((DTSTART DTEND) + (time->string value "~Y~m~dT~H~M~SZ")) + ((DURATION) + #; (time->string value "~H~M~S") + (let ((s (time-second value))) + (format #f "~a~a~a" + (floor/ s 3600) + (floor/ (modulo s 3600) 60) + (modulo s 60)) + )) + (else value))) + +(define (escape-chars str) + (with-output-to-string + (lambda () + (string-for-each (lambda (ch) + (case ch + ((#\, #\\) => (lambda (c) (display "\\") (display c))) + (else (display ch))) + ) str)))) + +(define (component->ical-string component) + (format #t "BEGIN:~a~%" (type component)) + (for-each (lambda (kv) + (let ((key (car kv)) + (vline (cdr kv))) + ;; key;p1=v;p3=10:value + (format #t "~a~:{;~a=~@{~a~^,~}~}:~a~%" + key (properties vline) + (escape-chars (value-format key (value vline))) + ))) + (attributes component)) + (for-each component->ical-string (children component)) + (format #t "END:~a~%" (type component)) + + ) + +(define (print-header) + (format #t +"BEGIN:VCALENDAR +PRODID:~a +VERSION:2.0 +CALSCALE:GREGORIAN +" +"Hugo" +)) + + +(define (print-footer) + (format #t "END:VCALENDAR~%")) + +(define-public (ical-main calendars events args) + (define opts (getopt-long args opt-spec)) + (define start (parse-freeform-date (option-ref opts 'from "2019-04-15"))) + (define end (parse-freeform-date (option-ref opts 'to "2019-05-10"))) + + (print-header) + + (stream-for-each + component->ical-string + (filter-sorted-stream (lambda (ev) ((in-date-range? start end) + (time-utc->date (attr ev 'DTSTART)))) + events)) + + (print-footer)) diff --git a/module/output/info.scm b/module/output/info.scm index 62600472..eba0979c 100644 --- a/module/output/info.scm +++ b/module/output/info.scm @@ -11,7 +11,9 @@ (format #t "~%Found ~a calendars, named:~%~{ - [~4@a] ~a~a\x1b[m~%~}~%" (length calendars) (concatenate - (zip (map (lambda (c) (length (children c 'VEVENT))) calendars) + (zip (map (lambda (c) (length (filter (lambda (e) (eq? 'VEVENT (type e))) + (children c)))) + calendars) (map (compose color-escape (extract 'COLOR)) calendars) (map (extract 'NAME) calendars))))) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index 67548537..16ba31e9 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -62,11 +62,14 @@ (define-values (height width) (get-terminal-size)) + (define grouped-stream (group-stream event-stream)) + (while #t ;; TODO reusing the same grouping causes it to lose events. ;; I currently have no idea why, but it's BAD. - (let ((groups (get-groups-between (group-stream event-stream) + (let ((groups (get-groups-between grouped-stream (time-utc->date time) (time-utc->date time)))) + (format (current-error-port) "len(groups) = ~a~%" (stream-length groups)) (let ((events (if (stream-null? groups) '() (group->event-list (stream-car groups))))) @@ -135,7 +138,7 @@ (let ((ev ((@ (vcomponent primitive) %vcomponent-make) fname))) (serialize-vcomponent ev (current-error-port)) - (push-child! (parent (list-ref events cur-event)) ev) + (add-child! (parent (list-ref events cur-event)) ev) (format (current-error-port) "Children: ~a~%start: ~a~%" (children ev) (attr ev 'DTSTART)) (set! event-stream (stream-insert ev-time<? ev event-stream))))))) @@ -156,5 +159,6 @@ (let ((time (date->time-utc (drop-time (or (and=> (option-ref opts 'date #f) parse-freeform-date) (current-date)))))) + ;; (format (current-error-port) "len(events) = ~a~%" (stream-length events)) (with-vulgar (lambda () (main-loop time events)))))) diff --git a/module/server/macro.scm b/module/server/macro.scm index 71452d0f..123fc468 100644 --- a/module/server/macro.scm +++ b/module/server/macro.scm @@ -7,14 +7,6 @@ (use-modules* (web (response uri))) -(define (not-null? obj) - (if (null? obj) #f obj)) - -(define (match-count pattern str) - (fold-matches pattern str 0 - (lambda (_ count) - (1+ count)))) - (define-public (parse-endpoint-string str) @@ -53,6 +45,8 @@ (define-macro (make-routes . routes) `(lambda* (request body #:optional state) + ;; ALl these bindings generate compile time warnings since the expansion + ;; of the macro might not use them. This isn't really a problem. (let ((r:method (request-method request)) (r:uri (request-uri request)) (r:version (request-version request)) diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm index 2e969f6e..4155b263 100644 --- a/module/srfi/srfi-19/util.scm +++ b/module/srfi/srfi-19/util.scm @@ -108,9 +108,9 @@ attribute set to 0. Can also be seen as \"Start of day\"" (define-public (day-stream start-day) (stream-iterate (lambda (d) - (mod! (day d) = (+ 1)) - (set! d (drop-time (normalize-date* d))) - d) + (drop-time + (normalize-date* + (set (date-day d) = (+ 1))))) (drop-time start-day))) (define-public (in-date-range? start-date end-date) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 050e1d2e..be363146 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -24,11 +24,19 @@ (define-public (stream-insert < item s) (interleave-streams < (list (stream item) s))) -(define-public (filter-sorted-stream proc stream) +;; Requires that stream is a total order in regards to what we filter +;; on. From there it knows that once it has found the first element +;; that satisfies our predicate all remaining elements satisfying pred +;; will be in direct succession. +(define-public (filter-sorted-stream pred stream) (stream-take-while - proc (stream-drop-while - (negate proc) stream))) + pred (stream-drop-while + (negate pred) stream))) + +;; Simmilar to the regular @code{filter-sorted-stream}, but once an +;; element satisfies @code{keep-remaning?} then the remaining tail +;; of the stream is all assumed to be good. (define-public (filter-sorted-stream* pred? keep-remaining? stream) (cond [(stream-null? stream) stream-null] [(keep-remaining? (stream-car stream)) stream] diff --git a/module/util.scm b/module/util.scm index 89f6dab6..707cba90 100644 --- a/module/util.scm +++ b/module/util.scm @@ -11,7 +11,7 @@ quote? re-export-modules use-modules* - -> set + -> set aif tree-map let-lazy) #:replace (let* set! define-syntax when unless if)) @@ -44,6 +44,13 @@ ((@ (guile) if) p t (begin f ...))])) +(define-syntax aif + (lambda (stx) + (syntax-case stx () + [(_ condition true-clause false-clause) + (with-syntax ((it (datum->syntax stx 'it))) + #'(let ((it condition)) + (if it true-clause false-clause)))]))) (define-public upstring->symbol (compose string->symbol string-upcase)) @@ -356,6 +363,9 @@ (-> (func obj) rest ...)])) +;; Non-destructive set, syntax extension from set-fields from (srfi +;; srfi-9 gnu). Also doubles as a non-destructive mod!, if the `=' +;; operator is used. (define-syntax set (syntax-rules (=) [(set (acc obj) value) diff --git a/module/util/strbuf.scm b/module/util/strbuf.scm new file mode 100644 index 00000000..2b574e82 --- /dev/null +++ b/module/util/strbuf.scm @@ -0,0 +1,52 @@ +;;; Description: +;; Alternative class to regular string, optimized for really fast appending, +;; Works on a byte level, and isn't really good for anything else. +;;; Code: + +(define-module (util strbuf) + :use-module (srfi srfi-9) + :use-module (rnrs bytevectors) + :use-module ((rnrs io ports) + :select (bytevector->string native-transcoder)) + :use-module ((ice-9 optargs) :select (define*-public)) + ) + +(define-record-type <strbuf> + (make-strbuf% len bytes) + strbuf? + (len get-length set-length!) + (bytes get-bytes set-bytes!)) + +(define-public (make-strbuf) + (make-strbuf% 0 (make-u8vector #x1000))) + +(define (strbuf-realloc! strbuf) + (let* ((len (u8vector-length (get-bytes strbuf))) + (nv (make-u8vector (ash len 1)))) + (bytevector-copy! (get-bytes strbuf) 0 + nv 0 len) + (set-bytes! strbuf nv))) + +;; TODO charset +(define*-public (strbuf->string strbuf #:optional + (transcoder (native-transcoder))) + (let ((bv (make-u8vector (get-length strbuf)))) + (bytevector-copy! (get-bytes strbuf) 0 + bv 0 + (get-length strbuf)) + (bytevector->string bv transcoder))) + +(define-public (strbuf-reset! strbuf) + (set-length! strbuf 0)) + +(define-public (strbuf-append! strbuf u8) + (catch 'out-of-range + (lambda () + (u8vector-set! (get-bytes strbuf) + (get-length strbuf) + u8)) + (lambda (err . args) + (strbuf-realloc! strbuf) + (strbuf-append! strbuf u8))) + (set-length! strbuf (1+ (get-length strbuf)))) + diff --git a/module/vcomponent.scm b/module/vcomponent.scm index cc79b646..871ac2e7 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,17 +1,17 @@ (define-module (vcomponent) - #:use-module ((vcomponent primitive) :select (%vcomponent-make)) #:use-module (vcomponent datetime) #:use-module (vcomponent recurrence) #:use-module (vcomponent timezone) #:use-module (vcomponent base) + #:use-module (vcomponent parse) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-19 util) #:use-module (srfi srfi-19 setters) #:use-module (srfi srfi-26) #:use-module (util) - #:export (make-vcomponent) - #:re-export (repeating?)) + #:export (parse-calendar) + #:re-export (repeating? make-vcomponent)) ;; All VTIMEZONE's seem to be in "local" time in relation to ;; themselves. Therefore, a simple comparison should work, @@ -26,29 +26,29 @@ (define (parse-dates! cal) "Parse all start times into scheme date objects." - (for tz in (children cal 'VTIMEZONE) + (for tz in (filter (lambda (o) (eq? 'VTIMEZONE (type o))) (children cal)) (for-each (lambda (p) (mod! (attr p "DTSTART") string->time-utc)) (children tz)) ;; TZSET is the generated recurrence set of a timezone (set! (attr tz 'X-HNH-TZSET) - (make-tz-set tz) - #; - ((@ (srfi srfi-41) stream) - (list - (car (children tz)) - (cadr (children tz)))) - )) - - (for ev in (children cal 'VEVENT) + (make-tz-set tz))) + + (for ev in (filter (lambda (o) (eq? 'VEVENT (type o))) (children cal)) (define dptr (attr* ev 'DTSTART)) (define eptr (attr* ev 'DTEND)) - (define date (parse-datetime (value dptr))) + (define date (parse-datetime (value dptr))) (define end-date - (if (value eptr) - (parse-datetime (value eptr)) - (set (date-hour date) = (+ 1)))) + (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))] + [(not eptr) + (let ((d (set (date-hour date) = (+ 1)))) + (set! (attr ev 'DTEND) d + eptr (attr* ev 'DTEND)) + d)] + [(value eptr) => parse-datetime] + [else + (set (date-hour date) = (+ 1))])) (set! (value dptr) (date->time-utc date) (value eptr) (date->time-utc end-date)) @@ -63,78 +63,76 @@ (value eptr) (date->time-utc end-date))))) -;; (define-public value caar) -;; (define-public next cdr) -;; (define-public next! pop!) - - -;; (define-public (reset! attr-list) -;; (while (not (car attr-list)) -;; (next! attr-list)) -;; (next! attr-list)) - -;; value -;; (define-public v -;; (make-procedure-with-setter car set-car!)) - - - -(define* (make-vcomponent #:optional path) - (if (not path) - (%vcomponent-make) - (let* ((root (%vcomponent-make path)) - (component - (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) - ;; == Single ICS file == - ;; Remove the abstract ROOT component, - ;; returning the wanted VCALENDAR component - ((file) - ;; TODO test this when an empty file is given. - (car (children root))) - - ;; == Assume vdir == - ;; Also removes the abstract ROOT component, but also - ;; merges all VCALENDAR's children into the a newly - ;; created VCALENDAR component, and return that component. - ;; - ;; TODO the other VCALENDAR components might not get thrown away, - ;; this since I protect them from the GC in the C code. - ((vdir) - (let ((accum (make-vcomponent)) - (ch (children root))) - (set! (type accum) "VCALENDAR") - - (unless (null? ch) - (for key in (attributes (car ch)) - (set! (attr accum key) (attr (car ch) key)))) - +(define* (parse-calendar path) + (let ((root (parse-cal-path path))) + (let* ((component + (case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type")) + ;; == Single ICS file == + ;; Remove the abstract ROOT component, + ;; returning the wanted VCALENDAR component + ((file) + ;; TODO test this when an empty file is given. + (car (children root))) + + ;; == Assume vdir == + ;; Also removes the abstract ROOT component, but also + ;; merges all VCALENDAR's children into the a newly + ;; created VCALENDAR component, and return that component. + ;; + ;; TODO the other VCALENDAR components might not get thrown away, + ;; this since I protect them from the GC in the C code. + ((vdir) + (let ((accum (make-vcomponent 'VCALENDAR)) + (ch (children root))) + + ;; Copy attributes from our parsed VCALENDAR + ;; to our newly created one. + (unless (null? ch) + (for key in (attributes (car ch)) + (set! (attr accum key) (attr (car ch) key)))) + + ;; Merge all children + (let ((tz '())) (for cal in ch (for component in (children cal) (case (type component) ((VTIMEZONE) + (set! tz (cons component tz)) + #; (unless (find (lambda (z) - (string=? (attr z "TZID") - (attr component "TZID"))) - (children accum 'VTIMEZONE)) - (push-child! accum component))) - (else (push-child! accum component))))) - ;; return - accum)) - - ((no-type) (throw 'no-type)) - - (else (throw 'something))))) - - (parse-dates! component) - - (unless (attr component "NAME") - (set! (attr component "NAME") - (or (attr component "X-WR-CALNAME") - (attr root "NAME")))) - - (unless (attr component "COLOR") - (set! (attr component "COLOR") - (attr root "COLOR"))) - - ;; return - component))) + (string=? (attr z "TZID") + (attr component "TZID"))) + (filter (lambda (o) (eq? 'VTIMEZONE (type o))) + (children accum))) + (add-child! accum component))) + ((VEVENT) + (add-child! accum component) + ) + (else => (lambda (type) + (format (current-error-port) + "Got unexpected component of type ~a~%" type)) + #; (add-child! accum component) + )))) + + (unless (null? tz) + (add-child! accum (car tz))) + ) + ;; return + accum)) + + ((no-type) (error 'no-type))))) + + (parse-dates! component) + + (unless (attr component "NAME") + (set! (attr component "NAME") + (or (attr component "X-WR-CALNAME") + (attr root "NAME") + "[NAMELESS]"))) + + (unless (attr component "COLOR") + (set! (attr component "COLOR") + (attr root "COLOR"))) + + ;; return + component))) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index fd8628f9..52bbe0c3 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,69 +1,123 @@ (define-module (vcomponent base) :use-module (util) :use-module (srfi srfi-1) + :use-module (srfi srfi-9) :use-module (srfi srfi-17) - :use-module (vcomponent primitive) - :use-module ((ice-9 optargs) :select (define*-public))) + :use-module (ice-9 hash-table) + :use-module ((ice-9 optargs) :select (define*-public)) + ) + + + +;; The <vline> type is a bit to many times refered to as a attr ptr. +(define-record-type <vline> + (make-vline% value parameters) + vline? + (value get-vline-value set-vline-value!) + (parameters get-vline-parameters)) + +(define*-public (make-vline value #:optional ht) + (make-vline% value (or ht (make-hash-table)))) + +(define-record-type <vcomponent> + (make-vcomponent% type children parent attributes) + vcomponent? + (type type) + (children children set-component-children!) + (parent get-component-parent set-component-parent!) + (attributes get-component-attributes)) +(export children type) + +;; TODO should this also update the parent +(define-public parent + (make-procedure-with-setter + get-component-parent set-component-parent!)) + +(define*-public (make-vcomponent #:optional (type 'VIRTUAL)) + (make-vcomponent% type '() #f (make-hash-table))) + +(define-public (add-child! parent child) + (set-component-children! parent (cons child (children parent))) + (set-component-parent! child parent)) -(define (get-attr component attr) - (%vcomponent-get-attribute - component - (as-string attr))) +(define* (get-attribute-value component key #:optional default) + (cond [(hashq-ref (get-component-attributes component) + key #f) + => get-vline-value] + [else default])) -(define (set-attr! component attr value) - (set! (car (get-attr component (as-string attr))) - value)) +(define (get-attribute component key) + (hashq-ref (get-component-attributes component) + key)) -(define-public value caar) +(define (set-attribute! component key value) + (let ((ht (get-component-attributes component))) + (cond [(hashq-ref ht key #f) + => (lambda (vline) (set-vline-value! vline value))] + [else (hashq-set! ht key (make-vline value))]))) -(define-public (values-left-count attr-list) - (length (take-while identity attr-list))) +(define-public (set-vline! component key vline) + (hashq-set! (get-component-attributes component) + key vline)) -(define-public (value-count attr-list) - (length (take-while identity (cdr (drop-while identity attr-list))))) + + +;; vline → value +(define-public value + (make-procedure-with-setter + get-vline-value set-vline-value!)) -(define-public attr* get-attr) +;; vcomponent x (or str symb) → vline +(define-public (attr* component attr) + (hashq-ref (get-component-attributes component) + (as-symb attr))) -(define (get-first c a) - (and=> (car (get-attr c a)) car)) +;; vcomponent x (or str symb) → value +(define (get-attr component key) + (get-attribute-value component (as-symb key) #f)) -(define (set-first! c a v) - (and=> (car (get-attr c a)) - (lambda (f) (set! (car f) v)))) +(define (set-attr! component key value) + (set-attribute! component (as-symb key) value)) (define-public attr (make-procedure-with-setter - get-first set-first!)) + get-attr + set-attr!)) (define-public prop (make-procedure-with-setter (lambda (attr-obj prop-key) - (hashq-ref (cdar attr-obj) prop-key)) + ;; TODO `list' is a hack since a bit to much code depends + ;; on prop always returning a list of values. + (and=> (hashq-ref (get-vline-parameters attr-obj) + (as-symb prop-key)) + list)) (lambda (attr-obj prop-key val) - (hashq-set! (cdar attr-obj) prop-key val)))) + (hashq-set! (get-vline-parameters attr-obj) + (as-symb prop-key) val)))) ;; Returns the properties of attribute as an assoc list. ;; @code{(map car <>)} leads to available properties. (define-public (properties attrptr) - (hash-map->list cons (cdar attrptr))) - -(define-public type (make-procedure-with-setter - %vcomponent-get-type - %vcomponent-set-type!)) -(define-public parent %vcomponent-parent) -(define-public push-child! %vcomponent-push-child!) -(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component))) - -(define*-public (children component #:optional only-type) - (let ((childs (%vcomponent-children component))) - (if only-type - (filter (lambda (e) (eq? only-type (type e))) childs) - childs))) - -(define-public copy-vcomponent %vcomponent-shallow-copy) - -(define-public filter-children! %vcomponent-filter-children!) + (hash-map->list cons (get-vline-parameters attrptr))) + +(define-public (attributes component) + (map car (hash-map->list cons (get-component-attributes component)))) + +(define (copy-vline vline) + (make-vline (get-vline-value vline) + ;; TODO deep-copy on properties? + (get-vline-parameters vline))) + +(define-public (copy-vcomponent component) + (make-vcomponent% (type component) + (children component) + (parent component) + ;; attributes + (alist->hashq-table + (hash-map->list (lambda (key value) (cons key (copy-vline value))) + (get-component-attributes component))))) (define-public (extract field) (lambda (e) (attr e field))) diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm index 38199161..3bdecc5a 100644 --- a/module/vcomponent/control.scm +++ b/module/vcomponent/control.scm @@ -5,7 +5,7 @@ (eval-when (expand load) ; No idea why I must have load here. - (define href (make-procedure-with-setter hashq-ref hashq-set!)) + (define href (make-procedure-with-setter hash-ref hash-set!)) (define (set-temp-values! table component kvs) (for-each (lambda (kv) diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm index c5b6948e..46160a3a 100644 --- a/module/vcomponent/group.scm +++ b/module/vcomponent/group.scm @@ -5,8 +5,9 @@ #:use-module (srfi srfi-19 util) #:use-module (srfi srfi-41) #:use-module (srfi srfi-41 util) - #:export (group-stream)) + #:export (group-stream get-groups-between)) +;; TODO templetize this (define-stream (group-stream in-stream) (define (ein? day) (lambda (e) (event-contains? e (date->time-utc day)))) @@ -15,19 +16,26 @@ (if (stream-null? stream) stream-null (let* ((day (stream-car days)) - (tomorow (add-day (date->time-utc (drop-time day))))) + (tomorow (date->time-utc (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) (time<? tomorow (attr e 'DTEND))) (lambda (e) (time<=? tomorow (attr e 'DTSTART))) stream))) + (stream-cons (cons day head) (loop (stream-cdr days) tail))))))) -(define-public (get-groups-between groups start-date end-date) +(define (get-groups-between groups start-date end-date) (filter-sorted-stream ;; TODO in-date-range? drops the first date (compose (in-date-range? start-date end-date) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm new file mode 100644 index 00000000..04a06d54 --- /dev/null +++ b/module/vcomponent/parse.scm @@ -0,0 +1,264 @@ +(define-module (vcomponent parse) + :use-module ((rnrs io ports) :select (get-u8)) + :use-module (rnrs bytevectors) + :use-module (srfi srfi-9) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module ((ice-9 textual-ports) :select (unget-char)) + :use-module ((ice-9 ftw) :select (scandir ftw)) + + :use-module (util) + :use-module (util strbuf) + :use-module (vcomponent base) + ) + + + + +(define-record-type <parse-ctx> + (make-parse-ctx% filename row col ctx line-key param-key param-table) + parse-ctx? + (filename get-filename) ; string + (row get-row set-row!) ; [0, ] + (col get-col set-col!) ; [1, ) + (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) + (line-key get-line-key set-line-key!) ; string + (param-key get-param-key set-param-key!) ; string + (param-table get-param-table set-param-table!) ; hash-map + ) + +(define (make-parse-ctx filename) + (make-parse-ctx% filename 1 0 'key + #f #f (make-hash-table))) + +(define (increment-column! ctx) + (set-col! ctx (1+ (get-col ctx)))) + +(define (increment-row! ctx) + (set-col! ctx 0) + (set-row! ctx (1+ (get-row ctx)))) + + + +(define (fold-proc ctx c) + ;; First extra character optionall read is to get the \n if our line + ;; ended with \r\n. Secound read is to get the first character of the + ;; next line. The initial \r which might recide in @var{c} is discarded. + (let ((pair (cons (if (char=? #\newline (integer->char c)) + c (get-u8 (current-input-port))) + (get-u8 (current-input-port))))) + (increment-row! ctx) + (cond [(not (char=? #\newline (integer->char (car pair)))) + (error "Expected newline after CR")] + + ;; The standard (3.4, l. 2675) says that each icalobject must + ;; end with CRLF. My files however does not. This means that + ;; an EOF can immideately follow a \n\r pair. But this case is the + ;; same as that we are at the end of line, so we spoof it and let + ;; the regular parser loop handle it. + [(eof-object? (cdr pair)) + 'end-of-line] + + ;; Following line begins with a whitespace character, + ;; meaning that we don't break the logical line here. + [(memv (integer->char (cdr pair)) '(#\space #\tab)) + (increment-column! ctx) ; since we just read the space + 'fold] + + [else + ;; TODO check if this failed, and signal a writeback error + (unget-char (current-input-port) + (integer->char (cdr pair))) + + 'end-of-line]))) + +(define (parse-calendar port) + (with-input-from-port port + (lambda () + (let ((component (make-vcomponent)) + (ctx (make-parse-ctx (port-filename port))) + (strbuf (make-strbuf))) + (with-throw-handler #t + (lambda () + (while #t + (let ((c (get-u8 (current-input-port)))) + (cond + + ;; End of file + [(eof-object? c) + ;; == NOTE == + ;; We never check the final line here. But since it + ;; ALWAYS should be "END:VCOMPONENT", and we do all + ;; the setup at creation this shouldn't be a problem. + (let ((component + (case (get-ctx ctx) + ;; Line ended before we came here, get the actual root + ;; component (instead of our virtual one: + [(key) (car (children component))] + ;; Line wasn't ended before we get here, so our current + ;; component is our "actual" root. + [(value) component] + [else + => (lambda (a) + (scm-error + 'wrong-type-arg "parse-break" + (string-append + "Bad context at end of file. " + "Expected `key' or `value', got ~a") + (list a) #f))]))) + ;; == NOTE == + ;; This sets to the VCALENDAR, which is correct, + ;; but the program later squashes together everything + ;; and drops this information. + (set! (attr component 'X-HNH-FILENAME) (get-filename ctx) + (parent component) #f) + (break component))] + + ;; End of line + [(memv (integer->char c) '(#\return #\newline)) + (case (fold-proc ctx c) + [(end-of-line) + (let ((str (strbuf->string strbuf))) + (cond [(eq? 'BEGIN (get-line-key ctx)) + (let ((child (make-vcomponent (string->symbol str)))) + (add-child! component child) + (set! component child))] + + [(eq? (get-line-key ctx) 'END) + (set! component (parent component))] + + [else + ;; TODO repeated keys + (set-vline! component (get-line-key ctx) + (make-vline str (get-param-table ctx))) + (set-param-table! ctx (make-hash-table))]) + + (strbuf-reset! strbuf) + (set-ctx! ctx 'key))] + [(fold) 'noop] ; Good case, here to catch errors in else + [else => (lambda (a) (error "Bad return from fold, unexpected" a))])] + + ;; Escaped characters + [(char=? #\\ (integer->char c)) + (case (integer->char (get-u8 (current-input-port))) + ;; Escape character '\' and escaped token sepparated by a newline + ;; (since the standard for some reason allows that (!!!)) + ;; We are at least guaranteed that it's a folded line, so just + ;; unfold it and continue trying to find a token to escape. + [(#\return #\newline) + => (lambda (c) + (case (fold-proc ctx (char->integer c)) + [(end-of-line) + (throw 'escape-error "ESC before not folded line")] + [(fold) + (increment-column! ctx) + (strbuf-append! strbuf (get-u8 (current-input-port)))]))] + + [(#\n #\N) (strbuf-append! strbuf (char->integer #\newline))] + [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))] + [else => (lambda (c) (throw 'escape-error "Non-escapable character" c))]) + (increment-column! ctx)] + + ;; Delimiter between param key and param value + [(and (eq? (get-ctx ctx) 'param-name) + (char=? #\= (integer->char c))) + (set-param-key! ctx (string->symbol (strbuf->string strbuf))) + (strbuf-reset! strbuf) + (set-ctx! ctx 'param-value)] + + ;; Delimiter between parameters (;), or between + ;; "something" and attribute value (:) + [(and (memv (integer->char c) '(#\: #\;)) + (memv (get-ctx ctx) '(param-value key))) + (case (get-ctx ctx) + [(param-value) + (hashq-set! (get-param-table ctx) + (get-param-key ctx) + (strbuf->string strbuf)) + (strbuf-reset! strbuf)] + [(key) + (set-line-key! ctx (string->symbol (strbuf->string strbuf))) + (strbuf-reset! strbuf)]) + + (set-ctx! ctx (case (integer->char c) + [(#\:) 'value] + [(#\;) 'param-name]))] + + ;; Regular character + [else + (strbuf-append! strbuf c) + (increment-column! ctx)])))) + + (lambda _ + (format (current-error-port) + "== PARSE ERROR == +filename = ~a +row ~a column ~a ctx = ~a +~a ; ~a = ... : ...~%~%" + (get-filename ctx) + (get-row ctx) (get-col ctx) (get-ctx ctx) + (get-line-key ctx) (get-param-key ctx)))))))) + + + +(define-public (read-vcalendar path) + (define st (stat path)) + (case (stat:type st) + [(regular) (let ((comp (call-with-input-file path parse-calendar))) + (set! (attr comp 'X-HNH-SOURCETYPE) "file") + (list comp))] + [(directory) + + (let ((/ (lambda args (string-join args file-name-separator-string 'infix)))) + (let ((color + (catch 'system-error + (lambda () (call-with-input-file (/ path "color") read-line)) + (const "#FFFFFF"))) + (name + (catch 'system-error + (lambda () (call-with-input-file (/ path "displayname") read-line)) + (const (basename path))))) + + (map (lambda (fname) + (let ((fullname (/ path fname))) + (let ((cal (call-with-input-file fullname + parse-calendar))) + (set! (attr cal 'COLOR) color + (attr cal 'NAME) name) + cal))) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3))))))))] + [(block-special char-special fifo socket unknown symlink) + => (lambda (t) (error "Can't parse file of type " t))])) + + +(define-public (parse-cal-path path) + (let ((parent (make-vcomponent))) + (for-each (lambda (child) (add-child! parent child)) + (read-vcalendar path)) + (set! (attr parent 'X-HNH-SOURCETYPE) + (if (null? (children parent)) + "vdir" + (or (attr (car (children parent)) + 'X-HNH-SOURCETYPE) + "vdir"))) + parent)) + + +(define-public (read-tree path) + (define list '()) + (ftw path + (lambda (filename statinfo flag) + (case flag + [(regular) + (case (stat:type statinfo) + [(regular) + (when (and (not (string= "." (string-take filename 1))) + (string= "ics" (string-take-right filename 3))) + (set! list (cons filename list))) + #t] + [else #t])] + [(directory) #t] + [else #f]))) + ((@ (ice-9 threads) n-par-map) 12 + (lambda (fname) (call-with-input-file fname parse-calendar)) + list)) diff --git a/module/vcomponent/primitive.scm b/module/vcomponent/primitive.scm deleted file mode 100644 index ad33a3be..00000000 --- a/module/vcomponent/primitive.scm +++ /dev/null @@ -1,19 +0,0 @@ -;;; Primitive export of symbols linked from C binary. - -(define-module (vcomponent primitive) - #:export (%vcomponent-children - %vcomponent-push-child! - %vcomponent-filter-children! - - %vcomponent-parent - - %vcomponent-make - %vcomponent-get-type - %vcomponent-set-type! - - %vcomponent-get-attribute - %vcomponent-attribute-list - - %vcomponent-shallow-copy)) - -(load-extension "libguile-calendar" "init_lib") diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 435d3009..3f4cb869 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -51,6 +51,9 @@ (get-tz-offset e) 0)))) + (set! (attr ev 'DTSTART) + (copy-time (attr ev 'DTSTART))) + (let ((i (interval r))) (case (freq r) ((SECONDLY) (mod! (second d) = (+ i))) @@ -73,8 +76,8 @@ (date->time-utc d)) (when (attr e 'DTEND) - (set! (attr e 'DTEND) - (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) + (set! (attr e 'DTEND) + (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) ;; Return e)) @@ -127,9 +130,9 @@ (when (and (attr event 'DTEND) (not (attr event 'DURATION))) (set! (attr event "DURATION") - (time-difference - (attr event "DTEND") - (attr event "DTSTART")))) + (time-difference + (attr event "DTEND") + (attr event "DTSTART")))) (if (attr event "RRULE") (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))) ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather diff --git a/module/vcomponent/timezone.scm b/module/vcomponent/timezone.scm index 4a312288..ed3bef6b 100644 --- a/module/vcomponent/timezone.scm +++ b/module/vcomponent/timezone.scm @@ -28,15 +28,20 @@ ;; : TZOFFSETFROM: +0200 ;; @end example -;; Given a tz stream of length 2, takes the time difference between the DTSTART -;; of those two. And creates a new VTIMEZONE with that end time. -;; TODO set remaining properties, and type of the newly created component. +;; Given a tz stream of length 2, extrapolates when the next timezone +;; change aught to be. +;; Currently it does so by taking the first time zone, and adding one +;; year. This kind of works. +;; Previously it took the difference between element 2 and 1, and added +;; that to the start of the secound time zone. This was even more wrong. +;; TODO? set remaining properties, and type of the newly created component. (define (extrapolate-tz-stream strm) - (let ((nevent (copy-vcomponent (stream-ref strm 1)))) - (mod! (attr nevent 'DTSTART) - = (add-duration (time-difference - (attr (stream-ref strm 1) 'DTSTART) - (attr (stream-ref strm 0) 'DTSTART)))) + (let ((nevent (copy-vcomponent (stream-car strm)))) + (set! (attr nevent 'DTSTART) + (date->time-utc + (set (date-year + (time-utc->date (attr nevent 'DTSTART))) + = (+ 1)))) (stream-append strm (stream nevent)))) ;; The RFC requires that at least one DAYLIGHT or STANDARD component is present. @@ -58,17 +63,20 @@ [else (stream-zip strm (stream-cdr strm))]))) +;; str ::= ±[0-9]{4} +;; str → int seconds (define (parse-offset str) - (let* (((pm h1 h0 m1 m0) (string->list str))) - ((primitive-eval (symbol pm)) - (+ (* 60 (string->number (list->string (list m1 m0)))) - (* 60 60 (string->number (list->string (list h1 h0)))))))) + (let* (((± h1 h0 m1 m0) (string->list str))) + ((primitive-eval (symbol ±)) + (+ (* 60 (string->number (string m1 m0))) + (* 60 60 (string->number (string h1 h0))))))) ;; Finds the VTIMEZONE with id @var{tzid} in calendar. ;; Crashes on error. (define (find-tz cal tzid) (let ((ret (find (lambda (tz) (string=? tzid (attr tz 'TZID))) - (children cal 'VTIMEZONE)))) + (filter (lambda (o) (eq? 'VTIMEZONE (type o))) + (children cal))))) ret)) ;; Takes a VEVENT. |