aboutsummaryrefslogtreecommitdiff
path: root/vcalendar/recurrence/parse.scm
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2019-03-22 20:11:11 +0100
committerHugo Hörnquist <hugo@lysator.liu.se>2019-03-22 20:17:52 +0100
commitd46183860c1f3f10095e95023adcb79b1896ab0e (patch)
treedd331a0efe9777bfe84160139da1e39df3226b71 /vcalendar/recurrence/parse.scm
parentAdd stuff to test.scm. (diff)
downloadcalp-d46183860c1f3f10095e95023adcb79b1896ab0e.tar.gz
calp-d46183860c1f3f10095e95023adcb79b1896ab0e.tar.xz
Move C and Scheme code into subdirs.
Diffstat (limited to 'vcalendar/recurrence/parse.scm')
-rw-r--r--vcalendar/recurrence/parse.scm106
1 files changed, 0 insertions, 106 deletions
diff --git a/vcalendar/recurrence/parse.scm b/vcalendar/recurrence/parse.scm
deleted file mode 100644
index abead3a9..00000000
--- a/vcalendar/recurrence/parse.scm
+++ /dev/null
@@ -1,106 +0,0 @@
-(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 datetime) #:select (parse-datetime))
- #:duplicates (last) ; Replace @var{count}
- #:use-module (vcalendar recurrence internal)
- #:use-module (util)
- #:use-module (exceptions)
- #:use-module (ice-9 curried-definitions)
- #:export (parse-recurrence-rule))
-
-(define (parse-recurrence-rule 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 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)))
-
-(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 #\;))))