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
(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
(define (highlight-comment number highlights)
(let loop ((highlights highlights))
@ -113,9 +127,9 @@
(define (print-source-listing lines highlights . args)
(let ((highlight-rules (get-keyword #:highlight-rules args
(lambda ()
'((error (ansi #:bold #:red) (ansi #:default))
(warning (ansi #:yellow) (ansi #:default))
(info (ansi #:cyan) (ansi #:default))
`((error ,(ansi #:bold #:red) ,(ansi #:default))
(warning ,(ansi #:yellow) ,(ansi #:default))
(info ,(ansi #:cyan) ,(ansi #:default))
))))
(ellipsis (get-keyword #:ellipsis args (lambda () "...")))
(ctx-pre (get-keyword #:context-pre args (lambda () "")))
@ -129,16 +143,20 @@
(printed-something #f)
(was-printing #f))
(when (not (null? lines))
(let* ((content? (in-highlights? number highlights))
(context? (and (not content?)
(let* ((highlight (match-highlight number highlights))
(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)))
(print? (or content? context?)))
(print? (or highlight context?)))
(cond (print?
(when (and printed-something
(not was-printing))
(print ellipsis))
(if content?
(display hl-pre)
(if highlight
(display hl-pre-real)
(when context?
(display ctx-pre)))
(display (sprintf "~A~A~A"
@ -148,8 +166,8 @@
(if comment
(sprintf " # <<< ~A" comment)
""))))
(if content?
(display hl-post)
(if highlight
(display hl-post-real)
(when context?
(display ctx-post)))
(newline)