stk/Lib/inspect-detail.stk

681 lines
25 KiB
Plaintext
Raw Permalink Normal View History

1996-09-27 06:29:02 -04:00
;******************************************************************************
;
; 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))
1998-04-10 06:59:06 -04:00
'(list pair vector closure widget stklos))
1996-09-27 06:29:02 -04:00
[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)
1998-04-10 06:59:06 -04:00
((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)))))
1996-09-27 06:29:02 -04:00
(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))
1998-04-10 06:59:06 -04:00
(if (inspected? obj)
((inspect-m-wid obj) 'entryconfigure "Detail" :state 'normal))
(if (viewed? obj)
((view-m-wid obj) 'entryconfigure "View" :state 'normal))
1996-09-27 06:29:02 -04:00
(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
1998-04-10 06:59:06 -04:00
(if (winfo 'exists top)
1996-09-27 06:29:02 -04:00
(destroy top))))
(define (detail-display obj)
(case (inspect::typeof (inspect::eval obj))
((vector pair list) (detail-VPL-display obj))
((closure) (detail-procedure-display obj))
1998-04-10 06:59:06 -04:00
((widget) (detail-widget-display obj))
((stklos) (detail-stklos-display obj))))
1996-09-27 06:29:02 -04:00
;---- 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)
1998-04-10 06:59:06 -04:00
((widget (detail-tl-str obj) ".menu.command.m") 'entryconfigure "Inspect" :state 'disabled)
(if (viewed? obj)
((view-w-wid obj) 'entryconfigure "Inspect" :state 'disabled))))
1996-09-27 06:29:02 -04:00
(define (detail-menu-Undetail key) (undetail (find-object-infos key)))
(define (detail-menu-View key)
(let ((obj (find-object-infos key)))
(view obj)
1998-04-10 06:59:06 -04:00
((widget (detail-tl-str obj) ".menu.command.m") 'entryconfigure "View" :state 'disabled)
(if (inspected? obj)
((inspect-m-wid obj) 'entryconfigure "View" :state 'disabled))))
1996-09-27 06:29:02 -04:00
;---- 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"
1998-04-10 06:59:06 -04:00
:command `(detail-menu-Inspect ',(object-symbol obj))
:state (if (inspected? obj) 'disabled 'normal))
1996-09-27 06:29:02 -04:00
(cmd-w 'add 'command :label "Undetail"
:command `(detail-menu-Undetail ',(object-symbol obj)))
(cmd-w 'add 'command :label "View"
1998-04-10 06:59:06 -04:00
:command `(detail-menu-View ',(object-symbol obj))
:state (if (viewed? obj) 'disabled 'normal))
1996-09-27 06:29:02 -04:00
(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)
1998-04-10 06:59:06 -04:00
; 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")
1996-09-27 06:29:02 -04:00
(pack [scrollbar (& w ".list.vsb") :orient "vertical"]
1998-04-10 06:59:06 -04:00
[listbox (& w ".list.lb1") :relief "raised" :bd 2]
1996-09-27 06:29:02 -04:00
:side "left" :fill "y")
(pack [listbox (& w ".list.lb2") :relief "raised" :bd 2]
:fill "both" :expand "yes")
1998-04-10 06:59:06 -04:00
; what's this do ??
; (tk-listbox-single-select (& w ".list.lb1") (& w ".list.lb2"))
1996-09-27 06:29:02 -04:00
(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))
1998-04-10 06:59:06 -04:00
; 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)))
1996-09-27 06:29:02 -04:00
(detail-VPL-display obj))
1998-04-10 06:59:06 -04:00
1996-09-27 06:29:02 -04:00
(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)))
1998-04-10 06:59:06 -04:00
;; ------------------ stklos detailer --------------------------
1996-09-27 06:29:02 -04:00
1998-04-10 06:59:06 -04:00
;; 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...
1996-09-27 06:29:02 -04:00
1998-04-10 06:59:06 -04:00
;; 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))))
1996-09-27 06:29:02 -04:00
;---- 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"
1998-04-10 06:59:06 -04:00
:command (lambda l
(apply (string->widget (& w ".body.t")) 'yview l))]
1996-09-27 06:29:02 -04:00
: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)))))