hackerbase/listing.scm

;;
;; 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.
;;

(declare (unit listing))

(module
 listing
 (
  print-source-listing
  listing-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken string)
	 (chicken format)
	 (chicken keyword)
	 testing
	 ansi)

 ;; 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)
   (let ((target-line (if (list? target)
			  (car target)
			  target)))
     (or (< context 0)
	 (<= (abs (- line target-line)) context))))

 ;; 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)
	 (< context 0)
	 (if (line-near-target? line (car targets) context)
	     #t
	     (loop (cdr targets))))))

 ;; Returns true if given number is in highlights.
 (define (in-highlights? number highlights)
   (let loop ((highlights highlights))
     (if (null? highlights)
	 #f
	 (let* ((highlight (car highlights))
		(line-number (if (list? highlight)
				 (car highlight)
				 highlight)))
	   (if (= number line-number)
	       #t
	       (loop (cdr highlights)))))))

 ;; Returns comment if there is any
 (define (highlight-comment number highlights)
   (let loop ((highlights highlights))
     (if (null? highlights)
	 #f
	 (let* ((highlight (car highlights))
		(line-number (if (list? highlight)
				 (car highlight)
				 highlight)))
	   (if (= number line-number)
	       (if (list? highlight)
		   (cadr highlight)
		   #f)
	       (loop (cdr highlights)))))))

 ;; 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* ((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!)
   (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))
    (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))
    ))

 )