Parsing work on recur.

1 files changed, 83 insertions, 146 deletions

diff --git a/vcalendar/recur.scm b/vcalendar/recur.scm
index 474d228d..572fb020 100644
--- a/vcalendar/recur.scm
+++ b/vcalendar/recur.scm
@@ -1,155 +1,92 @@
 (define-module (vcalendar recur)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-41)
+  #:use-module (util))
 
-  #:use-module (vcalendar)
-  )
-
-(define s "FREQ=WEEKLY;UNTIL=20191130")
-
-(define (generate-kv-pairs str)
-  (map (cut string-split <> #\=)
-       (string-split str #\;)))
-
-(define upstring->symbol (compose string->symbol string-upcase))
-
-(define-syntax-rule (ensure key val test)
-  ((key)
-   (let ((v val))
-     (if (test v)
-         v
-         (throw 'bad-value key val))
-     )))
-
-#;
-(let ((key 'FREQ)
-      (val-base 'HOURLY))
-  (case key
-    (FREQ (upstring->symbol val-base)
-          (memv <> '(SECONDLY MINUTELY HOURLY DAILY
-                           WEEKLY MONTHLY YEARLY)))))
 
 (define-immutable-record-type <recur-rule>
   (make-recur-rules freq until count interval)
   recur-rule?
-  (freq get-freq set-freq)
-  (until get-until set-until)
-  (count get-count set-count)
-  (interval get-interval set-interval)))
-
-(let ((s->n string->number))
- (reduce (lambda (kv rule)
-        (let ((key (upstring->symbol (car kv)))
-              (val-base (cadr kv)))
-          (case key
-            ((FREQ)
-             (set-freq rule
-                       (ensure (upstring->symbol val-base)
-                               (cut memv <>
-                                    '(SECONDLY MINUTELY HOURLY DAILY
-                                               WEEKLY MONTHLY YEARLY)))))
-            
-
-            ((UNTIL)
-             (set-until rule (parse-datetime val-base)))
-
-            ((COUNT) (set-count rule (s->n val-base)))
-
-            ((INTERVAL) (set-internal rule (s->n val-base)))
-
-            ((BYSECOND) (let ((s (s->n val-base)))
-                          (<= 0 s 60)))
-
-            ((BYMINUTE) (let ((m (s->n val-base)))
-                          (<= 0 m 59)))
-
-            ((BYHOUR) (let ((h (s->n val-base)))
-                        (<= 0 h 23)))
-            
-            #|
-            ((BYDAY) #; TODO )
-
-            ((BYMONTHDAY) #; TODO)
-            ((BYYEARDAY)  )
-            ((BYWEEKNO)  )
-            ((BYMONTH)  )
-            ((BYSETPOS) )
-            ((WKST)  )
-            |#
-            (else 'err))))
-
-      (generate-kv-pairs s)))
-
-
-
-#|
-Each recuring event should be expanded to a stream of all it's occurances.
-
-The first instance of the event is at DTSTART,
-times for following instances are calculating according to the DSL below. 
-     
-3.3.10. Recurrence Rule
-     Value Name: RECUR
-|#
-
-
-#|
-       byseclist   = ( seconds *("," seconds) )
-
-       seconds     = 1*2DIGIT       ;0 to 60
-
-       byminlist   = ( minutes *("," minutes) )
-
-       minutes     = 1*2DIGIT       ;0 to 59
-
-       byhrlist    = ( hour *("," hour) )
-
-       hour        = 1*2DIGIT       ;0 to 23
-
-       bywdaylist  = ( weekdaynum *("," weekdaynum) )
-
-       weekdaynum  = [[±] ordwk] weekday
-
-       ordwk       = 1*2DIGIT       ;1 to 53
-
-       weekday     = "SU" / "MO" / "TU" / "WE" / "TH" / "FR" / "SA"
-       ;Corresponding to SUNDAY, MONDAY, TUESDAY, WEDNESDAY, THURSDAY,
-       ;FRIDAY, and SATURDAY days of the week.
-
-
-
-Desruisseaux                Standards Track                    [Page 39]
-
-RFC 5545                       iCalendar                  September 2009
-
-
-       bymodaylist = ( monthdaynum *("," monthdaynum) )
-
-       monthdaynum = [±] ordmoday
-
-       ordmoday    = 1*2DIGIT       ;1 to 31
-
-       byyrdaylist = ( yeardaynum *("," yeardaynum) )
-
-       yeardaynum  = [±] ordyrday
-
-       ordyrday    = 1*3DIGIT      ;1 to 366
-
-       bywknolist  = ( weeknum *("," weeknum) )
-
-       weeknum     = [±] ordwk
-
-       bymolist    = ( monthnum *("," monthnum) )
-
-       monthnum    = 1*2DIGIT       ;1 to 12
-
-       bysplist    = ( setposday *("," setposday) )
-
-       setposday   = yeardaynum
-
-
-
-|#
+  (freq     get-freq     set-freq)
+  (until    get-until    set-until)
+  (count    get-count    set-count)
+  (interval get-interval set-interval))
+
+
+;; (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
+  (lambda () (%build-recur-rules str))
+
+  ((unknown-key
+    (lambda (err cont obj key . rest)
+      (format #t "ERR Invalid key [~a] while parsing recurence rule, ignoring.~%" key)
+      (cont obj)))
+
+   (unfulfilled-constraint
+    (lambda (err cont obj key val . rest)
+      (let ((default-value (case key
+                             ((INTERVAL) 1)
+                             (else #f))))
+        (format #t "ERR Value [~a] doesn't fulfill constraint of type [~a], defauting to [~a].~%"
+                val key default-value)
+        (cont default-value))))
+
+   (invalid-value
+    (lambda (err cont obj key val . rest)
+      (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 (%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 (string->date 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) <>))
+                 ))
+   (make-recur-rules #f #f #f 1)
+   (map (cut string-split <> #\=)
+        (string-split str #\;))))
+
+
+;;; 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-helper obj parent-expr expr )
+  "Helper function for quick-case below"
+  (with-syntax ((obj (datum->syntax parent-expr obj)))
+    (syntax-case expr ()
+      ((key val proc)
+       (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))))))))))))
+
+(define-syntax quick-case 
+  (lambda (x)
+    (syntax-case x ()
+      ((_ var-key obj (key val proc) ...)
+       (let* ((make-setter (lambda (symb) (symbol-append 'set- (symbol-downcase symb))))
+              (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))))))))))