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

Switch listings to use util-kwargs.

Browse source
This commit is contained in:
Dominik Pantůček 2023-05-15 11:27:24 +02:00
parent 7bd4c7d222
commit 2ede889714
2 changed files with 61 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/Makefile
View file

@ -96,7 +96,8 @@ TESTING-SOURCES=testing.scm
testing.o: testing.import.scm
testing.import.scm: $(TESTING-SOURCES)
LISTING-SOURCES=listing.scm testing.import.scm ansi.import.scm
LISTING-SOURCES=listing.scm testing.import.scm ansi.import.scm \
util-kwargs.import.scm
listing.o: listing.import.scm
listing.import.scm: $(LISTING-SOURCES)

117
src/listing.scm
View file

@ -37,9 +37,9 @@
(chicken base)
(chicken string)
(chicken format)
(chicken keyword)
testing
ansi)
ansi
util-kwargs)
;; Returns the number of digits required to represent a given number
;; in decimal format.
@ -125,62 +125,63 @@
;; Prints and highlights a selection of source listing lines and
;; their optional context.
(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* ((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 highlight context?)))
(cond (print?
(when (and printed-something
(not was-printing))
(print ellipsis))
(if highlight
(display hl-pre-real)
(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 highlight
(display hl-post-real)
(when context?
(display ctx-post)))
(newline)
(loop (cdr lines)
(+ number 1)
#t
#t))
(else
(loop (cdr lines)
(+ number 1)
printed-something
#f)))))))))
(define-kwproc (print-source-listing
lines
highlights
(#:highlight-rules highlight-rules
`((error ,(ansi #:bold #:red) ,(ansi #:default))
(warning ,(ansi #:yellow) ,(ansi #:default))
(info ,(ansi #:cyan) ,(ansi #:default))
))
(#:ellipsis ellipsis "...")
(#:context-pre ctx-pre "")
(#:context-post ctx-post "")
(#:highlight-pre hl-pre a:error)
(#:highlight-post hl-post a:default)
(#:context context 3))
(let ((digits (number-digits (length lines))))
(let loop ((lines lines)
(number 1)
(printed-something #f)
(was-printing #f))
(when (not (null? lines))
(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 highlight context?)))
(cond (print?
(when (and printed-something
(not was-printing))
(print ellipsis))
(if highlight
(display hl-pre-real)
(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 highlight
(display hl-post-real)
(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!)