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/output/general.scm | 10 +++ module/output/html.scm | 164 +++++++++++++++++++++++++++++++++++++++++++++ module/output/terminal.scm | 113 +++++++++++++++++++++++++++++++ 3 files changed, 287 insertions(+) create mode 100644 module/output/general.scm create mode 100644 module/output/html.scm create mode 100644 module/output/terminal.scm (limited to 'module/output') 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)))) -- cgit v1.2.3