diff options
| -rwxr-xr-x | test.scm | 3 | ||||
| -rw-r--r-- | util.scm | 57 | ||||
| -rw-r--r-- | vcalendar/recur.scm | 185 |
3 files changed, 151 insertions, 94 deletions
@@ -13,8 +13,7 @@ (define cal (make-vcomponent "testcal/repeating-event.ics")) -(define ev (find (lambda (ev) (eq? 'VEVENT (type ev))) - (children cal))) +(define ev (car (children cal 'VEVENT))) (define ev-copy (copy-vcomponent ev)) @@ -1,7 +1,9 @@ (define-module (util) #:use-module (srfi srfi-1) #:export (destructure-lambda let-multi fold-lists catch-let - for-each-in) + for-each-in + define-quick-record define-quick-record!) + #:replace (let*) ) (define-public upstring->symbol (compose string->symbol string-upcase)) @@ -16,10 +18,6 @@ (lambda (expr) (apply (lambda expr-list body ...) expr))))) -#; -(map (destructure-lambda (a b) (+ a b)) - (map list (iota 10) (iota 10 10))) - (define-syntax let-multi (syntax-rules () ((let-m identifiers lst body ...) @@ -47,3 +45,52 @@ (define-syntax-rule (for-each-in lst proc) (for-each proc lst)) + + +(define (class-name symb) (symbol-append '< symb '>)) +(define (constructor symb) (symbol-append 'make- symb)) +(define (pred symb) (symbol-append symb '?)) + +(define (getter name symb) (symbol-append 'get- name '- symb)) +(define* (setter name symb #:optional bang?) + (symbol-append 'set- name '- symb (if bang? '! (symbol)))) + +(define (%define-quick-record internal-define bang? name fields) + (let ((symb (gensym))) + `(begin (,internal-define ,(class-name name) + (,(constructor name) ,@fields) + ,(pred name) + ,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?))) + fields)) + ,@(map (lambda (f) `(define ,f (make-procedure-with-setter + ,(getter f symb) ,(setter f symb bang?)))) + fields)))) + +(define-macro (define-quick-record name . fields) + (%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type) + #f name fields)) + +(define-macro (define-quick-record! name . fields) + (%define-quick-record '(@ (srfi srfi-9) define-record-type) + #t name fields)) + +(define-syntax let* + (syntax-rules () + + ;; Base case + [(_ () body ...) + (begin body ...)] + + ;; (let (((a b) '(1 2))) (list b a)) => (2 1) + [(_ (((k k* ...) list-value) rest ...) + body ...) + (apply (lambda (k k* ...) + (let* (rest ...) + body ...)) + list-value)] + + ;; "Regular" case + [(_ ((k value) rest ...) body ...) + (let ((k value)) + (let* (rest ...) + body ...))])) 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 |