You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
554 lines
21 KiB
Scheme
554 lines
21 KiB
Scheme
; main.ss
|
|
; Defines main MrSpidey class
|
|
; ----------------------------------------------------------------------
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
|
;
|
|
; This program is free software; you can redistribute it and/or
|
|
; modify it under the terms of the GNU General Public License
|
|
; version 2 as published by the Free Software Foundation.
|
|
;
|
|
; This program is distributed in the hope that it will be useful,
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
; GNU General Public License for more details.
|
|
;
|
|
; You should have received a copy of the GNU General Public License
|
|
; along with this program; if not, write to the Free Software
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define-structure (fileinfo filename frame thunk-port annotations))
|
|
;; annotations may also be (-> zodiac:parsed)
|
|
|
|
(define NUM-EXTRA-LINES 20)
|
|
|
|
(define-struct exn:flow-arrow-exists ())
|
|
|
|
(define (wrap-busy-cursor thunk)
|
|
(dynamic-wind
|
|
(lambda () (wx:begin-busy-cursor))
|
|
thunk
|
|
(lambda () (wx:end-busy-cursor))))
|
|
|
|
; ----------------------------------------------------------------------
|
|
(define tm (void))
|
|
|
|
(define MrSpidey%
|
|
(class null ()
|
|
|
|
(public
|
|
|
|
[fileinfo* '()]
|
|
[multiple-files
|
|
(lambda ()
|
|
(not (= (length fileinfo*) 1)))]
|
|
;; ------------------------------
|
|
;; Progress frame
|
|
|
|
[progress-frame 'progress-frame]
|
|
[progress-canvas 'progress-canvas]
|
|
[progress-edit 'progress-edit]
|
|
|
|
[init-progress-frame!
|
|
(lambda ()
|
|
(pretty-debug-gui `(init-progress-frame))
|
|
(let* ( [f (parameterize
|
|
([wx:current-eventspace (wx:make-eventspace)])
|
|
(make-object mred:frame% '()
|
|
(format "~a Progress" st:name)))]
|
|
[p (make-object mred:vertical-panel% f)]
|
|
[c (make-object mred:wrapping-canvas% p)]
|
|
[ph (make-object mred:horizontal-panel% p)]
|
|
[_ (send ph stretchable-in-y #f)]
|
|
[_ (make-object mred:horizontal-panel% ph)]
|
|
[b (make-object mred:button% ph
|
|
(lambda _ (send f show #f))
|
|
"Hide")]
|
|
[e (make-object mred:media-edit%)])
|
|
(set! progress-frame f)
|
|
(set! progress-canvas c)
|
|
(set! progress-edit e)
|
|
(send p add-child c)
|
|
;;(send c set-media e)
|
|
(send progress-frame set-size -1 -1 400 200);; ht was 130
|
|
(send progress-frame show #f)))]
|
|
|
|
[new-progress-frame!
|
|
(lambda ()
|
|
(pretty-debug-gui `(new-progress-frame))
|
|
(set! progress-edit (make-object mred:media-edit%))
|
|
(send progress-edit lock #t)
|
|
(send progress-canvas set-media progress-edit)
|
|
(send progress-frame show #t)
|
|
(send progress-frame iconize #f)
|
|
(pretty-debug-gui `(new-progress-frame-done)))]
|
|
|
|
[with-progress-frame
|
|
(lambda (thunk)
|
|
(let*
|
|
( [old-progress-handler (mrspidey:progress-handler)]
|
|
[current '()]
|
|
|
|
[current-start-time 0]
|
|
[width 6]
|
|
[total-width 18])
|
|
(letrec
|
|
([insert-numbers
|
|
(lambda (n)
|
|
(send progress-edit insert
|
|
(format "~a ~ams"
|
|
(padl
|
|
(if (eq? n 'done) "" (format "~a" n))
|
|
width)
|
|
(padl (- (current-process-milliseconds)
|
|
(current-gc-milliseconds)
|
|
current-start-time)
|
|
width))
|
|
(send progress-edit last-position)))]
|
|
[f (match-lambda*
|
|
[((? string? name) line)
|
|
(if (equal? name current)
|
|
(let ([end (send progress-edit last-position)])
|
|
(send progress-edit delete
|
|
(- end total-width) end)
|
|
(insert-numbers line))
|
|
(begin
|
|
(f 'fresh-line)
|
|
(set! current name)
|
|
(set! current-start-time
|
|
(- (current-process-milliseconds)
|
|
(current-gc-milliseconds)))
|
|
(send progress-edit insert
|
|
(padr name 30))
|
|
(insert-numbers line)))]
|
|
[((? string? str))
|
|
(f 'fresh-line)
|
|
(send progress-edit insert str)
|
|
(f #\newline)]
|
|
[(#\newline)
|
|
(send progress-edit insert (format "~n"))
|
|
(set! current '())]
|
|
[('fresh-line)
|
|
(unless (null? current) (f #\newline))])]
|
|
[g (lambda args
|
|
(send progress-edit lock #f)
|
|
(apply f args)
|
|
(send progress-edit lock #t))])
|
|
(parameterize
|
|
([mrspidey:progress-handler
|
|
(lambda args
|
|
;;(apply old-progress-handler args)
|
|
(apply g args)
|
|
(wx:flush-display))])
|
|
(send progress-frame show #t)
|
|
(begin0
|
|
(thunk)
|
|
(mrspidey:progress
|
|
"=Done======================================"))))))]
|
|
|
|
;; ------------------------------
|
|
|
|
[filename->fileinfo
|
|
(lambda (file)
|
|
(pretty-debug-gui `(filename->fileinfo ,file))
|
|
(or
|
|
(ormap
|
|
(match-lambda
|
|
[(and fi ($ fileinfo filename frame))
|
|
(and (string? file)
|
|
(string=? filename file)
|
|
fi)])
|
|
fileinfo*)
|
|
(assert #f 'filename->fileinfo file)))]
|
|
|
|
[filename->frame
|
|
(lambda (file)
|
|
(let ([x (filename->fileinfo file)])
|
|
(and x (fileinfo-frame x))))]
|
|
|
|
[filename->edit
|
|
(lambda (file)
|
|
(let ([x (filename->frame file)])
|
|
(and x (ivar x program-edit))))]
|
|
|
|
[for-each-frame
|
|
(lambda (f)
|
|
(for-each
|
|
(match-lambda
|
|
[($ fileinfo filename frame)
|
|
(when frame (f frame))])
|
|
fileinfo*))]
|
|
|
|
[focus-def
|
|
(lambda (loc)
|
|
(assert (zodiac:location? loc) 'focus-def loc)
|
|
(let* ([file (zodiac:location-file loc)]
|
|
[frame (filename->frame file)])
|
|
(if frame
|
|
(send frame focus-def (zodiac:location-offset loc))
|
|
(wx:message-box
|
|
(format "File ~s is not loaded" (file-name-from-path file))
|
|
"Error"
|
|
(bitwise-ior wx:const-ok)))))]
|
|
|
|
;; ------------------------------
|
|
|
|
[open-analyzed-file-choice
|
|
(lambda ()
|
|
(let ([choice
|
|
(wx:get-single-choice
|
|
"Select referenced unit file to open"
|
|
"Open Unit"
|
|
(sort string<? (map fileinfo-filename fileinfo*))
|
|
'() -1 -1 #t 500 300)])
|
|
(when (string? choice)
|
|
(open-fileinfo (filename->fileinfo choice) #t))))]
|
|
|
|
[open-fileinfo
|
|
(match-lambda*
|
|
[((and fi ($ fileinfo filename frame)) show)
|
|
(if frame
|
|
(when show
|
|
(send frame show #t)
|
|
(send frame iconize #f))
|
|
(add-frame fi show))])]
|
|
|
|
[open-all
|
|
(lambda (show)
|
|
(for-each
|
|
(lambda (fi) (open-fileinfo fi show))
|
|
fileinfo*))]
|
|
|
|
[add-frame
|
|
(match-lambda*
|
|
[( (and fi ($ fileinfo filename frame thunk-port thunk-expression))
|
|
show
|
|
. first-frame-locs)
|
|
(pretty-debug-gui
|
|
`(add-no-show-frame ,filename ,fi ,@first-frame-locs))
|
|
(assert (not frame))
|
|
(let ([summary-edit (make-object mred:media-edit%)])
|
|
(initialize-summary summary-edit)
|
|
(pretty-debug-gui `(summary-initialized))
|
|
(parameterize
|
|
([mrspidey:add-summary-handler (add-summary summary-edit)])
|
|
(with-progress-frame
|
|
(lambda ()
|
|
(pretty-debug-gui '(progress-frame-initialized))
|
|
(mrspidey:progress
|
|
"===========================================")
|
|
'(mrspidey:progress
|
|
(format "Analyzing ~a" (file-name-from-path filename)))
|
|
(let* ([annotations
|
|
(calc-annotations (thunk-expression))]
|
|
[_ (set-fileinfo-annotations! fi annotations)]
|
|
[_ (pretty-debug-gui `(calling-Tframe ,filename))]
|
|
[frame (apply make-object spidey:frame%
|
|
;; only use margin
|
|
this
|
|
filename summary-edit
|
|
first-frame-locs)])
|
|
(pretty-debug-gui `(Have-Tframe ,filename))
|
|
(when show (send frame show #t))
|
|
(unless show (send frame show #t) (send frame show #f))
|
|
(set-fileinfo-frame! fi frame)
|
|
(update-arrows)
|
|
)))))])]
|
|
|
|
[initialize-summary
|
|
(lambda (edit)
|
|
(let* ([delta (make-object wx:style-delta%
|
|
wx:const-change-family
|
|
wx:const-decorative)]
|
|
[click-delta (make-object wx:style-delta%)])
|
|
(send delta set-delta wx:const-change-size 10)
|
|
(send click-delta copy delta)
|
|
(send click-delta set-delta-foreground "BLUE")
|
|
(send click-delta set-delta wx:const-change-underline 1)
|
|
|
|
(let ( [insert
|
|
(lambda (s)
|
|
(let ([before (send edit get-end-position)])
|
|
(send edit insert s)
|
|
(let ([after (send edit get-end-position)])
|
|
(values before after))))])
|
|
(let*-values
|
|
( [(s1 e1) (insert "Welcome to ")]
|
|
[(s2 e2) (insert "MrSpidey")]
|
|
[(s3 e3) (insert (format ", version ~a." (mred:version)))]
|
|
[(s4 e4) (insert (format "~n"))])
|
|
(send edit change-style delta s1 e1)
|
|
(send edit change-style click-delta s2 e2)
|
|
(send edit change-style delta s3 e3)
|
|
(send edit set-clickback s2 e2
|
|
(lambda args
|
|
(make-object mred:hyper-view-frame%
|
|
(string-append
|
|
"file:"
|
|
(build-path
|
|
(collection-path "mrspidey") ; MATTHEW: got rid of plt-home
|
|
"about.html"))))
|
|
click-delta)))))]
|
|
|
|
[local-record-analyzed-file
|
|
(lambda (filename thunk-port thunk-expression)
|
|
(pretty-debug-gui
|
|
`(local-record-analyzed-file ,filename
|
|
,thunk-port
|
|
,thunk-expression))
|
|
(set! fileinfo*
|
|
(append fileinfo*
|
|
(list (make-fileinfo filename #f
|
|
thunk-port
|
|
thunk-expression)))))]
|
|
|
|
;; ------------------------------
|
|
|
|
[add-summary
|
|
(lambda (summary-edit)
|
|
(lambda line
|
|
(send summary-edit lock #f)
|
|
(match line
|
|
[(str loc word-ofs)
|
|
(cond
|
|
[(zodiac:zodiac? loc)
|
|
((add-summary summary-edit) str
|
|
(zodiac:zodiac-start loc) word-ofs)]
|
|
[(zodiac:location? loc)
|
|
(let* ( [click (lambda ignore (focus-def loc))]
|
|
[init-pos-box (box 0)]
|
|
[_ (send summary-edit get-position init-pos-box)]
|
|
[_ (send summary-edit insert str)]
|
|
[_ (send summary-edit insert
|
|
(format " in file ~s line ~s"
|
|
(file-name-from-path
|
|
(zodiac:location-file loc))
|
|
(zodiac:location-line loc)))]
|
|
[_ (send summary-edit insert #\newline)]
|
|
;; Find start and end of word
|
|
[end (unbox init-pos-box)]
|
|
[_
|
|
(for i 0 (add1 word-ofs)
|
|
(set! end (mred:scheme-forward-match
|
|
summary-edit end
|
|
(send summary-edit last-position))))]
|
|
[start (mred:scheme-backward-match summary-edit end 0)])
|
|
|
|
'(pretty-debug-gui
|
|
`(send summary-edit change-style check-link-delta
|
|
,(send check-link-delta get-underlined-on)
|
|
,start ,end))
|
|
;; Paranoia - check have proper locations
|
|
(if (and start end)
|
|
(begin
|
|
(send summary-edit set-clickback start end click)
|
|
(send summary-edit change-style check-link-delta
|
|
start end))
|
|
;; Error
|
|
(pretty-print
|
|
`(Error: annotate-summary
|
|
,str ,loc ,word-ofs ,start ,end))))]
|
|
[else
|
|
(begin
|
|
(printf
|
|
"Bad location in main:add-summary-handler ~s~n"
|
|
loc)
|
|
(mrspidey:add-summary str))])]
|
|
[(str)
|
|
(send summary-edit insert str)
|
|
(send summary-edit insert #\newline)]
|
|
[x (printf "add-summary, can't handle ~s~n" x)])
|
|
(send summary-edit lock #t)))]
|
|
|
|
;; ------------------------------
|
|
|
|
[on-frame-close
|
|
(lambda (filename)
|
|
(void))]
|
|
|
|
[close-all-frames
|
|
(lambda ()
|
|
(send progress-frame show #f)
|
|
(close-all-frames-except-progress)
|
|
)]
|
|
|
|
[close-all-frames-except-progress
|
|
(lambda ()
|
|
(for-each-frame (lambda (frame) (send frame on-close)))
|
|
)]
|
|
|
|
;; ------------------------------
|
|
|
|
[annotated-edit
|
|
(lambda (mode filename canvas)
|
|
;; create edit buffer, load file and add annotations
|
|
(pretty-debug-gui `(annotate-edit ,mode ,filename))
|
|
(match (filename->fileinfo filename)
|
|
[($ fileinfo filename frame thunk-port annotations)
|
|
(let* ( [port (thunk-port)]
|
|
[edit (make-object
|
|
(mode-edit-class mode)
|
|
(if (multiple-files) " " "")
|
|
this canvas)])
|
|
(send edit set-filename filename)
|
|
(send edit edit-sequence
|
|
(lambda ()
|
|
(pretty-debug-gui "loading!")
|
|
(let ([s (format "Loading ~a: "
|
|
(file-name-from-path filename))])
|
|
(recur loop ([n 1])
|
|
(when (zero? (modulo n 50))
|
|
(mrspidey:progress s n))
|
|
(let ([r (read-line port)])
|
|
;;(pretty-debug-gui `(inserting ,r))
|
|
(if (eof-object? r)
|
|
(mrspidey:progress s (sub1 n))
|
|
(begin
|
|
(send edit insert-line r)
|
|
(loop (add1 n))))))
|
|
(when (multiple-files)
|
|
(for i 0 NUM-EXTRA-LINES (send edit insert-line ""))))
|
|
(close-input-port port)
|
|
(pretty-debug-gui `(last-line ,(send edit last-line)))
|
|
(send edit change-style base-delta
|
|
0 (send edit last-position))
|
|
|
|
(pretty-debug-gui "annotating!")
|
|
(annotate! filename edit mode annotations)
|
|
|
|
(send edit set-position 0)
|
|
(pretty-debug-gui `(annotate-buffer done))))
|
|
|
|
edit)]))]
|
|
|
|
[annotate!
|
|
(lambda (filename edit mode annotations)
|
|
(let ([s (format "Annotating ~a:" (file-name-from-path filename))])
|
|
(mrspidey:progress s '...)
|
|
(pretty-debug-gui `(annotate! ,filename ,edit ,mode ,annotations))
|
|
(let ([annotation-fn-list (mode-annotation-fn-list mode)])
|
|
(for-each
|
|
(lambda (annotation-fn annotations)
|
|
(when annotation-fn
|
|
(for-each
|
|
(let ([fn (uq-ivar edit annotation-fn)])
|
|
(match-lambda
|
|
[(and annotation ($ annotation loc))
|
|
(when (string=? (zodiac:location-file loc)
|
|
filename)
|
|
;; Call the method named func to annotate etc.
|
|
(fn annotation))]))
|
|
annotations)))
|
|
annotation-fn-list
|
|
(vector->list annotations)))
|
|
(mrspidey:progress s 'done)))]
|
|
|
|
;; ------------------------------
|
|
|
|
[shake-it
|
|
'(lambda ()
|
|
(let* ([n (random (vector-length fileinfo*))]
|
|
[fi (vector-ref fileinfo* n)]
|
|
[frame (fileinfo-frame fi)])
|
|
(send frame shake-it)))]
|
|
|
|
;; ------------------------------
|
|
;; Arrows
|
|
|
|
[list-flow-arrows '()]
|
|
[add-flow-arrow
|
|
(lambda (src dest)
|
|
(assert (and (FlowType? src) (FlowType? dest)))
|
|
(pretty-debug-gui
|
|
`(main:add-flow-arrow
|
|
,(FlowType->pretty src) ,(FlowType->pretty dest)))
|
|
(with-handlers
|
|
([exn:flow-arrow-exists? (lambda (exn) (void))])
|
|
(let ([flow-arrow (make-object flow-arrow% this src dest)])
|
|
(when flow-arrow
|
|
(set! list-flow-arrows (cons flow-arrow list-flow-arrows))))))]
|
|
[draw-arrows
|
|
(lambda ()
|
|
(pretty-debug-gui `(main:draw-arrows))
|
|
(for-each-frame
|
|
(lambda (frame)
|
|
(send (ivar frame program-edit) draw-arrows))))]
|
|
[update-arrows
|
|
(lambda ()
|
|
(pretty-debug-gui `(main:update-arrows))
|
|
(for-each
|
|
(lambda (arrow) (send arrow update))
|
|
list-flow-arrows)
|
|
(draw-arrows))]
|
|
[delete-arrow
|
|
(lambda (arrow)
|
|
(send arrow delete-local)
|
|
(set! list-flow-arrows (remv arrow list-flow-arrows)))]
|
|
[delete-arrow-refresh
|
|
(lambda (arrow)
|
|
(delete-arrow arrow)
|
|
(draw-arrows))]
|
|
[delete-arrows
|
|
(lambda ()
|
|
(for-each
|
|
(lambda (arrow) (send arrow delete-local))
|
|
list-flow-arrows)
|
|
(set! list-flow-arrows '())
|
|
(draw-arrows))]
|
|
|
|
;; ------------------------------
|
|
|
|
[reanalyze 'reanalyze]
|
|
|
|
[run-mrspidey
|
|
|
|
(lambda (file . first-frame-locs)
|
|
|
|
(pretty-debug-gui `(run-mrspidey ,file))
|
|
(set! reanalyze
|
|
(lambda () (apply run-mrspidey file first-frame-locs)))
|
|
|
|
(close-all-frames-except-progress)
|
|
(pretty-debug-gui `(frames-closed))
|
|
(set! fileinfo* '())
|
|
(new-progress-frame!)
|
|
|
|
(let ([file (normalize-path (normalize-path file))])
|
|
;; Following calls record-anlyzed-file
|
|
(st:analyze-and-make-annotations file)
|
|
(apply add-frame (filename->fileinfo file) #t first-frame-locs)
|
|
|
|
))])
|
|
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(sequence
|
|
(set! tm this)
|
|
(record-analyzed-file-hook local-record-analyzed-file)
|
|
(init-progress-frame!))))
|
|
|
|
(define spidey (make-object MrSpidey%))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; mode says for each set of annotations,
|
|
;; either #f or fn to handle annotation.
|
|
|
|
(define-const-structure (mode name edit-class annotation-fn-list))
|
|
|
|
(define modes
|
|
(list
|
|
(make-mode
|
|
"Types and Checks"
|
|
flow-arrow:media-edit%
|
|
(list
|
|
'add-type-annotation
|
|
'add-check-annotation
|
|
'add-uncheck-annotation))
|
|
(make-mode "Normal"
|
|
spidey:static-edit%
|
|
(list #f #f #f))))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
|
|
|