view: Generate blocks of lines and style the blocks.
authorRicardo Wurmus <rekado@elephly.net>
Thu, 7 May 2020 12:03:55 +0000 (14:03 +0200)
committerRicardo Wurmus <rekado@elephly.net>
Thu, 7 May 2020 12:03:55 +0000 (14:03 +0200)
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.

assets/css/screen.css
mumi/web/view/utils.scm

index 1d7b7647f31fd6c950b4649f4b650c8161d0e05e..97b603470db76018aca5138bb6d26cae3b4bf197 100644 (file)
@@ -221,6 +221,15 @@ details {
     margin-top: .5em;
 }
 
     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;
 .message .body pre {
     background: transparent;
     border: none;
@@ -306,24 +315,25 @@ details {
 .message span.line {
     white-space: pre-wrap;
     font-family: monospace;
 .message span.line {
     white-space: pre-wrap;
     font-family: monospace;
+    display: block;
 }
 
 /* diff styles */
 }
 
 /* diff styles */
-.message span.line.diff.file {
+.message .diff span.line.diff.file {
     color: #005cc5;
 }
     color: #005cc5;
 }
-.message span.line.diff.separator {
+.message .diff span.line.diff.separator {
     color: #005cc5;
 }
     color: #005cc5;
 }
-.message span.line.diff.addition {
+.message .diff span.line.diff.addition {
     color: #22863a;
     background-color: #f0fff4;
 }
     color: #22863a;
     background-color: #f0fff4;
 }
-.message span.line.diff.deletion {
+.message .diff span.line.diff.deletion {
     color: #b31d28;
     background-color: #ffeef0;
 }
     color: #b31d28;
     background-color: #ffeef0;
 }
-.message span.line.diff.range {
+.message .diff span.line.diff.range {
     color: #6f42c1;
     font-weight: bold;
 }
     color: #6f42c1;
     font-weight: bold;
 }
@@ -343,12 +353,12 @@ details {
 }
 
 /* quote styles */
 }
 
 /* quote styles */
-.message span.line.quote {
+.message .quote span.line {
     color: #3868cc;
 }
 
     color: #3868cc;
 }
 
-.message span.line.cut-here {
-    color: #888;
+.message .snippet {
+    background-color: #fbfbfb;
 }
 
 .filter {
 }
 
 .filter {
index 782f73700bc226ddcf46832c55bb4049590df5be..ab42b88a8fad82c38c59d20c9bb2c908efa676f2 100644 (file)
@@ -23,6 +23,7 @@
   #:use-module (ice-9 receive)
   #:use-module (ice-9 iconv)
   #:use-module (srfi srfi-1)
   #: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)
   #:use-module (srfi srfi-26)
   #:use-module (syntax-highlight)
   #:use-module (syntax-highlight scheme)
             avatar-color
             display-message-body))
 
             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)
 
 (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))))
                    (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"
 
 (define colors
   (circular-list "#8dd3c7" "#bebada" "#fb8072"