diff options
author | Ricardo Wurmus <rekado@elephly.net> | 2020-05-07 14:03:55 +0200 |
---|---|---|
committer | Ricardo Wurmus <rekado@elephly.net> | 2020-05-07 14:03:55 +0200 |
commit | 52ef2529c877b2b08ac67ebee8f1842b84720e90 (patch) | |
tree | 3b6790c22d20365020317310e585e7b9103a71df /mumi | |
parent | baae0f305f1cbbe1de0da084c6fb05a9f289571f (diff) |
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.
Diffstat (limited to 'mumi')
-rw-r--r-- | mumi/web/view/utils.scm | 162 |
1 files changed, 115 insertions, 47 deletions
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" |