aboutsummaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/config.scm12
-rw-r--r--module/exceptions.scm5
-rwxr-xr-xmodule/fetch.scm31
-rw-r--r--module/helpers.scm43
-rwxr-xr-xmodule/main.scm139
-rw-r--r--module/srfi/srfi-19/setters.scm15
-rw-r--r--module/srfi/srfi-19/util.scm83
-rw-r--r--module/srfi/srfi-41/util.scm29
-rw-r--r--module/terminal/escape.scm28
-rw-r--r--module/terminal/termios.scm13
-rw-r--r--module/terminal/util.scm37
-rwxr-xr-xmodule/test.scm77
-rw-r--r--module/util.scm168
-rw-r--r--module/vcalendar.scm112
-rw-r--r--module/vcalendar/control.scm39
-rw-r--r--module/vcalendar/datetime.scm34
-rw-r--r--module/vcalendar/output.scm93
-rw-r--r--module/vcalendar/primitive.scm23
-rw-r--r--module/vcalendar/recur.scm12
-rw-r--r--module/vcalendar/recurrence/generate.scm126
-rw-r--r--module/vcalendar/recurrence/internal.scm28
-rw-r--r--module/vcalendar/recurrence/parse.scm106
22 files changed, 1253 insertions, 0 deletions
diff --git a/module/config.scm b/module/config.scm
new file mode 100644
index 00000000..3c6ebbb0
--- /dev/null
+++ b/module/config.scm
@@ -0,0 +1,12 @@
+;;; Preliminary config file for the system.
+;;; Currently loaded by main, and requires that `calendar-files`
+;;; is set to a list of files (or directories).
+
+
+(use-modules (srfi srfi-26)
+ (ice-9 ftw))
+
+(define calendar-files
+ (let ((path (string-append (getenv "HOME") "/.calendars/")))
+ (map (cut string-append path <>)
+ (scandir path (lambda (str) (not (char=? #\. (string-ref str 0))))))))
diff --git a/module/exceptions.scm b/module/exceptions.scm
new file mode 100644
index 00000000..027c75ee
--- /dev/null
+++ b/module/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/module/fetch.scm b/module/fetch.scm
new file mode 100755
index 00000000..a91e4d0d
--- /dev/null
+++ b/module/fetch.scm
@@ -0,0 +1,31 @@
+#!/usr/bin/guile -s
+!#
+
+#|
+ | Example file which reads my regular calendar, filters it down to only
+ | the events between specific times, and prints that calendar in ICS
+ | format to standard output.
+ |#
+
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules (srfi srfi-1)
+ (srfi srfi-19)
+ (srfi srfi-26)
+ (vcalendar)
+ (vcalendar datetime)
+ (vcalendar output)
+ (util))
+
+
+(begin
+ ;; (define *path* "/home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/")
+ (define *path* "/home/hugo/.calendars/D1/")
+ (define cal (make-vcomponent *path*)))
+
+(filter-children!
+ (lambda (ev) (and (eq? 'VEVENT (type ev))
+ (event-in? ev (date->time-utc (string->date "2019-04-03" "~Y-~m-~d")))))
+ cal)
+
+(serialize-vcomponent cal)
diff --git a/module/helpers.scm b/module/helpers.scm
new file mode 100644
index 00000000..717a10d4
--- /dev/null
+++ b/module/helpers.scm
@@ -0,0 +1,43 @@
+(use-modules (srfi srfi-1)
+ (srfi srfi-8) ; receive
+ )
+
+(define (nlist? l)
+ "Returns #t if l is a pair that is not a list."
+ (and (pair? l)
+ (not (list? l))))
+
+(define (flatten tree)
+ "Flattens tree, should only return propper lists."
+ (cond ((null? tree) '())
+ ((list? tree)
+ (if (null? (cdr tree))
+ (flatten (car tree))
+ (let ((ret (cons (flatten (car tree))
+ (flatten (cdr tree)))))
+ (if (nlist? ret)
+ (list (car ret) (cdr ret))
+ ret))))
+ (else tree)))
+
+
+(define (map-lists f lst)
+ "Map f over lst, if (car lst) is a list, pass the list to f. If (car list)
+isn't a list, pass the rest of lst to f."
+ (cond ((null? lst) '())
+ ((list? (car lst)) (cons (f (car lst))
+ (map-lists f (cdr lst))))
+ (else (f lst))))
+
+(define (beautify tree)
+ "Takes a prefix tree and turns some characters to strings."
+ (define (helper branch)
+ (receive (head tail)
+ (span char? branch)
+ (cons (list->string head)
+ (beautify tail))))
+ (if (or (null? tree)
+ (not (list? tree)))
+ tree
+ (cons (beautify (car tree))
+ (map-lists helper (cdr tree)))))
diff --git a/module/main.scm b/module/main.scm
new file mode 100755
index 00000000..223b3d2e
--- /dev/null
+++ b/module/main.scm
@@ -0,0 +1,139 @@
+#!/usr/bin/guile \
+-e main -s
+!#
+
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules (srfi srfi-1)
+ (srfi srfi-19)
+ (srfi srfi-19 util)
+ (srfi srfi-26)
+ (srfi srfi-41)
+ (srfi srfi-41 util)
+ (ice-9 format)
+ (texinfo string-utils) ; string->wrapped-lines
+ (util)
+ (vcalendar)
+ (vcalendar recur)
+ (vcalendar datetime)
+ (vcalendar output)
+ (terminal escape)
+ (terminal util))
+
+(define (ev-time<? a b)
+ (time<? (attr a 'DTSTART)
+ (attr b 'DTSTART)))
+
+;;; ------------------------------------------------------------
+
+#; (define pizza-event (search cal "pizza"))
+
+(define (trim-to-width str len)
+ (let ((trimmed (string-pad-right str len)))
+ (if (< (string-length trimmed)
+ (string-length str))
+ (string-append (string-drop-right trimmed 1)
+ "…")
+ trimmed)))
+ ; TODO show truncated string
+
+
+(define (main-loop regular-events repeating-events)
+ (define time (date->time-utc (current-date)))
+ (define cur-event 0)
+ (let loop ((char #\nul))
+ (let ((events
+ (merge (filter-sorted
+ (cut event-in? <> time)
+ regular-events)
+
+ (stream->list
+ (filter-sorted-stream
+ (cut event-in? <> time)
+ repeating-events))
+
+ ev-time<?)))
+
+ (case char
+ ;; TODO The explicit loop call is a hack to rerender the display
+ ;; It's REALLY ugly.
+ ((#\L #\l) (set! time (add-day time)) (set! cur-event 0) (loop #\nul))
+ ((#\h #\H) (set! time (remove-day time)) (set! cur-event 0) (loop #\nul))
+ ((#\j #\J) (unless (= cur-event (1- (length events)))
+ (set! cur-event (1+ cur-event))))
+ ((#\k #\K) (unless (= cur-event 0)
+ (set! cur-event (1- cur-event)))))
+
+ (cls)
+ (display-calendar-header! (time-utc->date time))
+ ;; (line)
+ (format #t "~a┬~a┬~a~%"
+ (make-string 20 #\─)
+ (make-string 32 #\─)
+ (make-string 10 #\─))
+
+
+ (for-each
+ (lambda (ev i)
+ (format #t "~a │ ~a~a~a~a │ ~a~a~%"
+ (time->string (attr ev 'DTSTART) "~1 ~3") ; TODO show truncated string
+ (if (= i cur-event) "\x1b[7m" "")
+ (color-escape (attr (parent ev) 'COLOR))
+ (trim-to-width (attr ev 'SUMMARY) 30)
+ STR-RESET
+ (trim-to-width
+ (or (attr ev 'LOCATION) "\x1b[1;30mINGEN LOKAL") 20)
+ STR-RESET))
+ events
+ (iota (length events)))
+
+ (format #t "~a┴~a┴~a~%"
+ (make-string 20 #\─)
+ (make-string 32 #\─)
+ (make-string 10 #\─))
+
+ (unless (null? events)
+ (let ((ev (list-ref events cur-event)))
+ (format #t "~a~%~aStart: ~a Slut: ~a~%~%~a~%"
+ (attr ev 'SUMMARY)
+ (or (and=> (attr ev 'LOCATION) (cut string-append "Plats: " <> "\n")) "")
+ (time->string (attr ev 'DTSTART) "~1 ~3")
+ (time->string (attr ev 'DTEND) "~1 ~3")
+ (string-join ; TODO replace this with a better text flower
+ (take-to ; This one destroys newlines used for layout
+ (string->wrapped-lines (or (attr ev 'DESCRIPTION) "")
+ #:line-width 60
+ #:collapse-whitespace? #f)
+ 10)
+ (string #\newline))
+ )))
+
+ ;; (format #t "c = ~c (~d)~%" char (char->integer char))
+
+ (unless (or (eof-object? char)
+ ;; TODO this requires that `q' is pressed as many
+ ;; times as other inputs where pressed to actually
+ ;; quit.
+ ;; ^C only works because it force closes the
+ ;; program.
+ (memv char (list #\q (ctrl #\C))))
+ (loop (read-char (current-input-port)))))))
+
+(load "config.scm")
+
+
+(define (main args)
+
+ (define calendars (map make-vcomponent calendar-files))
+ (define events (concatenate (map (cut children <> 'VEVENT) calendars)))
+
+ (let* ((repeating regular (partition repeating? events)))
+ (sort*! repeating time<? (extract 'DTSTART))
+ (sort*! regular time<? (extract 'DTSTART))
+
+ (let ((repeating (interleave-streams ev-time<?
+ (map generate-recurrence-set repeating))))
+ (with-vulgar
+ (lambda () (main-loop regular repeating))))))
+
+
diff --git a/module/srfi/srfi-19/setters.scm b/module/srfi/srfi-19/setters.scm
new file mode 100644
index 00000000..45876382
--- /dev/null
+++ b/module/srfi/srfi-19/setters.scm
@@ -0,0 +1,15 @@
+(define-module (srfi srfi-19 setters)
+ #:use-module (srfi srfi-19) ; Date/Time
+ ;; (record-type-fields (@@ (srfi srfi-19) date))
+ #:export (nanosecond second minute hour day month year zone-offset))
+
+
+(define nanosecond (make-procedure-with-setter date-nanosecond (@@ (srfi srfi-19) set-date-nanosecond!)))
+(define second (make-procedure-with-setter date-second (@@ (srfi srfi-19) set-date-second!)))
+(define minute (make-procedure-with-setter date-minute (@@ (srfi srfi-19) set-date-minute!)))
+(define hour (make-procedure-with-setter date-hour (@@ (srfi srfi-19) set-date-hour!)))
+(define day (make-procedure-with-setter date-day (@@ (srfi srfi-19) set-date-day!)))
+(define month (make-procedure-with-setter date-month (@@ (srfi srfi-19) set-date-month!)))
+(define year (make-procedure-with-setter date-year (@@ (srfi srfi-19) set-date-year!)))
+(define zone-offset (make-procedure-with-setter date-zone-offset (@@ (srfi srfi-19) set-date-zone-offset!)))
+
diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm
new file mode 100644
index 00000000..a4b704b0
--- /dev/null
+++ b/module/srfi/srfi-19/util.scm
@@ -0,0 +1,83 @@
+(define-module (srfi srfi-19 util)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-19 setters)
+ #:export (copy-date
+ drop-time! drop-time
+ in-day? today?
+ ;; seconds minutes hours days weeks
+ ;; time-add
+ make-duration
+ time->string
+ add-day remove-day))
+
+#;
+(define (copy-date date)
+ "Returns a copy of the given date structure"
+ (let* ((date-type (@@ (srfi srfi-19) date))
+ (access (lambda (field) ((record-accessor date-type field) date))))
+ (apply make-date (map access (record-type-fields date-type)))))
+
+(define (drop-time! date)
+ "Sets the hour, minute, second and nanosecond attribute of date to 0."
+ (set! (hour date) 0)
+ (set! (minute date) 0)
+ (set! (second date) 0)
+ (set! (nanosecond date) 0)
+ date)
+
+(define (drop-time date)
+ "Returns a copy of date; with the hour, minute, second and nanosecond
+attribute set to 0. Can also be seen as \"Start of day\""
+ (set-fields date
+ ((date-hour) 0)
+ ((date-minute) 0)
+ ((date-second) 0)
+ ((date-nanosecond) 0)))
+
+(define (make-duration s)
+ (make-time time-duration 0 s))
+
+(define (in-day? day-date time)
+ (let* ((now (date->time-utc (drop-time day-date)))
+ (then (add-duration now (make-duration (* 60 60 24)))))
+ (and (time<=? now time)
+ (time<=? time then))))
+
+(define (today? time)
+ (in-day? (current-date) time))
+
+(define* (time->string time #:optional (format "~1 ~3"))
+ (date->string (time-utc->date time) format))
+
+
+(define (add-day time)
+ (add-duration time (make-time time-duration 0 (* 60 60 24))))
+
+(define (remove-day time)
+ (add-duration time (make-time time-duration 0 (- (* 60 60 24)))))
+
+;; A B C D ¬E
+;; |s1| : |s2| : |s1| : |s2| : |s1|
+;; | | : | | : | ||s2| : |s1|| | : | |
+;; | ||s2| : |s1|| | : | || | : | || | :
+;; | | : | | : | || | : | || | : |s2|
+;; | | : | | : | | : | | : | |
+(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
+ "Return whetever or not two timespans overlap."
+ (or
+ ;; A
+ (and (time<=? s2-begin s1-end)
+ (time<=? s1-begin s2-end))
+
+ ;; B
+ (and (time<=? s1-begin s2-end)
+ (time<=? s2-begin s1-end))
+
+ ;; C
+ (and (time<=? s1-begin s2-begin)
+ (time<=? s2-end s1-end))
+
+ ;; D
+ (and (time<=? s2-begin s1-begin)
+ (time<=? s1-end s2-end))))
diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm
new file mode 100644
index 00000000..5bef95cb
--- /dev/null
+++ b/module/srfi/srfi-41/util.scm
@@ -0,0 +1,29 @@
+(define-module (srfi srfi-41 util)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-41)
+ #:use-module (util) ; let*, find-min
+ #:export (stream-car+cdr interleave-streams))
+
+(define (stream-car+cdr stream)
+ (values (stream-car stream)
+ (stream-cdr stream)))
+
+;; Merges a number of totally ordered streams into a single
+;; totally ordered stream.
+;; ((≺, stream)) → (≺, stream)
+(define (interleave-streams < streams)
+ ;; Drop all empty streams
+ (let ((streams (remove stream-null? streams)))
+ ;; If all streams where empty, end the output stream
+ (if (null? streams)
+ stream-null
+ (let* ((min other (find-min < stream-car streams))
+ (m ms (stream-car+cdr min)))
+ (stream-cons m (interleave-streams < (cons ms other)))))))
+
+;;; Varför är allting så långsamt‽‽‽‽‽‽‽‽
+
+(define-public (filter-sorted-stream proc stream)
+ (stream-take-while
+ proc (stream-drop-while
+ (negate proc) stream)))
diff --git a/module/terminal/escape.scm b/module/terminal/escape.scm
new file mode 100644
index 00000000..8f1b0c2b
--- /dev/null
+++ b/module/terminal/escape.scm
@@ -0,0 +1,28 @@
+;;; Module for terminal (ANSI) escape codes.
+
+(define-module (terminal escape)
+ #:use-module (srfi srfi-60)
+ #:use-module (terminal termios)
+ #:export (with-vulgar))
+
+(define-public (cls)
+ (display "\x1b[H") ; Move cursor to the origin
+ (display "\x1b[J") ; Clear everything after cursor
+ )
+
+;;; I don't curse, I'm just vulgar.
+
+(define-syntax with-vulgar
+ (syntax-rules ()
+ ((_ thunk)
+ (let ((ifd (fileno (current-input-port)))
+ (ofd (fileno (current-output-port))))
+ (dynamic-wind
+ (lambda ()
+ (let ((bits (bitwise-ior ECHO ICANON)))
+ (c-lflags-disable! ifd bits)
+ (c-lflags-disable! ofd bits)))
+ thunk
+ (lambda ()
+ (c-lflag-restore! ifd)
+ (c-lflag-restore! ofd)))) )))
diff --git a/module/terminal/termios.scm b/module/terminal/termios.scm
new file mode 100644
index 00000000..50683f84
--- /dev/null
+++ b/module/terminal/termios.scm
@@ -0,0 +1,13 @@
+;;; Module for termios interaction from Guile,
+;;; Since that for some reason isn't built in.
+
+(define-module (terminal termios)
+ #:export (c-lflags-disable! c-lflag-restore!))
+
+(define-public ECHO #x0000010)
+(define-public ICANON #x0000002)
+
+(setenv "LD_LIBRARY_PATH"
+ (string-append (dirname (dirname (dirname (current-filename))))
+ "/lib"))
+(load-extension "libtermios" "init_termios")
diff --git a/module/terminal/util.scm b/module/terminal/util.scm
new file mode 100644
index 00000000..a7435ad8
--- /dev/null
+++ b/module/terminal/util.scm
@@ -0,0 +1,37 @@
+(define-module (terminal util)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-60)
+ #:export (line ctrl color-escape))
+
+(define* (line #:optional (width 64))
+ (display (make-string width #\_))
+ (newline))
+
+(define (ctrl char)
+ (integer->char (bitwise-and #b00011111 (char->integer char))))
+
+(define-public (display-calendar-header! date)
+ (let* ((day (number->string (date-day date)))
+ (month (number->string (date-month date)))
+ (year (number->string (date-year date))))
+ ;; BSD cal only supports setting highlighted day explicitly for
+ ;; testing the functionality. This seems to at least give me
+ ;; an (almost) working display, albeit ugly.
+ (if (file-exists? "/usr/bin/ncal")
+ (system* "ncal" "-3" "-H" (format #f "~a-~a-~a"
+ year month day)
+ month year)
+ (system* "cal" "-3" day month year))))
+
+(define (color-escape n)
+ (cond ((not n) "")
+ ((char=? #\# (string-ref n 0))
+ (let* ((str (string-drop n 1))
+ (rs (substring str 0 2))
+ (gs (substring str 2 4))
+ (bs (substring str 4 6)))
+ (format #f "\x1b[38;2;~a;~a;~am"
+ (string->number rs 16)
+ (string->number gs 16)
+ (string->number bs 16))))))
+
diff --git a/module/test.scm b/module/test.scm
new file mode 100755
index 00000000..10c6c1a1
--- /dev/null
+++ b/module/test.scm
@@ -0,0 +1,77 @@
+#!/usr/bin/guile -s
+!#
+
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules (rnrs base) ; assert
+ (srfi srfi-1)
+ (srfi srfi-19)
+ (srfi srfi-19 util)
+ (srfi srfi-41)
+ (vcalendar)
+ (vcalendar output)
+ (vcalendar recur))
+
+(define cal (make-vcomponent "../testcal/repeating-event.ics"))
+
+(define ev (car (children cal 'VEVENT)))
+
+(define ev-copy (copy-vcomponent ev))
+
+(assert (equal? (children ev)
+ (children ev-copy)))
+
+(define (display-timespan ev)
+ (format #t "~a ~a ~a -- ~a~%"
+ (attr ev 'NEW_ATTR)
+ (attr ev 'N)
+ (time->string (attr ev "DTSTART"))
+ (time->string (attr ev "DTEND"))))
+
+(display (attr ev 'N)) (newline)
+(display-timespan ev)
+(display (attr ev 'NEW_ATTR)) (newline)
+(newline)
+(define strm (generate-recurrence-set ev))
+(display (attr ev 'RRULE)) (newline)
+
+(if #f
+ (begin
+ (stream-for-each display-timespan (stream-take 20 strm))
+
+ (newline)
+
+ ;; (define strm (generate-recurrence-set ev))
+ (display (attr ev 'RRULE)) (newline)
+
+ ;; This makes the amount of events lookad at before have the same DTSTART,
+ ;; which is the last from that set. The one's after that however are fine.
+ (stream-for-each display-timespan (stream-take 40 strm))
+ (newline)
+ ;; This makes all the DTSTART be the last dtstart
+ ;; (for-each display-timespan (stream->list (stream-take 20 strm)))
+
+;;; I believe that I might have something to do with the stream's cache.
+
+ (newline)
+
+ (display-timespan ev)
+ (display (attr ev 'NEW_ATTR))
+ (newline))
+ (begin
+ ;; These two acts as one large unit.
+ ;; Something modifies the initial ev even though it shouldn't
+ (display-timespan ev)
+ (stream-for-each
+ display-timespan
+ (stream-take 20 (generate-recurrence-set (copy-vcomponent ev))))
+ (newline)
+ (display-timespan ev)
+ (newline)
+ (stream-for-each
+ display-timespan
+ (stream-take 40 (generate-recurrence-set (copy-vcomponent ev))))
+ (newline)
+ (display-timespan ev)
+ ))
+
diff --git a/module/util.scm b/module/util.scm
new file mode 100644
index 00000000..6f1b955a
--- /dev/null
+++ b/module/util.scm
@@ -0,0 +1,168 @@
+(define-module (util)
+ #:use-module (srfi srfi-1)
+ #:use-module ((sxml fold) #:select (fold-values))
+ #:export (destructure-lambda let-multi fold-lists catch-let
+ for-each-in
+ define-quick-record define-quick-record!
+ mod! sort* sort*!
+ find-min)
+ #:replace (let*)
+ )
+
+(define-public upstring->symbol (compose string->symbol string-upcase))
+
+(define-public symbol-upcase (compose string->symbol string-upcase symbol->string))
+
+(define-public symbol-downcase (compose string->symbol string-downcase symbol->string))
+
+(define-syntax destructure-lambda
+ (syntax-rules ()
+ ((_ expr-list body ...)
+ (lambda (expr)
+ (apply (lambda expr-list body ...) expr)))))
+
+(define-syntax catch-let
+ (syntax-rules ()
+ ((_ thunk ((type handler) ...))
+ (catch #t thunk
+ (lambda (err . args)
+ (case err
+ ((type) (apply handler err args)) ...
+ (else (format #t "Unhandled error type ~a, rethrowing ~%" err)
+ (apply throw err args))))))))
+
+;;; For-each with arguments in reverse order.
+(define-syntax-rule (for-each-in lst proc)
+ (for-each proc lst))
+
+
+;;; 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))
+
+;; (define (define-quick-record-templated define-proc name field))
+
+(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)
+;; @lisp
+;; (let* ([a b (values 1 2)] ; @r{SRFI-71}
+;; [(c d) '(3 4)] ; @r{Let-list (mine)}
+;; [e 5]) ; @r{Regular}
+;; (list e d c b a))
+;; ;; => (5 4 3 2 1)
+;; @end lisp
+(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 ...))]
+
+ ;; SRFI-71 let-values
+ [(_ ((k k* ... values) rest ...) body ...)
+ (call-with-values (lambda () values)
+ (lambda (k k* ...)
+ (let* (rest ...)
+ body ...)))]
+
+ ))
+
+;; Like set!, but applies a transformer on the already present value.
+(define-syntax-rule (mod! field transform-proc)
+ (set! field (transform-proc field)))
+
+(define-public (concat lists)
+ (apply append lists))
+
+;; This function borrowed from web-ics (calendar util)
+(define* (sort* items comperator #:optional (get identity))
+ "A sort function more in line with how python's sorted works"
+ (sort items (lambda (a b)
+ (comperator (get a)
+ (get b)))))
+
+;;; This function borrowed from web-ics (calendar util)
+(define* (sort*! items comperator #:optional (get identity))
+ "A sort function more in line with how python's sorted works"
+ (sort! items (lambda (a b)
+ (comperator (get a)
+ (get b)))))
+
+;; Finds the smallest element in @var{items}, compared with @var{<} after
+;; applying @var{foo}. Returns 2 values. The smallest item in @var{items},
+;; and the other items in some order.
+(define (find-min < ac items)
+ (if (null? items)
+ ;; Vad fan retunerar man här?
+ (values #f '())
+ (fold-values
+ (lambda (c min other)
+ (if (< (ac c) (ac min))
+ ;; Current stream head is smaller that previous min
+ (values c (cons min other))
+ ;; Previous min is still smallest
+ (values min (cons c other))))
+ (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 =))
+
+(define-public (take-to lst i)
+ "Like @var{take}, but might lists shorter than length."
+ (if (> i (length lst))
+ lst (take lst i)))
diff --git a/module/vcalendar.scm b/module/vcalendar.scm
new file mode 100644
index 00000000..3f7ba6ba
--- /dev/null
+++ b/module/vcalendar.scm
@@ -0,0 +1,112 @@
+(define-module (vcalendar)
+ #:use-module (vcalendar primitive)
+ #:use-module (vcalendar datetime)
+ #:use-module (vcalendar recur)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (util)
+ #:re-export (repeating?))
+
+(define (parse-dates! cal)
+ "Parse all start times into scheme date objects."
+ (for-each-in (children cal 'VEVENT)
+ (lambda (ev)
+ (mod! (attr ev "DTSTART") parse-datetime)
+ (mod! (attr ev "DTEND") parse-datetime)))
+ cal)
+
+
+(define-public (type-filter t lst)
+ (filter (lambda (e) (eqv? t (type e)))
+ lst))
+
+(define* (children component #:optional only-type)
+ (let ((childs (%vcomponent-children component)))
+ (if only-type
+ (type-filter only-type childs)
+ childs)))
+(export children)
+
+(define (set-attr! component attr value)
+ (%vcomponent-set-attribute!
+ component
+ (if (symbol? attr) (symbol->string attr) attr)
+ value))
+
+(define (get-attr component attr)
+ (%vcomponent-get-attribute
+ component
+ (if (symbol? attr) (symbol->string attr) attr)))
+
+;; Enables symmetric get and set:
+;; (set! (attr ev "KEY") 10)
+(define-public attr (make-procedure-with-setter get-attr set-attr!))
+
+(define-public type %vcomponent-type)
+(define-public parent %vcomponent-parent)
+(define-public push-child! %vcomponent-push-child!)
+(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component)))
+
+(define-public copy-vcomponent %vcomponent-shallow-copy)
+
+(define-public filter-children! %vcomponent-filter-children!)
+
+(define-public (search cal term)
+ (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev)))
+ (children cal))))
+ (find (lambda (ev) (string-contains-ci (car ev) term))
+ (map cons (map (cut get-attr <> "SUMMARY")
+ events)
+ events)))))
+
+(define-public (extract field)
+ (cut get-attr <> field))
+
+(define-public (key=? k1 k2)
+ (eq?
+ (if (string? k1) (string->symbol k1) k1)
+ (if (string? k2) (string->symbol k2) k2)))
+
+(define-public (make-vcomponent path)
+ (let* ((root (%vcomponent-make path))
+ (component
+ (parse-dates!
+ (case (string->symbol (or (attr root "TYPE") "no-type"))
+ ;; == Single ICS file ==
+ ;; Remove the abstract ROOT component,
+ ;; returning the wanted VCALENDAR component
+ ((file)
+ (car (%vcomponent-children root)))
+
+ ;; == Assume vdir ==
+ ;; Also removes the abstract ROOT component, but also
+ ;; merges all VCALENDAR's children into the first
+ ;; VCALENDAR, and return that VCALENDAR.
+ ;;
+ ;; TODO the other VCALENDAR components might not get thrown away,
+ ;; this since I protect them from the GC in the C code.
+ ((vdir)
+ (reduce (lambda (cal accum)
+ (for-each (lambda (component)
+ (case (type component)
+ ((VTIMEZONE)
+ (let ((zones (children cal 'VTIMEZONE)))
+ (unless (find (lambda (z)
+ (string=? (attr z "TZID")
+ (attr component "TZID")))
+ zones)
+ (%vcomponent-push-child! accum component))))
+ (else (%vcomponent-push-child! accum component))))
+ (%vcomponent-children cal))
+ accum)
+ '() (%vcomponent-children root)))
+
+ ((no-type) (throw 'no-type))
+
+ (else (throw 'something))))))
+
+ (set! (attr component "NAME")
+ (attr root "NAME"))
+ (set! (attr component "COLOR")
+ (attr root "COLOR"))
+ component))
diff --git a/module/vcalendar/control.scm b/module/vcalendar/control.scm
new file mode 100644
index 00000000..a38d678f
--- /dev/null
+++ b/module/vcalendar/control.scm
@@ -0,0 +1,39 @@
+(define-module (vcalendar control)
+ #:use-module (util)
+ #:use-module (vcalendar)
+ #:export (with-replaced-attrs))
+
+
+(eval-when (expand load) ; No idea why I must have load here.
+ (define href (make-procedure-with-setter hashq-ref hashq-set!))
+
+ (define (set-temp-values! table component kvs)
+ (for-each (lambda (kv)
+ (let* (((key val) kv))
+ (when (attr component key)
+ (set! (href table key) (attr component key))
+ (set! (attr component key) val))))
+ kvs))
+
+ (define (restore-values! table component keys)
+ (for-each (lambda (key)
+ (and=> (href table key)
+ (lambda (val)
+ (set! (attr component key) val))))
+ keys)))
+
+;;; TODO with-added-attributes
+
+(define-syntax with-replaced-attrs
+ (syntax-rules ()
+ [(_ (component (key val) ...)
+ body ...)
+
+ (let ((htable (make-hash-table 10)))
+ (dynamic-wind
+ (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard
+ (lambda () body ...)
+ (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard
+
+;;; TODO test that restore works, at all
+;;; Test that non-local exit and return works
diff --git a/module/vcalendar/datetime.scm b/module/vcalendar/datetime.scm
new file mode 100644
index 00000000..360b8348
--- /dev/null
+++ b/module/vcalendar/datetime.scm
@@ -0,0 +1,34 @@
+(define-module (vcalendar datetime)
+ #:use-module (vcalendar)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-19 util)
+
+ #:export (parse-datetime
+ event-overlaps?
+ event-in?)
+ )
+
+(define (parse-datetime dtime)
+ "Parse the given date[time] string into a date object."
+ ;; localize-date
+ (date->time-utc
+ (string->date
+ dtime
+ (case (string-length dtime)
+ ((8) "~Y~m~d")
+ ((15) "~Y~m~dT~H~M~S")
+ ((16) "~Y~m~dT~H~M~S~z")))))
+
+(define (event-overlaps? event begin end)
+ "Returns if the event overlaps the timespan.
+Event must have the DTSTART and DTEND attribute set."
+ (timespan-overlaps? (attr event 'DTSTART)
+ (attr event 'DTEND)
+ begin end))
+
+(define (event-in? ev time)
+ "Does event overlap the date that contains time."
+ (let* ((date (time-utc->date time))
+ (start (date->time-utc (drop-time date)))
+ (end (add-duration start (make-duration (* 60 60 24)))))
+ (event-overlaps? ev start end)))
diff --git a/module/vcalendar/output.scm b/module/vcalendar/output.scm
new file mode 100644
index 00000000..e4635beb
--- /dev/null
+++ b/module/vcalendar/output.scm
@@ -0,0 +1,93 @@
+(define-module (vcalendar output)
+ #:use-module (vcalendar)
+ #:use-module (vcalendar control)
+ #:use-module (util)
+ #:use-module (srfi srfi-19 util)
+ #:use-module (srfi srfi-26)
+ #:export (print-vcomponent
+ serialize-vcomponent
+ color-if
+ STR-YELLOW STR-RESET))
+
+(define STR-YELLOW "\x1b[0;33m")
+(define STR-RESET "\x1b[m")
+
+(define-syntax-rule (color-if pred color body ...)
+ (let ((pred-value pred))
+ (format #f "~a~a~a"
+ (if pred-value color "")
+ (begin body ...)
+ (if pred-value STR-RESET ""))))
+
+(define* (print-vcomponent comp #:optional (depth 0))
+ (let ((kvs (map (lambda (key) (cons key (attr comp key)))
+ (attributes comp))))
+ (format #t "~a <~a> :: ~:a~%"
+ (make-string depth #\:)
+ (type comp) comp)
+ (for-each-in kvs
+ (lambda (kv)
+ (let ((key (car kv))
+ (value (cdr kv)))
+ (format #t "~a ~20@a: ~a~%"
+ (make-string depth #\:)
+ key value))))
+ (for-each-in (children comp)
+ (cut print-vcomponent <> (1+ depth)))))
+
+
+
+;;; TODO
+;; Error in CREATED /home/hugo/.calendars/b85ba2e9-18aa-4451-91bb-b52da930e977/a1a25238-d63d-46a1-87fd-d0c9334a7a30CalSync.ics:
+;; Wrong type argument in position 1 (expecting string): ("20180118T124015Z" "VALARM")
+
+(define (string->ics-safe-string str)
+ "TODO wrap at 75(?) columns."
+ (define (escape char)
+ (string #\\ char))
+
+ (string-concatenate
+ (map (lambda (c)
+ (case c
+ ((#\newline) "\\n")
+ ((#\, #\; #\\) => escape)
+ (else => string)))
+ (string->list str))))
+
+;;; TODO parameters ( ;KEY=val: )
+(define* (serialize-vcomponent comp #:optional (port (current-output-port)))
+ "Recursively write a component back to its ICS form.
+Removes the X-HNH-FILENAME attribute, and sets PRODID to
+\"HugoNikanor-calparse\" in the output."
+ (with-replaced-attrs
+ (comp (prodid "HugoNikanor-calparse"))
+
+ (format port "BEGIN:~a~%" (type comp))
+ (let ((kvs (map (lambda (key) (list key (attr comp key)))
+ (filter (negate (cut key=? <> 'X-HNH-FILENAME))
+ (attributes comp)))))
+ (for-each-in
+ kvs (lambda (kv)
+ (let* (((key value) kv))
+ (catch 'wrong-type-arg
+ (lambda ()
+ (format port "~a:~a~%" key
+ (string->ics-safe-string
+ (case key
+ ((DTSTART DTEND)
+ (if (string? value)
+ value
+ (time->string value "~Y~m~dT~H~M~S")))
+
+ ((RRULE DURATION) "Just forget it")
+
+ (else value)))))
+
+ ;; Catch
+ (lambda (type proc fmt . args)
+ (apply format (current-error-port) "[ERR] ~a in ~a (~a) ~a:~%~?~%"
+ type key proc (attr comp 'X-HNH-FILENAME)
+ fmt args))))))
+
+ (for-each (cut serialize-vcomponent <> port) (children comp)))
+ (format port "END:~a~%" (type comp))))
diff --git a/module/vcalendar/primitive.scm b/module/vcalendar/primitive.scm
new file mode 100644
index 00000000..b5eb9388
--- /dev/null
+++ b/module/vcalendar/primitive.scm
@@ -0,0 +1,23 @@
+;;; Primitive export of symbols linked from C binary.
+
+(define-module (vcalendar primitive)
+ #:export (%vcomponent-children
+ %vcomponent-push-child!
+ %vcomponent-filter-children!
+
+ %vcomponent-parent
+
+ %vcomponent-make
+ %vcomponent-type
+
+ %vcomponent-set-attribute!
+ %vcomponent-get-attribute
+
+ %vcomponent-attribute-list
+
+ %vcomponent-shallow-copy))
+
+(setenv "LD_LIBRARY_PATH"
+ (string-append (dirname (dirname (dirname (current-filename))))
+ "/lib"))
+(load-extension "libguile-calendar" "init_lib")
diff --git a/module/vcalendar/recur.scm b/module/vcalendar/recur.scm
new file mode 100644
index 00000000..3657cae6
--- /dev/null
+++ b/module/vcalendar/recur.scm
@@ -0,0 +1,12 @@
+(define-module (vcalendar recur)
+ #:use-module (vcalendar)
+ #:use-module (vcalendar recurrence generate)
+ #:re-export (generate-recurrence-set)
+ #:export (repeating?))
+
+;; 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?"
+ (or (attr ev 'RRULE)
+ (attr ev 'RDATE)))
diff --git a/module/vcalendar/recurrence/generate.scm b/module/vcalendar/recurrence/generate.scm
new file mode 100644
index 00000000..fae404ec
--- /dev/null
+++ b/module/vcalendar/recurrence/generate.scm
@@ -0,0 +1,126 @@
+(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) ; call-with-escape-continuation
+ #: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 freq)
+ (case freq
+ ((SECONDLY) 1)
+ ((MINUTELY) 60)
+ ((HOURLY) (* 60 60))
+ ((DAILY) (* 60 60 24))
+ ((WEEKLY) (* 60 60 24 7))))
+
+
+;; BYDAY and the like depend on the freq?
+;; Line 7100
+;; Table @@ 2430
+;;
+;; Event x Rule → Bool (continue?)
+;; Alternative, monadic solution using <optional>.
+;; @example
+;; (optional->bool
+;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r))
+;; (<$> (negate zero?) (count r))
+;; (just #t)))
+;; @end example
+(define-stream (recur-event-stream event rule-obj)
+ (stream-unfold
+
+ ;; Event x Rule → Event
+ (match-lambda
+ ((last r)
+ (let ((e (copy-vcomponent last))) ; new event
+ (cond
+
+ ((memv (freq r) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY))
+ (mod! (attr e 'DTSTART) ; MUTATE
+ (cut add-duration! <>
+ (make-duration
+ (* (interval r) ; INTERVAL
+ (seconds-in (freq r)))))))
+
+ ((memv (freq r) '(MONTHLY YEARLY))
+ #f ; Hur fasen beräkrnar man det här!!!!
+ ))
+
+ ;; TODO this is just here for testing
+ (mod! (attr e 'NEW_ATTR) not) ; MUTATE
+ ;; This segfaults...
+ ;; (set! (attr e 'N) #t) ; MUTATE
+ ((@ (vcalendar output) print-vcomponent) e)
+ (set! (attr e 'D) #t)
+
+ (set! (attr e 'DTEND) ; MUTATE
+ (add-duration
+ (attr e 'DTSTART)
+ (attr e 'DURATION)))
+ e)))
+
+ ;; Event x Rule → Bool (continue?)
+ (match-lambda
+ ((e r)
+
+ (or (and (not (until r)) (not (count r))) ; Never ending
+ (and=> (count r) (negate zero?)) ; COUNT
+ (and=> (until r) (cut time<=? (attr e 'DTSTART) <>))))) ; UNTIL
+
+ ;; _ x Rule → (_, (next) Rule)
+ (match-lambda
+ ((e r)
+ (list
+ e (if (count r)
+ ;; Note that this doesn't modify, since r is immutable.
+ (mod! (count r) 1-)
+ r))))
+
+ ;; Seed
+ (list event rule-obj)))
+
+
+(define (generate-recurrence-set event)
+ (unless (attr event "DURATION")
+ (set! (attr event "DURATION") ; MUTATE
+ (time-difference
+ (attr event "DTEND")
+ (attr event "DTSTART"))))
+ (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))))
+
+ ;; How doee stream-unfold even work?
+ ;; What element is used as the next seed?
+;;; stream-fold:
+;; (stream-let recur ((base base))
+;; (if (pred? base)
+;; (stream-cons (mapper base) (recur (generator base)))
+;; stream-null))
diff --git a/module/vcalendar/recurrence/internal.scm b/module/vcalendar/recurrence/internal.scm
new file mode 100644
index 00000000..b62d75c2
--- /dev/null
+++ b/module/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/module/vcalendar/recurrence/parse.scm b/module/vcalendar/recurrence/parse.scm
new file mode 100644
index 00000000..abead3a9
--- /dev/null
+++ b/module/vcalendar/recurrence/parse.scm
@@ -0,0 +1,106 @@
+(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 #\;))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-25 08:57:56 +0200