diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-03-22 20:11:11 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-03-22 20:17:52 +0100 |
commit | d46183860c1f3f10095e95023adcb79b1896ab0e (patch) | |
tree | dd331a0efe9777bfe84160139da1e39df3226b71 /module/vcalendar | |
parent | Add stuff to test.scm. (diff) | |
download | calp-d46183860c1f3f10095e95023adcb79b1896ab0e.tar.gz calp-d46183860c1f3f10095e95023adcb79b1896ab0e.tar.xz |
Move C and Scheme code into subdirs.
Diffstat (limited to 'module/vcalendar')
-rw-r--r-- | module/vcalendar/control.scm | 39 | ||||
-rw-r--r-- | module/vcalendar/datetime.scm | 34 | ||||
-rw-r--r-- | module/vcalendar/output.scm | 93 | ||||
-rw-r--r-- | module/vcalendar/primitive.scm | 23 | ||||
-rw-r--r-- | module/vcalendar/recur.scm | 12 | ||||
-rw-r--r-- | module/vcalendar/recurrence/generate.scm | 126 | ||||
-rw-r--r-- | module/vcalendar/recurrence/internal.scm | 28 | ||||
-rw-r--r-- | module/vcalendar/recurrence/parse.scm | 106 |
8 files changed, 461 insertions, 0 deletions
diff --git a/module/vcalendar/control.scm b/module/vcalendar/control.scm new file mode 100644 index 00000000..a38d678f --- /dev/null +++ b/module/vcalendar/control.scm @@ -0,0 +1,39 @@ +(define-module (vcalendar control) + #:use-module (util) + #:use-module (vcalendar) + #:export (with-replaced-attrs)) + + +(eval-when (expand load) ; No idea why I must have load here. + (define href (make-procedure-with-setter hashq-ref hashq-set!)) + + (define (set-temp-values! table component kvs) + (for-each (lambda (kv) + (let* (((key val) kv)) + (when (attr component key) + (set! (href table key) (attr component key)) + (set! (attr component key) val)))) + kvs)) + + (define (restore-values! table component keys) + (for-each (lambda (key) + (and=> (href table key) + (lambda (val) + (set! (attr component key) val)))) + keys))) + +;;; TODO with-added-attributes + +(define-syntax with-replaced-attrs + (syntax-rules () + [(_ (component (key val) ...) + body ...) + + (let ((htable (make-hash-table 10))) + (dynamic-wind + (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard + (lambda () body ...) + (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard + +;;; TODO test that restore works, at all +;;; Test that non-local exit and return works diff --git a/module/vcalendar/datetime.scm b/module/vcalendar/datetime.scm new file mode 100644 index 00000000..360b8348 --- /dev/null +++ b/module/vcalendar/datetime.scm @@ -0,0 +1,34 @@ +(define-module (vcalendar datetime) + #:use-module (vcalendar) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 util) + + #:export (parse-datetime + event-overlaps? + event-in?) + ) + +(define (parse-datetime dtime) + "Parse the given date[time] string into a date object." + ;; localize-date + (date->time-utc + (string->date + dtime + (case (string-length dtime) + ((8) "~Y~m~d") + ((15) "~Y~m~dT~H~M~S") + ((16) "~Y~m~dT~H~M~S~z"))))) + +(define (event-overlaps? event begin end) + "Returns if the event overlaps the timespan. +Event must have the DTSTART and DTEND attribute set." + (timespan-overlaps? (attr event 'DTSTART) + (attr event 'DTEND) + begin end)) + +(define (event-in? ev time) + "Does event overlap the date that contains time." + (let* ((date (time-utc->date time)) + (start (date->time-utc (drop-time date))) + (end (add-duration start (make-duration (* 60 60 24))))) + (event-overlaps? ev start end))) diff --git a/module/vcalendar/output.scm b/module/vcalendar/output.scm new file mode 100644 index 00000000..e4635beb --- /dev/null +++ b/module/vcalendar/output.scm @@ -0,0 +1,93 @@ +(define-module (vcalendar output) + #:use-module (vcalendar) + #:use-module (vcalendar control) + #:use-module (util) + #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-26) + #:export (print-vcomponent + serialize-vcomponent + color-if + STR-YELLOW STR-RESET)) + +(define STR-YELLOW "\x1b[0;33m") +(define STR-RESET "\x1b[m") + +(define-syntax-rule (color-if pred color body ...) + (let ((pred-value pred)) + (format #f "~a~a~a" + (if pred-value color "") + (begin body ...) + (if pred-value STR-RESET "")))) + +(define* (print-vcomponent comp #:optional (depth 0)) + (let ((kvs (map (lambda (key) (cons key (attr comp key))) + (attributes comp)))) + (format #t "~a <~a> :: ~:a~%" + (make-string depth #\:) + (type comp) comp) + (for-each-in kvs + (lambda (kv) + (let ((key (car kv)) + (value (cdr kv))) + (format #t "~a ~20@a: ~a~%" + (make-string depth #\:) + key value)))) + (for-each-in (children comp) + (cut print-vcomponent <> (1+ depth))))) + + + +;;; TODO +;; Error in CREATED /home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/a1a25238-d63d-46a1-87fd-d0c9334a7a30CalSync.ics: +;; Wrong type argument in position 1 (expecting string): ("20180118T124015Z" "VALARM") + +(define (string->ics-safe-string str) + "TODO wrap at 75(?) columns." + (define (escape char) + (string #\\ char)) + + (string-concatenate + (map (lambda (c) + (case c + ((#\newline) "\\n") + ((#\, #\; #\\) => escape) + (else => string))) + (string->list str)))) + +;;; TODO parameters ( ;KEY=val: ) +(define* (serialize-vcomponent comp #:optional (port (current-output-port))) + "Recursively write a component back to its ICS form. +Removes the X-HNH-FILENAME attribute, and sets PRODID to +\"HugoNikanor-calparse\" in the output." + (with-replaced-attrs + (comp (prodid "HugoNikanor-calparse")) + + (format port "BEGIN:~a~%" (type comp)) + (let ((kvs (map (lambda (key) (list key (attr comp key))) + (filter (negate (cut key=? <> 'X-HNH-FILENAME)) + (attributes comp))))) + (for-each-in + kvs (lambda (kv) + (let* (((key value) kv)) + (catch 'wrong-type-arg + (lambda () + (format port "~a:~a~%" key + (string->ics-safe-string + (case key + ((DTSTART DTEND) + (if (string? value) + value + (time->string value "~Y~m~dT~H~M~S"))) + + ((RRULE DURATION) "Just forget it") + + (else value))))) + + ;; Catch + (lambda (type proc fmt . args) + (apply format (current-error-port) "[ERR] ~a in ~a (~a) ~a:~%~?~%" + type key proc (attr comp 'X-HNH-FILENAME) + fmt args)))))) + + (for-each (cut serialize-vcomponent <> port) (children comp))) + (format port "END:~a~%" (type comp)))) diff --git a/module/vcalendar/primitive.scm b/module/vcalendar/primitive.scm new file mode 100644 index 00000000..b5eb9388 --- /dev/null +++ b/module/vcalendar/primitive.scm @@ -0,0 +1,23 @@ +;;; Primitive export of symbols linked from C binary. + +(define-module (vcalendar primitive) + #:export (%vcomponent-children + %vcomponent-push-child! + %vcomponent-filter-children! + + %vcomponent-parent + + %vcomponent-make + %vcomponent-type + + %vcomponent-set-attribute! + %vcomponent-get-attribute + + %vcomponent-attribute-list + + %vcomponent-shallow-copy)) + +(setenv "LD_LIBRARY_PATH" + (string-append (dirname (dirname (dirname (current-filename)))) + "/lib")) +(load-extension "libguile-calendar" "init_lib") diff --git a/module/vcalendar/recur.scm b/module/vcalendar/recur.scm new file mode 100644 index 00000000..3657cae6 --- /dev/null +++ b/module/vcalendar/recur.scm @@ -0,0 +1,12 @@ +(define-module (vcalendar recur) + #:use-module (vcalendar) + #:use-module (vcalendar recurrence generate) + #:re-export (generate-recurrence-set) + #:export (repeating?)) + +;; EXDATE is also a property linked to recurense rules +;; but that property alone don't create a recuring event. +(define (repeating? ev) + "Does this event repeat?" + (or (attr ev 'RRULE) + (attr ev 'RDATE))) diff --git a/module/vcalendar/recurrence/generate.scm b/module/vcalendar/recurrence/generate.scm new file mode 100644 index 00000000..fae404ec --- /dev/null +++ b/module/vcalendar/recurrence/generate.scm @@ -0,0 +1,126 @@ +(define-module (vcalendar recurrence generate) + ;; #:use-module (srfi srfi-1) + ;; #:use-module (srfi srfi-9 gnu) ; Records + #:use-module (srfi srfi-19) ; Datetime + #:use-module (srfi srfi-19 util) + + #:use-module (srfi srfi-26) ; Cut + #:use-module (srfi srfi-41) ; Streams + ;; #:use-module (ice-9 control) ; call-with-escape-continuation + #:use-module (ice-9 match) + #:use-module (vcalendar) + #:use-module (vcalendar datetime) + #:use-module (util) + + #:use-module (vcalendar recurrence internal) + #:use-module (vcalendar recurrence parse) + + #:export (generate-recurrence-set) + ) + +;;; TODO implement +;;; EXDATE and RDATE + +;;; EXDATE (3.8.5.1) +;;; comma sepparated list of dates or datetimes. +;;; Can have TZID parameter +;;; Specifies list of dates that the event should not happen on, even +;;; if the RRULE say so. +;;; Can have VALUE field specifiying "DATE-TIME" or "DATE". + +;;; RDATE (3.8.5.2) +;;; Comma sepparated list of dates the event should happen on. +;;; Can have TZID parameter. +;;; Can have VALUE parameter, specyfying "DATE-TIME", "DATE" or "PREIOD". +;;; PERIOD (see 3.3.9) + +(define (seconds-in freq) + (case freq + ((SECONDLY) 1) + ((MINUTELY) 60) + ((HOURLY) (* 60 60)) + ((DAILY) (* 60 60 24)) + ((WEEKLY) (* 60 60 24 7)))) + + +;; BYDAY and the like depend on the freq? +;; Line 7100 +;; Table @@ 2430 +;; +;; Event x Rule → Bool (continue?) +;; Alternative, monadic solution using <optional>. +;; @example +;; (optional->bool +;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r)) +;; (<$> (negate zero?) (count r)) +;; (just #t))) +;; @end example +(define-stream (recur-event-stream event rule-obj) + (stream-unfold + + ;; Event x Rule → Event + (match-lambda + ((last r) + (let ((e (copy-vcomponent last))) ; new event + (cond + + ((memv (freq r) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY)) + (mod! (attr e 'DTSTART) ; MUTATE + (cut add-duration! <> + (make-duration + (* (interval r) ; INTERVAL + (seconds-in (freq r))))))) + + ((memv (freq r) '(MONTHLY YEARLY)) + #f ; Hur fasen beräkrnar man det här!!!! + )) + + ;; TODO this is just here for testing + (mod! (attr e 'NEW_ATTR) not) ; MUTATE + ;; This segfaults... + ;; (set! (attr e 'N) #t) ; MUTATE + ((@ (vcalendar output) print-vcomponent) e) + (set! (attr e 'D) #t) + + (set! (attr e 'DTEND) ; MUTATE + (add-duration + (attr e 'DTSTART) + (attr e 'DURATION))) + e))) + + ;; Event x Rule → Bool (continue?) + (match-lambda + ((e r) + + (or (and (not (until r)) (not (count r))) ; Never ending + (and=> (count r) (negate zero?)) ; COUNT + (and=> (until r) (cut time<=? (attr e 'DTSTART) <>))))) ; UNTIL + + ;; _ x Rule → (_, (next) Rule) + (match-lambda + ((e r) + (list + e (if (count r) + ;; Note that this doesn't modify, since r is immutable. + (mod! (count r) 1-) + r)))) + + ;; Seed + (list event rule-obj))) + + +(define (generate-recurrence-set event) + (unless (attr event "DURATION") + (set! (attr event "DURATION") ; MUTATE + (time-difference + (attr event "DTEND") + (attr event "DTSTART")))) + (recur-event-stream event (parse-recurrence-rule (attr event "RRULE")))) + + ;; How doee stream-unfold even work? + ;; What element is used as the next seed? +;;; stream-fold: +;; (stream-let recur ((base base)) +;; (if (pred? base) +;; (stream-cons (mapper base) (recur (generator base))) +;; stream-null)) diff --git a/module/vcalendar/recurrence/internal.scm b/module/vcalendar/recurrence/internal.scm new file mode 100644 index 00000000..b62d75c2 --- /dev/null +++ b/module/vcalendar/recurrence/internal.scm @@ -0,0 +1,28 @@ +(define-module (vcalendar recurrence internal) + #:use-module (util) + #:use-module (srfi srfi-88) + #:export (make-recur-rule + weekdays intervals)) + +;; (list +;; (build-recur-rules "FREQ=HOURLY") +;; (build-recur-rules "FREQ=HOURLY;COUNT=3") +;; (build-recur-rules "FREQ=ERR;COUNT=3") +;; (build-recur-rules "FREQ=HOURLY;COUNT=err") +;; (build-recur-rules "FREQ=HOURLY;COUNT=-1")) + +;; Immutable, since I easily want to be able to generate the recurence set for +;; the same event multiple times. +(define-quick-record recur-rule + (public: freq until count interval bysecond byminute byhour + byday bymonthday byyearday byweekno bymonth bysetpos + wkst)) + +(define (make-recur-rule interval wkst) + ((record-constructor <recur-rule> '(interval wkst)) interval wkst)) + +(define weekdays + '(SU MO TU WE TH FR SA)) + +(define intervals + '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) diff --git a/module/vcalendar/recurrence/parse.scm b/module/vcalendar/recurrence/parse.scm new file mode 100644 index 00000000..abead3a9 --- /dev/null +++ b/module/vcalendar/recurrence/parse.scm @@ -0,0 +1,106 @@ +(define-module (vcalendar recurrence parse) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) ; Datetime + #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-26) + #:use-module ((vcalendar datetime) #:select (parse-datetime)) + #:duplicates (last) ; Replace @var{count} + #:use-module (vcalendar recurrence internal) + #:use-module (util) + #:use-module (exceptions) + #:use-module (ice-9 curried-definitions) + #:export (parse-recurrence-rule)) + +(define (parse-recurrence-rule str) + "Takes a RECUR value (string), and returuns a <recur-rule> object" + (catch #t + (lambda () (%build-recur-rules str)) + (lambda (err cont obj key val . rest) + (let ((fmt (case err + ((unfulfilled-constraint) + "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%") + ((invalid-value) + "ERR ~a [~a] for key [~a], ignoring.~%") + (else "~a ~a ~a")))) + (format #t fmt err val key)) + (cont obj)))) + +(eval-when (expand) + (define ((handle-case stx obj) key val proc) + (with-syntax ((skey (datum->syntax + stx (symbol-downcase (syntax->datum key))))) + #`((#,key) + (let ((v #,val)) + (cond ((not v) (throw-returnable 'invalid-value #,obj (quote #,key) v)) + ((#,proc #,val) (set! (skey #,obj) v)) + (else (set! (skey #,obj) + (throw-returnable 'unfulfilled-constraint + #,obj (quote #,key) v))))))))) + + +;; A special form of case only useful in parse-recurrence-rules above. +;; Each case is on the form (KEY val check-proc) where: +;; `key` is what should be matched against, and what is used for the setter +;; `val` is the value to bind to the loop object and +;; `check` is something the object must conform to +(define-syntax quick-case + (lambda (stx) + (syntax-case stx () + ((_ var-key obj (key val proc) ...) + #`(case var-key + #,@(map (handle-case stx #'obj) + #'(key ...) + #'(val ...) + #'(proc ...)) + (else obj)))))) + +(define-syntax all-in + (syntax-rules () + ((_ var rules ...) + (cut every (lambda (var) (and rules ...)) <>)))) + +(define (string->number-list val delim) + (map string->number (string-split val delim))) + +(define (string->symbols val delim) + (map string->symbol (string-split val delim))) + +(define (%build-recur-rules str) + (fold + (lambda (kv obj) + (let* (((key val) kv) + ;; Lazy fields for the poor man. + (symb (lambda () (string->symbol val))) + (date (lambda () (parse-datetime val))) + (num (lambda () (string->number val))) + (nums (lambda () (string->number-list val #\,)))) + (quick-case (string->symbol key) obj + (FREQ (symb) (cut memv <> intervals)) ; Requirek + (UNTIL (date) identity) + (COUNT (num) (cut <= 0 <>)) + (INTERVAL (num) (cut <= 0 <>)) + (BYSECOND (nums) (all-in n (<= 0 n 60))) + (BYMINUTE (nums) (all-in n (<= 0 n 59))) + (BYHOUR (nums) (all-in n (<= 0 n 23))) + + ;; TODO + ;; <weekday> ∈ weekdays + ;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO + ;; (<weekadynum>, ...) + ;; (BYDAY (string-split val #\,)) + + (BYMONTHDAY (nums) (all-in n (<= -31 n 31) (!= n 0))) + (BYYEARDAY (nums) (all-in n (<= -366 n 366) (!= n 0))) + (BYWEEKNO (nums) (all-in n (<= -53 n 53) (!= n 0))) + (BYMONTH (nums) (all-in n (<= 1 n 12))) + (BYSETPOS (nums) (all-in n (<= -366 n 366) (!= n 0))) + + (WKST (symb) (cut memv <> weekdays)) + ))) + + ;; obj + (make-recur-rule 1 'MO) + + ;; ((key val) ...) + (map (cut string-split <> #\=) + (string-split str #\;)))) |