A whole bunch of macro rewrites!

1 files changed, 98 insertions, 87 deletions

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 (<recur-rule> build-recur-rules recur-event))
 
-(define-immutable-record-type <recur-rule>
-  (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") ; => #<<recur-rule> freq: HOURLY until: #f count: #f interval: #f>
-;; (build-recur-rules "FREQ=HOURLY;COUNT=3") ; => #<<recur-rule> freq: HOURLY until: #f count: 3 interval: #f>
-;; (build-recur-rules "FREQ=ERR;COUNT=3") ; => #<<recur-rule> freq: #f until: #f count: 3 interval: #f>
-;; (build-recur-rules "FREQ=HOURLY;COUNT=err") ; => #<<recur-rule> freq: HOURLY until: #f count: #f interval: #f>
-;; (build-recur-rules "FREQ=HOURLY;COUNT=-1") ; => #<<recur-rule> freq: HOURLY until: #f count: #f interval: #f>
+
+;; (define-immutable-record-type <recur-rule>
+;;   (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")
+;; ;; => #<<recur-rule> freq: HOURLY until: #f count: #f interval: #f>
+;; (build-recur-rules "FREQ=HOURLY;COUNT=3")
+;; ;; => #<<recur-rule> freq: HOURLY until: #f count: 3 interval: #f>
+;; (build-recur-rules "FREQ=ERR;COUNT=3")
+;; ;; => #<<recur-rule> freq: #f until: #f count: 3 interval: #f>
+;; (build-recur-rules "FREQ=HOURLY;COUNT=err")
+;; ;; => #<<recur-rule> freq: HOURLY until: #f count: #f interval: #f>
+;; (build-recur-rules "FREQ=HOURLY;COUNT=-1")
+;; ;; => #<<recur-rule> 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 <recur-rule> '(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
-      (($ <recur-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