diff options
-rw-r--r-- | mumi/web/view/utils.scm | 72 |
1 files changed, 41 insertions, 31 deletions
diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm index 9547f4b..8043c4e 100644 --- a/mumi/web/view/utils.scm +++ b/mumi/web/view/utils.scm @@ -19,7 +19,9 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 receive) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (syntax-highlight) #:use-module (syntax-highlight scheme) #:use-module (debbugs email) @@ -30,52 +32,60 @@ ;; 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) +(define (process line context) (cond ((string-prefix? "--8<---------------cut here" line) - `(span (@ (class "line cut-here")) ,line)) - ((string= "---" line) - `(span (@ (class "line diff separator")) ,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) - `(span (@ (class "line diff file")) ,line)) - ((string-prefix? "+" line) - `(span (@ (class "line diff addition")) ,line)) - ((and (string-prefix? "-" 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))) - `(span (@ (class "line diff deletion")) ,line)) - ((string-prefix? "@@" line) - `(span (@ (class "line diff range")) ,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) - `(span (@ (class "line quote")) ,line)) + (values `(span (@ (class "line quote")) ,line) #f)) ((or (string-prefix? "Signed-off-by" line) (string-prefix? "Co-authored-by" line)) - `(span (@ (class "commit attribution")) ,line)) + (values `(span (@ (class "commit attribution")) ,line) #f)) ((or (string-prefix? "From: " line) (string-prefix? "Date: " line) (string-prefix? "Subject: " line)) - `(span (@ (class "commit header")) ,line)) - ((or (string-prefix? "* " line) - (string-prefix? " * " line)) - `(span (@ (class "commit changelog")) ,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 - `(span (@ (class "line")) ,line)))) + (values `(span (@ (class "line")) ,line) #f)))) (define (prettify text) "Read each line of TEXT and apply PROCESS to it." - (call-with-input-string text - (lambda (port) - (let loop ((line (read-line port)) - (result '())) - (if (eof-object? line) - ;; Drop the first line break, because it's for an eof - ;; read. - (match (reverse result) - ((_ . rest) rest) - (() '())) - (loop (read-line port) - (cons (process line) - (cons '(br) result)))))))) + (let ((res (fold (lambda (line acc) + (match acc + ((#:result res #:context context) + (receive (processed new-context) + (process line context) + `(#:result ,(append (list processed '(br)) res) + #:context ,(if new-context + (cons new-context context) + context)))))) + '(#:result () #:context ()) + (string-split text #\newline)))) + ;; Drop the first line break, because it's for an eof + ;; read. + (match (reverse (cadr (find-tail (cut eq? #:result <>) res))) + ((_ . rest) rest) + (() '())))) (define colors (circular-list "#8dd3c7" "#bebada" "#fb8072" |