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

Convert print-source-listings to use keywords.

Browse source
This commit is contained in:
Dominik Pantůček 2023-03-28 18:51:13 +02:00
parent 7a0db40062
commit ffc5442c17
3 changed files with 57 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

96
listing.scm
View file

@ -36,7 +36,9 @@
(chicken base)
(chicken string)
(chicken format)
testing)
(chicken keyword)
testing
ansi)
;; Returns the number of digits required to represent a given number
;; in decimal format.
@ -108,46 +110,58 @@
;; Prints and highlights a selection of source listing lines and
;; their optional context.
(define (print-source-listing lines highlights context hl-pre hl-post ctx-pre ctx-post ellipsis)
(let ((digits (number-digits (length lines))))
(let loop ((lines lines)
(number 1)
(printed-something #f)
(was-printing #f))
(when (not (null? lines))
(let* ((content? (in-highlights? number highlights))
(context? (and (not content?)
(line-near-targets? number highlights context)))
(print? (or content? context?)))
(cond (print?
(when (and printed-something
(not was-printing))
(print ellipsis))
(if content?
(display hl-pre)
(when context?
(display ctx-pre)))
(display (sprintf "~A~A~A"
(format-line-number number digits)
(car lines)
(let ((comment (highlight-comment number highlights)))
(if comment
(sprintf " # <<< ~A" comment)
""))))
(if content?
(display hl-post)
(when context?
(display ctx-post)))
(newline)
(loop (cdr lines)
(+ number 1)
#t
#t))
(else
(loop (cdr lines)
(+ number 1)
printed-something
#f))))))))
(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))
))))
(ellipsis (get-keyword #:ellipsis args (lambda () "...")))
(ctx-pre (get-keyword #:context-pre args (lambda () "")))
(ctx-post (get-keyword #:context-post args (lambda () "")))
(hl-pre (get-keyword #:highlight-pre args (lambda () a:error)))
(hl-post (get-keyword #:highlight-post args (lambda () a:default)))
(context (get-keyword #:context args (lambda () 3))))
(let ((digits (number-digits (length lines))))
(let loop ((lines lines)
(number 1)
(printed-something #f)
(was-printing #f))
(when (not (null? lines))
(let* ((content? (in-highlights? number highlights))
(context? (and (not content?)
(line-near-targets? number highlights context)))
(print? (or content? context?)))
(cond (print?
(when (and printed-something
(not was-printing))
(print ellipsis))
(if content?
(display hl-pre)
(when context?
(display ctx-pre)))
(display (sprintf "~A~A~A"
(format-line-number number digits)
(car lines)
(let ((comment (highlight-comment number highlights)))
(if comment
(sprintf " # <<< ~A" comment)
""))))
(if content?
(display hl-post)
(when context?
(display ctx-post)))
(newline)
(loop (cdr lines)
(+ number 1)
#t
#t))
(else
(loop (cdr lines)
(+ number 1)
printed-something
#f)))))))))
;; Performs self-tests of the listing module.
(define (listing-tests!)