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

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

 )