From 34da56150cbee6449faec22faabf6b2af3c84ed9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 23 Apr 2019 19:26:54 +0200 Subject: Move stuff from main. --- module/html/html.scm | 164 ----------------------------------------- module/main.scm | 131 ++------------------------------ module/output/general.scm | 10 +++ module/output/html.scm | 164 +++++++++++++++++++++++++++++++++++++++++ module/output/terminal.scm | 113 ++++++++++++++++++++++++++++ module/vcomponent/datetime.scm | 4 + 6 files changed, 299 insertions(+), 287 deletions(-) delete mode 100644 module/html/html.scm create mode 100644 module/output/general.scm create mode 100644 module/output/html.scm create mode 100644 module/output/terminal.scm diff --git a/module/html/html.scm b/module/html/html.scm deleted file mode 100644 index 3dcfdb55..00000000 --- a/module/html/html.scm +++ /dev/null @@ -1,164 +0,0 @@ -(define-module (html html) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-41) - #:use-module (srfi srfi-41 util) - #:use-module (vcomponent) - #:use-module (vcomponent datetime) - #:use-module (util) - #:use-module (util tree) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-19 util) - - #:use-module (parameters) - #:use-module (config)) - -(define-stream (group-stream in-stream) - (define (ein? day) (lambda (e) (event-in? e (date->time-utc day)))) - - (let loop ((days (day-stream (time-utc->date (attr (stream-car in-stream) 'DTSTART)))) - (stream in-stream)) - (if (stream-null? stream) - stream-null - (let* ((day (stream-car days)) - (tomorow (add-day (date->time-utc (drop-time day))))) - (let ((head (stream-take-while (ein? day) stream)) - (tail - (filter-sorted-stream* - (lambda (e) (time? (lambda (e) (event-length/day e start-of-day)))))) - -;; This should only be used on time intervals, never on absolute times. -;; For that see @var{date->decimal-hour}. -(define (time->decimal-hour time) - (exact->inexact (/ (time-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 (vevent->sxml day ev) - (define time (date->time-utc day)) - (define style - (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;" - - (* 100 (x-pos ev)) ; left - (* 100 (width ev)) ; width - - ;; top - (if (in-day? day (attr ev 'DTSTART)) - (* 100/24 - (time->decimal-hour - (time-difference (attr ev 'DTSTART) - (start-of-day* (attr ev 'DTSTART))))) - 0) - - ;; height - (* 100/24 (time->decimal-hour (event-length/day ev time))))) - - `(div (@ (class "event CAL_" ,(html-attr (let ((l (attr (parent ev) 'NAME))) - (if (pair? l) (car l) l))) - ,(if (timestring date)) - (fix-event-widths! (date->time-utc date) (stream->list events)) - `(div (@ (class "day")) - (div (@ (class "meta")) - (span (@ (class "dayname")) ,(date->string date "~a")) - (span (@ (class "daydate")) ,(date->string date "~Y-~m-~d"))) - (div (@ (class "events")) - " " - ,@(stream->list (stream-map (lambda (e) (vevent->sxml date e)) events)))))) - - -(define (time-marker-div) - (map (lambda (time) - `(div (@ (id ,(string-append "clock-" time)) - (class "clock")) - ,(string-append time ":00"))) - (map number->string (iota 12 0 2)))) - -(define (d str) - (string->date str "~Y-~m-~d")) - - -(define (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)) - "black" "#e5e8e6"))) - -(define (include-css path) - `(link (@ (type "text/css") - (rel "stylesheet") - (href ,path)))) - -(define-public (html-main calendars events) - - (define evs - (filter-sorted-stream - (compose (in-date-range? - (d "2019-04-15") - (d "2019-05-10")) - car) - (group-stream events))) - - ((@ (sxml simple) sxml->xml) - `(html (head - (title "Calendar") - (meta (@ (charset "utf-8"))) - ,(include-css "static/style.css") - (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%~}" - (map (lambda (c) - (list (html-attr (if (pair? (attr c 'NAME)) - (car (attr c 'NAME)) - (attr c 'NAME))) - (or (attr c 'COLOR) "white") - (or (and=> (attr c 'COLOR) calculate-fg-color) "black"))) - calendars)))) - (body (div (@ (class "calendar")) - ,@(time-marker-div) - (div (@ (class "days")) - ,@(stream->list (stream-map lay-out-day evs)))))))) diff --git a/module/main.scm b/module/main.scm index 58ea8ae7..b20134f9 100755 --- a/module/main.scm +++ b/module/main.scm @@ -6,136 +6,21 @@ (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) - (ice-9 control) ; call-with-escape-continuation - (texinfo string-utils) ; string->wrapped-lines (util) (vcomponent) (vcomponent recurrence) (vcomponent datetime) - (vcomponent output) - (terminal escape) - (terminal util) - (html html) + (output html) + (output terminal) (ice-9 getopt-long) (parameters) - ) - -(define (ev-timetime-utc (current-date))) - -(define (box-top intersection line . lengths) - (reduce (lambda (str done) (string-append done (string intersection) str)) - "" (map (cut make-string <> line) lengths))) - -(define (displayln a) - (display a) (newline)) - -(define (display-event-table cur-event events) - (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)) - ;; Summary filter is a hook for the user - (trim-to-width ((summary-filter) ev (attr ev 'SUMMARY)) 30) - STR-RESET - (trim-to-width - (or (attr ev 'LOCATION) "\x1b[1;30mINGEN LOKAL") 20) - STR-RESET)) - events - (iota (length events)))) - -(define (main-loop event-stream) - (define time (now)) - (define cur-event 0) - (while #t - (let ((events - (stream->list - (filter-sorted-stream - (cut event-in? <> time) - event-stream)))) - - (cls) - (display-calendar-header! (time-utc->date time)) - - (displayln (box-top #\┬ #\─ 20 32 10)) - (display-event-table cur-event events) - (displayln (box-top #\┴ #\─ 20 32 10)) - - (unless (null? events) - (let ((ev (list-ref events cur-event))) - (format #t "~a~%~a~%~aStart: ~a Slut: ~a~%~%~a~%" - (attr ev 'X-HNH-FILENAME) - (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)) - ))) - - (let ((char (read-char))) - ;; (format (current-error-port) - ;; "c = ~c (~d)~%" char (char->integer char)) - (case char - ((#\L #\l) - (set! time (add-day time) - cur-event 0)) - ((#\h #\H) - (set! time (remove-day time) - cur-event 0)) - ((#\t) - (set! time (now) - cur-event 0)) - ((#\j #\J) (unless (= cur-event (1- (length events))) - (mod! cur-event 1+))) - ((#\k #\K) (unless (= cur-event 0) - (mod! cur-event 1-))) - ((#\p) (print-vcomponent (list-ref events cur-event) - (current-error-port))) - ((#\g) (set! cur-event 0)) - ((#\G) (set! cur-event (1- (length events))))) - - (when (or (eof-object? char) - (memv char (list #\q (ctrl #\C)))) - (break))) - ))) - - - -;; (load "config.scm") -(use-modules (config)) + (config)) ;; Reads all calendar files from disk, and creates a list of "regular" events, ;; and a stream of "repeating" events, which are passed in that order to the @@ -166,9 +51,9 @@ (define (main args) (let ((opts (getopt-long args options #:stop-at-first-non-option #t))) (init - (case (string->symbol (option-ref opts 'mode "term")) - ((html) html-main) - ((term) (lambda (calendars events) - (with-vulgar - (lambda () (main-loop events))))))) + (lambda (c e) + ((case (string->symbol (option-ref opts 'mode "term")) + ((html) html-main) + ((term) terminal-main)) + c e (option-ref opts '() '())))) (newline))) diff --git a/module/output/general.scm b/module/output/general.scm new file mode 100644 index 00000000..f455f18b --- /dev/null +++ b/module/output/general.scm @@ -0,0 +1,10 @@ +(define-module (output general) + ) + +(define-public (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))) diff --git a/module/output/html.scm b/module/output/html.scm new file mode 100644 index 00000000..3df3c713 --- /dev/null +++ b/module/output/html.scm @@ -0,0 +1,164 @@ +(define-module (output html) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-41) + #:use-module (srfi srfi-41 util) + #:use-module (vcomponent) + #:use-module (vcomponent datetime) + #:use-module (util) + #:use-module (util tree) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 util) + + #:use-module (parameters) + #:use-module (config)) + +(define-stream (group-stream in-stream) + (define (ein? day) (lambda (e) (event-in? e (date->time-utc day)))) + + (let loop ((days (day-stream (time-utc->date (attr (stream-car in-stream) 'DTSTART)))) + (stream in-stream)) + (if (stream-null? stream) + stream-null + (let* ((day (stream-car days)) + (tomorow (add-day (date->time-utc (drop-time day))))) + (let ((head (stream-take-while (ein? day) stream)) + (tail + (filter-sorted-stream* + (lambda (e) (time? (lambda (e) (event-length/day e start-of-day)))))) + +;; This should only be used on time intervals, never on absolute times. +;; For that see @var{date->decimal-hour}. +(define (time->decimal-hour time) + (exact->inexact (/ (time-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 (vevent->sxml day ev) + (define time (date->time-utc day)) + (define style + (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;" + + (* 100 (x-pos ev)) ; left + (* 100 (width ev)) ; width + + ;; top + (if (in-day? day (attr ev 'DTSTART)) + (* 100/24 + (time->decimal-hour + (time-difference (attr ev 'DTSTART) + (start-of-day* (attr ev 'DTSTART))))) + 0) + + ;; height + (* 100/24 (time->decimal-hour (event-length/day ev time))))) + + `(div (@ (class "event CAL_" ,(html-attr (let ((l (attr (parent ev) 'NAME))) + (if (pair? l) (car l) l))) + ,(if (timestring date)) + (fix-event-widths! (date->time-utc date) (stream->list events)) + `(div (@ (class "day")) + (div (@ (class "meta")) + (span (@ (class "dayname")) ,(date->string date "~a")) + (span (@ (class "daydate")) ,(date->string date "~Y-~m-~d"))) + (div (@ (class "events")) + " " + ,@(stream->list (stream-map (lambda (e) (vevent->sxml date e)) events)))))) + + +(define (time-marker-div) + (map (lambda (time) + `(div (@ (id ,(string-append "clock-" time)) + (class "clock")) + ,(string-append time ":00"))) + (map number->string (iota 12 0 2)))) + +(define (d str) + (string->date str "~Y-~m-~d")) + + +(define (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)) + "black" "#e5e8e6"))) + +(define (include-css path) + `(link (@ (type "text/css") + (rel "stylesheet") + (href ,path)))) + +(define-public (html-main calendars events args) + + (define evs + (filter-sorted-stream + (compose (in-date-range? + (d "2019-04-15") + (d "2019-05-10")) + car) + (group-stream events))) + + ((@ (sxml simple) sxml->xml) + `(html (head + (title "Calendar") + (meta (@ (charset "utf-8"))) + ,(include-css "static/style.css") + (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%~}" + (map (lambda (c) + (list (html-attr (if (pair? (attr c 'NAME)) + (car (attr c 'NAME)) + (attr c 'NAME))) + (or (attr c 'COLOR) "white") + (or (and=> (attr c 'COLOR) calculate-fg-color) "black"))) + calendars)))) + (body (div (@ (class "calendar")) + ,@(time-marker-div) + (div (@ (class "days")) + ,@(stream->list (stream-map lay-out-day evs)))))))) diff --git a/module/output/terminal.scm b/module/output/terminal.scm new file mode 100644 index 00000000..1d49896c --- /dev/null +++ b/module/output/terminal.scm @@ -0,0 +1,113 @@ +(define-module (output terminal) + #:use-module (output general) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-41) + #:use-module (srfi srfi-41 util) + #:use-module (util) + #:use-module (terminal escape) + #:use-module (terminal util) + #:use-module (vcomponent output) + + #:use-module (vcomponent) + #:use-module (vcomponent datetime) + + #:use-module (texinfo string-utils) ; string->wrapped-lines + #:use-module (ice-9 format) + #:use-module (parameters) + #:use-module (config) + + #:export (terminal-main)) + +(define (box-top intersection line . lengths) + (reduce (lambda (str done) (string-append done (string intersection) str)) + "" (map (cut make-string <> line) lengths))) + +(define (display-event-table cur-event events) + (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)) + ;; Summary filter is a hook for the user + (trim-to-width ((summary-filter) ev (attr ev 'SUMMARY)) 30) + STR-RESET + (trim-to-width + (or (attr ev 'LOCATION) "\x1b[1;30mINGEN LOKAL") 20) + STR-RESET)) + events + (iota (length events)))) + +(define (now) + (date->time-utc (current-date))) + +(define (displayln a) + (display a) (newline)) + +(define (main-loop event-stream) + (define time (now)) + (define cur-event 0) + (while #t + (let ((events + (stream->list + (filter-sorted-stream + (cut event-in? <> time) + event-stream)))) + + (cls) + (display-calendar-header! (time-utc->date time)) + + (displayln (box-top #\┬ #\─ 20 32 10)) + (display-event-table cur-event events) + (displayln (box-top #\┴ #\─ 20 32 10)) + + (unless (null? events) + (let ((ev (list-ref events cur-event))) + (format #t "~a~%~a~%~aStart: ~a Slut: ~a~%~%~a~%" + (attr ev 'X-HNH-FILENAME) + (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)) + ))) + + (let ((char (read-char))) + ;; (format (current-error-port) + ;; "c = ~c (~d)~%" char (char->integer char)) + (case char + ((#\L #\l) + (set! time (add-day time) + cur-event 0)) + ((#\h #\H) + (set! time (remove-day time) + cur-event 0)) + ((#\t) + (set! time (now) + cur-event 0)) + ((#\j #\J) (unless (= cur-event (1- (length events))) + (mod! cur-event 1+))) + ((#\k #\K) (unless (= cur-event 0) + (mod! cur-event 1-))) + ((#\p) (print-vcomponent (list-ref events cur-event) + (current-error-port))) + ((#\g) (set! cur-event 0)) + ((#\G) (set! cur-event (1- (length events))))) + + (when (or (eof-object? char) + (memv char (list #\q (ctrl #\C)))) + (break))) + ))) + +(define (terminal-main calendars events args) + (with-vulgar + (lambda () (main-loop events)))) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 2270d10e..e427b088 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -56,3 +56,7 @@ Event must have the DTSTART and DTEND attribute set." (time-difference (time-min (add-day start-of-day) (attr e 'DTEND)) (time-max start-of-day (attr e 'DTSTART)))) + +(define-public (ev-time