Finish source listing module.

listing.scm

@@ -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!)

testing.scm

@@ -1,6 +1,8 @@
 ;;
 ;; testing.scm
 ;;
+;; Infrastructure for sipmle unit tests.
+;;
 ;; ISC License
 ;;
 ;; Copyright 2023 Brmlab, z.s.
@@ -20,6 +22,7 @@
 ;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
 ;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 ;;
+
 (module
  testing
  (test-eq? test-equal? test-exn test-true test-false run-tests)