From f852c30bcef530d18a474ab6ab8350a3ef93d563 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Jan 2020 22:51:45 +0100 Subject: Once again compiles. --- module/entry-points/html.scm | 8 +- module/entry-points/terminal.scm | 6 +- module/main.scm | 29 ++++- module/output/general.scm | 24 +++-- module/output/html.scm | 171 +++++++++++++++--------------- module/srfi/srfi-19/alt.scm | 137 +++++++++++++++++++++--- module/srfi/srfi-19/alt/util.scm | 113 +++++++++++++++----- module/srfi/srfi-19/setters.scm | 6 +- module/srfi/srfi-19/util.scm | 14 +++ module/util.scm | 15 ++- module/vcomponent/datetime.scm | 16 ++- module/vcomponent/group.scm | 10 +- module/vcomponent/load.scm | 8 +- module/vcomponent/output.scm | 15 ++- module/vcomponent/parse.scm | 7 +- module/vcomponent/recurrence/generate.scm | 46 +++++--- module/vcomponent/recurrence/internal.scm | 3 +- module/vcomponent/recurrence/parse.scm | 22 ++-- module/vulgar/components.scm | 2 +- 19 files changed, 460 insertions(+), 192 deletions(-) (limited to 'module') diff --git a/module/entry-points/html.scm b/module/entry-points/html.scm index 82f972ae..16306031 100644 --- a/module/entry-points/html.scm +++ b/module/entry-points/html.scm @@ -3,8 +3,8 @@ :use-module (output html) :use-module (util) :use-module (vcomponent) - :use-module (srfi srfi-19) - :use-module (srfi srfi-19 util) + :use-module (srfi srfi-19 alt) + :use-module (srfi srfi-19 alt util) :use-module (ice-9 getopt-long) :use-module (parameters) @@ -22,13 +22,15 @@ (define start (cond [(option-ref opts 'from #f) => parse-freeform-date] [else (start-of-month (current-date))])) (define end (cond [(option-ref opts 'to #f) => parse-freeform-date] - [else (normalize-date* (set (date-month start) = (+ 1)))])) + [else (date+ start (date month: 1)) ])) (define-values (calendars events) (load-calendars calendar-files: (cond [(option-ref opts 'file #f) => list] [else (calendar-files)]) )) + ((@ (srfi srfi-41) stream->list) events) + (if (option-ref opts 'chunked #f) (html-chunked-main calendars events start) (html-generate calendars events start end))) diff --git a/module/entry-points/terminal.scm b/module/entry-points/terminal.scm index df15116c..e53a3d05 100644 --- a/module/entry-points/terminal.scm +++ b/module/entry-points/terminal.scm @@ -20,9 +20,9 @@ calendar-files: (cond [(option-ref opts 'file #f) => list] [else (calendar-files)]) )) - (let ((time (drop-time (or (and=> (option-ref opts 'date #f) parse-freeform-date) - (current-date))))) + (let ((date (or (and=> (option-ref opts 'date #f) parse-freeform-date) + (current-date)))) ;; (format (current-error-port) "len(events) = ~a~%" (stream-length events)) (with-vulgar - (lambda () (main-loop time events)))) + (lambda () (main-loop date events)))) ) diff --git a/module/main.scm b/module/main.scm index 92df5e20..1765ef43 100755 --- a/module/main.scm +++ b/module/main.scm @@ -7,7 +7,7 @@ exec guile -e main -s $0 "$@" !# (use-modules (srfi srfi-1) - (srfi srfi-19) + ;; (srfi srfi-19) (srfi srfi-41) (srfi srfi-41 util) (srfi srfi-88) ; keyword syntax @@ -40,7 +40,7 @@ exec guile -e main -s $0 "$@" (if (null? a) b a)) -(define (main args) +(define (wrapped-main args) (define opts (getopt-long args options #:stop-at-first-non-option #t)) (define stprof (option-ref opts 'statprof #f)) @@ -80,3 +80,28 @@ exec guile -e main -s $0 "$@" style: (if (boolean? stprof) 'flat (string->symbol stprof))))) + + +(use-modules (system vm frame)) + +(define (main args) + (with-throw-handler #t + (lambda () (wrapped-main args)) + (lambda (err . args) + (define stack (make-stack #t)) + (format + (current-error-port) + "bindings = (~a)~%" + (with-output-to-string + (lambda () + (let loop ((frame (stack-ref stack 0))) + (when frame + (format #t "~{~a~^ ~}" (map binding-name (frame-bindings frame))) + (let ((event (and=> (frame-lookup-binding frame 'event) + binding-ref))) + (when event + (format (current-error-port) "event = ~a~%" event) + ((@ (vcomponent output) serialize-vcomponent) + event (current-error-port)))) + + (loop (frame-previous frame)))))))))) diff --git a/module/output/general.scm b/module/output/general.scm index 526c449e..4d9b4ce8 100644 --- a/module/output/general.scm +++ b/module/output/general.scm @@ -3,12 +3,18 @@ ;; Returns a color with good contrast to the given background color. (define-public (calculate-fg-color c) - (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16)) - (let ((r (str->num c 1)) - (g (str->num c 3)) - (b (str->num c 5))) - (if (< 1/2 (/ (+ (* 0.299 r) - (* 0.587 g) - (* 0.144 b)) - #xFF)) - "#000000" "#e5e8e6"))) + (catch #t + (lambda () + (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16)) + (let ((r (str->num c 1)) + (g (str->num c 3)) + (b (str->num c 5))) + (if (< 1/2 (/ (+ (* 0.299 r) + (* 0.587 g) + (* 0.144 b)) + #xFF)) + "#000000" "#e5e8e6"))) + (lambda args + (format (current-error-port) "Error calculating foreground color?~%~a~%" args) + "#FF0000" + ))) diff --git a/module/output/html.scm b/module/output/html.scm index 16520f0b..cd3e2974 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -8,8 +8,8 @@ #:use-module (vcomponent datetime) #:use-module (util) #:use-module (util tree) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-19 alt) + #:use-module (srfi srfi-19 alt util) #:use-module (output general) @@ -26,15 +26,14 @@ (define (date-link date) (date->string date "~Y-~m-~d")) -(define (time-link time) - (time->string time "~Y-~m-~d")) - (define x-pos (make-object-property)) (define width (make-object-property)) (define (UID ev) (string-append - (time->string (attr ev 'DTSTART) "~s") + ;; (date/-time->string (attr ev 'DTSTART) "~s") + (date->string (as-date (attr ev 'DTSTART)) "~Y~m~d") + (time->string (as-time (attr ev 'DTSTART)) "~H~M~S") (html-attr (attr ev 'UID)))) ;; Takes a list of vcomponents, sets their widths and x-positions to optimally @@ -49,7 +48,7 @@ ;; @var{x} is how for left in the container we are. (let inner ((x 0) (tree (make-tree overlapping? - (sort* lst time>? (lambda (e) (event-length/day e start-of-day)))))) + (sort* lst time>? (lambda (e) (event-length/day e)))))) (unless (null? tree) (let ((w (/ (- 1 x) (+ 1 (length-of-longst-branch (left-subtree tree)))))) @@ -60,16 +59,17 @@ ;; This should only be used on time intervals, never on absolute times. ;; For that see @var{date->decimal-hour}. +;; NOTE Above comment probably deprecated (define (time->decimal-hour time) - (exact->inexact (/ (time-second time) - 3600))) + (exact->inexact (+ (/ (minute time) 60) + (/ (second time) 3600)))) (define (html-attr str) (define cs (char-set-adjoin char-set:letter+digit #\- #\_)) (string-filter (lambda (c) (char-set-contains? cs c)) str)) -(define (create-block-general day ev fmt) - (define time (date->time-utc day)) +(define (create-block-general date ev fmt) + ;; (define time (date->time-utc day)) (define style (format #f fmt @@ -77,22 +77,24 @@ (* 100 (width ev)) ; width ;; top - (if (in-day? day (attr ev 'DTSTART)) + (if (in-day? date (attr ev 'DTSTART)) (* 100/24 (time->decimal-hour - (time-difference (attr ev 'DTSTART) - (start-of-day* (attr ev 'DTSTART))))) + (as-time (attr ev 'DTSTART)) + #; + (time- (as-time (attr ev 'DTSTART)) + (start-of-day* (attr ev 'DTSTART))))) 0) ;; height - (* 100/24 (time->decimal-hour (event-length/day ev time))))) + (* 100/24 (time->decimal-hour (event-length/day ev))))) `(a (@ (href "#" ,(UID ev)) (class "hidelink")) (div (@ (class "event CAL_" ,(html-attr (attr (parent ev) 'NAME)) - ,(when (time sxml (define (lay-out-day day) (let* (((date . events) day) - (time (date->time-utc date)) + (time-obj (datetime date: date)) (long-events short-events (partition (lambda (ev) - (time<=? (make-duration (* 3600 24)) - (time-difference (attr ev 'DTEND) - (attr ev 'DTSTART)))) + (or (date? (attr ev 'DTSTART)) + (datetime<=? (datetime time: (time hour: 24)) + (datetime- (attr ev 'DTEND) + (attr ev 'DTSTART))))) (stream->list events)))) - (fix-event-widths! time short-events) - (fix-event-widths! time long-events) + (fix-event-widths! time-obj short-events) + (fix-event-widths! time-obj long-events) `(div (@ (class "day")) (div (@ (class "meta")) ,(let ((str (date-link date))) @@ -154,12 +157,27 @@ (define (fmt-time-span ev) - (let* ((fmt (if (timestring (attr ev 'DTSTART) fmt)) - (end (time->string (attr ev 'DTEND) fmt))) - (values start end))) + (cond [(attr ev 'DTSTART) date? + => (lambda (s) + (cond [(attr ev 'DTEND) + => (lambda (e) + (if (date= e (date+ s (date day: 1))) + (values (date->string s) "") + (values (date->string s) + (date->string e))))] + [else (date->string s)]))] + [else ; guaranteed datetime + ;; TODO rewrite this + (values (time->string (get-time (attr ev 'DTSTART))) + (time->string (get-time (attr ev 'DTEND)))) + #; + (let* ((fmt (if (date/-timestring (attr ev 'DTSTART) fmt)) + (end (date/-time->string (attr ev 'DTEND) fmt))) + (values start end))])) ;; For sidebar, just text @@ -167,7 +185,7 @@ `(article (@ (id ,(UID ev)) (class "eventtext CAL_bg_" ,(html-attr (attr (parent ev) 'NAME)))) - (h3 (a (@ (href "#" ,(time-link (attr ev 'DTSTART))) + (h3 (a (@ (href "#" ,(date-link (as-date (attr ev 'DTSTART)))) (class "hidelink")) ,(attr ev 'SUMMARY))) (div @@ -192,35 +210,17 @@ ;; This removes all descriptions from ;; events for previous days, ;; solving duplicates. - (time<=? (date->time-utc date) - (attr ev 'DTSTART))) + (date/-time<=? date + (attr ev 'DTSTART))) events)))))) -(define (days-in-month date) - (define rem=0? (compose zero? remainder)) - (let ((m (date-month date))) - (cond ((memv m '(1 3 5 7 8 10 12)) 31) - ((memv m '(4 6 9 11)) 30) - (else - ;; Please don't mention non-gregorian calendars. - (let ((y (date-year date))) - (if (and (rem=0? y 4) - (or (not (rem=0? y 100)) - (rem=0? y 400))) - 29 28)))))) - -(define (previous-month n) - (1+ (modulo (- n 2) 12))) - -;; 0 indexed, starting at monday. -(define (week-day date) - (modulo (1- (date-week-day date)) 7)) - -(define* (month+ date #:optional (change 1)) - (normalize-date* (set (date-month date) = (+ change)))) +(define* (month+ date-object #:optional (change 1)) + ;; (normalize-date* (set (date-month date) = (+ change))) + (date+ date-object (date month: change)) + ) -(define* (month- date #:optional (change -1)) - (month+ date change)) +(define* (month- date-object #:optional (change 1)) + (date- date-object (date month: change))) ;; date should be start of month ;; @example @@ -245,16 +245,15 @@ `(table (@ (class "small-calendar")) (thead (tr ,@(map (lambda (d) `(td ,d)) '(MÅ TI ON TO FR LÖ SÖ)))) (tbody ,@(let recur - ((lst (let* ((month (date-month date)) + ((lst (let* ((month (month date)) (month-len (days-in-month date)) - (prev-month-len (days-in-month (month- date) #; (previous-month month) - )) + (prev-month-len (days-in-month (month- date))) (month-start (week-day date))) (append (map (td '(class "prev") (month- date)) (iota month-start (1+ (- prev-month-len month-start)))) (map (lambda (p) `(td (@ ,@(assq-merge '((class " cur ")) (cdar p))) ,@(cdr p))) - (map (lambda (d) `((@ (class ,(when (date=? today (set (date-day date) d)) + (map (lambda (d) `((@ (class ,(when (date=? today (set (day date) d)) "today"))) (a (@ (href "#" ,(date->string date "~Y-~m-") ,(pad0 d)) @@ -274,9 +273,9 @@ ;;; and the html-generate procedure also filters, but instead to find earlier eventns. ;;; All this filtering is probably slow, and should be looked into. -(define-public (html-generate calendars events start end) +(define-public (html-generate calendars events start-date end-date) (define evs (get-groups-between (group-stream events) - start end)) + start-date end-date)) ;; (display "") (newline) (define (nav-link display date) @@ -295,8 +294,8 @@ (meta (@ (name viewport) (content "width=device-width, initial-scale=0.5"))) (meta (@ (name description) - (content "Calendar for the dates between " ,(date->string start) - " and " ,(date->string end)))) + (content "Calendar for the dates between " ,(date->string start-date) + " and " ,(date->string end-date)))) ,(include-css "static/style.css") (script (@ (src "static/script.js")) "") (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~a }~%~}" @@ -332,14 +331,14 @@ ;; Small calendar and navigation (div (@ (class "about")) ;; prev button - ,(nav-link "«" (month- start)) + ,(nav-link "«" (month- start-date)) ;; calendar table - (div ,(cal-table (start-of-month start) + (div ,(cal-table (start-of-month start-date) (current-date))) ;; next button - ,(nav-link "»" (month+ start))) + ,(nav-link "»" (month+ start-date))) ;; List of events (div (@ (class "eventlist")) @@ -348,25 +347,25 @@ (header (h2 "Tidigare")) ,@(stream->list (stream-map fmt-single-event - (stream-take-while (compose (cut time (date->time-utc start)) + (stream-take-while (compose (cut date/-time start-date) (extract 'DTSTART)) (cdr (stream-car evs)))))) ,@(stream->list (stream-map fmt-day evs))))))))) -(define-public (html-chunked-main calendars events start) +(define-public (html-chunked-main calendars events start-date) ;; NOTE Something here isn't thread safe. ;; TODO make it thread safe - (stream-for-each (lambda (pair) - (format (current-error-port) "d = ~a~%u = ~a~%" (car pair) (cadr pair)) - (let ((fname (format #f "./html/~a.html" (date->string (car pair) "~1")))) - (format (current-error-port) "Writing to [~a]~%" fname) - (with-output-to-file fname - (lambda () (apply html-generate calendars events pair))))) - (let ((ms (month-stream start))) - (stream-take - 12 (stream-zip - ms (stream-map (lambda (d) (normalize-date - (set (date-day d) = (- 1)))) - (stream-cdr ms)))) - ))) + (stream-for-each + (lambda (pair) + (format (current-error-port) "d = ~a~%u = ~a~%" (car pair) (cadr pair)) + (let ((fname (format #f "./html/~a.html" (date->string (car pair) "~1")))) + (format (current-error-port) "Writing to [~a]~%" fname) + (with-output-to-file fname + (lambda () (apply html-generate calendars events pair))))) + (let ((ms (month-stream start-date))) + (stream-take + 12 (stream-zip + ms (stream-map (lambda (d) (date- d (date day: 1))) ; last in month + (stream-cdr ms)))) + ))) diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm index eda1b1f3..a9359a32 100644 --- a/module/srfi/srfi-19/alt.scm +++ b/module/srfi/srfi-19/alt.scm @@ -71,9 +71,6 @@ (hour r) (minute r) (second r) (if (utc r) "Z" ""))))) -(define-public (time->string time _) - (with-output-to-string (lambda () (display time)))) - (define*-public (time key: (hour 0) (minute 0) (second 0) (utc #f)) (make-time hour minute second utc)) @@ -113,12 +110,23 @@ ((apr jun sep nov) 30) ((feb) (if (leap-year? (year date)) - 29 28)))) + 29 28)) + (else (error "No month ~a (~a)" (month date) date)))) (define-public (days-in-year date) (if (leap-year? (year date)) 366 365)) + +(define-public (as-date date/-time) + (if (date? date/-time) + date/-time + (get-date date/-time))) + +(define-public (as-time date/-time) + (if (datetime? date/-time) + (get-time date/-time) + (time))) ;;; EQUIALENCE @@ -147,7 +155,7 @@ (time=?) time= (datetime=?) datetime=) -(define-public (date< a b) +(define (date<% a b) (let ((ay (year a)) (by (year b))) (if (= ay ay) @@ -158,6 +166,14 @@ (< am bm))) (< ay by)))) +(define-public date< + (match-lambda* + [() #t] + [(_) #t] + [(first second . rest) + (and (date<% first second) + (apply date< second rest))])) + (define-public (time< a b) (let ((ah (hour a)) @@ -176,25 +192,39 @@ (time< (get-time a) (get-time b)) (date< (get-date a) (get-date b)))) +(define-public (date/-time< a b) + (if (date< (as-date a) (as-date b)) + #t + (time< (as-time a) (as-time b)))) (define-many define-public (date date>?) (swap date<) + (date<= date<=?) (negate date>) + (date>= date>=?) (negate date<) (time time>?) (swap time<) - (time<= time<=?) (negate time>) (time>= time>=?) (negate time<) (datetime datetime>?) (swap datetime<)) + (datetime> datetime>?) (swap datetime<) + (datetime<= datetime<=?) (negate datetime>) + (datetime>= datetime>=?) (negate datetime<) + + (date/-time date/-time>?) (swap date/-time<) + (date/-time<= date/-time<=?) (negate date/-time>) + (date/-time>= date/-time>=?) (negate date/-time<) + ) ;;; OPERATIONS ;; Base and change inverted to better work with fold in the exported date+ +#; (define (date+% change base) ;; while (day base) > (days-in-month base) @@ -219,18 +249,82 @@ (set (year months-fixed) = (+ (year change)))) +(define-public (date-zero? date) + (= 0 (year date) (month date) (day date))) + +(define (date+%% change base) + + (define-values (days-fixed change*) + (let loop ((target base) (change change)) + ;; (format (current-error-port) "1 ~s : ~s~%" target change) + (if (> (days-in-month target) (+ (day change) (day target))) + ;; No date overflow, just add the change + (values (set-> target (day = (+ (day change)))) + (set-> change (day 0))) + ;; Date (and possibly year) overflow + (loop (if (= 12 (month target)) + (set-> target + (year = (+ 1)) + (month 1) + (day 1)) + (set-> target + (month = (+ 1)) + (day 1))) + (set-> change (day = (- (1+ (- (days-in-month target) (day target)))))))))) + + (define-values (month-fixed change**) + (if (date-zero? change*) + (values days-fixed change*) + (let loop ((target days-fixed) (change change*)) + ;; (format (current-error-port) "2 ~s : ~s~%" target change) + (if (>= 12 (+ (month change) (month target))) + (values (set (month target) = (+ (month change))) + (set (month change) 0)) + + (loop (set-> target + (year = (+ 1)) + (month 1)) + (set (month change) = (- 12 (month target)))) + )))) + + ;; change** should here should have both month and date = 0 + + (set (year month-fixed) = (+ (year change**)))) + +(define (date+% change base) + + (when (or (negative? (year change)) + (negative? (month change)) + (negative? (day change))) + (error "Change can't be negative")) + + (when (or (negative? (month base)) + (negative? (day base))) + (error "Base month or day can't be negative")) + + (date+%% change base) + ) + +;; @var{base} MUST be a valid real date. all rest arguments can however +;; be "invalid" dates, such as 0000-00-10 (define-public (date+ base . rest) (fold date+% base rest)) -(define (date-% change base) - +(define (date-%% change base) (define-values (days-fixed change*) (let loop ((target base) (change change)) (if (>= (day change) (day target)) - (loop (set-> target - (month = (- 1)) - (day (days-in-month (set (month target) = (- 1))))) - (set (day change) = (- (day target)))) + (let ((new-change (set (day change) = (- (day target))))) + (loop (if (= 1 (month target)) + (set-> target + (year = (- 1)) + (month 12) + (day 31) ; days in december + ) + (set-> target + (month = (- 1)) + (day (days-in-month (set (month target) = (- 1)))))) + new-change)) (values (set (day target) = (- (day change))) (set (day change) 0))))) @@ -246,7 +340,21 @@ ;; change** should here should have both month and date = 0 - (set (year month-fixed) = (- (year change)))) + (set (year month-fixed) = (- (year change**)))) + +(define (date-% change base) + + (when (or (negative? (year change)) + (negative? (month change)) + (negative? (day change))) + (error "Change can't be negative")) + + (when (or (negative? (month base)) + (negative? (day base))) + (error "Base month or day can't be negative")) + + (date-%% change base) + ) (define-public (date- base . rest) (fold date-% base rest)) @@ -384,7 +492,6 @@ day: ((@ (srfi srfi-19) date-day) d)))) - ;; Reader extensions diff --git a/module/srfi/srfi-19/alt/util.scm b/module/srfi/srfi-19/alt/util.scm index 877da69f..3310df85 100644 --- a/module/srfi/srfi-19/alt/util.scm +++ b/module/srfi/srfi-19/alt/util.scm @@ -1,6 +1,6 @@ (define-module (srfi srfi-19 alt util) :use-module (srfi srfi-19 alt) - :use-module (srfi srfi-1) + :use-module ((srfi srfi-1) :select (fold)) :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module (util) @@ -19,24 +19,64 @@ (stream-iterate (cut date+ <> #0-0-1) start-day)) -(define-public (as-date date/-time) - (if (date? date/-time) - date/-time - (get-date date/-time))) - -(define-public (as-time date/-time) - (if (datetime? date/-time) - (get-time date/-time) - #00:00:00)) - -(define-public (date/-time< a b) - (if (date< (as-date a) (as-date b)) - #t - (time< (as-time a) (as-time b)))) +(define-public (month-stream start-day) + (stream-iterate (cut date+ <> #0-1-0) + start-day)) -(define-public date/-timestring date optional: (fmt "~Y-~m-~d")) +(define-public (week-day-name week-day-number) + ;; TODO internationalization + (case* week-day-number + [(sun 7) "Sön"] + [(mon) "Mån"] + [(tue) "Tis"] + [(wed) "Ons"] + [(thu) "Tor"] + [(fri) "Fre"] + [(sat) "Lör"])) + +(define*-public (date->string date optional: (fmt "~Y-~m-~d") key: allow-unknown?) (with-output-to-string (lambda () (fold (lambda (token state) @@ -47,13 +87,17 @@ ((#\Y) (format #t "~4'0d" (year date))) ((#\m) (format #t "~2'0d" (month date))) ((#\d) (format #t "~2'0d" (day date))) - (else (error "Invalid format token ~a" token))) + ((#\1) (format #t "~4'0d-~2'0d-~2'0d" + (year date) (month date) (day date))) + ((#\a) (display (week-day-name (week-day date)))) + (else (unless allow-unknown? + (error 'date->string "Invalid format token ~a" token)))) #f) (else (unless (char=? #\~ token) (display token)) token))) #f (string->list fmt))))) -(define*-public (time->string time optional: (fmt "~H:~M:~S")) +(define*-public (time->string time optional: (fmt "~H:~M:~S") key: allow-unknown?) (with-output-to-string (lambda () (fold (lambda (token state) @@ -61,16 +105,19 @@ ((#\~) (case token ((#\~) (display "~")) - ((#\H) (format #t "~2'0d" (hour date))) - ((#\M) (format #t "~2'0d" (minute date))) - ((#\S) (format #t "~2'0d" (second date))) - (else (error "Invalid format token ~a" token))) + ((#\H) (format #t "~2'0d" (hour time))) + ((#\M) (format #t "~2'0d" (minute time))) + ((#\S) (format #t "~2'0d" (second time))) + (else (unless allow-unknown? + (error 'time->string "Invalid format token ~a" token)))) #f) (else (unless (char=? #\~ token) (display token)) token))) #f (string->list fmt))))) + + ;; @verbatim ;; A B C D E ¬F ;; |s1| : |s2| : |s1| : |s2| : : |s1| @@ -100,8 +147,20 @@ (and (date/-time + (if (< 12 (date-hour date)) + ;; round up + (set (date-day date) = (+ 1)) + ;; round down + date) + (date-day = (+ 1)) + (date-hour 0) + (date-minute 0) + (date-second 0))) diff --git a/module/util.scm b/module/util.scm index a2ab43c3..717c61d8 100644 --- a/module/util.scm +++ b/module/util.scm @@ -193,11 +193,22 @@ (define-public (swap f) (lambda args (apply f (reverse args)))) + +(define-syntax case*% + (syntax-rules (else) + [(_ _ else) + #t] + [(_ invalue (value ...)) + (memv invalue (list value ...))] + #; + [(_ invalue target) + (eq? invalue target)])) + ;; Like `case', but evals the case parameters (define-syntax case* (syntax-rules (else) - [(_ invalue ((value ...) body ...) ...) - (cond ((memv invalue (list value ...)) + [(_ invalue (cases body ...) ...) + (cond ((case*% invalue cases) body ...) ...)])) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index c01de7e7..765c065d 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -34,9 +34,9 @@ Event must have the DTSTART and DTEND attribute set." (attr event-b 'DTSTART) (attr event-b 'DTEND))) -(define (event-contains? ev datetime) +(define (event-contains? ev date/-time) "Does event overlap the date that contains time." - (let* ((start (get-date datetime)) + (let* ((start (as-date date/-time)) (end (add-day start))) (event-overlaps? ev start end))) @@ -52,8 +52,14 @@ Event must have the DTSTART and DTEND attribute set." ;; Returns the length of the part of @var{e} which is within the day ;; starting at the time @var{start-of-day}. -(define-public (event-length/day e start-of-day) +;; currently the secund argument is a date, but should possibly be changed +;; to a datetime to allow for more explicit TZ handling? +(define-public (event-length/day e) (time- - (time-min (add-day start-of-day) (attr e 'DTEND)) - (time-max start-of-day (attr e 'DTSTART)))) + (time-min #00:00:00 (as-time (attr e 'DTEND))) + (time-max #24:00:00 (as-time (attr e 'DTSTART))))) + +;; 22:00 - 03:00 +;; 2h för dag 1 +;; 3h för dag 2 diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm index acf41999..83d79f9a 100644 --- a/module/vcomponent/group.scm +++ b/module/vcomponent/group.scm @@ -9,14 +9,14 @@ ;; TODO templetize this (define-stream (group-stream in-stream) - (define (ein? day) (lambda (e) (event-contains? e (date->time-utc day)))) + (define (ein? day) (lambda (e) (event-contains? e day))) - (let loop ((days (day-stream (time-utc->date (attr (stream-car in-stream) 'DTSTART)))) + (let loop ((days (day-stream (as-date (attr (stream-car in-stream) 'DTSTART)))) (stream in-stream)) (if (stream-null? stream) stream-null (let* ((day (stream-car days)) - (tomorow (date->time-utc (stream-car (stream-cdr days))))) + (tomorow (stream-car (stream-cdr days)))) (let ((head (stream-take-while (ein? day) stream)) (tail @@ -26,8 +26,8 @@ ;; of tommorow, and finishes with the rest when it finds the first ;; object which begins tomorow (after midnight, exclusize). (filter-sorted-stream* - (lambda (e) (timestream regular) + #; (interleave-streams ev-timestream regular) - (map generate-recurrence-set repeating)))))) + '() + ;; TODO reactivate this + #; (map generate-recurrence-set repeating) + ))))) ;; Basic version, loads calendrs, sorts the events, and returns ;; regular and repeating events separated from each other. diff --git a/module/vcomponent/output.scm b/module/vcomponent/output.scm index 14c1bf13..55cc0b12 100644 --- a/module/vcomponent/output.scm +++ b/module/vcomponent/output.scm @@ -3,7 +3,8 @@ #:use-module (vcomponent control) #:use-module (util) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-19 alt) + #:use-module (srfi srfi-19 alt util) #:use-module (srfi srfi-26) #:use-module (ice-9 format) #:export (print-vcomponent @@ -66,9 +67,15 @@ Removes the X-HNH-FILENAME attribute, and sets PRODID to (string->ics-safe-string (case key ((DTSTART DTEND) - (if (string? value) - value - (time->string value "~Y~m~dT~H~M~S"))) + (cond [(string? value) value] + [(date? value) (date->string value "~H~M~S")] + [(datetime? value) + (string-append + (date->string (get-date value) "~Y~m~d") + "T" + (time->string (get-time value) "~H~M~S"))])) + ((X-HNH-DURATION) + (format #f "~s" value)) (else value))))) ;; Catch diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 646d1f72..24becd13 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -167,7 +167,12 @@ (mod! (value it) (if (or (and=>> v car (cut string=? <> "DATE-TIME")) (string-contains (value it) "T")) - parse-datetime parse-date)))] + (begin + (set! (prop it 'VALUE) "DATE-TIME") + parse-datetime) + (begin + (set! (prop it 'VALUE) "DATE") + parse-date))))] ) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 938d99f9..8a4eed36 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -142,20 +142,32 @@ ;; TODO DURATION might be used for something else, check applicable types ;; TODO Far from all events have DTEND ;; VTIMEZONE's always lack it. - (if (not (attr event 'RRULE)) - (stream event) - (begin - (set! (attr event 'X-HNH-DURATION) - (cond [(attr event 'DURATION) => identity] - [(attr event 'DTEND) - => (lambda (end) - ;; The value type of dtstart and dtend must be the same - ;; according to RFC 5545 3.8.2.2 (Date-Time End). - (if (date? end) - (date- end (attr event 'DTSTART)) - (datetime- end (attr event 'DTSTART))))])) - (if (attr event "RRULE") - (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))) - ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather - ;; just mention the current part. Handle this - stream-null)))) + (catch #t + (lambda () + (if (not (attr event 'RRULE)) + (stream event) + (begin + (set! (attr event 'X-HNH-DURATION) + (cond [(attr event 'DURATION) => identity] + [(attr event 'DTEND) + => (lambda (end) + ;; The value type of dtstart and dtend must be the same + ;; according to RFC 5545 3.8.2.2 (Date-Time End). + (if (date? end) + (date- end (attr event 'DTSTART)) + (datetime- end (attr event 'DTSTART))))])) + (if (attr event "RRULE") + (recur-event-stream event (parse-recurrence-rule + (attr event "RRULE") + (if (string= "DATE" (and=> (prop (attr* event 'DTSTART) 'VALUE) car)) + parse-date parse-datetime))) + ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather + ;; just mention the current part. Handle this + stream-null)))) + (lambda (err . args) + (format (current-error-port) + "\x1b[0;31mError\x1b[m while parsing recurrence rule (ignoring and continuing)~%~a ~a~%~a~%~%" + err args + (attr event 'X-HNH-FILENAME)) + (stream ; event + )))) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index 12cf7a7b..50c44a60 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -37,7 +37,8 @@ (display "=" port) (display (case field - ((until) ((@ (srfi srfi-19 util) time->string) it)) + ;; TODO check over date/time/datetime here + ((until) ((@ (srfi srfi-19 alt util) time->string) it)) (else it)) port))) (display ">" port)))))) diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index f532987a..1c974727 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -18,15 +18,20 @@ ;; (, ...) ;; @end example +;;; weekdaynum can contain ± +;;; only used in bywdaylist +;;; only present with by BYDAY + ;; Returns a pair, where the @code{car} is the offset ;; and @code{cdr} is the day symbol. ;; The @code{car} may be @code{#f}. +;; str → ( . ) (define (parse-day-spec str) - (let* ((numchars (append '(#\+ #\-) (map integer->char (iota 10 #x30)))) - (num symb (span (cut memv <> numchars) - (string->list str)))) - (cons (string->number (list->string num)) - (apply symbol symb)))) + (let* ((numerical-characters (append '(#\+ #\-) (map integer->char (iota 10 #x30)))) + (numbers letters (span (cut memv <> numerical-characters) + (string->list str)))) + (cons (string->number (list->string numbers)) + (apply symbol letters)))) (define-macro (quick-case key . cases) (let ((else-clause (or (assoc-ref cases 'else) @@ -43,17 +48,20 @@ `(else ,@body))) cases)))) -(define (parse-recurrence-rule str) +;; UNTIL must have the exact same value type as the DTSTART of the event from which +;; this string came. I have however seen exceptions to that rule... +(define* (parse-recurrence-rule str optional: (datetime-parser parse-datetime)) (fold (lambda (kv o) (let* (((key val) kv)) (let-lazy ((symb (string->symbol val)) - (date (parse-datetime val)) + (date (datetime-parser val)) (days (map parse-day-spec (string-split val #\,))) (num (string->number val)) (nums (map string->number (string-split val #\,)))) + ;; 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)) diff --git a/module/vulgar/components.scm b/module/vulgar/components.scm index 640d4747..e0467a52 100644 --- a/module/vulgar/components.scm +++ b/module/vulgar/components.scm @@ -1,5 +1,5 @@ (define-module (vulgar components) - #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 alt) #:use-module (util) #:export ()) -- cgit v1.2.3