From d46183860c1f3f10095e95023adcb79b1896ab0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 22 Mar 2019 20:11:11 +0100 Subject: Move C and Scheme code into subdirs. --- module/config.scm | 12 +++ module/exceptions.scm | 5 + module/fetch.scm | 31 ++++++ module/helpers.scm | 43 ++++++++ module/main.scm | 139 +++++++++++++++++++++++++ module/srfi/srfi-19/setters.scm | 15 +++ module/srfi/srfi-19/util.scm | 83 +++++++++++++++ module/srfi/srfi-41/util.scm | 29 ++++++ module/terminal/escape.scm | 28 ++++++ module/terminal/termios.scm | 13 +++ module/terminal/util.scm | 37 +++++++ module/test.scm | 77 ++++++++++++++ module/util.scm | 168 +++++++++++++++++++++++++++++++ module/vcalendar.scm | 112 +++++++++++++++++++++ module/vcalendar/control.scm | 39 +++++++ module/vcalendar/datetime.scm | 34 +++++++ module/vcalendar/output.scm | 93 +++++++++++++++++ module/vcalendar/primitive.scm | 23 +++++ module/vcalendar/recur.scm | 12 +++ module/vcalendar/recurrence/generate.scm | 126 +++++++++++++++++++++++ module/vcalendar/recurrence/internal.scm | 28 ++++++ module/vcalendar/recurrence/parse.scm | 106 +++++++++++++++++++ 22 files changed, 1253 insertions(+) create mode 100644 module/config.scm create mode 100644 module/exceptions.scm create mode 100755 module/fetch.scm create mode 100644 module/helpers.scm create mode 100755 module/main.scm create mode 100644 module/srfi/srfi-19/setters.scm create mode 100644 module/srfi/srfi-19/util.scm create mode 100644 module/srfi/srfi-41/util.scm create mode 100644 module/terminal/escape.scm create mode 100644 module/terminal/termios.scm create mode 100644 module/terminal/util.scm create mode 100755 module/test.scm create mode 100644 module/util.scm create mode 100644 module/vcalendar.scm create mode 100644 module/vcalendar/control.scm create mode 100644 module/vcalendar/datetime.scm create mode 100644 module/vcalendar/output.scm create mode 100644 module/vcalendar/primitive.scm create mode 100644 module/vcalendar/recur.scm create mode 100644 module/vcalendar/recurrence/generate.scm create mode 100644 module/vcalendar/recurrence/internal.scm create mode 100644 module/vcalendar/recurrence/parse.scm (limited to 'module') 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-timetime-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-timedate 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 timestring + 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 . +;; @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 '(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 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 + ;; ∈ weekdays + ;; ::= [[±] ] ;; +3MO + ;; (, ...) + ;; (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 #\;)))) -- cgit v1.2.3