Preliminary move of table output to markup.

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)