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

(provide "inspect-detail")

(define Bug-correction read-from-string)
;---- detailer widget

(define DETAILER_WIDGET_NAME ".detailer")
(define detailed-objects-list ())

(define (detail-tl-wid obj) (widget DETAILER_WIDGET_NAME (object-symbol obj)))
(define (detail-tl-str obj) (& DETAILER_WIDGET_NAME (object-symbol obj)))
(define (detail-l-wid obj) (widget (detail-tl-str obj) ".f1.l"))
(define (detail-l-str obj) (& (detail-tl-str obj) ".f1.l"))
(define (detail-e-wid obj) (widget (detail-tl-str obj) ".f1.e"))
(define (detail-e-str obj) (& (detail-tl-str obj) ".f1.e"))
(define (detail-m-wid obj) (widget (detail-tl-str obj) ".menu.command.m"))
(define (detail-m-str obj) (& (detail-tl-str obj) ".menu.command.m"))

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

(define (detail obj)
  (if (member (inspect::typeof (inspect::eval obj))
	      '(list pair vector closure widget stklos))
      [unless (detailed? obj) (detail-object obj)]
      [error "The object ~s can not be detailed" obj]))

(define (detail-object obj)
  (set! detailed-objects-list (cons obj detailed-objects-list))
  (unless (object-infos obj)
	  (add-object-infos obj)
	  (if (symbol? obj) (trace-var obj `(update-object ',obj))))
  (let ((obj-val (inspect::eval obj)))
    (case (inspect::typeof obj-val)
      ((list pair vector)
       (detail-VPL obj))
      ((closure)
       (detail-procedure obj))
      ((widget)
       (when (winfo 'exists (detail-tl-wid obj-val)) (detail-widget obj)))
      ((stklos)
       (detail-stklos obj)))))

(define (undetail obj)
  (if (detailed? obj) (undetail-object obj)))

(define (undetail-object obj)
  (let ((top (detail-tl-wid obj)))
    (set! detailed-objects-list (list-remove obj detailed-objects-list))
    (if (inspected? obj)
	((inspect-m-wid obj) 'entryconfigure "Detail" :state 'normal))
    (if (viewed? obj)
	((view-m-wid obj) 'entryconfigure "View" :state 'normal))
    (unless (or (inspected? obj) (viewed? 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 (detail-display obj)
  (case (inspect::typeof (inspect::eval obj))
    ((vector pair list) (detail-VPL-display obj))
    ((closure) (detail-procedure-display obj))
    ((widget) (detail-widget-display obj))
    ((stklos) (detail-stklos-display obj))))


;---- Detailer menu -----------------------------------------------------------

(define (detail-menu-Eval entry obj)
  (eval-string (format #f "(set! ~a ~a)" obj [entry 'get])))

(define (detail-menu-Quote entry obj)
  (eval-string (format #f "(set! ~a '~a)" obj [entry 'get])))

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

(define (detail-menu-Undetail key) (undetail (find-object-infos key)))

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


;---- VPL menu ----------------------------------------------------------------

(define (get-VPL-index obj)
  (let ((s (tk-get (VPL-l-wid obj) :text)))
    (string->number (substring s 6 (string-length s)))))

(define (get-VPL-value obj) [(VPL-e-wid obj) 'get])

(define (set-VPL-index&value obj index)
  (tk-set! (VPL-l-wid obj) :text (& "Value " index))
  (let ((value-w (VPL-e-wid obj)))
    (value-w 'delete 0 'end)
    (value-w 'insert 0 (->object (Bug-correction [(VPL-vlb-wid obj) 'get index])))))

(define (VPL-menu-Eval obj)
  (define index (get-VPL-index obj))
  ((VPL-vlb-wid obj) 'delete index)
  ((VPL-vlb-wid obj) 'insert index
		     (->object (eval-string (get-VPL-value obj))))
  (modify-VPL obj))

(define (VPL-menu-Quote obj)
  (define index (get-VPL-index obj))
  ((VPL-vlb-wid obj) 'delete index)
  ((VPL-vlb-wid obj) 'insert index (get-VPL-value obj))
  (modify-VPL obj))


;---- VPL detailer ------------------------------------------------------------

(define (VPL-l-wid obj) (widget (detail-tl-str obj) ".value.l"))
(define (VPL-l-str obj) (& (detail-tl-str obj) ".value.l"))
(define (VPL-e-wid obj) (widget (detail-tl-str obj) ".value.e"))
(define (VPL-e-str obj) (& (detail-tl-str obj) ".value.e"))
(define (VPL-ilb-wid obj) (widget (detail-tl-str obj) ".list.lb1"))
(define (VPL-ilb-str obj) (& (detail-tl-str obj) ".list.lb1"))
(define (VPL-vlb-wid obj) (widget (detail-tl-str obj) ".list.lb2"))
(define (VPL-vlb-str obj) (& (detail-tl-str obj) ".list.lb2"))

(define (create-detail-toplevel-widget obj)
  (define w (create-toplevel-widget (detail-tl-str obj)))
  (define id-w (widget w ".id"))
  (define menu-w (widget w ".menu"))
  (set-id-label1 id-w "Object" 6)
  (set-id-label2 id-w "Value" 6)
  ((widget menu-w ".help.m") 'add 'command :label "Detailer"
			     :command '(stk:make-help Detailer-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 `(detail-menu-Inspect ',(object-symbol obj))
		       :state (if (inspected? obj) 'disabled 'normal))
  (cmd-w 'add 'command :label "Undetail"
	 	       :command `(detail-menu-Undetail ',(object-symbol obj)))
  (cmd-w 'add 'command :label "View" 
		       :command `(detail-menu-View ',(object-symbol obj))
		       :state (if (viewed? obj) 'disabled 'normal))

  (if (modifiable-object? obj)
      [begin
	(bind (widget w ".id.f2.e") "<Return>" 
	      `(detail-menu-Eval |%W| ',obj))
	(bind (widget w ".id.f2.e") "<Shift-Return>" 
	      `(detail-menu-Quote |%W| ',obj))]
      [begin
	(set-id-value id-w (format #f "~S" (inspect::eval obj)))
	(inspect::shadow-entry (widget w ".id.f2.e"))])
  
  (bind w "<Destroy>" `(detail-menu-Undetail ',obj))
  w)

(define (detail-VPL obj)
  (define w (create-detail-toplevel-widget obj))
  ((widget w ".menu.help.m") 'add 'command)
  (tk-set! (widget w ".id.f1.l2") :width 20)
  (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  (pack [frame (& w ".value")] :side "top" :fill "x" :padx 4 :pady 2)
  (pack [label (& w ".value.l") :text "Value 0"] :side "left")
  (pack [entry (& w ".value.e") :relief "sunken" :bd 2] :fill "x")
  (pack [frame (& w ".list") :relief "sunken" :bd 2]
	:fill "both" :expand "yes" :padx 4 :pady 2)
; geometry option is not valid
;  (pack [scrollbar (& w ".list.vsb") :orient "vertical"]
;	[listbox (& w ".list.lb1") :relief "raised" :bd 2 :geometry "4x8"]
;	:side "left" :fill "y")
  (pack [scrollbar (& w ".list.vsb") :orient "vertical"]
	[listbox (& w ".list.lb1") :relief "raised" :bd 2]
	:side "left" :fill "y")
  (pack [listbox (& w ".list.lb2") :relief "raised" :bd 2]
	:fill "both" :expand "yes")
; what's this do ??
;  (tk-listbox-single-select (& w ".list.lb1") (& w ".list.lb2"))
  (if (modifiable-object? obj)
      [begin
	(bind (widget w ".value.e") "<Return>" `(VPL-menu-Eval ',obj))
	(bind (widget w ".value.e") "<Shift-Return>" `(VPL-menu-Quote ',obj))]
      [inspect::shadow-entry (widget w ".value.e")])

  (bind (widget w ".list.lb1") "<Button-1>" `(VPL-select ',obj %y))
  (bind (widget w ".list.lb2") "<Button-1>" `(VPL-select ',obj %y))

  ; set the scroll command for the listbox
  (tk-set! (widget w ".list.lb1")
	   :yscroll (& w ".list.vsb 'set"))

  ; set up the scroll command for the scrollbar to adjust the view in
  ; BOTH listboxes
  (tk-set! (widget w ".list.vsb")
	   :command (lambda l (apply (widget w ".list.lb1") 'yview l)
		      (apply (widget w ".list.lb2") 'yview l)))
  (detail-VPL-display obj))


(define (VPL-select obj y)
  (let ((index-w (VPL-ilb-wid obj))
	(value-w (VPL-vlb-wid obj))
	(entry-w (VPL-e-wid obj))
	(index ()))
    [value-w 'select 'from [value-w 'nearest y]]
    (set! index [value-w 'curselection])
    (tk-set! (VPL-l-wid obj) :text (& "Value " index))
    (let ((state [tk-get entry-w :state]))
      (tk-set! entry-w :state "normal")
      (entry-w 'delete 0 'end)
      [entry-w 'insert 0 (->object (Bug-correction [value-w 'get index]))]
      (tk-set! entry-w :state state))
    [focus entry-w]))
  
(define (scroll-VPL w . param)
  ((widget w ".list.lb1") 'yview (car param))
  ((widget w ".list.lb2") 'yview (car param)))

(define (select-VPL-value w index)
  (let ((index-l (widget w ".value.l"))
	(value-e (widget w ".value.e")))
    (tk-set! index-l :text index)
    (value-e 'delete 0 'end)
    (value-e 'insert 0 (->object 
			(Bug-correction ((widget w ".list.lb2") 'get index))))
    (focus value-e)))

;---- VPL display

(define (detail-VPL-display obj)
  (define id-w (& (detail-tl-str obj) ".id"))
  (set-id-object id-w (->object obj))
  (set-id-value id-w (->object (inspect::eval obj)))
  (case (inspect::typeof (inspect::eval obj))
    ((list) (detail-VPL-display-list obj))
    ((pair) (detail-VPL-display-pair obj))
    ((vector) (detail-VPL-display-vector obj)))
  (let ((index (get-VPL-index obj)))
    (if (< index [(VPL-ilb-wid obj) 'size])
	(set-VPL-index&value obj index)
	(set-VPL-index&value obj 0))))

(define (detail-VPL-display-list obj)
  (define w (detail-tl-wid obj))
  (wm 'title w "List detailer")
  ((widget w ".menu.help.m") 'entryconfig 2 :label "List detailer"
			     :command '(stk:make-help List-detailer-help))
  (let ((obj-val (inspect::eval obj))
	(index-w (VPL-ilb-wid obj))
	(value-w (VPL-vlb-wid obj))
	(index 0))
    (index-w 'delete 0 'end)
    (value-w 'delete 0 'end)
    (until (null? obj-val)
	   (index-w 'insert 'end index)
	   (value-w 'insert 'end (->object (car obj-val)))
	   (set! obj-val (cdr obj-val))
	   (set! index (+ index 1)))))

(define (detail-VPL-display-pair obj)
  (define w (detail-tl-wid obj))
  (wm 'title w "Pair detailer")
  ((widget w ".menu.help.m") 'entryconfig 2 :label "Pair detailer"
			     :command '(stk:make-help Pair-detailer-help))
  (let ((obj-val (inspect::eval obj))
	(index-w (VPL-ilb-wid obj))
	(value-w (VPL-vlb-wid obj))
	(index 0))
    (index-w 'delete 0 'end)
    (value-w 'delete 0 'end)
    (while (pair? obj-val)
	   (index-w 'insert 'end index)
	   (value-w 'insert 'end (->object (car obj-val)))
	   (set! obj-val (cdr obj-val))
	   (set! index (+ index 1)))
    (index-w 'insert 'end (& "." index))
    (value-w 'insert 'end (->object obj-val))))

(define (detail-VPL-display-vector obj)
  (define w (detail-tl-wid obj))
  (wm 'title w "Vector detailer")
  ((widget w ".menu.help.m") 'entryconfig 2 :label "Vector detailer"
			     :command '(stk:make-help Vector-detailer-help))
  (let* ((obj-val (inspect::eval obj))
	 (length (vector-length obj-val))
	 (index-w (VPL-ilb-wid obj))
	 (value-w (VPL-vlb-wid obj)))
    (index-w 'delete 0 'end)
    (value-w 'delete 0 'end)
    (for ((index 0 (+ index 1)))
	 (< index length)
	 (index-w 'insert 'end index)
	 (value-w 'insert 'end (->object (vector-ref obj-val index))))))

;---- VPL modify

(define (modify-VPL obj)
  (case (inspect::typeof (inspect::eval obj))
    ((list) (modify-VPL-list obj))
    ((pair) (modify-VPL-pair obj))
    ((vector) (modify-VPL-vector obj))))

(define (modify-VPL-list obj)
  (let* ((value-w (VPL-vlb-wid obj))
	 (cmd (format #f "(set! ~S '(" obj))
	 (size (value-w 'size)))
    (for ((i 0 (+ i 1)))
	 (< i size)
	 (set! cmd (string-append cmd 
				  (->object (Bug-correction (value-w 'get i)))
				  " ")))
    (set! cmd (string-append cmd "))"))
    (eval-string cmd)))

(define (modify-VPL-pair obj)
  (let* ((value-w (VPL-vlb-wid obj))
	 (cmd (format #f "(set! ~S '(" obj))
	 (size (value-w 'size))
	 (size-1 (- size 1)))
    (for ((i 0 (+ i 1)))
	 (< i size-1)
	 (set! cmd (string-append cmd 
				  (->object (Bug-correction (value-w 'get i)))
				  " ")))
    (set! cmd (string-append cmd 
			     ". " 
			     (->object (Bug-correction (value-w 'get size-1)))
			     "))"))
    (eval-string cmd)))

(define (modify-VPL-vector obj)
  (let* ((value-w (VPL-vlb-wid obj))
	 (cmd (format #f "(set! ~S '#(" obj))
	 (size (value-w 'size)))
    (for ((i 0 (+ i 1)))
	 (< i size)
	 (set! cmd (string-append cmd 
				  (->object (Bug-correction (value-w 'get i)))
				  " ")))
    (set! cmd (string-append cmd "))"))
    (eval-string cmd)))

;; ------------------ stklos detailer --------------------------

;; a shameless rip-off of the VPL procedures.  I'm sure there is some
;; clever way of integrating it into the VPL procedures but I didn't
;; feel like thinking too hard...

;; mostly just Tk display widget set-up

(define (stklos-l-wid obj) (widget (detail-tl-str obj) ".value.l"))
(define (stklos-l-str obj) (& (detail-tl-str obj) ".value.l"))
(define (stklos-e-wid obj) (widget (detail-tl-str obj) ".value.e"))
(define (stklos-e-str obj) (& (detail-tl-str obj) ".value.e"))
(define (stklos-ilb-wid obj) (widget (detail-tl-str obj) ".list.lb1"))
(define (stklos-ilb-str obj) (& (detail-tl-str obj) ".list.lb1"))
(define (stklos-vlb-wid obj) (widget (detail-tl-str obj) ".list.lb2"))
(define (stklos-vlb-str obj) (& (detail-tl-str obj) ".list.lb2"))

(define (get-stklos-index obj)
  (let ((s (tk-get (stklos-l-wid obj) :text)))
    (string->number (substring s 6 (string-length s)))))

(define (get-stklos-value obj) [(stklos-e-wid obj) 'get])

(define (set-stklos-index&value obj index)
  (tk-set! (stklos-l-wid obj) :text (& "Value " index))
  (let ((value-w (stklos-e-wid obj)))
    (value-w 'delete 0 'end)
    (value-w 'insert 0
	     (->object (Bug-correction [(stklos-vlb-wid obj) 'get index])))))

(define (detail-stklos obj)
  (define w (create-detail-toplevel-widget obj))
  ((widget w ".menu.help.m") 'add 'command)
  (tk-set! (widget w ".id.f1.l2") :width 20)
  (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  (pack [frame (& w ".value")] :side "top" :fill "x" :padx 4 :pady 2)
  (pack [label (& w ".value.l") :text "Value 0"] :side "left")
  (pack [entry (& w ".value.e") :relief "sunken" :bd 2] :fill "x")
  (pack [frame (& w ".list") :relief "sunken" :bd 2]
	:fill "both" :expand "yes" :padx 4 :pady 2)
; geometry option is not valid
;  (pack [scrollbar (& w ".list.vsb") :orient "vertical"]
;	[listbox (& w ".list.lb1") :relief "raised" :bd 2 :geometry "4x8"]
;	:side "left" :fill "y")
  (pack [scrollbar (& w ".list.vsb") :orient "vertical"]
	[listbox (& w ".list.lb1") :relief "raised" :bd 2]
	:side "left" :fill "y")
  (pack [listbox (& w ".list.lb2") :relief "raised" :bd 2]
	:fill "both" :expand "yes")
; what's this do ??
;  (tk-listbox-single-select (& w ".list.lb1") (& w ".list.lb2"))
  (if (modifiable-object? obj)
      [begin
	(bind (widget w ".value.e") "<Return>" `(stklos-menu-Eval ',obj))
	(bind (widget w ".value.e") "<Shift-Return>" `(stklos-menu-Quote ',obj))]
      [inspect::shadow-entry (widget w ".value.e")])

  (bind (widget w ".list.lb1") "<Button-1>" `(stklos-select ',obj %y))
  (bind (widget w ".list.lb2") "<Button-1>" `(stklos-select ',obj %y))

  ; set the scroll command for the listbox
  (tk-set! (widget w ".list.lb1")
	   :yscroll (& w ".list.vsb 'set"))

  ; set up the scroll command for the scrollbar to adjust the view in
  ; BOTH listboxes
  (tk-set! (widget w ".list.vsb")
	   :command (lambda l (apply (widget w ".list.lb1") 'yview l)
		      (apply (widget w ".list.lb2") 'yview l)))

  (detail-stklos-display obj))

;; this does the actual display of of the STklos object. It actually
;; displays the slot information as well as the value of the slot.

(define (detail-stklos-display obj)
  (define id-w (& (detail-tl-str obj) ".id"))
  (set-id-object id-w (->object obj))
  (set-id-value id-w (->object (inspect::eval obj)))

  (define w (detail-tl-wid obj))
  (wm 'title w "STklos detailer")
  ((widget w ".menu.help.m") 'entryconfig 2 :label "stklos detailer"
			     :command '(stk:make-help List-detailer-help))

  (let* ((obj-val (class-slots (class-of obj)))
	(slot-name-w (stklos-ilb-wid obj))
	(value-w (stklos-vlb-wid obj))
	(slot (caar obj-val)))
    (slot-name-w 'delete 0 'end)
    (value-w 'delete 0 'end)
    (until (null? obj-val)
	   (set! slot (caar obj-val))

	   ;; insert the slot information
	   (slot-name-w 'insert 'end slot)

	   ;; now insert the actual value of the slot
	   (value-w 'insert 'end (->object
				  (if (slot-bound? obj slot)
				      (slot-ref obj slot)
				    "#[unbound]")))
	   ;; add the rest of the slot information (i.e. accessors',
	   ;; init-keywords, etc...  use this sleazy until loop to go
	   ;; throught the list two-elements at a time
	   (let ((slot-info (cdar obj-val)))
	     (until (null? slot-info)
		    (slot-name-w 'insert 'end (->object (car slot-info)))
		    (value-w 'insert 'end (->object (cadr slot-info)))
		    (set! slot-info (cddr slot-info))))

	   (set! obj-val (cdr obj-val))))

  (let ((index (get-stklos-index obj)))
    (if (< index [(stklos-ilb-wid obj) 'size])
	(set-stklos-index&value obj index))))

;---- Procedure detailer ------------------------------------------------------

(define (inspect::pretty-print body) (pp (uncode body) #f))

(define (detail-procedure-set obj)
  (define text-w (widget (detail-tl-str obj) ".body.t"))
  (eval-string (format #f "(set! ~a ~a)" obj (text-w 'get "1.0" 'end))))

(define (detail-procedure obj)
  (define w (create-detail-toplevel-widget obj))
  (wm 'title w "Procedure detailer")
  (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
  ((widget w ".menu.help.m") 'add 'command :label "Procedure detailer"
			     :command '(stk:make-help Procedure-detailer-help))
  (pack [label (& w ".menu.set") :text "Set"] :side "left")
  (bind (widget w ".menu.set") "<ButtonPress-1>" `(detail-procedure-set ',obj))
  (pack [frame (& w ".body") :relief "sunken" :bd 2]
	:fill "both" :expand "yes" :padx 4 :pady 2)
  (pack [scrollbar (& w ".body.vsb")
		   :orient "vertical"
		   :command (lambda l
			      (apply (string->widget (& w ".body.t")) 'yview l))]
	:side "left" :fill "y")
  (pack [text (& w ".body.t")
	      :relief "raised" :bd 2 :width 60 :height 16
	      :yscroll (format #f "~a 'set" (& w ".body.vsb"))]
	:fill "both" :expand "yes")
  (detail-procedure-display obj))

(define (detail-procedure-display obj)
  (define obj-val (inspect::eval obj))
  (define id-w (& (detail-tl-str obj) ".id"))
  (set-id-object id-w (->object obj))
  (set-id-value id-w (->object obj-val))
  (define body (procedure-body obj-val))
  (define text-w (widget (detail-tl-str obj) ".body.t"))
  (tk-set! text-w :state "normal")
  (text-w 'delete "1.0" 'end)
  (text-w 'insert "1.0" (inspect::pretty-print body))
  (unless (symbol? obj)
     (inspect::shadow-entry text-w)))


;---- Widget detailer ---------------------------------------------------------

(define (detail-widget obj)
  (define w (create-detail-toplevel-widget obj))
  (wm 'title w "Widget detailer")
  (tk-set! (widget w ".id.f1.l2") :width 40)
  ((widget w ".menu.help.m") 'add 'command :label "Widget detailer"
			     :command '(stk:make-help Widget-detailer-help))
  (pack [menubutton (& w ".menu.bindings") :text "Bindings"] :side "left")
  (tk-set! (widget w ".menu.bindings") :menu [menu (& w ".menu.bindings.m")])
  (detail-widget-create-options obj)
  (detail-widget-display obj))

(define (detail-widget-create-options obj)
  (define w-str (detail-tl-str obj))
  (catch (destroy (& w-str ".options")))
  (pack [frame (& w-str ".options") :relief "raised" :bd 2]
	:fill "both" :expand "yes" :padx 4 :pady 2)
  (pack [frame (& w-str ".options.class")] 
	:side "top" :fill "x" :padx 4 :pady 4)
  (pack [label (& w-str ".options.class.l1")
	       :text "Class" :width 16 :anchor "e"]
	:side "left")
  (pack [label (& w-str ".options.class.l2")
	       :relief "groove" :bd 2 :anchor "w" :font ITALIC-MEDIUM_FONT]
	:fill "x")
  (let ((options-infos ((eval obj) 'config))
	(i 1))
    (for-each
     (lambda (infos)
       (if (= 5 (length infos))
	   (let ((option-w (& w-str ".options.f" i))
		 (s        (symbol->string (car infos))))
	     (pack [frame option-w] :side "top" :fill "x" :padx 4)
	     (pack [label (& option-w ".l")
			  :text (substring s 1 (string-length s))
			  :width 16 :anchor "e"]
		   :side "left")
	     (pack [entry (& option-w ".e") :relief "sunken" :bd 2] :fill "x")
	     (bind (& option-w ".e") "<Return>"      `(WID-eval-option ',obj |%W|))
	     (bind (& option-w ".e") "<Shift-Return>"`(WID-quote-option ',obj |%W|))
	     (set! i (+ i 1)))))
     options-infos))
  (pack [frame (& w-str ".options.children")]
	:side "top" :fill "x" :padx 4 :pady 4)
  (pack [label (& w-str ".options.children.1")
	       :text "Children" :width 16 :anchor "e"]
	:side "left")
  (pack [entry (& w-str ".options.children.e")
	       :relief "groove" :bd 2 :state "disabled" :font MEDIUM_FONT]
	:fill "x")
  (update 'idletasks)
  (define req-h (winfo 'reqheight w-str))
  (wm 'minsize w-str 0 req-h)
  (wm 'maxsize w-str SCREEN_WIDTH req-h))

(define (WID-bindings-menu-str obj) (& (detail-tl-str obj) ".menu.bindings.m"))
(define (WID-bindings-menu-wid obj)
  (widget (detail-tl-str obj) ".menu.bindings.m"))

(define (binding->string binding)
  (let ((binding (if (string? binding) binding (symbol->string binding))))
    (substring binding 1 (- (string-length binding) 1))))

(define (WID-bindings-menu-add obj binding)
  (if (catch ((WID-bindings-menu-wid obj) 'index binding))
      ((WID-bindings-menu-wid obj) 'add 'command 
	   :label    (symbol->string binding)
	   :command `(show-binding ',(object-symbol obj) 
				   ,(symbol->string  binding)))))

(define (show-binding key binding)
  (let* ((obj     (find-object-infos key))
	 (obj-val (inspect::eval obj))
	 (name    (string-lower (binding->string binding)))
	 (body    (bind obj-val binding)))
    
    (if (null? body) (set! body (bind (winfo 'class obj-val) binding)))
    ((WID-bindings-menu-wid obj) 'disable binding)
    (define w (& (detail-tl-str obj) "._" name))
    (create-toplevel-widget w)
    (wm 'title w "Widget binding")
    (wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
    (set-id-label1 (& w ".id") "Widget" 6)
    (set-id-object (& w ".id") (->object obj))
    (set-id-label2 (& w ".id") "Binding" 6)
    (set-id-value (& w ".id") binding)
    (inspect::shadow-entry (string->widget (& w ".id.f2.e")))
    (pack [button (& w ".menu.dismiss") 
		  :text "Dismiss" 
		  :relief "flat"
		  :command `(begin 
			      ((WID-bindings-menu-wid ,obj-val) 
			       		'enable ',binding)
			      (destroy ,w))]
	  :side "left")

    (pack [button (& w ".menu.set") 
		  :text "Set binding"
		  :relief "flat"
		  :command `(bind ,obj-val ,binding [(widget ,w ".body.t")
						     'get "1.0" 'end])]
	  :side "left")
    (pack [frame (& w ".body") :relief "sunken" :bd 2]
	  :fill "both" :expand "yes" :padx 4 :pady 2)
    (pack [scrollbar (& w ".body.vsb") :orient "vertical"]
	  :side "left" :fill "y")
    (pack [text (& w ".body.t") :relief "raised" :bd 2 :width 60 :height 8]
	  :fill "both" :expand "yes")
    ((widget w ".body.t") 'insert "1.0" (inspect::pretty-print body))))


(define (detail-widget-display obj)
  (define obj-val (inspect::eval obj))
  (define w-str (detail-tl-str obj))
  (define id-w (widget w-str ".id"))
  (set-id-object id-w (->object obj))
  (set-id-value id-w (->object obj-val))
  (tk-set! (widget w-str ".options.class.l2") :text (winfo 'class obj-val))
  (define children-w (widget w-str ".options.children.e"))
  (tk-set! children-w :state "normal")
  (children-w 'delete 0 'end)
  (children-w 'insert 0 (winfo 'children obj-val))
  (tk-set! children-w :state "disabled")
  (let ((options-infos (obj-val 'config))
	(i 1))
    (for-each
     (lambda (infos)
       (if (= 5 (length infos))
	   (let ((option-w (widget w-str ".options.f" i ".e")))
	     (option-w 'delete 0 'end)
	     (option-w 'insert 0 (list-ref infos 4))
	     (set! i (+ i 1)))))
     options-infos))
  (define menu-w (WID-bindings-menu-wid obj))
  (menu-w 'delete 0 'last)
  (for-each (lambda (binding) (WID-bindings-menu-add obj binding))
	    (bind obj-val))
  (menu-w 'add 'separator)
  (for-each (lambda (binding) (WID-bindings-menu-add obj binding))
	    (bind [winfo 'class obj-val])))

(define (WID-eval-option obj window)
  (let ((parent (winfo 'parent window)))
    (eval-string 
     (format #f "(tk-set! ~a :~a ~s)"
	        obj
		(tk-get (widget parent ".l") :text)
		(eval-string (window 'get))))))

(define (WID-quote-option obj window)
 (let ((parent (winfo 'parent window)))
    (eval-string 
     (format #f "(tk-set! ~a :~a ~s)"
	        obj
		(tk-get (widget parent ".l") :text)
		(window 'get)))))