Fixed recurrence code.

6 files changed, 279 insertions, 223 deletions

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")
-;; ;; => #<<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>
+;; 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 <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))))
-
-;;; 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
-                   ;; <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
-   ((record-constructor <recur-rule> '(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<? u (attr ne "DTSTART"))
-            ;; TODO early return
-            (values '() '()))))
-
-
-    (set! (attr ne "DTEND")
-          (add-duration (attr ne "DTSTART")
-                        (attr ne "DURATION")))
-
-    (values ne rule)))
-
-(define-stream (recur-event-stream event rule-obj)
-  (stream-cons event
-               (let* ([next-event next-rule (generate-next event rule-obj)])
-                 (if (null? next-event)
-                     stream-null
-                     (recur-event-stream next-event next-rule)))))
-
-;;; 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 (recur-event 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"))))
+  (or (attr ev 'RRULE)
+      (attr ev 'RDATE)))
diff --git a/vcalendar/recurrence/generate.scm b/vcalendar/recurrence/generate.scm
new file mode 100644
index 00000000..222362fd
--- /dev/null
+++ b/vcalendar/recurrence/generate.scm
@@ -0,0 +1,108 @@
+(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)          ; ?
+  #: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 interval)
+  (case interval
+    ((SECONDLY) 1)
+    ((MINUTELY) 60)
+    ((HOURLY) (* 60 60))
+    ((DAILY) (* 60 60 24))
+    ((WEEKLY) (* 60 60 24 7))))
+
+(define-stream (recur-event-stream event rule-obj)
+  (stream-unfold
+   ;; Rule → event
+   (match-lambda
+     ((last r)
+      (let ((e (copy-vcomponent last)))   ; new event
+        ;; TODO
+        ;; Update DTEND as (add-duration DTSTART DURATINO)
+        (cond
+
+         ;; BYDAY and the like depend on the freq?
+         ;; Line 7100
+         ;; Table @ 2430
+
+         ((memv (freq r) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY))
+          (mod! (attr e "DTSTART")
+                (cut add-duration! <>
+                     (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 <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
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 <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 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
+                   ;; <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 #\;))))