681 lines
25 KiB
Plaintext
681 lines
25 KiB
Plaintext
;******************************************************************************
|
|
;
|
|
; 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)))))
|
|
|