Rename module vcalendar => vcomponent.

1 files changed, 131 insertions, 0 deletions

diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm
new file mode 100644
index 00000000..7df0e2e6
--- /dev/null
+++ b/module/vcomponent/recurrence/parse.scm
@@ -0,0 +1,131 @@
+(define-module (vcomponent 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 ((vcomponent datetime) #:select (parse-datetime))
+  #:duplicates (last)                   ; Replace @var{count}
+  #:use-module (vcomponent recurrence internal)
+  #:use-module (util)
+  #:use-module (exceptions)
+  #:use-module (ice-9 curried-definitions)
+  #:export (parse-recurrence-rule))
+
+
+(define (printerr fmt . args)
+  (apply format (current-error-port)
+          fmt args))
+
+(define (parse-recurrence-rule str)
+  (catch-multiple
+    (lambda () (%build-recur-rules str))
+
+    [unfulfilled-constraint
+     (cont obj key val . rest)
+     (printerr "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%"
+               err val key)
+     (cont #f)]
+
+    [invalid-value
+     (cont obj key val . rest)
+     (printerr "ERR ~a [~a] for key [~a], ignoring.~%"
+               err val key)
+     (cont #f)]))
+
+(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 parse-recurrence-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)))
+
+;; @example
+;; <weekday> ∈ weekdays
+;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO
+;; (<weekadynum>, ...)
+;; @end example
+
+;; Returns a pair, where the @code{car} is the offset
+;; and @code{cdr} is the day symbol.
+;; The @code{car} may be @code{#f}.
+(define (parse-day-spec str)
+  (let* ((numchars (append '(#\+ #\-) (map integer->char (iota 10 #x30))))
+         (num symb (span (cut memv <> numchars)
+                         (string->list str))))
+    (cons (string->number (list->string num))
+          (apply symbol symb))))
+
+(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 () (date->time-utc (parse-datetime val))))
+            (days (lambda () (map parse-day-spec (string-split val #\,))))
+            (num  (lambda () (string->number val)))
+            (nums (lambda () (string->number-list val #\,))))
+       (quick-case (string->symbol key) obj
+                   (FREQ     (symb) (cut memv <> intervals)) ; Required
+                   (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)))
+
+                   (BYDAY (days)
+                          (lambda (p*)
+                            (map (lambda (p)
+                                   (let* (((num . symb) p))
+                                     (memv symb weekdays)))
+                                 p*)))
+
+                   (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 #\;))))