From ecb92a54a8c2dce5f60765f3dece4223b9ff856a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 21 Mar 2019 21:19:50 +0100 Subject: Fixed recurrence code. --- exceptions.scm | 5 + util.scm | 30 +++-- vcalendar/recur.scm | 223 ++------------------------------------ vcalendar/recurrence/generate.scm | 108 ++++++++++++++++++ vcalendar/recurrence/internal.scm | 28 +++++ vcalendar/recurrence/parse.scm | 108 ++++++++++++++++++ 6 files changed, 279 insertions(+), 223 deletions(-) create mode 100644 exceptions.scm create mode 100644 vcalendar/recurrence/generate.scm create mode 100644 vcalendar/recurrence/internal.scm create mode 100644 vcalendar/recurrence/parse.scm diff --git a/exceptions.scm b/exceptions.scm new file mode 100644 index 00000000..027c75ee --- /dev/null +++ b/exceptions.scm @@ -0,0 +1,5 @@ +(define-module (exceptions) + #:export (throw-returnable)) + +(define-syntax-rule (throw-returnable symb args ...) + (call/cc (lambda (cont) (throw symb cont args ...)))) diff --git a/util.scm b/util.scm index e2151b79..421b38f4 100644 --- a/util.scm +++ b/util.scm @@ -48,7 +48,7 @@ (define (%define-quick-record internal-define bang? name fields) (let ((symb (gensym))) - `(begin (,internal-define ,(class-name name) + `((,internal-define ,(class-name name) (,(constructor name) ,@fields) ,(pred name) ,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?))) @@ -60,13 +60,21 @@ ;;; Creates srfi-9 define{-immutable,}-record-type declations. ;;; Also creates srfi-17 accessor ((set! (access field) value)) -(define-macro (define-quick-record name . fields) - (%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type) - #f name fields)) +;; (define (define-quick-record-templated define-proc name field)) -(define-macro (define-quick-record! name . fields) - (%define-quick-record '(@ (srfi srfi-9) define-record-type) - #t name fields)) +(define-macro (define-quick-record name . fields) + (let ((public-fields (or (assoc-ref fields #:public) '())) + (private-fields (or (assoc-ref fields #:private) '()))) + `(begin + ,@(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type) + #f name + (append public-fields private-fields)) + ,@(map (lambda (field) `(export ,field)) + public-fields)))) + ;; (define-quick-record-templated 'define-immutable-record-type name fields)) + +;; (define-macro (define-quick-record! name . fields) +;; (define-quick-record-templated 'define-record-type name fields)) ;;; Replace let* with a version that can bind from lists. ;;; Also supports SRFI-71 (extended let-syntax for multiple values) @@ -146,3 +154,11 @@ (cdr items) ;; seeds: (car items) '()))) + +(define-public (filter-sorted proc list) + (take-while + proc (drop-while + (negate proc) list))) + +;; (define (!= a b) (not (= a b))) +(define-public != (negate =)) diff --git a/vcalendar/recur.scm b/vcalendar/recur.scm index 9ae60fb7..3657cae6 100644 --- a/vcalendar/recur.scm +++ b/vcalendar/recur.scm @@ -1,221 +1,12 @@ (define-module (vcalendar recur) - #: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 curried-definitions) #:use-module (vcalendar) - #:use-module (vcalendar datetime) - #:use-module (util) + #:use-module (vcalendar recurrence generate) + #:re-export (generate-recurrence-set) + #:export (repeating?)) - #:export (recur-event repeating?)) - -;; (build-recur-rules "FREQ=HOURLY") -;; ;; => #< freq: HOURLY until: #f count: #f interval: #f> -;; (build-recur-rules "FREQ=HOURLY;COUNT=3") -;; ;; => #< freq: HOURLY until: #f count: 3 interval: #f> -;; (build-recur-rules "FREQ=ERR;COUNT=3") -;; ;; => #< freq: #f until: #f count: 3 interval: #f> -;; (build-recur-rules "FREQ=HOURLY;COUNT=err") -;; ;; => #< freq: HOURLY until: #f count: #f interval: #f> -;; (build-recur-rules "FREQ=HOURLY;COUNT=-1") -;; ;; => #< freq: HOURLY until: #f count: #f interval: #f> +;; 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?" - (attr ev 'RRULE)) - -(define-quick-record recur-rule - freq until count interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst) - -(define (build-recur-rules str) - "Takes a RECUR value (string), and returuns a 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)))) - -;;; A special form of case only useful in build-recur-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-rule (throw-returnable symb args ...) - (call/cc (lambda (cont) (throw symb cont args ...)))) - -(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))))))))) - -(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 (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-syntax all-in - (syntax-rules () - ((_ var rules ...) - (cut every (lambda (var) (and rules ...)) <>)))) - -(define (!= a b) (not (= a b))) - -(define weekdays - '(SU MO TU WE TH FR SA)) - -(define intervals - '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) - -(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 - ;; ∈ weekdays - ;; ::= [[±] ] ;; +3MO - ;; (, ...) - ;; (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 - ((record-constructor '(interval wkst)) 1 'MO) - - ;; ((key val) ...) - (map (cut string-split <> #\=) - (string-split str #\;)))) - -(define (seconds-in interval) - (case interval - ((SECONDLY) 1) - ((MINUTELY) 60 ) - ((HOURLY) (* 60 60)) - ((DAILY) (* 60 60 24)) - ((WEEKLY) (* 60 60 24 7)))) - -(define (generate-next event rule) - - (when (count rule) - (set! (count rule) - (1- (count rule))) - - (when (zero? (count rule)) - ;; TODO early return - (values '() '()))) - - - (let ((ne (copy-vcomponent event))) ; new event - (cond - - ;; BYDAY and the like depend on the freq? - ;; Line 7100 - ;; Table @ 2430 - - ((memv (freq rule) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY)) - (mod! (attr ne "DTSTART") - (cut add-duration! <> - (make-duration (* (interval rule) - (seconds-in (freq rule))))))) - ((memv (freq rule) '(MONTHLY YEARLY)) - ;; Hur fasen beräkrnar man det här!!!! - ) - (else #f)) - - - ;; Make sure DTSTART is updated before this point - - (and=> (until rule) - (lambda (u) - (when (time + (make-duration + ;; INTERVAL + (* (interval r) + (seconds-in (freq r))))))) + + ((memv (freq r) '(MONTHLY YEARLY)) + ;; Hur fasen beräkrnar man det här!!!! + #f + ) + + (else #f)) + e))) + + ;; Rule → Bool (#t if continue, #f if stop) + (match-lambda + ((last r) + + ;; (optional->bool + ;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r)) + ;; (<$> (negate zero?) (count r)) + ;; (just #t))) + + (or (and (not (until r)) (not (count r))) + (and=> (until r) (cut time<=? (attr last 'DTSTART) <>)) ; UNTIL + (and=> (count r) (negate zero?))) ; COUNT + + ) + ) + + ;; Rule → (next) Rule + (match-lambda + ((last r) + ;; Note that this doesn't modify, since r is immutable. + (list last + (if (count r) + (mod! (count r) 1-) + r)))) + (list event rule-obj))) + + +(define (generate-recurrence-set event) + (unless (attr event "DURATION") + (set! (attr event "DURATION") + (time-difference + (attr event "DTEND") + (attr event "DTSTART")))) + (recur-event-stream event (build-recur-rules (attr event "RRULE")))) diff --git a/vcalendar/recurrence/internal.scm b/vcalendar/recurrence/internal.scm new file mode 100644 index 00000000..b62d75c2 --- /dev/null +++ b/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 '(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 new file mode 100644 index 00000000..938cfc61 --- /dev/null +++ b/vcalendar/recurrence/parse.scm @@ -0,0 +1,108 @@ +(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 recurrence internal) + #:use-module (util) + #:use-module (exceptions) + #:use-module (ice-9 curried-definitions) + #:export (build-recur-rules) + + ) + + + +(define (build-recur-rules str) + "Takes a RECUR value (string), and returuns a 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 build-recur-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 + ;; ∈ weekdays + ;; ::= [[±] ] ;; +3MO + ;; (, ...) + ;; (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 #\;)))) -- cgit v1.2.3