brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Parametric highlight styles.

Browse source
This commit is contained in:
Dominik Pantůček 2023-03-28 18:58:32 +02:00
parent ffc5442c17
commit a849da5418
1 changed files with 28 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

38
listing.scm
View file

@ -93,6 +93,20 @@
#t #t
(loop (cdr highlights))))))) (loop (cdr highlights)))))))
;; Returns hihglight match - each highlight should contain:
;; line-number, message, stage, type (error, warning, info ...)
(define (match-highlight number highlights)
(let loop ((highlights highlights))
(if (null? highlights)
#f
(let* ((highlight (car highlights))
(line-number (if (list? highlight)
(car highlight)
highlight)))
(if (= number line-number)
highlight
(loop (cdr highlights)))))))
;; Returns comment if there is any ;; Returns comment if there is any
(define (highlight-comment number highlights) (define (highlight-comment number highlights)
(let loop ((highlights highlights)) (let loop ((highlights highlights))
@ -113,9 +127,9 @@
(define (print-source-listing lines highlights . args) (define (print-source-listing lines highlights . args)
(let ((highlight-rules (get-keyword #:highlight-rules args (let ((highlight-rules (get-keyword #:highlight-rules args
(lambda () (lambda ()
'((error (ansi #:bold #:red) (ansi #:default)) `((error ,(ansi #:bold #:red) ,(ansi #:default))
(warning (ansi #:yellow) (ansi #:default)) (warning ,(ansi #:yellow) ,(ansi #:default))
(info (ansi #:cyan) (ansi #:default)) (info ,(ansi #:cyan) ,(ansi #:default))
)))) ))))
(ellipsis (get-keyword #:ellipsis args (lambda () "..."))) (ellipsis (get-keyword #:ellipsis args (lambda () "...")))
(ctx-pre (get-keyword #:context-pre args (lambda () ""))) (ctx-pre (get-keyword #:context-pre args (lambda () "")))
@ -129,16 +143,20 @@
(printed-something #f) (printed-something #f)
(was-printing #f)) (was-printing #f))
(when (not (null? lines)) (when (not (null? lines))
(let* ((content? (in-highlights? number highlights)) (let* ((highlight (match-highlight number highlights))
(context? (and (not content?) (hl-type (if highlight (cadddr highlight) #f))
(hl-def (assq hl-type highlight-rules))
(hl-pre-real (if hl-def (cadr hl-def) hl-pre))
(hl-post-real (if hl-def (caddr hl-def) hl-post))
(context? (and (not highlight)
(line-near-targets? number highlights context))) (line-near-targets? number highlights context)))
(print? (or content? context?))) (print? (or highlight context?)))
(cond (print? (cond (print?
(when (and printed-something (when (and printed-something
(not was-printing)) (not was-printing))
(print ellipsis)) (print ellipsis))
(if content? (if highlight
(display hl-pre) (display hl-pre-real)
(when context? (when context?
(display ctx-pre))) (display ctx-pre)))
(display (sprintf "~A~A~A" (display (sprintf "~A~A~A"
@ -148,8 +166,8 @@
(if comment (if comment
(sprintf " # <<< ~A" comment) (sprintf " # <<< ~A" comment)
"")))) ""))))
(if content? (if highlight
(display hl-post) (display hl-post-real)
(when context? (when context?
(display ctx-post))) (display ctx-post)))
(newline) (newline)