From b026949266a4275c9b83b8d3c52824110063f59d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?=
 <dominik.pantucek@trustica.cz>
Date: Mon, 13 Mar 2023 19:30:59 +0100
Subject: [PATCH] Start tracking the listing module.

---
 listing.scm | 76 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 testing.scm | 24 ++++++++++++++++-
 2 files changed, 99 insertions(+), 1 deletion(-)
 create mode 100644 listing.scm

diff --git a/listing.scm b/listing.scm
new file mode 100644
index 0000000..cd9f3a0
--- /dev/null
+++ b/listing.scm
@@ -0,0 +1,76 @@
+
+(module
+ listing (print-source-listing listing-tests!)
+
+ (import scheme
+	 testing
+	 (chicken base)
+	 (chicken string)
+	 (chicken format))
+
+ ;; Returns the number of digits required to represent a given number
+ ;; in decimal format.
+ (define (number-digits number)
+   (let loop ((number (abs number))
+	      (digits 0))
+     (if (= number 0)
+	 (if (= digits 0)
+	     1
+	     digits)
+	 (loop (quotient number 10)
+	       (+ digits 1)))))
+
+ ;; Formats line number padding it with spaces from the left for
+ ;; alignment with number of given maximum number of digits and
+ ;; appends ordinal dot and space.
+ (define (format-line-number number digits)
+   (let loop ((args (list (sprintf "~A. " number)))
+	      (spaces (- digits (number-digits number))))
+     (if (<= spaces 0)
+	 (string-intersperse args "")
+	 (loop (cons " " args)
+	       (- spaces 1)))))
+
+ ;; Returns true if given line is near the target line.
+ (define (line-near-target? line target context)
+   (or (< context 0)
+       (<= (abs (- line target)) context)))
+
+ (define (print-source-listing lines highlights context hl-pre hl-post ctx-pre ctx-pre ellipsis)
+   (let ((digits (number-digits (length lines))))
+     (let loop ((lines lines)
+		(number 1))
+       (when (not (null? lines))
+	 (print (format-line-number number digits) (car lines))
+	 (loop (cdr lines)
+	       (+ number 1))))))
+
+ ;; Performs self-tests of the listing module.
+ (define (listing-tests!)
+   (run-tests
+    listing
+    (test-eq? number-digits (number-digits 0) 1)
+    (test-eq? number-digits (number-digits 1) 1)
+    (test-eq? number-digits (number-digits 9) 1)
+    (test-eq? number-digits (number-digits 10) 2)
+    (test-eq? number-digits (number-digits 999) 3)
+    (test-equal? format-line-number (format-line-number 5 3) "  5. ")
+    (test-true line-near-target? (line-near-target? 4 5 -1))
+    (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))
+    ))
+
+ )
+
+(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!)
diff --git a/testing.scm b/testing.scm
index 1950789..624fb84 100644
--- a/testing.scm
+++ b/testing.scm
@@ -22,7 +22,7 @@
 ;;
 (module
  testing
- (test-eq? test-equal? test-exn run-tests)
+ (test-eq? test-equal? test-exn test-true test-false run-tests)
 
  (import scheme
 	 (chicken condition))
@@ -59,6 +59,28 @@
 	    (error 'test-equal? (sprintf "~A expression=~S expected-result=~S result=~S"
 					 'name 'expression expected-result result)))))))
 
+ ;; Test passes if the expression evaluates to #t, raises exception
+ ;; otherwise.
+ (define-syntax test-true
+   (syntax-rules ()
+     ((_ name expression)
+      (let ((result expression))
+	(if (eq? result #t)
+	    (display ".")
+	    (error 'test-true (sprintf "~A expression=~S result=~S"
+				       'name 'expression result)))))))
+
+ ;; Test passes if the expression evaluates to #f, raises exception
+ ;; otherwise.
+ (define-syntax test-false
+   (syntax-rules ()
+     ((_ name expression)
+      (let ((result expression))
+	(if (eq? result #f)
+	    (display ".")
+	    (error 'test-true (sprintf "~A expression=~S result=~S"
+				       'name 'expression result)))))))
+
  ;; Passes if the-test raises an exception
  (define-syntax test-exn
    (syntax-rules ()