From 3cb1c509d88db5cf7199bd25d4fcfc5821ad4818 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 8 Mar 2019 21:55:40 +0100 Subject: A whole bunch of macro rewrites! --- vcalendar/recur.scm | 185 ++++++++++++++++++++++++++++------------------------ 1 file changed, 98 insertions(+), 87 deletions(-) (limited to 'vcalendar') diff --git a/vcalendar/recur.scm b/vcalendar/recur.scm index 80bd03a9..2c765056 100644 --- a/vcalendar/recur.scm +++ b/vcalendar/recur.scm @@ -6,32 +6,40 @@ #:use-module (srfi srfi-19 util) #:use-module (srfi srfi-26) ; Cut #:use-module (srfi srfi-41) ; Streams - #:use-module (ice-9 match) + #:use-module (ice-9 curried-definitions) + ;; #:use-module (ice-9 match) #:use-module (vcalendar) #:use-module (vcalendar datetime) #:use-module (util) #:export ( build-recur-rules recur-event)) -(define-immutable-record-type - (make-recur-rules - freq until count interval bysecond byminute byhour wkst) - recur-rule? - (freq get-freq set-freq) - (until get-until set-until) - (count get-count set-count) - (interval get-interval set-interval) ; 1 - (bysecond get-bysecond set-bysecond) - (byminute get-byminute set-byminute) - (byhour get-byhour set-byhour) - (wkst get-wkst set-wkst) ; MO - ) - - -;; (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> + +;; (define-immutable-record-type +;; (make-recur-rules +;; freq until count interval bysecond byminute byhour wkst) +;; recur-rule? +;; (freq get-freq set-freq) +;; (until get-until set-until) +;; (count get-count set-count) +;; (interval get-interval set-interval) ; 1 +;; (bysecond get-bysecond set-bysecond) +;; (byminute get-byminute set-byminute) +;; (byhour get-byhour set-byhour) +;; (wkst get-wkst set-wkst) ; MO +;; ) + +(define-quick-record recur-rule freq until count interval bysecond byminute byhour wkst) + +;; (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> (define (build-recur-rules str) (catch-let @@ -56,14 +64,6 @@ (format #t "ERR Invalid value [~a] for key [~a], ignoring.~%" val key) (cont 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 weekdays - '(SU MO TU WE TH FR SA)) ;;; A special form of case only useful in build-recur-rules above. ;;; Each case is on the form (KEY val check-proc) where: @@ -71,75 +71,86 @@ ;;; `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 ...)))) + +(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 #f)))))) +(define weekdays + '(SU MO TU WE TH FR SA)) -(define-syntax quick-case - (lambda (x) - (let ((syntax-helper - (lambda (obj parent-expr expr) - "Helper function for quick-case below" - (with-syntax ((obj (datum->syntax parent-expr obj))) - (syntax-case expr () - ((key val proc) - (let ((make-setter (lambda (symb) (symbol-append 'set- (symbol-downcase symb))))) - (with-syntax ((setter (datum->syntax parent-expr (make-setter (syntax->datum (syntax key)))))) - #'((key) - (cond ((not val) (call/cc (lambda (cont) (throw 'invalid-value cont obj (quote key) val)))) - ((proc val) (setter obj val)) - (else (setter obj (call/cc (lambda (cont) (throw 'unfulfilled-constraint cont obj (quote key) val))))))))))))))) - (syntax-case x () - ((_ var-key obj (key val proc) ...) - (let ((cc (lambda (lst) (map (cut syntax-helper (syntax->datum (syntax obj)) x <>) - lst)))) - #`(case var-key - #,@(cc #'((key val proc) ...)) - (else (call/cc (lambda (cont) (throw 'unknown-key cont obj var-key))))))))))) +(define intervals + '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) + +(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-lists - (lambda ((key val) obj) - (quick-case (string->symbol key) obj - (FREQ (string->symbol val) (cut memv <> '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY))) - (UNTIL (parse-datetime val) identity) - (COUNT (string->number val) (cut <= 0 <>)) - (INTERVAL (string->number val) (cut <= 0 <>)) - (BYSECOND (string->number-list val #\,) (cut every (cut <= 0 <> 60) <>)) - (BYMINUTE (string->number-list val #\,) (cut every (cut <= 0 <> 59) <>)) - (BYHOUR (string->number-list val #\,) (cut every (cut <= 0 <> 23) <>)) - ;; TODO implement these - ;; (BYDAY) - ;; (BYMONTHDAY) - ;; (BYYEARDAY) - ;; (BYWEEKNO) - ;; (BYMONTH) - ;; (BYSETPOS) - (WKST (string->symbol val) (cut memv <> weekdays)) - )) + (fold + (lambda (lst obj) + (let* (((key val) lst)) + (quick-case (string->symbol key) obj + (FREQ (string->symbol val) (cut memv <> intervals)) + (UNTIL (parse-datetime val) identity) + (COUNT (string->number val) (cut <= 0 <>)) + (INTERVAL (string->number val) (cut <= 0 <>)) + (BYSECOND (string->number-list val #\,) (cut every (cut <= 0 <> 60) <>)) + (BYMINUTE (string->number-list val #\,) (cut every (cut <= 0 <> 59) <>)) + (BYHOUR (string->number-list val #\,) (cut every (cut <= 0 <> 23) <>)) + ;; TODO implement these + ;; (BYDAY) + ;; (BYMONTHDAY) + ;; (BYYEARDAY) + ;; (BYWEEKNO) + ;; (BYMONTH) + ;; (BYSETPOS) + (WKST (string->symbol val) (cut memv <> weekdays)) + ))) + ;; obj ((record-constructor '(interval wkst)) 1 'MO) + ;; ((key val) ...) (map (cut string-split <> #\=) (string-split str #\;)))) - (define (generate-next event rule) (let ((new-event (copy-vcomponent event))) - (match rule - (($ freq until count interval bysecond byminute byhour wkst) - (case freq - ((WEEKLY) - (transform-attr! new-event "DTSTART" (cut time-add <> 1 weeks)) - (set! (attr new-event "DTEND") - (add-duration (attr new-event "DTSTART") - (attr new-event "DURATION"))) - (values new-event rule)) - ((DAILY) - (transform-attr! new-event "DTSTART" (cut time-add <> 1 days)) - (set! (attr new-event "DTEND") - (add-duration (attr new-event "DTSTART") - (attr new-event "DURATION"))) - (values new-event rule)) - (else (values '() rule)))) - (_ (values event rule))))) + (case (freq rule) + ((WEEKLY) + (transform-attr! new-event "DTSTART" (cut time-add <> 1 weeks)) + (set! (attr new-event "DTEND") + (add-duration (attr new-event "DTSTART") + (attr new-event "DURATION"))) + (values new-event rule)) + ((DAILY) + (transform-attr! new-event "DTSTART" (cut time-add <> 1 days)) + (set! (attr new-event "DTEND") + (add-duration (attr new-event "DTSTART") + (attr new-event "DURATION"))) + (values new-event rule)) + (else (values '() rule))))) (define-stream (recur-event-stream event rule-obj) (stream-cons event -- cgit v1.2.3