;;
;; progress.scm
;;
;; Progress reporting.
;;
;; 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 progress))

(module
 progress
 (
  run-with-progress
  progress-advance
  with-progress
  run-progress-break
  progress-break
  )

 (import scheme
	 (chicken base)
	 (chicken format)
	 (chicken port))

 ;; Parameterized current progress string
 (define *current-progress* (make-parameter #f))

 ;; Prints current progress.
 (define (print-current-progress . args)
   (let ((cp (*current-progress*)))
     (when cp
       (display (sprintf "\r\x1b[K~A" cp)))))

 ;; Adds something to current progress and refreshes the display.
 (define (progress-advance . args)
   (when (*current-progress*)
     (let ((str (if (null? args)
		    "."
		    (car args))))
       (*current-progress* (string-append (*current-progress*) (sprintf "~A" str)))
       (print-current-progress))))

 ;; Runs given procedure within progress environment
 (define (run-with-progress echo? pre-msg post-msg thunk)
   (parameterize ((*current-progress* (if echo? pre-msg #f)))
     (print-current-progress)
     (let ((result (thunk)))
       (print-current-progress)
       (when echo?
	 (print post-msg))
       result)))

 ;; Allows printing output when progress is advancing.
 (define (run-progress-break thunk)
   (when (*current-progress*)
     (display "\r\x1b[K"))
   (thunk)
   (print-current-progress))

 ;; Friendly syntax wrapper.
 (define-syntax with-progress
   (syntax-rules ()
     ((_ echo? pre post body ...)
      (run-with-progress echo? pre post (lambda () body ...)))))

 ;; Evaluate some expressions without progress.
 (define-syntax progress-break
   (syntax-rules ()
     ((_ body ...)
      (run-progress-break (lambda () body ...)))))

 ;; If the program uses progress module, disable buffering
 (set-buffering-mode! (current-output-port) #:none)

 )