diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-01 21:08:47 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-01 21:08:47 +0200 |
commit | 97c9e9c975d5e80a55cc1aa624cfe5f662a84f96 (patch) | |
tree | 691583e609981786c3abcdc15429ea4c58098be7 /module | |
parent | Resolve zic TODO's. (diff) | |
download | calp-97c9e9c975d5e80a55cc1aa624cfe5f662a84f96.tar.gz calp-97c9e9c975d5e80a55cc1aa624cfe5f662a84f96.tar.xz |
Preliminary move of table output to markup.
Diffstat (limited to '')
-rw-r--r-- | module/output/terminal.scm | 61 | ||||
-rw-r--r-- | module/text/markup.scm | 63 |
2 files changed, 91 insertions, 33 deletions
diff --git a/module/output/terminal.scm b/module/output/terminal.scm index f4f46272..9e806b28 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -30,6 +30,8 @@ #:use-module (oop goops) #:use-module (oop goops describe) + #:use-module (text markup) + #:export (main-loop)) (define-values (height width) (get-terminal-size)) @@ -49,36 +51,22 @@ (location-width 20)) (define summary-width (- width date-width location-width 6)) - (displayln - (box-top #\┬ #\─ date-width (+ summary-width 2) (1+ location-width))) - (for-each - (lambda (ev i) - (display - (string-append - (if (datetime? (prop ev 'DTSTART)) - (datetime->string (prop ev 'DTSTART) "~Y-~m-~d ~H:~M") - (date->string (prop ev 'DTSTART) "~Y-~m-~d --:--")) - " │ " - (if (= i active-element) "\x1b[7m" "") - (color-escape (prop (parent ev) 'COLOR)) - ;; Summary filter is a hook for the user - (let ((dirty (prop ev '-X-HNH-DIRTY))) - (string-append - (if dirty "* " "") - ;; TODO reintroduce summary-filter - (trim-to-width (prop ev 'SUMMARY) (- summary-width - (if dirty 2 0))))) - STR-RESET - " │ " - (if (prop ev 'LOCATION) "" "\x1b[1;30m") - (trim-to-width - (or (prop ev 'LOCATION) "INGEN LOKAL") location-width) - STR-RESET - "\n"))) - events - (iota (length events))) - (displayln - (box-top #\┴ #\─ date-width (+ summary-width 2) (1+ location-width)))) + (display + (sxml->ansi-text + `(table (@ (max-width ,(+ 20 15 summary-width)) + (widths (20 ,summary-width 15))) + ,@(map (lambda (ev i) + `(tr (@ (style invert)) + ,(if (datetime? (prop ev 'DTSTART)) + (datetime->string (prop ev 'DTSTART) "~Y-~m-~d ~H:~M") + (date->string (prop ev 'DTSTART) "~Y-~m-~d --:--")) + (color (@ (c ,(prop (parent ev) 'COLOR))) + ,(prop ev 'SUMMARY)) + ,(aif (prop ev 'LOCATION) + it `(color (@ (c grey)) "INGEN LOKAL")))) + events + (iota (length events)))))) + ) (define (displayln a) (display a) (newline)) @@ -336,6 +324,19 @@ (cached-page this) #f)) (else (next-method)))) +;; (define-class <edit-view> (<view>) +;; (event init-keyword: event: +;; getter: get-event) +;; ) + +;; (define-method (output (this <edit-view>)) +;; (display "== Edit View ==\n") + +;; `(table +;; ,@(for (key value) in (properties (get-event this)) +;; `(tr (td ,key) (td (textbox ,value)))))) + + (app/define-method (main-loop date) (define state (list (day-view (app/getf 'event-set) date))) diff --git a/module/text/markup.scm b/module/text/markup.scm index 84bf7f61..b4724838 100644 --- a/module/text/markup.scm +++ b/module/text/markup.scm @@ -5,7 +5,8 @@ :use-module (ice-9 pretty-print) :use-module (text util) :use-module (text flow) - :use-module (texinfo string-utils)) + :use-module (texinfo string-utils) + :use-module (vulgar color)) (define (esc . effect) @@ -31,9 +32,15 @@ [nonlist nonlist])) -(define (get-attr args key default) +(define* (get-attr args key optional: default) (aif (assoc-ref args key) - (car it) default)) + (car it) + (if default default + (error "~a required" key)))) + +(define (box-top intersection line . lengths) + (reduce (lambda (str done) (string-append done (string intersection) str)) + "" (map (lambda (len) (make-string len line)) lengths))) ;; NOTE Some tags can be given a `width' attribute. This is however not yet ;; fully supported. @@ -42,6 +49,39 @@ [(*TOP* group block) (string-concatenate (map (compose sxml->ansi-text (add-attributes args)) body))] + [(table) + ;; TODO border option + (let* ((width-list (get-attr args 'widths)) + (auto-count (count (lambda (e) (eq? '- e)) width-list)) + (width (if (zero? auto-count) + (apply + width-list) + (get-attr args 'max-width))) + (auto-width (- (get-attr args 'max-width) + (fold (lambda (item sum) + (if (eq? item '-) sum (+ item sum))) + 0 width-list))) + (resolved-widths (map (lambda (w) (if (eq? w '-) auto-width w)) width-list))) + (string-append + (apply box-top #\┬ #\─ resolved-widths) + "\n" + (string-concatenate + (map (compose sxml->ansi-text (add-attributes + (acons 'widths (list resolved-widths) + args))) + body)) + + (apply box-top #\┴ #\─ resolved-widths) + "\n"))] + [(tr) ; table row + (string-append + (string-concatenate + (intersperce + "│" + (map (lambda (element width) + (trim-to-width (sxml->ansi-text element) width)) + body + (get-attr args 'widths)))) + "\n")] [(header) (sxml->ansi-text `(group (center (@ ,@args) (b ,@body)) (br)))] [(center) (center-string (string-concatenate (map sxml->ansi-text body)) (get-attr args 'width 70))] @@ -94,6 +134,23 @@ (lambda () (pretty-print form width: (aif (assoc-ref args 'width) (car it) 70)))))) body))] + [(invert) + (string-append + "\x1b[7m" (string-concatenate (map sxml->ansi-text body)) STR-RESET)] + + [(color) + (let ((c (get-attr args 'c))) + (define cesc + (if (symbol? c) + (case c + ((grey gray) "\x1b[1;30m") + (else "\x1b[1:31m")) + (color-escape c))) + + (string-concatenate `(,cesc + ,@(intersperce cesc (map sxml->ansi-text body)) + ,STR-RESET)))] + [else (string-append (esc 'bold) "??" "`" (esc 'invert) |