view: Generate blocks of lines and style the blocks.

This allows us to toggle the display of lines that belong together.

* mumi/web/view/utils.scm (<block>): New record type.
(add-block-line!): New procedure.
(process): Take the list of blocks as an argument; return the new
blocks and the next context.
(prettify): Render blocks with classes derived from the block type.
* assets/css/screen.css: Adjust.

2 files changed, 133 insertions, 55 deletions

diff --git a/assets/css/screen.css b/assets/css/screen.css
index 1d7b764..97b6034 100644
--- a/assets/css/screen.css
+++ b/assets/css/screen.css
@@ -221,6 +221,15 @@ details {
     margin-top: .5em;
 }
 
+.message details {
+    border-top: 2px dotted #efefef;
+    border-bottom: 2px dotted #efefef;
+}
+.message details summary {
+    color: #586069;
+    padding: 1em 0;
+}
+
 .message .body pre {
     background: transparent;
     border: none;
@@ -306,24 +315,25 @@ details {
 .message span.line {
     white-space: pre-wrap;
     font-family: monospace;
+    display: block;
 }
 
 /* diff styles */
-.message span.line.diff.file {
+.message .diff span.line.diff.file {
     color: #005cc5;
 }
-.message span.line.diff.separator {
+.message .diff span.line.diff.separator {
     color: #005cc5;
 }
-.message span.line.diff.addition {
+.message .diff span.line.diff.addition {
     color: #22863a;
     background-color: #f0fff4;
 }
-.message span.line.diff.deletion {
+.message .diff span.line.diff.deletion {
     color: #b31d28;
     background-color: #ffeef0;
 }
-.message span.line.diff.range {
+.message .diff span.line.diff.range {
     color: #6f42c1;
     font-weight: bold;
 }
@@ -343,12 +353,12 @@ details {
 }
 
 /* quote styles */
-.message span.line.quote {
+.message .quote span.line {
     color: #3868cc;
 }
 
-.message span.line.cut-here {
-    color: #888;
+.message .snippet {
+    background-color: #fbfbfb;
 }
 
 .filter {
diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm
index 782f737..ab42b88 100644
--- a/mumi/web/view/utils.scm
+++ b/mumi/web/view/utils.scm
@@ -23,6 +23,7 @@
   #:use-module (ice-9 receive)
   #:use-module (ice-9 iconv)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (syntax-highlight)
   #:use-module (syntax-highlight scheme)
@@ -33,58 +34,125 @@
             avatar-color
             display-message-body))
 
-;; TODO: at some point this should tokenize the text, then apply
-;; styles, then output sxml, but for now we keep it simple
-(define (process line context)
-  (cond
-   ((string-prefix? "--8<---------------cut here" line)
-    (values `(span (@ (class "line cut-here")) ,line) #f))
-   ((and (member 'diff context)
-         (string= "---" line))
-    (values `(span (@ (class "line diff separator")) ,line) #f))
-   ((string-prefix? "diff --git" line)
-    (values `(span (@ (class "line diff file")) ,line) 'diff))
-   ((and (member 'diff context)
-         (string-prefix? "+" line))
-    (values `(span (@ (class "line diff addition")) ,line) #f))
-   ((and (member 'diff context)
-         (string-prefix? "-" line)
-         (not (string= "--" line))
-         (not (string= "-- " line)))
-    (values `(span (@ (class "line diff deletion")) ,line) #f))
-   ((and (member 'diff context)
-         (string-prefix? "@@" line))
-    (values `(span (@ (class "line diff range")) ,line) #f))
-   ((string-prefix? ">" line)
-    (values `(span (@ (class "line quote")) ,line) #f))
-   ((or (string-prefix? "Signed-off-by" line)
-        (string-prefix? "Co-authored-by" line))
-    (values `(span (@ (class "commit attribution")) ,line) #f))
-   ((or (string-prefix? "From: " line)
-        (string-prefix? "Date: " line)
-        (string-prefix? "Subject: " line))
-    (values `(span (@ (class "commit header")) ,line) 'commit))
-   ((and (member 'commit context)
-         (or (string-prefix? "* " line)
-             (string-prefix? " * " line)))
-    (values `(span (@ (class "commit changelog")) ,line) #f))
-   (else
-    (values `(span (@ (class "line")) ,line) #f))))
+(define-record-type <block>
+  (make-block type lines)
+  block?
+  (type   block-type)
+  (lines  block-raw-lines set-block-lines!))
+
+(define (block-lines block)
+  (reverse (block-raw-lines block)))
+
+(define (add-block-line! block line)
+  (set-block-lines! block
+                    (cons line (block-raw-lines block)))
+  block)
+
+(define (process line blocks context)
+  "Process the current LINE.  Add it to the latest block in BLOCKS or
+add it to a new block, dependent on CONTEXT.  Return the blocks along
+with the next context."
+  (match blocks
+    ((block . other-blocks)
+     (cond
+      ((string-null? line)
+       (values (cons (add-block-line! block `(br))
+                     other-blocks)
+               context))
+      ((eq? context 'snippet)
+       (values (cons (add-block-line! block
+                                      `(span (@ (class "line")) ,line))
+                     other-blocks)
+               (if (string-prefix? "--8<---------------cut here" line)
+                   #f context)))
+      ((eq? context 'diff)
+       (if (string= "--" line)
+           ;; Retry
+           (process line blocks #f)
+           ;; Format line and add to current block
+           (let ((formatted-line
+                  (cond
+                   ((string= "---" line)
+                    `(span (@ (class "line diff separator")) ,line))
+                   ((string-prefix? "+" line)
+                    `(span (@ (class "line diff addition")) ,line))
+                   ((and (string-prefix? "-" line)
+                         (not (string= "--" line))
+                         (not (string= "-- " line)))
+                    `(span (@ (class "line diff deletion")) ,line))
+                   ((string-prefix? "@@" line)
+                    `(span (@ (class "line diff range")) ,line))
+                   (else
+                    `(span (@ (class "line")) ,line)))))
+             (values (cons (add-block-line! block formatted-line)
+                           other-blocks)
+                     context))))
+      ((eq? context 'quote)
+       (if (string-prefix? ">" line)
+           ;; Add line to current block
+           (values (cons (add-block-line! block
+                                          `(span (@ (class "line")) ,line))
+                         other-blocks)
+                   context)
+           ;; Retry
+           (process line blocks #f)))
+      (else
+       (let ((new-context
+              (cond
+               ((string-prefix? "diff --git" line)
+                'diff)
+               ((string-prefix? ">" line)
+                'quote)
+               ((string-prefix? "--8<---------------cut here" line)
+                'snippet)
+               (else 'text)))
+             (formatted-line
+              (cond
+               ((or (string-prefix? "Signed-off-by" line)
+                    (string-prefix? "Co-authored-by" line))
+                `(span (@ (class "line commit attribution")) ,line))
+               ((or (string-prefix? "From: " line)
+                    (string-prefix? "Date: " line)
+                    (string-prefix? "Subject: " line))
+                `(span (@ (class "line commit header")) ,line))
+               ((or (string-prefix? "* " line)
+                    (string-prefix? " * " line))
+                `(span (@ (class "line commit changelog")) ,line))
+               ((string-prefix? "diff --git" line)
+                `(span (@ (class "line diff file")) ,line))
+               (else
+                `(span (@ (class "line")) ,line)))))
+         (if (eq? new-context context)
+             (values (cons (add-block-line! block formatted-line)
+                           other-blocks)
+                     context)
+             (values (cons (make-block new-context (list formatted-line))
+                           blocks)
+                     new-context))))))))
 
 (define (prettify text)
   "Read each line of TEXT and apply PROCESS to it."
   (let ((res (fold (lambda (line acc)
-                     (match acc
-                       ((#:result res #:context context)
-                        (receive (processed new-context)
-                            (process line context)
-                          `(#:result ,(cons* '(br) processed res)
-                            #:context ,(if new-context
-                                           (cons new-context context)
-                                           context))))))
-                   '(#:result () #:context ())
+                     (call-with-values
+                         (lambda ()
+                           (process line
+                                    (cadr (memq #:blocks acc))
+                                    (cadr (memq #:context acc))))
+                       (lambda (new-blocks new-context)
+                         `(#:blocks ,new-blocks #:context ,new-context))))
+                   (list #:blocks (list (make-block 'text '()))
+                         #:context 'text)
                    (string-split text #\newline))))
-    (reverse (and=> (memq #:result res) cadr))))
+    (map (lambda (block)
+           (if (eq? 'text (block-type block))
+               `(div (@ (class ,(format #f "block ~a" (block-type block))))
+                     ,(block-lines block))
+               `(details (@ (class ,(format #f "block ~a" (block-type block)))
+                            (open "open"))
+                         (summary ,(format #f "Toggle ~a (~a lines)" (block-type block)
+                                           (length (block-raw-lines block))))
+                         ,(block-lines block))))
+         (reverse (cadr (memq #:blocks res))))))
 
 (define colors
   (circular-list "#8dd3c7" "#bebada" "#fb8072"