diff options
Diffstat (limited to 'module/vcomponent')
| -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 |
7 files changed, 400 insertions, 82 deletions
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. |