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

Finish source listing module.

Browse source
This commit is contained in:
Dominik Pantůček 2023-03-13 19:45:32 +01:00
parent b026949266
commit 8d4eb05e4c
2 changed files with 72 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

86
listing.scm
View file

@ -1,3 +1,27 @@
;;
;; listing.scm
;;
;; Source listing with line highlights.
;;
;; ISC License
;;
;; Copyright 2023 Brmlab, z.s.
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
;; for any purpose with or without fee is hereby granted, provided
;; that the above copyright notice and this permission notice appear
;; in all copies.
;;
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;
(module
listing (print-source-listing listing-tests!)
@ -36,14 +60,51 @@
(or (< context 0)
(<= (abs (- line target)) context)))
(define (print-source-listing lines highlights context hl-pre hl-post ctx-pre ctx-pre ellipsis)
;; Returns true if given line is near one of the target lines given.
(define (line-near-targets? line targets context)
(let loop ((targets targets))
(if (null? targets)
#f
(if (line-near-target? line (car targets) context)
#t
(loop (cdr targets))))))
;; 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))
(number 1)
(printed-something #f)
(was-printing #f))
(when (not (null? lines))
(print (format-line-number number digits) (car lines))
(loop (cdr lines)
(+ number 1))))))
(let* ((content? (if (member number highlights) #t #f))
(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" (format-line-number number digits) (car lines)))
(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!)
@ -59,18 +120,9 @@
(test-true line-near-target? (line-near-target? 4 5 1))
(test-true line-near-target? (line-near-target? 1 5 10))
(test-false line-near-target? (line-near-target? 4 5 0))
(test-true line-near-targets? (line-near-targets? 4 '(1 5 10) 1))
(test-false line-near-targets? (line-near-targets? 3 '(1 5 10) 1))
(test-true line-near-targets? (line-near-targets? 3 '(1 5 10) 2))
))
)
(import listing)
(print-source-listing
'("asdf" "qwer")
'(1)
5
"\x1b[31;1m" "\x1b[0m"
"\x1b[33;1m" "\x1b[0m"
"\x1b[30;1m...\x1b[0m")
(listing-tests!)