stk/Lib/inspect-main.stk

193 lines
7.3 KiB
Plaintext

;******************************************************************************
;
; Project : STk-inspect, a graphical debugger for STk
;
; File name : inspect-main.stk
; Creation date : Aug-10-1993
; Last update : Sep-17-1993
;
;******************************************************************************
;
; This file implements the "General inspector".
;
;******************************************************************************
(provide "inspect-main")
(load "inspect-misc")
(load "inspect-view")
(load "inspect-detail")
(load "inspect-help")
(define INSPECTOR_WIDGET_NAME ".inspector")
(define inspected-objects-list ())
(define (inspected? obj) (member obj inspected-objects-list))
(define (inspect-frame-wid obj)
(widget INSPECTOR_WIDGET_NAME ".f1." (object-symbol obj)))
(define (inspect-frame-str obj)
(& INSPECTOR_WIDGET_NAME ".f1." (object-symbol obj)))
(define (inspect-l-wid obj) (widget (inspect-frame-str obj) ".l"))
(define (inspect-l-str obj) (& (inspect-frame-str obj) ".l"))
(define (inspect-e-wid obj) (widget (inspect-frame-str obj) ".e"))
(define (inspect-e-str obj) (& (inspect-frame-str obj) ".e"))
(define (inspect-mb-wid obj) (widget (inspect-frame-str obj) ".mb"))
(define (inspect-mb-str obj) (& (inspect-frame-str obj) ".mb"))
(define (inspect-m-str obj) (& (inspect-frame-str obj) ".mb.m"))
(define (inspect-m-wid obj) (widget (inspect-frame-str obj) ".mb.m"))
;---- Inspector menu
(define (create-inspect-menu obj)
(define w (eval [menu (inspect-m-str obj)]))
(w 'add 'command :label "Uninspect"
:command `(inspect-menu-Uninspect ',(object-symbol obj)))
(w 'add 'command :label "Detail"
:command `(inspect-menu-Detail ',(object-symbol obj)))
(if (detailed? obj) ((inspect-m-wid obj) 'entryconfigure "Detail" :state 'disabled))
(w 'add 'command :label "View"
:command `(inspect-menu-View ',(object-symbol obj)))
(if (viewed? obj) ((inspect-m-wid obj) 'entryconfigure "View" :state 'disabled)))
(define (inspect-menu-Eval obj)
(eval-string (format #f "(set! ~a ~a)" obj ((inspect-e-wid obj) 'get))))
(define (inspect-menu-Quote obj)
(eval-string (format #f "(set! ~a '~a)" obj ((inspect-e-wid obj) 'get))))
(define (inspect-menu-Uninspect key)
(uninspect (find-object-infos key)))
(define (inspect-menu-Detail key)
(let ((obj (find-object-infos key)))
(detail obj)
((inspect-m-wid obj) 'entryconfigure "Detail" :state 'disabled)
(if (viewed? obj)
((view-m-wid obj) 'entryconfigure "View" :state 'disabled))))
(define (inspect-menu-View key)
(let ((obj (find-object-infos key)))
(view obj)
((inspect-m-wid obj) 'entryconfigure "View" :state 'disabled)
(if (detailed? obj) ((detail-m-wid obj) 'entryconfigure "View" :state 'disabled))))
(define (create-inspector)
(define w [toplevel INSPECTOR_WIDGET_NAME])
(wm 'title w "General inspector")
(wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
(define menu-w (create-menu-widget (& INSPECTOR_WIDGET_NAME ".menu")))
(pack menu-w :side "top" :fill "x" :padx 4 :pady 2)
((widget menu-w ".help.m") 'add 'command :label "General inspector"
:command '(stk:make-help General-Inspector-help))
(pack [menubutton (& INSPECTOR_WIDGET_NAME ".menu.command") :text "Command"]
:side "left")
(define cmd-w (eval [menu (& INSPECTOR_WIDGET_NAME ".menu.command.m")]))
(cmd-w 'add 'command :label "Uninspect all" :command '(destroy-inspector))
(cmd-w 'add 'command :label "Undebug" :command '(undebug))
(tk-set! (widget INSPECTOR_WIDGET_NAME ".menu.command") :menu cmd-w)
(pack [frame (& INSPECTOR_WIDGET_NAME ".caption")]
:side "top" :fill "x" :padx 4)
(pack [label (& INSPECTOR_WIDGET_NAME ".caption.l1")
:text "Objects" :width 20]
:side "left")
(pack [label (& INSPECTOR_WIDGET_NAME ".caption.l2")
:text "Values" :width 40]
:side "left" :padx 4)
(pack [frame (& INSPECTOR_WIDGET_NAME ".f1")]
:fill "both" :expand "yes" :padx 4 :pady 2))
(define (destroy-inspector)
(for-each uninspect-object inspected-objects-list))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; inspect
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (inspect obj)
(when (not (winfo 'exist INSPECTOR_WIDGET_NAME)) (create-inspector))
;; Kludge to avoid problems . Should be modified [eg]
(let ((obj-val (inspect::eval obj)))
(when (eqv? (inspect::typeof obj-val) 'widget)
(set! obj obj-val)))
(unless (inspected? obj)
(inspect-object obj)
(let ((obj-val (format #f "~S" (inspect::eval obj))))
(pack [frame (inspect-frame-str obj)] :side "top" :fill "x")
(pack [menubutton (inspect-mb-str obj)
:relief "raised" :bd 2 :bitmap BITMAP_MENU]
:side "right")
(pack [label (inspect-l-str obj) :relief "groove" :bd 2
:anchor "w" :text (format #f "~S" obj)
:width 20 :font MEDIUM_FONT]
:side "left")
(pack [entry (inspect-e-str obj) :relief "sunken" :bd 2 :width 40]
:fill "x" :expand "yes" :padx 4)
(create-inspect-menu obj)
(tk-set! (inspect-mb-wid obj) :menu (inspect-m-wid obj))
(let ((E (inspect-e-wid obj)))
(E 'insert 0 obj-val)
;; If obj is a symbol, lets the entry modifiable. Otherwise let it as is
(if (modifiable-object? obj)
[begin
(bind E "<Return>" `(inspect-menu-Eval ',obj))
(bind E "<Shift-Return>" `(inspect-menu-Quote ',obj))]
[inspect::shadow-entry E]))))
;; Destroy Event -> set the list of inspected object to '()
(bind INSPECTOR_WIDGET_NAME "<Destroy>" '(set! inspected-objects-list '()))
;; Allow resizing only in width
(update 'idletasks)
(let ((req-h (winfo 'reqheight INSPECTOR_WIDGET_NAME)))
(wm 'minsize INSPECTOR_WIDGET_NAME 0 req-h)
(wm 'maxsize INSPECTOR_WIDGET_NAME SCREEN_WIDTH req-h)
(wm 'geometry INSPECTOR_WIDGET_NAME
(& (winfo 'width INSPECTOR_WIDGET_NAME) "x" req-h))))
(define (inspect-object obj)
(set! inspected-objects-list (cons obj inspected-objects-list))
(unless (object-infos obj)
(add-object-infos obj)
(if (symbol? obj) (trace-var obj `(update-object ',obj)))))
(define (inspect-display obj)
(let ((entry-w (inspect-e-wid obj)))
(entry-w 'delete 0 'end)
(entry-w 'insert 0 (->object (eval obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; uninspect
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (uninspect obj)
(when (inspected? obj) (uninspect-object obj))
(update 'idletasks)
(when (winfo 'exist INSPECTOR_WIDGET_NAME)
(let ((req-h (winfo 'reqheight INSPECTOR_WIDGET_NAME)))
(wm 'minsize INSPECTOR_WIDGET_NAME 0 req-h)
(wm 'maxsize INSPECTOR_WIDGET_NAME SCREEN_WIDTH req-h)
(wm 'geometry INSPECTOR_WIDGET_NAME
(& (winfo 'width INSPECTOR_WIDGET_NAME) "x" req-h)))))
(define (uninspect-object obj)
(set! inspected-objects-list (list-remove obj inspected-objects-list))
(destroy (inspect-frame-wid obj))
(when (null? inspected-objects-list) (destroy INSPECTOR_WIDGET_NAME))
(if (detailed? obj)
((detail-m-wid obj) 'entryconfigure "Inspect" :state 'normal))
(if (viewed? obj)
((view-m-wid obj) 'entryconfigure "Inspect" :state 'normal))
(unless (or (detailed? obj) (viewed? obj))
(remove-object-infos obj)
(if (symbol? obj) (untrace-var obj))))