From 9c0cd729b5c1bf3eb6dae70f636d707e5058fafa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 21 Apr 2020 00:23:46 +0200 Subject: Remove define-quick-record macros. --- module/util.scm | 43 --------- module/vcomponent/recurrence/generate.scm | 3 +- module/vcomponent/recurrence/internal.scm | 143 ++++++++++++++++++++++-------- module/vcomponent/recurrence/parse.scm | 30 +++---- 4 files changed, 121 insertions(+), 98 deletions(-) diff --git a/module/util.scm b/module/util.scm index d54ad07b..474c7589 100644 --- a/module/util.scm +++ b/module/util.scm @@ -100,49 +100,6 @@ -;;; Helper macros to make define-quick-record better - -(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))) - `((,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)))) - -;;; Creates srfi-9 define{-immutable,}-record-type declations. -;;; Also creates srfi-17 accessor ((set! (access field) value)) - -;;; TODO allow extra properties to be sent to this macro, -;;; such as @var{:muttable} or @var{:immutable} - -(define-macro (define-quick-record name . fields) - (let ((public-fields (or (assoc-ref fields #:public) '())) - (private-fields (or (assoc-ref fields #:private) '())) - (printer (and=> (assoc-ref fields #:printer) car))) - `(begin - ,@(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type) - #f name - (append public-fields private-fields)) - (when ,printer - ((@ (srfi srfi-9 gnu) set-record-type-printer!) - ,(class-name name) ,printer)) - ,@(map (lambda (field) `(export ,field)) - public-fields)))) - - - ;; Replace let* with a version that can bind from lists. ;; Also supports SRFI-71 (extended let-syntax for multiple values) ;; @lisp diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index c03a935a..1ff3cc49 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -128,8 +128,7 @@ ((e r) (list (next-event e r) (if (count r) - ;; Note that this doesn't modify, since r is immutable. - (mod! (count r) 1-) + (set (count r) = (- 1)) r )))) ;; Seed diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index cb00cd3d..69d0469a 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -4,6 +4,8 @@ #:use-module (srfi srfi-88) ; better keywords #:use-module ((vcomponent base) :select (attr)) #:use-module (datetime util) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (util) ) @@ -14,46 +16,111 @@ (or (attr ev 'RRULE) (attr ev 'RDATE))) +;; weekday := [0, 7) + ;; 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) - - ;; TODO make this part of define-quick-record. - ;; Only "hard" part would be to provide type hints for fields for - ;; string conversions. - (printer: - (lambda (r port) - (define (get f) - ((record-accessor f) r)) - (with-output-to-string - (lambda () - (display "#<" port) - (for field in (record-type-fields ) - (awhen (get field) - (display " " port) - (display field port) - (display "=" port) - (display - (case field - ;; TODO check over date/time/datetime here - ;; ((until) ((@ (datetime util) time->string) it)) - (else it)) - port))) - (display ">" port)))))) - -;; @begin{example} -;; (mkrule (freq HOURLY) (wkst MO) (interval 1)) -;; @end -;; TODO field validation here, like in parse-recurrence-rule. -;; NOTE this shadows built in constructor generated in define-quick-record -(define-syntax make-recur-rule - (syntax-rules () - ((_ (key val) ...) - ((record-constructor (quote (key ...))) - val ...)))) +(define-immutable-record-type + (make-recur-rule% freq until count interval bysecond byminute byhour + byday bymonthday byyearday byweekno bymonth bysetpos + wkst) + recur-rule? + (freq freq) ; 'SECONDLY | 'MINUTELY | 'HOURLY | 'DAILY | 'WEEKLY | 'MONTHLY | 'YEARLY + (until until) ; | + (count count) ; 𝐙₊ + (interval interval) ; 𝐙₊ + (bysecond bysecond) ; (list [0, 60]) + (byminute byminute) ; (list [0, 59]) + (byhour byhour) ; (list [0, 23]) + (byday byday) ; (list (cons [#f | 𝐙] weekday) + (bymonthday bymonthday) ; (list [-31, 31] \ { 0 }) + (byyearday byyearday) ; (list [-366, 366] \ { 0 }) + (byweekno byweekno) ; (list [-53, 53] \ { 0 }) + (bymonth bymonth) ; (list [-12, 12] \ { 0 }) + (bysetpos bysetpos) ; (list [-366, 366] \ { 0 }) + (wkst wkst) ; weekday + ) + +(export freq until count interval bysecond byminute byhour + byday bymonthday byyearday byweekno bymonth bysetpos + wkst) + +(define*-public (make-recur-rule + key: + freq until count interval bysecond byminute byhour + byday bymonthday byyearday byweekno bymonth bysetpos + wkst) + (make-recur-rule% freq until count interval bysecond byminute byhour + byday bymonthday byyearday byweekno bymonth bysetpos + wkst)) + +;; only print fields with actual values. +(set-record-type-printer! + + (lambda (r port) + (define (get f) + ((record-accessor f) r)) + (with-output-to-string + (lambda () + (display "#<" port) + (for field in (record-type-fields ) + (awhen (get field) + (display " " port) + (display field port) + (display "=" port) + (display + (case field + ;; TODO check over date/time/datetime here + ;; ((until) ((@ (datetime util) time->string) it)) + (else it)) + port))) + (display ">" port))))) + + +(define (byday->string pair) + (let* (((off . day) pair)) + (string-append + (or (and=> off number->string) "") + (string-upcase + (week-day-name day 2 + locale: (make-locale (list LC_TIME) "C")))))) + +(use-modules (ice-9 i18n) + (datetime) + (srfi srfi-1)) + +(define-public (recur-rule->rrule-string rrule) + (define (get f) + ((record-accessor f) rrule)) + (string-join + (filter-map + (lambda (field) + (if (not (get field)) + #f + (string-append + (string-upcase (symbol->string field)) + "=" + (case field + [(wkst) + (string-upcase + (week-day-name (get field) 2 + locale: (make-locale (list LC_TIME) "C")))] + [(byday) + (string-join (map byday->string (get field)) ",")] + [(freq count interval) + (format #f "~a" (get field))] + [(until) + (let ((o (get field))) + (if (date? o) + (date->string o "~Y~m~d") + (datetime->string o "~Y~m~dT~H~M~S~Z") + ))] + [else (format #f "~{~a~^,~}" (get field))])))) + (record-type-fields )) + ";")) + + + (define-public weekdays (weekday-list sun)) diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index a2221660..b044aae1 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -83,32 +83,32 @@ ;; TODO I think it's an error to give BYHOUR and under for dates which aren't datetimes (quick-case (string->symbol key) - (UNTIL (set! (until o) date)) + (UNTIL (set (until o) date)) - (COUNT (<= 0 num) => (set! (count o) num)) - (INTERVAL (<= 0 num) => (set! (interval o) num)) + (COUNT (<= 0 num) => (set (count o) num)) + (INTERVAL (<= 0 num) => (set (interval o) num)) - (FREQ (memv symb intervals) => (set! (freq o) symb)) - (WKST (memv symb weekdays) => (set! (wkst o) (cdar days))) + (FREQ (memv symb intervals) => (set (freq o) symb)) + (WKST (memv symb weekdays) => (set (wkst o) (cdar days))) ;; Always positive - (BYSECOND (every (lambda (n) (<= 0 n 60)) nums) => (set! (bysecond o) nums)) - (BYMINUTE (every (lambda (n) (<= 0 n 59)) nums) => (set! (byminute o) nums)) - (BYHOUR (every (lambda (n) (<= 0 n 23)) nums) => (set! (byhour o) nums)) - (BYMONTH (every (lambda (n) (<= 1 n 12)) nums) => (set! (bymonth o) nums)) + (BYSECOND (every (lambda (n) (<= 0 n 60)) nums) => (set (bysecond o) nums)) + (BYMINUTE (every (lambda (n) (<= 0 n 59)) nums) => (set (byminute o) nums)) + (BYHOUR (every (lambda (n) (<= 0 n 23)) nums) => (set (byhour o) nums)) + (BYMONTH (every (lambda (n) (<= 1 n 12)) nums) => (set (bymonth o) nums)) ;; May be negative - (BYDAY (every (lambda (p) (memv (cdr p) weekdays)) days) => (set! (byday o) days)) + (BYDAY (every (lambda (p) (memv (cdr p) weekdays)) days) => (set (byday o) days)) - (BYMONTHDAY (every (lambda (n) (and (!= n 0) (<= -31 n 31))) nums) => (set! (bymonthday o) nums)) - (BYYEARDAY (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set! (byyearday o) nums)) - (BYSETPOS (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set! (bysetpos o) nums)) - (BYWEEKNO (every (lambda (n) (and (!= n 0) (<= -53 n 53))) nums) => (set! (byweekno o) nums)) + (BYMONTHDAY (every (lambda (n) (and (!= n 0) (<= -31 n 31))) nums) => (set (bymonthday o) nums)) + (BYYEARDAY (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set (byyearday o) nums)) + (BYSETPOS (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set (bysetpos o) nums)) + (BYWEEKNO (every (lambda (n) (and (!= n 0) (<= -53 n 53))) nums) => (set (byweekno o) nums)) (else o))))) ;; obj - (make-recur-rule (interval 1) (wkst mon)) + (make-recur-rule interval: 1 wkst: mon) ;; ((key val) ...) (map (cut string-split <> #\=) -- cgit v1.2.3