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.
1074 lines
39 KiB
Scheme
1074 lines
39 KiB
Scheme
27 years ago
|
; annotat.ss
|
||
|
|
; Defines flow-arrow:media-edit%, type-annotation% and flow-arrow%
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; 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.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
;; Constants concerning positioning
|
||
|
|
;; Global so easy to modify
|
||
|
|
|
||
|
|
(define arrow-start-dx 2)
|
||
|
|
(define arrow-start-dy 12)
|
||
|
|
(define arrow-end-dx 2)
|
||
|
|
(define arrow-end-dy 12)
|
||
|
|
(define arrow-delta 7)
|
||
|
|
|
||
|
|
(define jump-start-dx -15)
|
||
|
|
(define jump-start-dy 25)
|
||
|
|
(define jump-end-dx -25)
|
||
|
|
(define jump-end-dy 25)
|
||
|
|
|
||
|
|
(define offset-menu-exp-y 20)
|
||
|
|
(define offset-menu-snip-y 25)
|
||
|
|
|
||
|
|
(define offsets-load-menu-src-known (cons 0 18))
|
||
|
|
(define offsets-load-menu-dest-known (cons 0 18))
|
||
|
|
(define offsets-load-menu-src-jump (cons -25 35))
|
||
|
|
(define offsets-load-menu-dest-jump (cons -25 35))
|
||
|
|
|
||
|
|
(define SELECT-SHOW-VALUE-SET 0)
|
||
|
|
(define SELECT-CLOSE-VALUE-SET 1)
|
||
|
|
(define SELECT-PARENTS 2)
|
||
|
|
(define SELECT-ANCESTORS 3)
|
||
|
|
(define SELECT-PATH-SOURCE 4)
|
||
|
|
(define SELECT-CHILDREN 5)
|
||
|
|
(define SELECT-DESCENDANTS 6)
|
||
|
|
(define SELECT-COPY-VALUE-SET 7)
|
||
|
|
(define SELECT-CLOSE-MENU 8)
|
||
|
|
(define SELECT-RECOMPUTE-VALUE-SET 11)
|
||
|
|
|
||
|
|
(define LOAD-NONLOCAL-FILE 9)
|
||
|
|
(define ZOOM-TO-FILE 10)
|
||
|
|
|
||
|
|
;; ------------------------------------------------------------
|
||
|
|
|
||
|
|
(define highlight
|
||
|
|
(lambda (edit src-pos)
|
||
|
|
;;(pretty-debug-gui `(highlight ,src-pos))
|
||
|
|
(let* ([src-end (send edit match-paren-forward src-pos)])
|
||
|
|
;;(send edit set-position src-pos src-end)
|
||
|
|
(send (send edit get-frame) show #t)
|
||
|
|
(send edit relocate-set-position src-pos)
|
||
|
|
(send edit relocate-flash-on src-pos src-end)
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ------------------------------------------------------------
|
||
|
|
;; The brushes, pens for drawing arrows
|
||
|
|
|
||
|
|
(define arrow-brush.pen
|
||
|
|
(cons
|
||
|
|
(make-object wx:brush% (get-resource-maybe "arrow-color" "BLUE")
|
||
|
|
wx:const-solid)
|
||
|
|
(make-object wx:pen% (get-resource-maybe "arrow-color" "BLUE")
|
||
|
|
1 wx:const-solid)))
|
||
|
|
|
||
|
|
(define nosrc-arrow-brush.pen
|
||
|
|
(cons
|
||
|
|
(make-object wx:brush% (get-resource-maybe "nosource-arrow-color" "RED")
|
||
|
|
wx:const-solid)
|
||
|
|
(make-object wx:pen% (get-resource-maybe "nosource-arrow-color" "RED")
|
||
|
|
1 wx:const-solid)))
|
||
|
|
|
||
|
|
(define nodest-arrow-brush.pen
|
||
|
|
(cons
|
||
|
|
(make-object wx:brush% (get-resource-maybe "nodest-arrow-color" "RED")
|
||
|
|
wx:const-solid)
|
||
|
|
(make-object wx:pen% (get-resource-maybe "nodest-arrow-color" "RED")
|
||
|
|
1 wx:const-solid)))
|
||
|
|
|
||
|
|
;; ------------------------------------------------------------
|
||
|
|
|
||
|
|
(define flow-report-on #t)
|
||
|
|
|
||
|
|
(define (generic-flow-report msg)
|
||
|
|
(when flow-report-on
|
||
|
|
(wx:message-box
|
||
|
|
msg "Error"
|
||
|
|
(bitwise-ior wx:const-ok wx:const-icon-exclamation))))
|
||
|
|
|
||
|
|
(define (generic-flow-report-filter msg)
|
||
|
|
(generic-flow-report
|
||
|
|
(format "~a~a!"
|
||
|
|
msg
|
||
|
|
(if (analysis-filter-on?)
|
||
|
|
(format " with values matching filter '~a'" (analysis-filter-on?))
|
||
|
|
""))))
|
||
|
|
|
||
|
|
(define (report-no-parents)
|
||
|
|
(generic-flow-report-filter "No parents"))
|
||
|
|
|
||
|
|
(define (report-no-children)
|
||
|
|
(generic-flow-report-filter "No children"))
|
||
|
|
|
||
|
|
(define (report-no-ancestors)
|
||
|
|
(generic-flow-report-filter "No ancestors"))
|
||
|
|
|
||
|
|
(define (report-no-descendants)
|
||
|
|
(generic-flow-report-filter "No descendants"))
|
||
|
|
|
||
|
|
(define (report-type-does-not-contain-filter)
|
||
|
|
(generic-flow-report
|
||
|
|
(if (analysis-filter-on?)
|
||
|
|
(format "Expression has no values matching filter '~a'!"
|
||
|
|
(analysis-filter-on?))
|
||
|
|
"Expression has no values!")))
|
||
|
|
|
||
|
|
(define (report-no-path-to-source)
|
||
|
|
(generic-flow-report
|
||
|
|
(if (analysis-filter-on?)
|
||
|
|
(format "No path to source for values matching filter '~a'!"
|
||
|
|
(analysis-filter-on?))
|
||
|
|
"No path to source!")))
|
||
|
|
|
||
|
|
(define lookup-ftype
|
||
|
|
(lambda (ftype)
|
||
|
|
(pretty-debug-gui `(lookup-ftype ,(FlowType->pretty ftype)))
|
||
|
|
(assert (FlowType? ftype) 'lookup-ftype ftype)
|
||
|
|
(let ([r (FlowType-type-annotation ftype)])
|
||
|
|
(pretty-debug-gui `(lookup-ftype-returning ,r))
|
||
|
|
(assert r 'lookup-ftype 'r= r ftype)
|
||
|
|
r)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
;; Edit class with flow arrows
|
||
|
|
;; sets mode to scheme mode
|
||
|
|
|
||
|
|
(define wx:const-break-special 8)
|
||
|
|
|
||
|
|
(define flow-arrow:media-edit%
|
||
|
|
(class arrow:media-edit% (margin arg-main arg-canvas)
|
||
|
|
(inherit
|
||
|
|
edit-sequence last-position change-style
|
||
|
|
find-wordbreak set-mode set-wordbreak-map
|
||
|
|
relocate-change-style
|
||
|
|
real-start-position
|
||
|
|
last-line position-line line-start-position frame-pos->source-pos
|
||
|
|
draw-arrows add-arrow delete-arrow
|
||
|
|
margin-length
|
||
|
|
get-keymap get-frame relocate-set-position
|
||
|
|
get-start-position get-end-position)
|
||
|
|
|
||
|
|
(public
|
||
|
|
|
||
|
|
main
|
||
|
|
canvas
|
||
|
|
|
||
|
|
[list-type-annotations '()]
|
||
|
|
[list-check-annotations '()]
|
||
|
|
|
||
|
|
;; ----------
|
||
|
|
;; dynamic allocation of jump positions
|
||
|
|
|
||
|
|
[vec-free-jump-posns '()]
|
||
|
|
[jump-posn-free?
|
||
|
|
(lambda (i)
|
||
|
|
(and
|
||
|
|
(>= i 0)
|
||
|
|
(< i (vector-length vec-free-jump-posns))
|
||
|
|
(vector-ref vec-free-jump-posns i)))]
|
||
|
|
[alloc-jump-posn
|
||
|
|
;; input and output in terms of relocate positions
|
||
|
|
;; not absolute positions
|
||
|
|
(lambda (posn)
|
||
|
|
(let ([line (position-line (real-start-position posn))])
|
||
|
|
(unless (vector? vec-free-jump-posns)
|
||
|
|
(set! vec-free-jump-posns (make-vector (last-line) #t)))
|
||
|
|
(let* ([free-line
|
||
|
|
(recur loop ([i 0])
|
||
|
|
(cond
|
||
|
|
[(= i (vector-length vec-free-jump-posns))
|
||
|
|
(mrspidey:error "Out of jump points")]
|
||
|
|
[(jump-posn-free? (+ line i)) (+ line i)]
|
||
|
|
[(jump-posn-free? (- line i)) (- line i)]
|
||
|
|
[else (loop (add1 i))]))]
|
||
|
|
[_ (vector-set! vec-free-jump-posns free-line #f)]
|
||
|
|
[start (line-start-position free-line)]
|
||
|
|
[src (frame-pos->source-pos (+ margin-length start))])
|
||
|
|
(pretty-debug-gui
|
||
|
|
`(alloc-jump-posn ,posn ,line ,free-line ,start ,src))
|
||
|
|
(values
|
||
|
|
src
|
||
|
|
(lambda ()
|
||
|
|
(assert (not (vector-ref vec-free-jump-posns free-line))
|
||
|
|
'free-jump-posn free-line)
|
||
|
|
(vector-set! vec-free-jump-posns free-line #t))))))]
|
||
|
|
|
||
|
|
;; ----------
|
||
|
|
|
||
|
|
[add-flow-arrow-part
|
||
|
|
(lambda ( src-posn src-clickback
|
||
|
|
dest-posn dest-clickback
|
||
|
|
brush.pen )
|
||
|
|
(pretty-debug-gui
|
||
|
|
`(add-flow-arrow-part ,src-posn ,dest-posn))
|
||
|
|
(assert
|
||
|
|
(and
|
||
|
|
(or (number? src-posn) (eq? src-posn 'jump))
|
||
|
|
(or (number? dest-posn) (eq? dest-posn 'jump))
|
||
|
|
(or (number? src-posn) (number? dest-posn)))
|
||
|
|
'add-flow-arrow-part
|
||
|
|
src-posn dest-posn)
|
||
|
|
(let*-vals
|
||
|
|
([(src-posn free-src start-dx start-dy)
|
||
|
|
(if (number? src-posn)
|
||
|
|
(values
|
||
|
|
src-posn (lambda () (void))
|
||
|
|
arrow-start-dx arrow-start-dy)
|
||
|
|
(let*-vals ([(p free) (alloc-jump-posn dest-posn)])
|
||
|
|
(values
|
||
|
|
p free
|
||
|
|
jump-start-dx jump-start-dy)))]
|
||
|
|
[(dest-posn free-dest end-dx end-dy)
|
||
|
|
(if (number? dest-posn)
|
||
|
|
(values
|
||
|
|
dest-posn (lambda () (void))
|
||
|
|
arrow-end-dx arrow-end-dy)
|
||
|
|
(let*-vals ([(p free) (alloc-jump-posn src-posn)])
|
||
|
|
(values
|
||
|
|
p free
|
||
|
|
jump-end-dx jump-end-dy)))]
|
||
|
|
[arrow
|
||
|
|
(add-arrow
|
||
|
|
src-posn start-dx start-dy
|
||
|
|
dest-posn end-dx end-dy
|
||
|
|
arrow-delta
|
||
|
|
(car brush.pen)
|
||
|
|
(cdr brush.pen)
|
||
|
|
(dest-clickback dest-posn)
|
||
|
|
(src-clickback src-posn))])
|
||
|
|
(lambda () (free-src) (free-dest) (delete-arrow arrow))))]
|
||
|
|
|
||
|
|
;; ----- shake it
|
||
|
|
[shake-it
|
||
|
|
(lambda ()
|
||
|
|
(fluid-let ([flow-report-on #f])
|
||
|
|
|
||
|
|
(let* ([n (random (length list-type-annotations))]
|
||
|
|
[ta (nth list-type-annotations n)])
|
||
|
|
(printf "(send ta show-type-refresh)~n")
|
||
|
|
(send ta show-type-refresh)
|
||
|
|
|
||
|
|
(printf "(send ta copy-type-to-clipboard)~n")
|
||
|
|
(send ta copy-type-to-clipboard)
|
||
|
|
|
||
|
|
(printf "(send ta delete-type-refresh)~n")
|
||
|
|
(send ta delete-type-refresh)
|
||
|
|
|
||
|
|
(printf "(send ta parents-refresh)~n")
|
||
|
|
(send ta parents-refresh)
|
||
|
|
(delete-arrows)
|
||
|
|
|
||
|
|
(printf "(send ta ancestors-refresh)~n")
|
||
|
|
(send ta ancestors-refresh)
|
||
|
|
(delete-arrows)
|
||
|
|
|
||
|
|
(printf "(send ta shortest-path-source-refresh)~n")
|
||
|
|
(send ta shortest-path-source-refresh)
|
||
|
|
(delete-arrows)
|
||
|
|
|
||
|
|
(printf "(send ta children-refresh)~n")
|
||
|
|
(send ta children-refresh)
|
||
|
|
(delete-arrows)
|
||
|
|
|
||
|
|
(printf "(send ta descendants-refresh)~n")
|
||
|
|
(send ta descendants-refresh)
|
||
|
|
(delete-arrows))))]
|
||
|
|
|
||
|
|
[send-ftype
|
||
|
|
(lambda (ftype method . args)
|
||
|
|
(pretty-debug-gui `(send-ftype ,(FlowType->pretty ftype)))
|
||
|
|
(assert (symbol? method) 'send-ftype ftype method args)
|
||
|
|
(apply (uq-ivar (lookup-ftype ftype) method) args))]
|
||
|
|
|
||
|
|
[flush-type-cache
|
||
|
|
(lambda ()
|
||
|
|
(for-each
|
||
|
|
(lambda (obj) (send obj flush-type))
|
||
|
|
list-type-annotations))]
|
||
|
|
|
||
|
|
[delete-types
|
||
|
|
(lambda ()
|
||
|
|
(edit-sequence
|
||
|
|
(lambda ()
|
||
|
|
(for-each
|
||
|
|
(lambda (obj) (send obj delete-type))
|
||
|
|
list-type-annotations))))]
|
||
|
|
|
||
|
|
[delete-arrows
|
||
|
|
(lambda ()
|
||
|
|
(send main delete-arrows))]
|
||
|
|
|
||
|
|
[add-type-annotation
|
||
|
|
(match-lambda
|
||
|
|
[($ type-annotation start end-first finish ftype)
|
||
|
|
'(pretty-debug-gui `(type-annotation
|
||
|
|
,(zodiac:location-offset start)
|
||
|
|
,(zodiac:location-offset end-first)
|
||
|
|
,(zodiac:location-offset finish)))
|
||
|
|
(let ([obj (make-object type-annotation%
|
||
|
|
this
|
||
|
|
(zodiac:location-offset start)
|
||
|
|
(zodiac:location-offset end-first)
|
||
|
|
(add1 (zodiac:location-offset finish))
|
||
|
|
ftype)])
|
||
|
|
(set-FlowType-type-annotation! ftype obj)
|
||
|
|
(set! list-type-annotations (cons obj list-type-annotations)))])]
|
||
|
|
|
||
|
|
[highlight
|
||
|
|
(lambda (start-pos name delta)
|
||
|
|
(cond
|
||
|
|
[(string=? name "(")
|
||
|
|
(let* ( [real-start (real-start-position start-pos)]
|
||
|
|
[rparen (mred:scheme-forward-match
|
||
|
|
this real-start (last-position))])
|
||
|
|
(change-style delta real-start (add1 real-start))
|
||
|
|
(if (number? rparen)
|
||
|
|
(change-style delta (sub1 rparen) rparen)
|
||
|
|
(printf "Can't match paren from ~s ~s~n" start-pos rparen)))]
|
||
|
|
[else
|
||
|
|
(let* ([endbox (box (real-start-position start-pos))]
|
||
|
|
[_ (find-wordbreak '() endbox wx:const-break-special)]
|
||
|
|
[startbox (box (unbox endbox))]
|
||
|
|
[_ (find-wordbreak startbox '() wx:const-break-special)])
|
||
|
|
'(pretty-debug-gui `(highlight start-pos ,start-pos endbox ,endbox
|
||
|
|
startbox ,startbox))
|
||
|
|
(change-style delta (unbox startbox) (unbox endbox)))]))]
|
||
|
|
|
||
|
|
[add-check-annotation
|
||
|
|
(match-lambda
|
||
|
|
[(and annotation ($ check-annotation start name num))
|
||
|
|
(set! list-check-annotations
|
||
|
|
(cons annotation list-check-annotations))
|
||
|
|
(highlight (zodiac:location-offset start) name check-delta)])]
|
||
|
|
|
||
|
|
[add-uncheck-annotation
|
||
|
|
(match-lambda
|
||
|
|
[($ uncheck-annotation start name)
|
||
|
|
(highlight (zodiac:location-offset start) name uncheck-delta)])]
|
||
|
|
|
||
|
|
[next-check-annotation
|
||
|
|
(lambda ()
|
||
|
|
(next-check-annotation-list
|
||
|
|
(get-end-position) < list-check-annotations 0))]
|
||
|
|
|
||
|
|
[prev-check-annotation
|
||
|
|
(lambda ()
|
||
|
|
(next-check-annotation-list
|
||
|
|
(get-start-position) > (reverse list-check-annotations)
|
||
|
|
(last-position)))]
|
||
|
|
|
||
|
|
[next-check-annotation-list
|
||
|
|
(lambda (start cmp list-annotations wrap)
|
||
|
|
;(pretty-print `(start ,start cmp ,cmp wrap ,wrap))
|
||
|
|
(or
|
||
|
|
(ormap
|
||
|
|
(match-lambda
|
||
|
|
[($ check-annotation start-ann)
|
||
|
|
;(pretty-print `(loop start ,start start-ann ,(zodiac:location-offset start-ann) ,(real-start-position (zodiac:location-offset start-ann))))
|
||
|
|
(if (cmp start
|
||
|
|
(real-start-position
|
||
|
|
(zodiac:location-offset start-ann)))
|
||
|
|
;; after current start
|
||
|
|
(begin
|
||
|
|
(relocate-set-position
|
||
|
|
(zodiac:location-offset start-ann))
|
||
|
|
#t)
|
||
|
|
#f)])
|
||
|
|
list-annotations)
|
||
|
|
(if wrap
|
||
|
|
(next-check-annotation-list wrap cmp list-annotations #f)
|
||
|
|
(wx:bell))))]
|
||
|
|
)
|
||
|
|
|
||
|
|
(sequence
|
||
|
|
(set! main arg-main)
|
||
|
|
(set! canvas arg-canvas)
|
||
|
|
(super-init margin)
|
||
|
|
(let ([wb (make-object wx:media-wordbreak-map%)])
|
||
|
|
(for i 0 256
|
||
|
|
(unless (or (char-whitespace? (integer->char i))
|
||
|
|
(memv (integer->char i) '(#\( #\) #\;)))
|
||
|
|
(send wb set-map i
|
||
|
|
(+ (send wb get-map i) wx:const-break-special))))
|
||
|
|
(set-wordbreak-map wb))
|
||
|
|
;;(set-mode (make-object mred:scheme-mode%))
|
||
|
|
(let ([keymap (get-keymap)])
|
||
|
|
(send keymap add-key-function
|
||
|
|
"next-check-annotation"
|
||
|
|
(lambda (edit event)
|
||
|
|
(send edit next-check-annotation)))
|
||
|
|
(send keymap map-function "tab" "next-check-annotation")
|
||
|
|
|
||
|
|
(send keymap add-key-function
|
||
|
|
"prev-check-annotation"
|
||
|
|
(lambda (edit event)
|
||
|
|
(send edit prev-check-annotation)))
|
||
|
|
(send keymap map-function "s:tab" "prev-check-annotation")
|
||
|
|
(send keymap map-function "a:tab" "prev-check-annotation"))
|
||
|
|
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ------------------------------------------------------------
|
||
|
|
;; A hyperlink object
|
||
|
|
|
||
|
|
(define cur-he #f)
|
||
|
|
(define te #f)
|
||
|
|
|
||
|
|
(define type-annotation%
|
||
|
|
(class null (arg-edit start-arg end-first finish-arg ftype-arg)
|
||
|
|
(public
|
||
|
|
|
||
|
|
edit ;; flow-arrow:media-edit%
|
||
|
|
start-pos
|
||
|
|
type-pos
|
||
|
|
ftype
|
||
|
|
|
||
|
|
[type #f]
|
||
|
|
[type-snip #f]
|
||
|
|
[src->arrows '()] ;; Maps ftype of source to the arrow
|
||
|
|
[dest->arrows '()] ;; ditto
|
||
|
|
|
||
|
|
;; ----- communication with arrows
|
||
|
|
[add-source-arrow
|
||
|
|
(lambda (src arrow)
|
||
|
|
(set! src->arrows (cons (cons src arrow) src->arrows)))]
|
||
|
|
[add-dest-arrow
|
||
|
|
(lambda (dest arrow)
|
||
|
|
(set! dest->arrows (cons (cons dest arrow) dest->arrows)))]
|
||
|
|
|
||
|
|
[remove-source-arrow
|
||
|
|
(lambda (arrow)
|
||
|
|
(set! src->arrows
|
||
|
|
(filter-map
|
||
|
|
(lambda (src.arrow)
|
||
|
|
(if (eq? (cdr src.arrow) arrow) #f src.arrow))
|
||
|
|
src->arrows)))]
|
||
|
|
[remove-dest-arrow
|
||
|
|
(lambda (arrow)
|
||
|
|
(set! dest->arrows
|
||
|
|
(filter-map
|
||
|
|
(lambda (dest.arrow)
|
||
|
|
(if (eq? (cdr dest.arrow) arrow) #f dest.arrow))
|
||
|
|
dest->arrows)))]
|
||
|
|
[remove-arrows
|
||
|
|
(for-each
|
||
|
|
(lambda (arrow) (send arrow delete))
|
||
|
|
(append (map cdr src->arrows) (map cdr dest->arrows)))]
|
||
|
|
|
||
|
|
[file-visable?
|
||
|
|
(lambda (filename)
|
||
|
|
(send (ivar edit main) filename->frame filename))]
|
||
|
|
|
||
|
|
|
||
|
|
;; ----- Arrows
|
||
|
|
[add-flow-arrow
|
||
|
|
(lambda (src dest)
|
||
|
|
(pretty-debug-gui
|
||
|
|
`(type-annotation%:add-flow-arrow
|
||
|
|
,(FlowType->pretty src) ,(FlowType->pretty dest)))
|
||
|
|
(send (ivar edit main) add-flow-arrow src dest))]
|
||
|
|
|
||
|
|
;; ------ Parents, ancestors
|
||
|
|
[shortest-path-source-refresh
|
||
|
|
(lambda ()
|
||
|
|
;; Show shortest path to a source
|
||
|
|
(let ([path (analysis-shortest-path ftype file-visable?)])
|
||
|
|
;; Returns list of ancestor Tvar-nums, last element is ()
|
||
|
|
(cond
|
||
|
|
[(eq? path #f)
|
||
|
|
(report-type-does-not-contain-filter)]
|
||
|
|
[(null? path)
|
||
|
|
(report-no-path-to-source)]
|
||
|
|
[else
|
||
|
|
(send edit edit-sequence
|
||
|
|
(lambda ()
|
||
|
|
(show-path path)
|
||
|
|
(send (ivar edit main) draw-arrows)))])))]
|
||
|
|
[show-path
|
||
|
|
(lambda (path)
|
||
|
|
(unless (null? path)
|
||
|
|
(let ([parent (car path)])
|
||
|
|
(unless (null? parent)
|
||
|
|
(add-flow-arrow parent ftype)
|
||
|
|
(send edit send-ftype parent 'show-path (cdr path))))))]
|
||
|
|
|
||
|
|
[calc-parents
|
||
|
|
(lambda ()
|
||
|
|
(analysis-parents ftype file-visable?))]
|
||
|
|
|
||
|
|
[add-parent-arrows
|
||
|
|
(lambda ()
|
||
|
|
(for-each (lambda (p) (add-flow-arrow p ftype)) (calc-parents)))]
|
||
|
|
|
||
|
|
[parents-refresh
|
||
|
|
(lambda ()
|
||
|
|
;; (pretty-print `(parents-refresh debugging ,debugging))
|
||
|
|
(pretty-debug-gui `(parents-refresh ,ftype ,type-snip))
|
||
|
|
(if (null? (calc-parents))
|
||
|
|
(report-no-parents)
|
||
|
|
(send edit edit-sequence
|
||
|
|
(lambda ()
|
||
|
|
(add-parent-arrows)
|
||
|
|
(send (ivar edit main) draw-arrows)))))]
|
||
|
|
|
||
|
|
[ancestors-refresh
|
||
|
|
(lambda ()
|
||
|
|
(let ([arrows (analysis-ancestors ftype file-visable?)])
|
||
|
|
(if (null? arrows)
|
||
|
|
(report-no-ancestors)
|
||
|
|
(send edit edit-sequence
|
||
|
|
(lambda ()
|
||
|
|
(for-each
|
||
|
|
(lambda (arrow) (apply add-flow-arrow arrow))
|
||
|
|
arrows)
|
||
|
|
(send (ivar edit main) draw-arrows))))))]
|
||
|
|
|
||
|
|
;; ------ Children, descendants
|
||
|
|
|
||
|
|
[calc-children
|
||
|
|
(lambda () (analysis-children ftype file-visable?))]
|
||
|
|
|
||
|
|
[add-child-arrows
|
||
|
|
(lambda ()
|
||
|
|
(for-each (lambda (p) (add-flow-arrow ftype p)) (calc-children)))]
|
||
|
|
|
||
|
|
[children-refresh
|
||
|
|
(lambda ()
|
||
|
|
(pretty-debug-gui `(children ,ftype ,type-snip))
|
||
|
|
(if (null? (calc-children))
|
||
|
|
(report-no-children)
|
||
|
|
(send edit edit-sequence
|
||
|
|
(lambda ()
|
||
|
|
(add-child-arrows)
|
||
|
|
(send (ivar edit main) draw-arrows)))))]
|
||
|
|
|
||
|
|
[descendants-refresh
|
||
|
|
(lambda ()
|
||
|
|
(let ([arrows (analysis-descendants ftype file-visable?)])
|
||
|
|
(if (null? arrows)
|
||
|
|
(report-no-descendants)
|
||
|
|
(send edit edit-sequence
|
||
|
|
(lambda ()
|
||
|
|
(for-each
|
||
|
|
(lambda (arrow) (apply add-flow-arrow arrow))
|
||
|
|
arrows)
|
||
|
|
(send (ivar edit main) draw-arrows))))))]
|
||
|
|
|
||
|
|
;; ------ Type stuff
|
||
|
|
|
||
|
|
[flush-type (lambda () (set! type #f))]
|
||
|
|
[calc-type
|
||
|
|
(lambda ()
|
||
|
|
(unless type
|
||
|
|
(assert (FlowType? ftype) 'type-annotation% ftype)
|
||
|
|
(set! type (analysis-callback ftype)))
|
||
|
|
type)]
|
||
|
|
|
||
|
|
;; ------ This snip stuff
|
||
|
|
[delete-type-refresh
|
||
|
|
(lambda ()
|
||
|
|
(when type-snip
|
||
|
|
(send edit edit-sequence delete-type)))]
|
||
|
|
[delete-type
|
||
|
|
(lambda ()
|
||
|
|
(when type-snip
|
||
|
|
(send edit relocate-delete-snip type-pos)
|
||
|
|
(set! type-snip #f)
|
||
|
|
|
||
|
|
))]
|
||
|
|
[arrow-zoom (lambda () (highlight))]
|
||
|
|
[current-focus (lambda () (highlight))]
|
||
|
|
[highlight
|
||
|
|
(lambda ()
|
||
|
|
(set! te edit)
|
||
|
|
(let* ( [frame (send edit get-frame)]
|
||
|
|
[frame (send (ivar edit main) filename->frame
|
||
|
|
(send edit get-filename))])
|
||
|
|
(assert (is-a? frame wx:frame%) 'highlight frame)
|
||
|
|
(send frame show #t)
|
||
|
|
(send edit relocate-set-position start-pos)
|
||
|
|
(send edit relocate-flash-on start-pos type-pos #f #t 50000)))]
|
||
|
|
|
||
|
|
[get-start-pos (lambda () start-pos)]
|
||
|
|
[get-type-pos (lambda () type-pos)]
|
||
|
|
|
||
|
|
[move-before-snip
|
||
|
|
(lambda ()
|
||
|
|
(pretty-debug-gui `(move-before-snip))
|
||
|
|
(send edit relocate-set-position start-pos)
|
||
|
|
(send edit set-caret-owner '()))]
|
||
|
|
|
||
|
|
[show-type
|
||
|
|
(lambda ()
|
||
|
|
(unless type-snip
|
||
|
|
|
||
|
|
(let* ([type (calc-type)]
|
||
|
|
[_ (set! type-snip (make-object mred:media-snip%))]
|
||
|
|
[snip-edit (make-object mred:searching-edit%)]
|
||
|
|
[_ (send type-snip set-media snip-edit)])
|
||
|
|
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda ()
|
||
|
|
(send snip-edit begin-edit-sequence))
|
||
|
|
(lambda ()
|
||
|
|
;; put type in the box
|
||
|
|
(send snip-edit insert type)
|
||
|
|
;; delete newline
|
||
|
|
(send snip-edit delete)
|
||
|
|
;; set style
|
||
|
|
(send snip-edit change-style base-delta
|
||
|
|
0 (string-length type))
|
||
|
|
(send snip-edit change-style type-delta 0 (string-length type))
|
||
|
|
;; add clickback
|
||
|
|
(send snip-edit set-clickback
|
||
|
|
0 (string-length type)
|
||
|
|
(lambda ignore
|
||
|
|
(popup-type/arrow-menu type-pos offset-menu-snip-y))
|
||
|
|
'()
|
||
|
|
#t))
|
||
|
|
(lambda ()
|
||
|
|
(send snip-edit end-edit-sequence)
|
||
|
|
(send snip-edit lock #t))))
|
||
|
|
|
||
|
|
(send edit edit-sequence
|
||
|
|
(lambda ()
|
||
|
|
(send edit relocate-insert-snip type-snip type-pos)
|
||
|
|
(send edit relocate-change-style normal-delta
|
||
|
|
type-pos (add1 type-pos))))))]
|
||
|
|
|
||
|
|
[show-type-refresh
|
||
|
|
(lambda ()
|
||
|
|
(send edit edit-sequence
|
||
|
|
(lambda ()
|
||
|
|
(show-type)
|
||
|
|
;;(highlight)
|
||
|
|
)))]
|
||
|
|
|
||
|
|
[copy-type-to-clipboard
|
||
|
|
(lambda ()
|
||
|
|
(let* ([snip-edit (send type-snip get-this-media)])
|
||
|
|
(send snip-edit copy #f 0 0 (send snip-edit last-position))))]
|
||
|
|
|
||
|
|
;; ---------- Making the popup menus
|
||
|
|
[popup-type/arrow-menu
|
||
|
|
(lambda (where offset-menu)
|
||
|
|
;; where is source text position for menu
|
||
|
|
(let ([menu (make-object wx:menu% '() menu-callback)]
|
||
|
|
[xb (box 0)]
|
||
|
|
[yb (box 0)])
|
||
|
|
(if type-snip
|
||
|
|
(send menu append
|
||
|
|
SELECT-CLOSE-VALUE-SET
|
||
|
|
"Close Value Set"
|
||
|
|
"Close this value set invariant box")
|
||
|
|
(send menu append
|
||
|
|
SELECT-SHOW-VALUE-SET "Show Value Set"
|
||
|
|
"Show the expressions value set invariant"))
|
||
|
|
(send* menu
|
||
|
|
(append-separator)
|
||
|
|
(append SELECT-PARENTS "Parents"
|
||
|
|
"Show the immediate sources of this type")
|
||
|
|
(append SELECT-ANCESTORS "Ancestors"
|
||
|
|
"Show all sources of this type")
|
||
|
|
(append SELECT-PATH-SOURCE "Path to Source"
|
||
|
|
"Show shortest path to a source constructor expression")
|
||
|
|
(append-separator)
|
||
|
|
(append SELECT-CHILDREN "Children"
|
||
|
|
"Show the immediate expressions to which this type may flow")
|
||
|
|
(append SELECT-DESCENDANTS "Descendants"
|
||
|
|
"Show all expressions to which this type may flow")
|
||
|
|
(append-separator))
|
||
|
|
(when type-snip
|
||
|
|
(send menu append
|
||
|
|
SELECT-COPY-VALUE-SET
|
||
|
|
"Copy Value Set"
|
||
|
|
"Copy the value set invariant to the clipboard")
|
||
|
|
(send menu append
|
||
|
|
SELECT-RECOMPUTE-VALUE-SET
|
||
|
|
"Recompute Value Set"
|
||
|
|
"Recompute the expressions value set invariant"))
|
||
|
|
(send menu append SELECT-CLOSE-MENU "Close Menu")
|
||
|
|
|
||
|
|
;; Get global location of expr
|
||
|
|
(send edit position-location
|
||
|
|
(send edit real-start-position where)
|
||
|
|
xb yb)
|
||
|
|
(pretty-debug-gui
|
||
|
|
`(source-pos ,where
|
||
|
|
frame-pos ,(send edit real-start-position where)))
|
||
|
|
|
||
|
|
(pretty-debug-gui `(position-location returns ,xb ,yb))
|
||
|
|
;; Convert to local location
|
||
|
|
(send edit local-to-global xb yb)
|
||
|
|
(pretty-debug-gui `(local-to-global returns ,xb ,yb))
|
||
|
|
(send (ivar edit canvas) popup-menu menu
|
||
|
|
(unbox xb) (+ (unbox yb) offset-menu))))]
|
||
|
|
|
||
|
|
[menu-callback
|
||
|
|
(lambda (menu command)
|
||
|
|
(set! cur-he this)
|
||
|
|
(move-before-snip)
|
||
|
|
(let ([arg (send command get-command-int)])
|
||
|
|
(pretty-debug-gui `(command ,arg))
|
||
|
|
(wrap-busy-cursor
|
||
|
|
(lambda ()
|
||
|
|
(cond
|
||
|
|
[(= arg SELECT-SHOW-VALUE-SET) (show-type-refresh)]
|
||
|
|
[(= arg SELECT-CLOSE-VALUE-SET) (delete-type-refresh)]
|
||
|
|
[(= arg SELECT-RECOMPUTE-VALUE-SET)
|
||
|
|
(delete-type-refresh)
|
||
|
|
(show-type-refresh)]
|
||
|
|
[(= arg SELECT-COPY-VALUE-SET) (copy-type-to-clipboard)]
|
||
|
|
[(= arg SELECT-PARENTS) (parents-refresh)]
|
||
|
|
[(= arg SELECT-ANCESTORS) (ancestors-refresh)]
|
||
|
|
[(= arg SELECT-PATH-SOURCE) (shortest-path-source-refresh)]
|
||
|
|
[(= arg SELECT-CHILDREN) (children-refresh)]
|
||
|
|
[(= arg SELECT-DESCENDANTS) (descendants-refresh)]
|
||
|
|
[(= arg SELECT-CLOSE-MENU) (void)])))))]
|
||
|
|
)
|
||
|
|
|
||
|
|
(sequence
|
||
|
|
|
||
|
|
(unless (FlowType? ftype-arg)
|
||
|
|
(pretty-debug-gui `(bad-ftype ,ftype-arg ,(FlowType? ftype-arg))))
|
||
|
|
(assert (FlowType? ftype-arg) 'type-annotation-init1 ftype-arg)
|
||
|
|
(set! edit arg-edit)
|
||
|
|
|
||
|
|
(set! start-pos start-arg)
|
||
|
|
(set! type-pos finish-arg)
|
||
|
|
(set! ftype ftype-arg)
|
||
|
|
(assert (FlowType? ftype) 'type-annotation-init ftype ftype-arg)
|
||
|
|
|
||
|
|
(send edit relocate-change-style type-link-delta start-arg end-first)
|
||
|
|
(send edit relocate-set-clickback start-arg end-first
|
||
|
|
(lambda ignore
|
||
|
|
(popup-type/arrow-menu start-arg offset-menu-exp-y))
|
||
|
|
'()
|
||
|
|
#t))))
|
||
|
|
|
||
|
|
;; ------------------------------------------------------------
|
||
|
|
|
||
|
|
(define last-arrow-popup (void))
|
||
|
|
|
||
|
|
(define flow-arrow%
|
||
|
|
(class null (arg-main arg-src arg-dest)
|
||
|
|
(public
|
||
|
|
|
||
|
|
src ; points to type-annotation% object
|
||
|
|
dest
|
||
|
|
main
|
||
|
|
delete-arrow-thunks
|
||
|
|
|
||
|
|
;; Deletion
|
||
|
|
[delete-local
|
||
|
|
(lambda ()
|
||
|
|
;; tell endpoints we're dead
|
||
|
|
(let ( [src-ta (lookup-ftype src)]
|
||
|
|
[dest-ta (lookup-ftype dest)])
|
||
|
|
(when (is-a? src-ta type-annotation%)
|
||
|
|
(send src-ta remove-dest-arrow this))
|
||
|
|
(when (is-a? dest-ta type-annotation%)
|
||
|
|
(send dest-ta remove-source-arrow this)))
|
||
|
|
;; delete
|
||
|
|
(assert (list? delete-arrow-thunks) 1 delete-arrow-thunks)
|
||
|
|
(for-each (lambda (th) (th)) delete-arrow-thunks)
|
||
|
|
)]
|
||
|
|
[delete
|
||
|
|
(lambda ()
|
||
|
|
(send main delete-arrow this))]
|
||
|
|
[delete-refresh
|
||
|
|
(lambda ()
|
||
|
|
(pretty-debug-gui '(delete-refresh))
|
||
|
|
(delete)
|
||
|
|
(send main draw-arrows))]
|
||
|
|
|
||
|
|
;; ----------
|
||
|
|
|
||
|
|
[update
|
||
|
|
;; Change if necy due to loaded file
|
||
|
|
(lambda ()
|
||
|
|
(let ( [src-ta (lookup-ftype src)]
|
||
|
|
[dest-ta (lookup-ftype dest)])
|
||
|
|
(pretty-debug-gui `(flow-arrow%:update ,src-ta ,dest-ta))
|
||
|
|
(when (and
|
||
|
|
(string? src-ta)
|
||
|
|
(send main filename->frame src-ta))
|
||
|
|
;; file loaded, so delete this arrow + show parents of dest
|
||
|
|
(delete)
|
||
|
|
(send dest-ta add-parent-arrows))
|
||
|
|
(when (and
|
||
|
|
(string? dest-ta)
|
||
|
|
(send main filename->frame dest-ta))
|
||
|
|
;; file loaded, so delete this arrow + show children of src
|
||
|
|
(delete)
|
||
|
|
(send src-ta add-child-arrows))))]
|
||
|
|
|
||
|
|
;; ----------
|
||
|
|
|
||
|
|
[popup-load-menu
|
||
|
|
(lambda (edit offsets where direction filename)
|
||
|
|
;; direction is "parent" or "child"
|
||
|
|
(assert (not (send main filename->edit filename)))
|
||
|
|
(let* ( [menu-callback
|
||
|
|
(lambda (menu command)
|
||
|
|
(wrap-busy-cursor
|
||
|
|
(lambda ()
|
||
|
|
(send main add-frame
|
||
|
|
(send main filename->fileinfo filename)
|
||
|
|
#t))))]
|
||
|
|
[menu (make-object wx:menu% '() menu-callback)]
|
||
|
|
[xb (box 0)]
|
||
|
|
[yb (box 0)])
|
||
|
|
(send menu append
|
||
|
|
LOAD-NONLOCAL-FILE
|
||
|
|
(format "Load ~s containing ~a"
|
||
|
|
(file-name-from-path filename) direction))
|
||
|
|
|
||
|
|
;; Get global location of expr
|
||
|
|
(send edit position-location
|
||
|
|
(send edit real-start-position where)
|
||
|
|
xb yb)
|
||
|
|
(send edit local-to-global xb yb)
|
||
|
|
(pretty-debug-gui `(local-to-global returns ,xb ,yb))
|
||
|
|
|
||
|
|
(send (ivar edit canvas) popup-menu menu
|
||
|
|
(+ (unbox xb) (car offsets))
|
||
|
|
(+ (unbox yb) (cdr offsets)))))]
|
||
|
|
|
||
|
|
[popup-zoom-menu
|
||
|
|
(lambda (edit offsets where to direction)
|
||
|
|
|
||
|
|
;; direction is "parent" or "child"
|
||
|
|
(let* ( [menu-callback
|
||
|
|
(lambda (menu command)
|
||
|
|
(wrap-busy-cursor
|
||
|
|
(lambda ()
|
||
|
|
(send to arrow-zoom))))]
|
||
|
|
[menu (make-object wx:menu% '() menu-callback)]
|
||
|
|
[xb (box 0)]
|
||
|
|
[yb (box 0)])
|
||
|
|
(set! last-arrow-popup
|
||
|
|
(lambda ()
|
||
|
|
(send this popup-zoom-menu edit offsets where to direction)))
|
||
|
|
(send menu append
|
||
|
|
ZOOM-TO-FILE
|
||
|
|
(format "Zoom to ~a in ~s"
|
||
|
|
direction
|
||
|
|
(file-name-from-path
|
||
|
|
(send (ivar to edit) get-filename))))
|
||
|
|
|
||
|
|
;; Get global location of expr
|
||
|
|
(send edit position-location
|
||
|
|
(send edit real-start-position where)
|
||
|
|
xb yb)
|
||
|
|
(send edit local-to-global xb yb)
|
||
|
|
(pretty-debug-gui `(local-to-global returns ,xb ,yb))
|
||
|
|
|
||
|
|
(send (ivar edit canvas) popup-menu menu
|
||
|
|
(+ (unbox xb) (car offsets))
|
||
|
|
(+ (unbox yb) (cdr offsets)))))]
|
||
|
|
)
|
||
|
|
|
||
|
|
(sequence
|
||
|
|
(assert (is-a? arg-main MrSpidey%))
|
||
|
|
(assert (FlowType? arg-src) arg-src)
|
||
|
|
(assert (FlowType? arg-dest) arg-dest)
|
||
|
|
(pretty-debug-gui
|
||
|
|
`(flow-arrow% ,arg-main
|
||
|
|
,(FlowType->pretty arg-src) ,(FlowType->pretty arg-dest)))
|
||
|
|
(set! main arg-main)
|
||
|
|
(set! src arg-src)
|
||
|
|
(set! dest arg-dest)
|
||
|
|
|
||
|
|
;; 4 cases for arrow
|
||
|
|
;; local - simple case
|
||
|
|
;; source-half - just show arrow coming in from edge
|
||
|
|
;; sink-half - just show arrow going to edge
|
||
|
|
;; both-halves - show incoming and outgoing arrows in resp edits
|
||
|
|
|
||
|
|
(let* ( [src-ta (lookup-ftype src)]
|
||
|
|
[dest-ta (lookup-ftype dest)])
|
||
|
|
|
||
|
|
(when (or
|
||
|
|
(and
|
||
|
|
(is-a? src-ta type-annotation%)
|
||
|
|
(assq dest-ta (ivar src-ta dest->arrows)))
|
||
|
|
(and
|
||
|
|
(is-a? dest-ta type-annotation%)
|
||
|
|
(assq src-ta (ivar dest-ta src->arrows))))
|
||
|
|
|
||
|
|
;; Arrow already there
|
||
|
|
(raise (make-exn:flow-arrow-exists)))
|
||
|
|
|
||
|
|
;; Not already there - first tell endpoints we're here
|
||
|
|
(when (is-a? src-ta type-annotation%)
|
||
|
|
(send src-ta add-dest-arrow dest-ta this))
|
||
|
|
(when (is-a? dest-ta type-annotation%)
|
||
|
|
(send dest-ta add-source-arrow src-ta this))
|
||
|
|
|
||
|
|
(pretty-debug-gui
|
||
|
|
`(src-ta ,src-ta
|
||
|
|
dest-ta ,dest-ta
|
||
|
|
srctadest->arrows
|
||
|
|
,(and
|
||
|
|
(is-a? src-ta type-annotation%)
|
||
|
|
(map car (ivar src-ta dest->arrows)))
|
||
|
|
desttasrc->arrows
|
||
|
|
,(and
|
||
|
|
(is-a? dest-ta type-annotation%)
|
||
|
|
(map car (ivar dest-ta src->arrows)))))
|
||
|
|
|
||
|
|
(let*
|
||
|
|
(
|
||
|
|
[ta->edit-or-false
|
||
|
|
(lambda (ta)
|
||
|
|
(cond
|
||
|
|
[(string? ta)
|
||
|
|
;; If ftype is from .za file,
|
||
|
|
;; corresponding edit should not exist yet
|
||
|
|
(assert (not (send main filename->edit ta)))
|
||
|
|
#f]
|
||
|
|
[(is-a? ta type-annotation%)
|
||
|
|
;; Is a type-annotation
|
||
|
|
(ivar ta edit)]))]
|
||
|
|
[src-edit (ta->edit-or-false src-ta)]
|
||
|
|
[dest-edit (ta->edit-or-false dest-ta)])
|
||
|
|
|
||
|
|
(set! delete-arrow-thunks
|
||
|
|
(cond
|
||
|
|
[(and src-edit (not dest-edit))
|
||
|
|
;; sink-half arrow
|
||
|
|
(let* ( [clickback-where
|
||
|
|
(lambda (offsets)
|
||
|
|
(lambda (where)
|
||
|
|
(lambda (event)
|
||
|
|
(cond
|
||
|
|
[(send event button-down? 1)
|
||
|
|
(popup-load-menu
|
||
|
|
src-edit offsets where
|
||
|
|
"child" dest-ta)]
|
||
|
|
[(send event button-down? 3)
|
||
|
|
(delete-refresh)
|
||
|
|
#t]
|
||
|
|
[else #f]))))])
|
||
|
|
(list
|
||
|
|
(send src-edit add-flow-arrow-part
|
||
|
|
(send src-ta get-start-pos)
|
||
|
|
(clickback-where offsets-load-menu-src-known)
|
||
|
|
'jump
|
||
|
|
(clickback-where offsets-load-menu-dest-jump)
|
||
|
|
nodest-arrow-brush.pen)))]
|
||
|
|
|
||
|
|
[(and dest-edit (not src-edit))
|
||
|
|
;; sink-half arrow
|
||
|
|
(let* ( [clickback-where
|
||
|
|
(lambda (offsets)
|
||
|
|
(lambda (where)
|
||
|
|
(lambda (event)
|
||
|
|
(cond
|
||
|
|
[(send event button-down? 1)
|
||
|
|
(popup-load-menu
|
||
|
|
dest-edit offsets where
|
||
|
|
"parent" src-ta)]
|
||
|
|
[(send event button-down? 3)
|
||
|
|
(delete-refresh)
|
||
|
|
#t]
|
||
|
|
[else #f]))))])
|
||
|
|
(list
|
||
|
|
(send dest-edit add-flow-arrow-part
|
||
|
|
'jump
|
||
|
|
(clickback-where offsets-load-menu-src-jump)
|
||
|
|
(send dest-ta get-start-pos)
|
||
|
|
(clickback-where offsets-load-menu-dest-known)
|
||
|
|
nosrc-arrow-brush.pen)))]
|
||
|
|
|
||
|
|
[(and src-edit dest-edit)
|
||
|
|
;; local or non-local arrow
|
||
|
|
(let* ( [clickback-zoom
|
||
|
|
(lambda (to)
|
||
|
|
(lambda (posn)
|
||
|
|
(lambda (event)
|
||
|
|
(cond
|
||
|
|
[(send event button-down? 1)
|
||
|
|
(send to arrow-zoom)]
|
||
|
|
[(send event button-down? 3)
|
||
|
|
(delete-refresh)
|
||
|
|
#t]
|
||
|
|
[else #f]))))])
|
||
|
|
|
||
|
|
(cond
|
||
|
|
[(eq? src-edit dest-edit)
|
||
|
|
;; local arrow
|
||
|
|
(list
|
||
|
|
(send src-edit add-flow-arrow-part
|
||
|
|
(send src-ta get-start-pos)
|
||
|
|
(clickback-zoom dest-ta)
|
||
|
|
(send dest-ta get-start-pos)
|
||
|
|
(clickback-zoom src-ta)
|
||
|
|
arrow-brush.pen))]
|
||
|
|
|
||
|
|
[else
|
||
|
|
;; non-local arrow
|
||
|
|
(let*
|
||
|
|
( [src-posn (send src-ta get-start-pos)]
|
||
|
|
[dest-posn (send dest-ta get-start-pos)]
|
||
|
|
[clickback-where
|
||
|
|
(lambda (edit offsets to direction)
|
||
|
|
(lambda (where)
|
||
|
|
(lambda (event)
|
||
|
|
(cond
|
||
|
|
[(send event button-down? 1)
|
||
|
|
(popup-zoom-menu
|
||
|
|
edit offsets where to direction)]
|
||
|
|
[(send event button-down? 3)
|
||
|
|
(delete-refresh)
|
||
|
|
#t]
|
||
|
|
[else #f]))))])
|
||
|
|
(list
|
||
|
|
(send src-edit add-flow-arrow-part
|
||
|
|
src-posn
|
||
|
|
(clickback-where
|
||
|
|
src-edit
|
||
|
|
offsets-load-menu-src-known
|
||
|
|
dest-ta "child")
|
||
|
|
'jump
|
||
|
|
(clickback-where
|
||
|
|
src-edit
|
||
|
|
offsets-load-menu-dest-jump
|
||
|
|
dest-ta "child")
|
||
|
|
arrow-brush.pen)
|
||
|
|
(send dest-edit add-flow-arrow-part
|
||
|
|
'jump
|
||
|
|
(clickback-where
|
||
|
|
dest-edit
|
||
|
|
offsets-load-menu-src-jump
|
||
|
|
src-ta "parent")
|
||
|
|
dest-posn
|
||
|
|
(clickback-where
|
||
|
|
dest-edit
|
||
|
|
offsets-load-menu-dest-known
|
||
|
|
src-ta "parent")
|
||
|
|
arrow-brush.pen)))]))]
|
||
|
|
[else
|
||
|
|
(assert #f 'flow-arrow% src-edit dest-edit)]
|
||
|
|
))
|
||
|
|
(assert (list? delete-arrow-thunks) 2 delete-arrow-thunks)
|
||
|
|
)))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
|