stk/Lib/inspect-view.stk

;******************************************************************************
;
; Project       : STk-inspect, a graphical debugger for STk.
;
; File name     : inspect-view.stk
; Creation date : Aug-30-1993
; Last update   : Sep-17-1993
;
;******************************************************************************
;
; This file implements the different sort of "Viewers".
;
;******************************************************************************

(provide "inspect-view")

(define (view-tl-wid obj) (widget VIEW_WIDGET_NAME (object-symbol obj)))
(define (view-tl-str obj) (& VIEW_WIDGET_NAME (object-symbol obj)))
(define (view-l-wid obj) (widget (view-tl-str obj) ".id.f1.l2"))
(define (view-l-str obj) (& (view-tl-str obj) ".id.f1.l2"))
(define (view-e-wid obj) (widget (view-tl-str obj) ".id.f2.e"))
(define (view-e-str obj) (& (view-tl-str obj) ".id.f2.e"))
(define (view-m-wid obj) (widget (view-tl-str obj) ".menu.command.m"))
(define (view-m-str obj) (& (view-tl-str obj) ".menu.command.m"))
(define (view-c-wid obj) (widget (view-tl-str obj) ".f3.c"))
(define (view-c-str obj) (& (view-tl-str obj) ".f3.c"))


;---- Viewer menu -------------------------------------------------------------

(define (view-menu-Eval obj)
  (eval-string (format #f "(set! ~a ~a)" obj ((view-e-wid obj) 'get))))

(define (view-menu-Quote obj)
  (eval-string (format #f "(set! ~a '~a)" obj ((view-e-wid obj) 'get))))

(define (view-menu-Inspect key)
  (let ((obj (find-object-infos key)))
    (inspect obj)
    ((widget (view-tl-str obj) ".menu.command.m") 'entryconfigure "Inspect" :state 'disabled)
    (if (detailed? obj) ((detail-m-wid obj) 'entryconfigure "Inspect" :state 'disabled))))

(define (view-menu-Detail key)
  (let ((obj (find-object-infos key)))
    (detail obj)
    ((widget (view-tl-str obj) ".menu.command.m") 'entryconfigure "Detail" :state 'disabled)
    (if (inspected? obj) ((inspect-m-wid obj) 'entryconfigure "Detail" :state 'disabled))))

(define (view-menu-Unview key) 
  (unview (find-object-infos key)))


;---- Viewer ------------------------------------------------------------------

(define VIEW_WIDGET_NAME ".viewer")
(define viewed-objects-list ())

(define (viewed? obj) (member obj viewed-objects-list))

(define (view obj)
  (unless (viewed? obj) (view-object obj)))

(define (view-object obj)
  (set! viewed-objects-list (cons obj viewed-objects-list))
  (unless (object-infos obj)
	  (add-object-infos obj)
	  (if (symbol? obj) (trace-var obj `(update-object ',obj))))
  (view-create obj))

(define (unview obj)
  (when (viewed? obj) (unview-object obj)))

(define (unview-object obj)
  (let ((top (view-tl-wid obj)))
    (set! viewed-objects-list (list-remove obj viewed-objects-list))
    ;; enable the viewer
    (if (inspected? obj) ((inspect-m-wid obj) 'entryconfigure "View" :state 'normal))
    (if (detailed? obj) ((detail-m-wid obj) 'entryconfigure "Inspect" :state 'normal))
    (unless (or (inspected? obj) (detailed? obj))
	    (remove-object-infos obj)
	    (if (symbol? obj) (untrace-var obj)))
    ;; If toplevel exists (i.e. it is not a <Destroy> event) destroy it
    (if (winfo 'exists top)
	(destroy top))))

(define (view-create obj)
  (let ((obj-val (inspect::eval obj)))
    (case (inspect::typeof obj-val)
      ((widget)  (when (winfo 'exists (view-tl-wid obj-val))
			 (view-widget-create obj-val)))
      ((closure) (view-procedure-create obj))
      (else      (view-object-create obj)))))

(define (view-display obj)
  (case (object-type obj)
    ((widget) (view-widget-display (inspect::eval obj)))
    ((closure) (view-procedure-display obj))
    (else (view-object-display obj))))


;---- Object/Procedure viewer -------------------------------------------------

(define CAR_COLOR "gray90")
(define CDR_COLOR "gray70")
(define ARROW_COLOR "black")
(define TEXT_COLOR "black")

(define (highlightItem canvas color1 color2)
(let ((item (car (canvas 'find 'withtag 'current))))
    (if (equal? (tki-get canvas item :fill) color1)
	(tki-set canvas item :fill color2)
	(tki-set canvas item :fill color1))))

(define (find-car/cdr fct count l)
  (define (_find-car/cdr fct count l path)
    (if (not (pair? l))
	(if (null? path)
	    #f
	    (_find-car/cdr fct count (caar path) (cdr path)))
	(if (equal? 0 count)
	    (fct l)
	    (_find-car/cdr fct (- count 1) (cdr l) (cons l path)))))
  (_find-car/cdr fct count l ()))

(define (double1OnCar obj)
  (let* ((canvas (view-c-wid obj))
	 (item (car (canvas 'find 'withtag 'current)))
	 (cars (canvas 'find 'withtag 'CAR)))
    (view (find-car/cdr car (list-first item cars) (inspect::eval obj)))))

(define (double1OnCdr canvas obj)
  (let ((item (car (canvas 'find 'withtag 'current)))
	(cdrs (canvas 'find 'withtag 'CDR)))
    (view (find-car/cdr cdr (list-first item cdrs) (inspect::eval obj)))))

(define (text-width text font)
  (canvas ".text-width")
  (define bbox
    (.text-width 'bbox (.text-width 'create 'text 0 0 :text text :font font)))
  (destroy .text-width)
  (- (caddr bbox) (car bbox)))

(define (view-create-toplevel obj)
  (define w (create-toplevel-widget (view-tl-str obj)))
  (define id-w (widget w ".id"))
  (set-id-label1 id-w "Object" 6)
  (set-id-label2 id-w "Value" 6)

  (define menu-w (widget w ".menu"))
  ((widget w ".menu.help.m") 'add 'command :label "Viewer"
			     :command '(stk:make-help Viewer-help))
  (pack [menubutton (& menu-w ".command") :text "Command"] :side "left")
  (define cmd-w (eval [menu (& menu-w ".command.m")]))
  (tk-set! (widget menu-w ".command") :menu cmd-w)
  (cmd-w 'add 'command :label "Inspect" 
	 	       :command `(view-menu-Inspect ',(object-symbol obj))
		       :state (if (inspected? obj) 'disabled 'normal))
  (cmd-w 'add 'command :label "Detail" 
	 		:command `(view-menu-Detail ',(object-symbol obj))
			:state (if (detailed? obj) 'disabled 'normal))
  (cmd-w 'add 'command :label "Unview" 
	 	       :command `(view-menu-Unview ',(object-symbol obj)))

  (if (modifiable-object? obj)
      [begin
	(bind (widget w ".id.f2.e") "<Return>" `(view-menu-Eval ',obj))
	(bind (widget w ".id.f2.e") "<Shift-Return>" `(view-menu-Quote ',obj))]
      [begin
	((view-e-wid obj) 'insert 0 (format #f "~S" (inspect::eval obj)))
	(inspect::shadow-entry (widget w ".id.f2.e"))])


  (pack [frame (& w ".f3") :relief "sunken" :bd 2]
	:fill "both" :expand "yes" :padx 4 :pady 2)
  (pack [scrollbar (& w ".f3.vsb") :orient "vertical"]
	:side "left" :fill "y")
  (pack [scrollbar (& w ".f3.hsb") :orient "horizontal"]
	:side "bottom" :fill "x")
  (pack [canvas (view-c-str obj) :relief "raised" :bd 2
		:yscrollcommand (& w ".f3.vsb 'set")
		:xscrollcommand (& w ".f3.hsb 'set")]
	:fill "both" :expand "yes")
  (tk-set! (widget w ".f3.vsb")
	   :command (lambda l (apply (string->widget (view-c-str obj)) 'yview l)))
  (tk-set! (widget w ".f3.hsb")
	   :command (lambda l (apply (string->widget (view-c-str obj)) 'xview l)))
  (bind w "<Destroy>" `(view-menu-Unview ',(object-symbol obj)))
  w)

(define (view-object/procedure-create obj)
  (define w (view-create-toplevel obj))
  (wm 'title w "Object viewer")
  (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  (define c (view-c-wid obj))
  (define c-name (widget-name c))
  (c 'bind 'CAR "<Enter>" `(highlightItem ,c-name CAR_COLOR "red"))
  (c 'bind 'CAR "<Leave>" `(highlightItem ,c-name CAR_COLOR "red"))
  (c 'bind 'CAR "<Double-1>" `(double1OnCar ',obj))
  (c 'bind 'CDR "<Enter>" `(highlightItem ,c-name CDR_COLOR "blue"))
  (c 'bind 'CDR "<Leave>" `(highlightItem ,c-name CDR_COLOR "blue"))
  (c 'bind 'CDR "<Double-1>" `(double1OnCdr ,c-name ',obj))
  w)

(define (view-object-create obj)
  (define w (view-object/procedure-create obj))
  (view-object-display obj))

(define (view-object-display obj)
  (wm 'title  (view-tl-wid obj) "Object viewer")
  (define obj-val (inspect::eval obj))
  (tk-set! (view-l-wid obj) :text (->object obj))
  ((view-e-wid obj) 'delete 0 'end)
  ((view-e-wid obj) 'insert 0 (->object obj-val))
  (view-object/procedure-display (view-c-wid obj) obj-val)) 

(define (view-procedure-create obj)
  (define w (view-object/procedure-create obj))
  (view-procedure-display obj))

(define (view-procedure-display obj)
  (wm 'title  (view-tl-wid obj) "Procedure viewer")
  (define obj-val (inspect::eval obj))
  (tk-set! (view-l-wid obj) :text (->object obj))
  ((view-e-wid obj) 'delete 0 'end)
  ((view-e-wid obj) 'insert 0 (->object obj-val))
  (view-object/procedure-display (view-c-wid obj) (procedure-body obj-val)))

(define (view-object/procedure-display c obj-val)
  (define grid-h 60) ; horizontal spacing between grid lines
  (define grid-v 40) ; vertical spacing between grid lines
  (define cons-h 40) ; horizontal size of cons cell
  (define cons-v 20) ; vertical size of cons cell
  (define cons-h/2 (quotient cons-h 2))
  (define cons-v/2 (quotient cons-v 2))
  (define arrow-space 2) ; space between arrow and box
  (define (x-h x) (* x grid-h))
  (define (y-v y) (* y grid-v))
  (define font "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")

  (define (draw-cons-cell x y)
    (let ((h (x-h x)) (v (y-v y)))
      (c 'create 'rectangle h v (+ h cons-h/2 1) (+ v cons-v)
	 :fill CAR_COLOR :tag 'CAR)
      (c 'create 'rectangle (+ h cons-h/2) v (+ h cons-h) (+ v cons-v)
	 :fill CDR_COLOR :tag 'CDR)))

  (define (car-arrow-pos x y d)
    (let ((h (x-h x)) (v (y-v y)))
      (list (+ h (quotient cons-h 4)) (+ v cons-v/2) (+ h (quotient cons-h 4))
	    (+ v cons-v/2 (- (* d grid-v) (+ cons-v/2 arrow-space))))))

  (define (draw-car-arrow x y d) ; draw arrow downwards 'd' grid squares
    (let ((pos (car-arrow-pos x y d)))
      (if (and (= x 0) (= y 0))
	  (eval `(,c 'create 'line ,@pos :arrow "last" :arrowshape "8 8 3"))
	  (eval `(,c 'create 'line ,@pos :arrow "last" :arrowshape "8 8 3"
		     :tag 'CAR_ARROW)))))

  (define (draw-car-text x y d text)
    (let ((pos (car-arrow-pos x y d)))
      (if (<= (text-width text font) grid-h)
	  (c 'create 'text (caddr pos) (cadddr pos)
	     :anchor "n" :font font :text text :tag 'CAR_TEXT)
	  (let* ((text-l [label (& c "." (gensym "__g"))
				:relief "groove" :bd 2
				:text text :anchor "w" :font font])
		 (item (c 'create 'window (caddr pos) (+ 2 (cadddr pos))
			  :window text-l :anchor "n" :width (- grid-h 2)
			  :tags 'LONG_CAR_TEXT)))
	    (bind text-l "<Enter>" 
		  `(,(widget-name c) 'itemconfig ,item
				     :width ,(+ 3 (text-width text font))))
	    (bind text-l "<Leave>" 
		  `(,(widget-name c) 'itemconfig ,item
				     :width ,(- grid-h 2)))))))

  (define (cdr-arrow-pos x y d)
    (let ((h (x-h x)) (v (y-v y)))
      (list (+ h (quotient (* cons-h 3) 4)) (+ v cons-v/2)
	    (+ h (quotient (* cons-h 3) 4)
	       (- (* d grid-h) (+ (quotient (* cons-h 3) 4) arrow-space)))
	    (+ v cons-v/2))))
  
  (define (draw-cdr-arrow x y d) ; draw arrow to the right 'd' grid squares
    (let ((pos (cdr-arrow-pos x y d)))
      (eval `(,c 'create 'line ,@pos :arrow "last" :arrowshape "8 8 3"
		 :tag 'CDR_ARROW))))

  (define (draw-cdr-text x y d text)
    (let ((pos (cdr-arrow-pos x y d)))
      (c 'create 'text (caddr pos) (cadddr pos)
	 :anchor "w" :font font :text text :tag 'CDR_TEXT)))

  (define (draw-nil x y) ; draw nil in cdr of cons cell
    (let ((h (x-h x)) (v (y-v y)))
      (c 'create 'line (+ h cons-h/2) v (+ h cons-h) (+ v cons-v))
      (c 'create 'line (+ h cons-h/2) (+ v cons-v -1) (+ h cons-h) (- v 1))))

  (define (object-length obj-val)
    (cond ((null? obj-val) 0)
	  ((pair? obj-val) (+ 1 (object-length (cdr obj-val))))
	  (else (+ 1 (quotient (text-width (->object obj-val) font)
				 grid-h)))))
    
  (define (initial-profile) 0)
  (define (car-profile p) (if (pair? p) (car p) p))
  (define (cdr-profile p) (if (pair? p) (cdr p) p))

  (define (make-profile len p)
    (define (fit1 len p)
      (if (> len 1)
	  (let ((p* (fit1 (- len 1) (cdr-profile p))))
	    (cons (car-profile p*) p*))
	  (fit2 (+ (car-profile p) 1) p)))
    (define (fit2 y p)
      (if (pair? p)
	  (cons (max y (car-profile p)) (fit2 y (cdr-profile p)))
	  (max y p)))
    (fit1 len p))

  (define (draw-list lst x y p)
    (draw-cons-cell x y)
    (let* ((tail (cdr lst))
	   (tail-p (cdr-profile p))
	   (new-p (cond ((null? tail)
			 (draw-nil x y)
			 tail-p)
			((pair? tail)
			 (draw-cdr-arrow x y 1)
			 (draw-list tail (+ x 1) y tail-p))
			(else
			 (draw-cdr-arrow x y 1)
			 (draw-cdr-text x y 1 (->object tail))
			 tail-p))))
      (draw-object (car lst) x y (cons (car-profile p) new-p))))

  (define (draw-object obj-val x y p)
    (if (pair? obj-val)
        (let* ((len (object-length obj-val))
	       (new-p (make-profile len p))
	       (yy (car-profile new-p)))
	  (draw-car-arrow x y (- yy y))
	  (draw-list obj-val x yy new-p))
	(let ((text (->object obj-val)))
          (draw-car-arrow x y 1)
	  (draw-car-text x y 1 text)
          (make-profile 1 p))))

  (c 'delete 'all)
  (draw-object obj-val 0 0 (initial-profile))
  (adjust-scrollregion c 20))


;---- Widget viewer -----------------------------------------------------------

(define show-widget
  (let ((bg-color ())
	(box-color ()))
    (lambda (obj item press)
      (let* ((canv-w (view-c-wid (inspect::eval obj)))
	     (tags (canv-w 'gettags item))
	     (wid (inspect::eval (list-ref tags 1))))
	(if press
	    (begin
	      (set! box-color (tki-get canv-w item :fill))
	      (set! bg-color (tk-get wid :bg))
	      (tki-set canv-w item :fill "magenta")
	      (tk-set! wid :bg "magenta"))
	    (begin
	      (tki-set canv-w item :fill box-color)
	      (tk-set! wid :bg bg-color)))))))

(define (inspect-sub-widget obj who)
  (catch 
   (inspect (inspect::eval (list-ref ((view-c-wid obj) 'gettags who) 1)))))

(define (view-widget-create obj)
  (define w (view-create-toplevel obj))
  (define obj-val (inspect::eval obj))
  (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  (pack [frame (& w ".menu.level")] :side "left")
  (pack [label (& w ".menu.level.l") :text "Level"] :side "left")
  (pack [entry (& w ".menu.level.e") :relief "sunken" :bd 2 :width 4]
	:side "left")
  ((widget w ".menu.level.e") 'insert 0 9999)
  (bind (widget (view-tl-str obj) ".menu.level.e") "<Return>"
	`(view-widget-modify-level ',(object-symbol obj)))

  (define c (view-c-wid obj))
  (c 'bind '|CLASS| "<Double-1>" 
     `(inspect-sub-widget ,(widget-name obj-val) 
			  'current))
  (c 'bind '|CLASS_NAME| "<Double-1>" 
     `(inspect-sub-widget ,(widget-name obj-val) 
			  (car (,(widget-name c) 'find 'below 'current))))

  (c 'bind '|CLASS| "<ButtonPress-1>" 
     		    `(show-widget ,(widget-name obj-val) 'current #t))
  (c 'bind '|CLASS| "<ButtonRelease-1>" 
		    `(show-widget ,(widget-name obj-val) 'current #f))
  (c 'bind '|CLASS_NAME| "<ButtonPress-1>"
     `(show-widget ,(widget-name obj-val)
		   (car (,(widget-name c) 'find 'below 'current)) #t))
  (c 'bind '|CLASS_NAME| "<ButtonRelease-1>"
     `(show-widget ,(widget-name obj-val) 
		   (car (,(widget-name c) 'find 'below 'current)) #f))
  (view-widget-display obj))

(define (view-widget-set-level obj level)
  ((widget (view-tl-str obj) ".menu.level.e") 'delete 0 'end)
  ((widget (view-tl-str obj) ".menu.level.e") 'insert 0 level))

(define (view-widget-get-level obj)
  (let ((level ((widget (view-tl-str obj) ".menu.level.e") 'get)))
    (if (equal? "" level) 9999 (string->number level))))

(define (view-widget-modify-level key)
  (let ((obj (find-object-infos key)))
    (unless (view-widget-get-level obj) (view-widget-set-level obj 9999))
    (view-widget-clear obj)
    (view-widget-display obj)))

(define (get-children wid)
  (let ((children (winfo 'children wid)))
    (if (list? children) children (list children))))

(define (view-widget-clear obj) ((view-c-wid obj) 'delete 'all))

(define (view-widget-display obj)
  (wm 'title (view-tl-wid obj) "Widget viewer")
  (define obj-wid obj)
  (define canv (view-c-wid obj))
  (define h-grid 60)
  (define v-grid 40)
  (define h-box 80) (define h-box/2 (/ h-box 2))
  (define v-box 20) (define v-box/2 (/ v-box 2))
  (define y-global 40)
  (define level (view-widget-get-level obj))
  (define level-min level)
  (define (_display wid x level)
    (let* ((name (winfo 'name wid))
	   (class (winfo 'class wid))
;	   (children (winfo 'children wid))
	   (children (get-children wid))
	   (y y-global))
      (canv 'create 'rectangle (- x h-box/2) (- y v-box) (+ x h-box/2) y 
	    :fill "gray90" :tags (format #f "CLASS ~a" (->string wid)))
      (canv 'create 'text x (- y v-box/2)
	    :anchor "center" :text class :font HELVETICA_MO12 
	    :tags "CLASS_NAME")
      (canv 'create 'text (+ x h-box/2 10) (- y v-box/2)
	    :anchor "w" :text name :font HELVETICA_BR12)
      (if (null? children)
	  (set! level-min (min level level-min))
	  (if (> level 0)
	      (let ((y-child y))
		(for-each
		 (lambda (child)
		   (set! y-global (+ y-global v-grid))
		   (set! y-child y-global)
		   (_display child (+ x h-grid) (- level 1)))
		 children)
		(canv 'create 'line x y x (- y-child v-box/2)))
	      (begin
		(set! level-min 0)
		(canv 'create 'line x y x (+ y v-box/2) :stipple "gray50"))))
      (unless (equal? obj-wid wid)
	      (canv 'create 'line 
		    (- x h-box/2) (- y v-box/2) (- x h-grid) (- y v-box/2)))))

  (set-id-object (& (view-tl-str obj) ".id") (format #f "~S" obj))
  (set-id-value (& (view-tl-str obj) ".id") (format #f "~S" (inspect::eval obj)))
  ((view-c-wid obj) 'delete 'all)
  (_display obj-wid 0 level)
  (view-widget-set-level obj (- level level-min))
  (adjust-scrollregion canv 20))

(define (adjust-scrollregion canv offset)
  (multiple-value-bind (x1 y1 x2 y2) (canv 'bbox 'all)
		       (tk-set! canv :scrollregion
				(&& (- x1 offset) (- y1 offset)
				    (+ x2 offset) (+ y2 offset))))
  (canv 'xview 'moveto 0)
  (canv 'yview 'moveto 0))

(define (view-widget obj)
  (view-widget-create obj)
  (view-widget-display obj))