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

 (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)))

 ;; 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)
		(printed-something #f)
		(was-printing #f))
       (when (not (null? lines))
	 (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!)
   (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))
    ))

 )