;;; -*-Scheme-*-
;;;
;;; A HyperNeWS Window-based debugger (needs much work)
;;; Russell Ritchie, Iain Graham Consultants, <russell@uk.co.igc>.
;;; Thu Apr 15 11:52:48 1976

(define inhibit-hnstartup-message #t)	; Don't show the IntroStack. 

(require 'ppport)
(require 'HyperNeWS)			; Change this to 'mHyperNeWS
					; for use with Xt/Motif, see ../HINTS.
(provide 'sdb)

(define (string-null? str) (= (string-length str) 0))

(define (rjust n x)
  (let* ((y (string-append (make-string n #\space) x))
	 (l (string-length y)))
    (substring y (- l n) l)))

(define (strip-leading-whitespace string)
  (do ((str string (substring str 1 (string-length str))))
      ((not (char-whitespace? (string-ref str 0))) str)))

(define (error->string error)
  (apply format (cons #f (cons (string-append "~a: " (cadr error))
			       (cons (car error)
				     (cddr error))))))
(define (display->string form)
  (let ((p (open-output-string)))
    (display form p)
    (get-output-string p)))

(define (pp->string thing)
  (let ((p (open-output-string)))
    (ppport thing p)
    (get-output-string p)))

(define (pp->textobject textobject thing)
  (let* ((tstr (pp->string thing))
	 (len (string-length tstr))
	 (last-i 0)
	 (lines))
    (do ((i 0 (1+ i)))
	((= i len)
	 (set! lines (append lines (list (substring tstr last-i i))))
	 (hns-set-text textobject lines))
      (if (char=? (string-ref tstr i) #\newline)
	  (begin
	   (set! lines (append! lines (list (substring tstr last-i i))))
	   (set! last-i (1+ i)))))))

(define (hns-append-text text line) (hns-send text "WriteLn" (list line)))

(define (hns-init-backtrace! traceobj trace)
  (let ((maxlen 28) (start-frame 0) (lines))
    (let loop ((frames (list-tail trace start-frame)) (num 0))
	 (if (null? frames) #v
	   (let ((frame (car frames)))
	     (let* ((func (format #f "~s" (vector-ref frame 0)))
		    (indent (- maxlen (+ 5 (string-length func)))))
 	       (set!
		lines
		(append
		 lines
		 (list
		  (format
		   #f "~a ~a~a~a"
		   (rjust 4 (number->string  num))
		   func
		   (make-string (if (negative? indent) 1 indent) #\space)
		   (fluid-let ((print-depth 2) (print-length 3))
		     (display->string (vector-ref frame 1)))))))))
	   (loop (cdr frames) (+ num 1))))
    (hns-set-text traceobj lines)))

(define inspect)

(let ((frame)
      (trace)
      (displayed-frames)		; ((frame-num . stack)...)
      (pp-list))			; (((name . thing) . stack)... )
  
  (define (hn-inspect error-msg)
    (let ((stack (hns-interface-object '() 'stack "SchemeDebugger")))
      (let ((hnbacktrace (hns-interface-object stack 'edittext "BackTrace"))
	    (hnmessage (hns-interface-object stack 'edittext "Message"))
	    (hntop (hns-interface-object stack 'button "Top"))
	    (hnbottom (hns-interface-object stack 'button "Bottom"))
	    (hnzoom (hns-interface-object stack 'button "Zoom"))
	    (hnshowenv (hns-interface-object stack 'button "ShowEnv"))
	    (hnobarrayinfo (hns-interface-object stack 'button "ObarrayInfo"))
	    (hndone (hns-interface-object stack 'button "Done"))
	    (exit? #f))

	(define (hn-top . hnargs)
	  (hns-send hnbacktrace "SetEditTop" '(0)))

	(define (hn-bottom . hnargs)
	  (hns-send hnbacktrace "SetEditTop" (list (1- (length trace)))))

	(define (hn-zoom . hnargs)
	  ;; Bug: SetEditTop won't scroll if the line you ask for is showing...
	  (hns-send hnbacktrace "SetEditTop" (1- (length trace)))
	  (hns-send hnbacktrace "SetEditTop" (list frame)))

	(define (hn-obarray-info . hnargs)
	   (let ((l (map length (oblist))))
	     (let ((n 0))
	       (for-each (lambda (x) (set! n (+ x n))) l)
	       (hns-set-text
		hnmessage
		(format #f "~s symbols (maximum bucket: ~s)"
			n (apply max l))))))
	
	(define (hn-ppready key thing who-line)
	  (let ((showing? (assq key (map car pp-list))))
	    (if showing?
		(hns-show (cdr (assq showing? pp-list)))
	      (set! pp-list (cons (cons key thing) pp-list))
	      (hns-send stack "Ready" '())
	      (hns-set-text
	       who-line
	       (format #f "Showing ~a, this may take a while..." key)))))

	(define (hn-pprint hnargs)
	  (let* ((ppstack (hns-interface-object '() 'stack (hn-third hnargs)))
		 (pptextobj (hns-interface-object ppstack 'edittext "Object"))
		 (ppname-thing (car pp-list))
		 (ppname (format #f "~a" (car ppname-thing))))
	    (hns-set-text (hns-interface-object ppstack 'edittext "NameFront")
			  ppname)
	    (hns-set-text (hns-interface-object ppstack 'edittext "NameBack")
			  ppname)
	    (set! pp-list (cons (cons ppname-thing ppstack) (cdr pp-list)))
	    (pp->textobject pptextobj (cdr ppname-thing))
	    (hns-send pptextobj "SetEditTop" '(0))))

	(define (hn-show-env hnargs)
	  (hn-ppready 'The\ Global\ Environment
		      (car (environment->list (global-environment)))
		      hnmessage))

	(define (hn-show-frame hnargs)
	  (let* ((fn (string->number (strip-leading-whitespace
				      (substring (hn-third hnargs) 0 4))))
		 (found? (assq fn displayed-frames))
		 (existing-stack? (if (pair? found?)
				      (hns-stack? (cdr found?)))))
	    (if existing-stack?
		(hns-show (cdr found?))
	      (and (hns-send stack "CreateNewFrame" '())
		   (hns-set-text hnmessage (format #f "Showing Frame ~a" fn))
		   (set! displayed-frames (cons fn displayed-frames))))))

	(define (hn-new-frame hnargs)
	  (let* ((fn (car displayed-frames))
		 (fstack
		  (hns-interface-object '() 'stack (hn-third hnargs)))
		 (inputstack
		  (hns-interface-object '() 'stack "InputDialog"))
		 (f (list-ref trace fn))
		 (procedure (vector-ref f 0))
		 (args (vector-ref f 1))
		 (env (vector-ref f 2))
		 (lbindings '())
		 (fname
		  (format #f "Frame #~a of ~a" fn (- (length trace) 1)))
		 (fmessage
		  (hns-interface-object fstack 'edittext "Message"))
		 (fprocedure
		  (hns-interface-object fstack 'edittext "Procedure"))
		 (fargobj
		  (hns-interface-object fstack 'edittext "Arguments"))
		 (fenvobj
		  (hns-interface-object fstack 'edittext "Environment")))
	    
	    (define (hn-ppprocedure hnargs)
	      (hn-ppready (string->symbol
			   (format #f "~a in Frame #~a" procedure fn))
			  procedure fmessage))

	    (define (argstr->argnumber astr)
	      (string->number (substring astr 9 (substring? ":" astr))))

	    (define (hn-pparg hnargs)
	      (let ((astr (hn-third hnargs)))
		(and (not (or (string=? astr "No arguments.")
			      (string-null? astr)))
		     (let ((argn (argstr->argnumber astr)))
		       (hn-ppready
			(string->symbol
			 (format #f "Argument ~a in Frame #~a" argn fn))
			(list-ref args (1- argn))
			fmessage)))))

	    (define (bstr->bindex bstr)
	      (string->symbol (substring bstr 0 (substring? ":" bstr))))

	    (define (hn-ppbinding hnargs)
	      (let ((bstr (hn-third hnargs)))
		(and (not (or (string=? bstr "Local Frame Bindings:")
			      (string-null? bstr)))
		     (let ((bvar (bstr->bindex bstr)))
		       (hn-ppready
			(string->symbol
			 (format #f "Local Binding of ~a in Frame #~a"
				 bvar fn))
			(assq bvar lbindings)
			fmessage)))))

	    (define (hn-eval-in-env hnargs)
	      (let ((input (hn-third hnargs)))
		(if (not (string-null? input))
		    (fluid-let ((error-handler
				 (lambda error
				   (call-with-current-continuation
				    (lambda (control-point)
				      (hns-show-error
				       (error->string error))
				      #t))
				   (let ((next-frame (car rep-frames)))
				     (next-frame #t)))))
		      (let ((evaluation
			     (eval (read (open-input-string input))
				   env)))
			(hn-ppready
			 (string->symbol
			  (format #f "Eval of ~a in Frame #~a" input fn))
			 evaluation
			 fmessage))))))

	    (set-car! displayed-frames (cons fn fstack))
	    (hns-set-handler fprocedure "Action" hn-ppprocedure)
	    (hns-set-handler fargobj "Action" hn-pparg)
	    (hns-set-handler fenvobj "Action" hn-ppbinding)
	    (hns-set-handler '() "InputReply" hn-eval-in-env)
	    
	    (hns-set-text
	     (hns-interface-object fstack 'edittext "NameFront") fname)
	    (hns-set-text
	     (hns-interface-object fstack 'edittext "NameBack") fname)
	    (hns-set-text fprocedure (format #f "~s" procedure))
	    (if (null? args)
		(hns-set-text fargobj "No arguments.")
	      (fluid-let ((print-depth 2) (print-length 3))
		(let ((arglines))
		  (do ((i 1 (1+ i)) (args args (cdr args)))
		      ((null? args) (hns-set-text fargobj arglines))
		    (set!
		     arglines
		     (append
		      arglines
		      (list
		       (format #f "Argument ~s:   ~s" i (car args))))))))
	      (hns-send fargobj "SetEditTop" '(0)))
	    (set! lbindings (if (not (eq? env (global-environment)))
				;; Only show the Global Environment once.
				(car (environment->list env))))
	    (fluid-let ((print-length 2) (print-depth 2))
	      (if lbindings
		  (let ((blines))
		    (do ((b lbindings (cdr b)))
			((null? b)
			 (hns-set-text
			  fenvobj (cons "Local Frame Bindings:" blines)))
		      (set!
		       blines
		       (append
			blines
			(list
			 (format #f "~s:   ~s" (caar b) (cdar b))))))
		    (hns-send fenvobj "SetEditTop" '(0)))))))

	(define (hn-forget-stacks stacklist)
	  (hns-ps "HyperNeWS begin")
	  (map (lambda (stack)
		 (hns-ps (format #f "StackDict /~a undef" (cadr stack))))
	    stacklist))

	(define (hn-done . hnargs)
	  (let ((stacks (append (map cdr displayed-frames) (map cdr pp-list))))
	    (set! exit? #t)
	    (for-each hns-hide stacks)
	    (hn-forget-stacks stacks)))

	(hns-clear-interests)		; Flush any old interests...
	(hns-set-handler hntop "Action" hn-top)
	(hns-set-handler hnbottom "Action" hn-bottom)
	(hns-set-handler hnzoom "Action" hn-zoom)
	(hns-set-handler hnshowenv "Action" hn-show-env)
	(hns-set-handler hnobarrayinfo "Action" hn-obarray-info)
	(hns-set-handler hnbacktrace "Action" hn-show-frame)
	(hns-set-handler hndone "Done" hn-done)
	(hns-set-handler '() "NewFrame" hn-new-frame)
	(hns-set-handler '() "Pprint" hn-pprint)
	;;(hns-set-handler '() '() hns-debug-handler)
	(hns-start)
	(hns-flush-input)
	(hns-connect stack)
	(hns-init-backtrace! hnbacktrace trace)
	(hns-set-text hnmessage error-msg)
	(hns-show stack)
	(hn-zoom)
	(do ()
	    ((or exit? (not (hns-interpret (hns-read -1)))) #t)))))

  (define (find-frame obj)
    (let loop ((l trace) (i 0))
	 (cond ((null? l) 0)
	       ((eq? (vector-ref (car l) 0) obj) i)
	       (else (loop (cdr l) (+ i 1))))))

  (set! inspect
	(lambda args
	  (let ((error (cadr args)))
	    (set! trace (backtrace-list))
	    (set! trace (cddr trace))
	    (if (null? args) (set! frame 0)
	      (set! frame (find-frame (car args))))
	    (do ((t trace (cdr t)) (f 1 (1+ f))) ((null? t))
	      (if (not (null? (vector-ref (car t) 1)))
		  (let ((last (last-pair (vector-ref (car t) 1))))
		    (if (not (null? (cdr last)))
			(begin
			 (format
			  #t
			  "[inspector: fixing improper arglist in frame ~s]~%"
			  f)
			 (set-cdr! last (cons (cdr last) '())))))))
	    (let loop ()
		 (if (call-with-current-continuation
		      (lambda (control-point)
			(push-frame control-point)
			(hn-inspect (error->string error))
			#f))
		     (begin
		      (pop-frame)
		      (loop))))
	    (pop-frame)
	    (let ((next-frame (car rep-frames)))
	      (next-frame #t))))))
  
(set! error-handler
      (lambda error-msg
	(call-with-current-continuation
	 (lambda (control-point)
	   (push-frame control-point)
	   (inspect error-handler error-msg)))
	(pop-frame)
	(let ((next-frame (car rep-frames)))
	  (next-frame #t))))
