;;;;
;;;; e r r o r . s t k 		-- All the stuff going with error messages 
;;;;				   display
;;;;
;;;;
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 15-Sep-1993 14:11
;;;; Last file update:  3-Sep-1999 19:50 (eg)
;;;;

(require "dialog")
(select-module Tk)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; report-error (this version of report-error needs Tk)
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (STk:report-error head message obj)
  ;; Since this function is loaded only when needed the stack is different 
  ;; on first execution 
  (define stack 	  (cddddr (%get-eval-stack)))
  (define env   	  (cddddr (%get-environment-stack)))
  (define current-env (global-environment))

  (define (truncate s len)
    (if (> (string-length s) len)
	(string-append (substring s 0 (- len 1)) " ...")
	s))

  (define (adjust-string s len)
    (let ((l (string-length s)))
      (if (>= l len)
	  s
	  (string-append s (make-string (- len l) #\space)))))

  (define (local-eval x)
    (eval x current-env))

  (define (select-expression |W| x y)
    (let ((index (|W| 'index (format #f "@~a,~a" x y))))
      (when (< index (length stack))
	(set! current-env (list-ref env index))
	(listener-insert-string .stackview.vt.l
				(format #f ";; Current environment is ~A\n"
					(if (eq? current-env (global-environment))
					    "global environment"
					    current-env))))))

  (define (select-environment |W| x y)
    (let ((index (|W| 'index (format #f "@~a,~a" x y))))
      (display-environment (if (= index (length env))
			       (global-environment)
			       (list-ref env index)))))

  (define (display-environment e)
    (let* ((top      (gensym ".top_env"))
	   (f1       (format #f "~A.f"        top))
	   (lst      (format #f "~A.f.lst"    top))
	   (scroll-x (format #f "~A.f.sx"     top))
	   (scroll-y (format #f "~A.f.sy"     top))
	   (f2	     (format #f "~A.b"	      top))
	   (parent   (format #f "~A.b.parent" top))
	   (quit     (format #f "~A.b.quit"   top))
	   (el	     (car (environment->list e))))

      (toplevel top)
      (wm 'title top (format #f "~S" e))
      (pack (frame f1) :expand #t :fill "both" :side "top")
      (pack (frame f2) :expand #f :fill "x" :side "top")

      ;;;;;  Listbox and its scrollbar
      (set! lst (listbox lst :width 70 :height (max 2 (min (length el) 20))
			 :font '(Courier -12)
			 :xscroll (lambda args (apply scroll-x 'set args))
			 :yscroll (lambda args (apply scroll-y 'set args))))
      (set! scroll-x (scrollbar scroll-x :orient "hor" 
				:command (lambda args (apply lst 'xview args))))
      (set! scroll-y (scrollbar scroll-y :orient "ver"
				:command (lambda args (apply lst 'yview args))))

      (pack scroll-x :side "bottom" :fill "x")
      (pack lst :expand #t :fill "both" :side "left")
      (pack scroll-y :side "left"   :fill "y")

      ;; fill it
      (let ((bindings (map (lambda (x) 
			     (format #f "~A = ~S" 
				     (adjust-string (symbol->string (car x)) 20)
				     (cdr x)))
			   el)))
	(apply lst 'insert 0 (sort bindings string<?)))

      ;; Parent and quit button
      (let ((p (parent-environment e)))
	(pack (button quit 
		      :text "Quit" :command (lambda () (destroy top)))
	      (button parent
		      :text "Parent environment" 
		      :state (if p "normal" "disabled")
		      :command (lambda () (display-environment p)))
	    :expand #t :fill "x" :side "left"))))


  (define (display-stack stack env)
    (catch (destroy ".stackview"))

    ;; Build a toplevel
    (toplevel '.stackview)
    (wm 'title .stackview "STk stack")

    ;; Dispose items
    (pack (label '.stackview.l :text "Stack content" :fg "RoyalBlue")
	  :side "top")
    (pack (frame '.stackview.f :bd 3 :relief "groove")
	  :side "top" :expand #t :fill "both" :padx 5 :pady 5)
    (pack (frame '.stackview.b)
	  :side "bottom" :fill "x")

    ;;;;;;;;;;;;;;;;;;;;
    ;;
    ;; The (double) listbox
    ;;
    ;;;;;;;;;;;;;;;;;;;;
    (pack (scrollbar '.stackview.f.sx 
		     :orient "hor" 
		     :command (lambda args 
				(apply .stackview.f.list 'xview args)))
	  :side "bottom" :fill "x")

    (pack (listbox '.stackview.f.env 
		   :width  18
		   :height 10
		   :font '(Courier -12)
		   :bd 1
		   :relief "raised")
	  :expand #f :fill "y" :side "left")

    (pack (listbox '.stackview.f.list 
		   :width  70
		   :height 10
		   :font '(Courier -12)
		   :bd 1
		   :relief "raised"
		   :xscroll (lambda args (apply .stackview.f.sx 'set args))
		   :yscroll (lambda args (apply .stackview.f.sy 'set args)))
	  :expand #t :fill "both" :side "left")

    (pack (scrollbar '.stackview.f.sy
		     :orient "vert"
		     :command (lambda args 
				(apply .stackview.f.list 'yview args)))
	  :side "left" :fill "y")

    ;; Insert the stack elements in the listbox
    (do ((stack stack (cdr stack))
	 (env   env   (cdr env)))
	((null? stack))
      (.stackview.f.list 'insert 'end 
			 (truncate (format #f "~S" (uncode(car stack))) 150))
      (.stackview.f.env 'insert 'end 
			(format #f "~A" 
				(if (equal? (car env) (global-environment))
				    "*global*"
				    (address-of (car env))))))

    ;; Insert a marker to delimit bottom of the stack
    (.stackview.f.list 'insert 'end "<<< STACK BOTTOM >>>")
    (.stackview.f.env  'insert 'end "*global*")

    ;; listbox bindings
    (bind .stackview.f.env  "<ButtonRelease-1>" select-environment)
    (bind .stackview.f.list "<ButtonRelease-1>" select-expression)

    ;;;;;;;;;;;;;;;;;;;;
    ;;;;
    ;;;; Listener
    ;;;;
    ;;;;;;;;;;;;;;;;;;;;
    (pack (label '.stackview.l2 :text "Listener" :fg "RoyalBlue")
	  :side "top")

    (pack (frame '.stackview.vt :bd 3 :relief "groove") 
	  :expand #t :fill "both" :padx 5 :pady 5)
    (pack (listener '.stackview.vt.l 
		    :font   '(Courier -12)
		    :wrap   "word" 
		    :height 10
		    :command (lambda (x) (format #f "~S" 
						 (eval-string x current-env)))
		    :yscroll (lambda args (apply .stackview.vt.s 'set args)))
	  :side "left" :expand #t :fill "both")
    (pack (scrollbar '.stackview.vt.s
		     :orient "vert"
		     :command (lambda args (apply .stackview.vt.l 'yview args)))
	  :side "right" :expand #f :fill "y")
    ;;;;;;;;;;;;;;;;;;;;
    ;;
    ;; Bottom buttons
    ;;
    ;;;;;;;;;;;;;;;;;;;;
    (pack [button '.stackview.b.q 
		  :text "Quit"
		  :command (lambda () (destroy .stackview))]
	  [button '.stackview.b.h 
		  :text "Help"
		  :command (lambda () 
			     (STk:show-help-file "error-hlp.html"))]
     :side "left" :expand #t :fill "x")

    ;; Center the window
    (STk:center-window .stackview))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;;
  ;;;; Report-error starts here
  ;;;; 
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let* ((who (if (null? obj) "" (format #f "~S" obj)))
	 (msg (truncate (string-append head "\n" message "\n" who "\n") 200)))

    ;; Print message on standard error stream
    (format (current-error-port) "\n~A~A~A\n" 
	    head 
	    message 
	    (if (equal? who "") "" (string-append ": " who)))

    ;; Remove grab (if any) to allow interactions in the the next dialog
    (for-each (lambda (x) (grab 'release x)) (winfo 'children *root*))

    ;; Open dialog box
    (stk::make-dialog 
	    :window   '.report-error
	    :title    "STk error"
	    :text     msg
	    :image    (make-image "error.gif")
	    :grab     #f
	    :default  0
	    :buttons  `(("    Quit     " ,(lambda () '()))
			("See the stack" ,(lambda ()
					    (display-stack stack env)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Misc 
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define *error-info* "")

(define (bgerror . message)
  ;; Important note: When a background error occurs, tk try to see if 
  ;; bgerror is bound to something. This is achieved by calling bgerror
  ;; with an empty message. In this case, nothing is printed
  (unless (null? message)
      (format (current-error-port) "**** Tk error (~S) ~S~%" 
	      (car message) *error-info*))
  (set! *error-info* ""))

(define tkerror bgerror) ;; For compatibility with pre-Tk4.1 (i.e STk-3.1)