diff options
Diffstat (limited to 'vcalendar')
-rw-r--r-- | vcalendar/control.scm | 39 | ||||
-rw-r--r-- | vcalendar/datetime.scm | 34 | ||||
-rw-r--r-- | vcalendar/output.scm | 93 | ||||
-rw-r--r-- | vcalendar/primitive.scm | 21 | ||||
-rw-r--r-- | vcalendar/recur.scm | 12 | ||||
-rw-r--r-- | vcalendar/recurrence/generate.scm | 126 | ||||
-rw-r--r-- | vcalendar/recurrence/internal.scm | 28 | ||||
-rw-r--r-- | vcalendar/recurrence/parse.scm | 106 |
8 files changed, 0 insertions, 459 deletions
diff --git a/vcalendar/control.scm b/vcalendar/control.scm deleted file mode 100644 index a38d678f..00000000 --- a/vcalendar/control.scm +++ /dev/null @@ -1,39 +0,0 @@ -(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/vcalendar/datetime.scm b/vcalendar/datetime.scm deleted file mode 100644 index 360b8348..00000000 --- a/vcalendar/datetime.scm +++ /dev/null @@ -1,34 +0,0 @@ -(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/vcalendar/output.scm b/vcalendar/output.scm deleted file mode 100644 index e4635beb..00000000 --- a/vcalendar/output.scm +++ /dev/null @@ -1,93 +0,0 @@ -(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/vcalendar/primitive.scm b/vcalendar/primitive.scm deleted file mode 100644 index fdce550c..00000000 --- a/vcalendar/primitive.scm +++ /dev/null @@ -1,21 +0,0 @@ -;;; 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" (dirname (dirname (current-filename)))) -(load-extension "libguile-calendar" "init_lib") diff --git a/vcalendar/recur.scm b/vcalendar/recur.scm deleted file mode 100644 index 3657cae6..00000000 --- a/vcalendar/recur.scm +++ /dev/null @@ -1,12 +0,0 @@ -(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/vcalendar/recurrence/generate.scm b/vcalendar/recurrence/generate.scm deleted file mode 100644 index fae404ec..00000000 --- a/vcalendar/recurrence/generate.scm +++ /dev/null @@ -1,126 +0,0 @@ -(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/vcalendar/recurrence/internal.scm b/vcalendar/recurrence/internal.scm deleted file mode 100644 index b62d75c2..00000000 --- a/vcalendar/recurrence/internal.scm +++ /dev/null @@ -1,28 +0,0 @@ -(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/vcalendar/recurrence/parse.scm b/vcalendar/recurrence/parse.scm deleted file mode 100644 index abead3a9..00000000 --- a/vcalendar/recurrence/parse.scm +++ /dev/null @@ -1,106 +0,0 @@ -(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 #\;)))) |