suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactored to make testing check syntax renaming possible

Browse Source 
made sure to remove duplicates from the list before doing renaming
  closes PR 11659
This commit is contained in:
Robby Findler 2011-01-21 15:47:27 -06:00
parent ac083b9148
commit 45a635339e
5 changed files with 322 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/drracket/private/syncheck/gui.rkt
View File

@ -69,6 +69,7 @@ If the namespace does not, they are colored the unbound color.
(λ (x) (memq x '(default-mode (λ (x) (memq x '(default-mode
my-obligations-mode my-obligations-mode
client-obligations-mode)))) client-obligations-mode))))
(define tool@ (define tool@
(unit (unit
(import drracket:tool^) (import drracket:tool^)
@ -691,16 +692,30 @@ If the namespace does not, they are colored the unbound color.
(invalidate-bitmap-cache))])) (invalidate-bitmap-cache))]))
(super on-event event)] (super on-event event)]
[(send event button-down? 'right) [(send event button-down? 'right)
(define menu
(let-values ([(pos text) (get-pos/text event)]) (let-values ([(pos text) (get-pos/text event)])
(if (and pos (is-a? text text%)) (syncheck:build-popup-menu pos text)))
(cond
[menu
(send (get-canvas) popup-menu menu
(+ 1 (inexact->exact (floor (send event get-x))))
(+ 1 (inexact->exact (floor (send event get-y)))))]
[else
(super on-event event)])]
[else (super on-event event)])
(super on-event event)))
(define/public (syncheck:build-popup-menu pos text)
(and pos
(is-a? text text%)
(let ([arrow-record (hash-ref arrow-records text #f)]) (let ([arrow-record (hash-ref arrow-records text #f)])
(when arrow-record (and arrow-record
(let ([vec-ents (interval-map-ref arrow-record pos null)] (let ([vec-ents (interval-map-ref arrow-record pos null)]
[start-selection (send text get-start-position)] [start-selection (send text get-start-position)]
[end-selection (send text get-end-position)]) [end-selection (send text get-end-position)])
(cond (cond
[(and (null? vec-ents) (= start-selection end-selection)) [(and (null? vec-ents) (= start-selection end-selection))
(super on-event event)] #f]
[else [else
(let* ([menu (make-object popup-menu% #f)] (let* ([menu (make-object popup-menu% #f)]
[arrows (filter arrow? vec-ents)] [arrows (filter arrow? vec-ents)]
@ -766,15 +781,10 @@ If the namespace does not, they are colored the unbound color.
(drracket:unit:add-search-help-desk-menu-item (drracket:unit:add-search-help-desk-menu-item
text text
menu menu
event pos
(λ () (new separator-menu-item% [parent menu]))) (λ () (new separator-menu-item% [parent menu])))
(send (get-canvas) popup-menu menu menu)]))))))
(+ 1 (inexact->exact (floor (send event get-x))))
(+ 1 (inexact->exact (floor (send event get-y))))))]))))
(super on-event event)))]
[else (super on-event event)])
(super on-event event)))
(define/private (update-status-line eles) (define/private (update-status-line eles)
(let ([has-txt? #f]) (let ([has-txt? #f])

28
collects/drracket/private/syncheck/traversals.rkt
View File

@ -1395,7 +1395,7 @@
(loop (list (syntax-source stx) (loop (list (syntax-source stx)
(syntax-position stx) (syntax-position stx)
(syntax-span stx)))))))) (syntax-span stx))))))))
(define to-be-renamed (sort (hash-map all-stxs (λ (k v) k)) > #:key syntax-position)) (define to-be-renamed (hash-map all-stxs (λ (k v) k)))
(define do-renaming? (define do-renaming?
(or (not (name-duplication? to-be-renamed id-sets new-sym)) (or (not (name-duplication? to-be-renamed id-sets new-sym))
(equal? (equal?
@ -1412,22 +1412,30 @@
(when do-renaming? (when do-renaming?
(unless (null? to-be-renamed) (unless (null? to-be-renamed)
(let ([txts (list defs-text)]) (let ([txts (list defs-text)])
(define positions-to-rename
(remove-duplicates
(sort (map (λ (stx) (list (find-source-editor/defs stx defs-text)
(syntax-position stx)
(syntax-span stx)))
to-be-renamed)
>
#:key cadr)))
(send defs-text begin-edit-sequence) (send defs-text begin-edit-sequence)
(for-each (λ (stx) (for ([info (in-list positions-to-rename)])
(let ([source-editor (find-source-editor/defs stx defs-text)]) (define source-editor (list-ref info 0))
(define position (list-ref info 1))
(define span (list-ref info 2))
(when (is-a? source-editor text%) (when (is-a? source-editor text%)
(unless (memq source-editor txts) (unless (memq source-editor txts)
(send source-editor begin-edit-sequence) (send source-editor begin-edit-sequence)
(set! txts (cons source-editor txts))) (set! txts (cons source-editor txts)))
(let* ([start (- (syntax-position stx) 1)] (let* ([start (- position 1)]
[end (+ start (syntax-span stx))]) [end (+ start span)])
(send source-editor delete start end #f) (send source-editor delete start end #f)
(send source-editor insert new-sym start start #f))))) (send source-editor insert new-sym start start #f))))
to-be-renamed)
(send defs-text invalidate-bitmap-cache) (send defs-text invalidate-bitmap-cache)
(for-each (for ([txt (in-list txts)])
(λ (txt) (send txt end-edit-sequence)) (send txt end-edit-sequence))))))))
txts)))))))
;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean
;; returns #t if the name chosen would be the same as another name in this scope. ;; returns #t if the name chosen would be the same as another name in this scope.

20
collects/drracket/private/unit.rkt
View File

@ -144,7 +144,13 @@ module browser threading seems wrong.
(set! added? #t) (set! added? #t)
(new separator-menu-item% [parent menu]))))]) (new separator-menu-item% [parent menu]))))])
(add-search-help-desk-menu-item text menu event add-sep) (add-search-help-desk-menu-item text menu
(let-values ([(x y)
(send text dc-location-to-editor-location
(send event get-x)
(send event get-y))])
(send text find-position x y))
add-sep)
(when (is-a? text editor:basic<%>) (when (is-a? text editor:basic<%>)
(let-values ([(pos text) (send text get-pos/text event)]) (let-values ([(pos text) (send text get-pos/text event)])
@ -181,20 +187,12 @@ module browser threading seems wrong.
(void)))))) (void))))))
(define (add-search-help-desk-menu-item text menu event [add-sep void]) (define (add-search-help-desk-menu-item text menu position [add-sep void])
(let* ([end (send text get-end-position)] (let* ([end (send text get-end-position)]
[start (send text get-start-position)]) [start (send text get-start-position)])
(unless (= 0 (send text last-position)) (unless (= 0 (send text last-position))
(let* ([str (if (= end start) (let* ([str (if (= end start)
(find-symbol (find-symbol text position)
text
(call-with-values
(λ ()
(send text dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(λ (x y)
(send text find-position x y))))
(send text get-text start end))] (send text get-text start end))]
;; almost the same code as "search-help-desk" in "rep.rkt" ;; almost the same code as "search-help-desk" in "rep.rkt"
[l (send text get-canvas)] [l (send text get-canvas)]

11
collects/drracket/tool-lib.rkt
View File

@ -627,14 +627,13 @@ all of the names in the tools library, for use defining keybindings
(proc-doc/names (proc-doc/names
drracket:unit:add-search-help-desk-menu-item drracket:unit:add-search-help-desk-menu-item
(->* ((is-a?/c text%) (is-a?/c menu-item-container<%>) (is-a?/c mouse-event%)) ((-> any)) void?) (->* ((is-a?/c text%) (is-a?/c menu-item-container<%>) exact-nonnegative-integer?) ((-> any)) void?)
((text menu event) ((text menu position)
((add-sep void))) ((add-sep void)))
@{Assuming that @racket[event] represents a mouse click in @racket[text], this @{Adds a menu item to @racket[menu] that searches in Help Desk
adds a menu item to @racket[menu] that searches in Help Desk for the word around @racket[position] in @racket[text].
for the text around the point where the click happened.
If there is only whitespace around the insertion point, If there is only whitespace around @racket[position],
then no @racket[menu-item%]s are added, and then no @racket[menu-item%]s are added, and
@racket[add-sep] is not called. If there is something to be @racket[add-sep] is not called. If there is something to be
added, then @racket[add-sep] is called before the menu item is added, then @racket[add-sep] is called before the menu item is

191
collects/tests/drracket/syncheck-test.rkt
View File

@ -1,3 +1,4 @@
#lang racket/base
#| #|
@ -5,15 +6,14 @@ tests involving object% are commented out, since they
trigger runtime errors in check syntax. trigger runtime errors in check syntax.
|# |#
#lang scheme/base
(require "drracket-test-util.rkt" (require "drracket-test-util.rkt"
string-constants/string-constant string-constants/string-constant
tests/utils/gui tests/utils/gui
scheme/path racket/path
scheme/class racket/class
scheme/list racket/list
scheme/file racket/file
mred mred
framework framework
mrlib/text-string-style-desc) mrlib/text-string-style-desc)
@ -24,8 +24,10 @@ trigger runtime errors in check syntax.
;; type test = (make-test string ;; type test = (make-test string
;; (listof str/ann) ;; (listof str/ann)
;; (listof (cons (list number number) (listof (list number number))))) ;; (listof (cons (list number number) (listof (list number number)))))
(define-struct test (input expected arrows)) (define-struct test (input expected arrows) #:transparent)
(define-struct (dir-test test) ()) (define-struct (dir-test test) () #:transparent)
(define-struct rename-test (input pos old-name new-name output) #:transparent)
(define build-test (define build-test
(λ (input expected [arrow-table '()]) (λ (input expected [arrow-table '()])
@ -34,7 +36,6 @@ trigger runtime errors in check syntax.
;; tests : (listof test) ;; tests : (listof test)
(define tests (define tests
(list (list
(build-test "12345" (build-test "12345"
'(("12345" constant))) '(("12345" constant)))
(build-test "'abcdef" (build-test "'abcdef"
@ -877,7 +878,103 @@ trigger runtime errors in check syntax.
(") " default-color) (") " default-color)
("#'" imported) ("#'" imported)
("1))" default-color)) ("1))" default-color))
(list '((27 33) (19 26) (36 49) (53 59) (64 66)))))) (list '((27 33) (19 26) (36 49) (53 59) (64 66))))
(rename-test "(lambda (x) x)"
9
"x"
"y"
"(lambda (y) y)")
(rename-test "(lambda (x) x)"
9
"x"
"yy"
"(lambda (yy) yy)")
(rename-test "(lambda (x) x)"
9
"x"
"yxy"
"(lambda (yxy) yxy)")
(rename-test "(lambda (x) x x)"
9
"x"
"yxy"
"(lambda (yxy) yxy yxy)")
(rename-test "(lambda (x) x x)"
12
"x"
"yxy"
"(lambda (yxy) yxy yxy)")
(rename-test "(lambda (x) x x)"
14
"x"
"yxy"
"(lambda (yxy) yxy yxy)")
(rename-test "(define-syntax-rule (m x) (λ (x) x))(m z)"
39
"z"
"qq"
"(define-syntax-rule (m x) (λ (x) x))(m qq)")
(rename-test (string-append
"#lang racket"
"\n"
"(define player%\n"
" (class object%\n"
" (init-field strategy player# tiles)\n"
" (field [score (set)])\n"
"\n"
" (super-new)\n"
"\n"
" (define/private (put t pl)\n"
" (set! tiles(remove t tiles)))))\n")
80
"tiles"
"*tiles"
(string-append
"#lang racket"
"\n"
"(define player%\n"
" (class object%\n"
" (init-field strategy player# *tiles)\n"
" (field [score (set)])\n"
"\n"
" (super-new)\n"
"\n"
" (define/private (put t pl)\n"
" (set! *tiles(remove t *tiles)))))\n"))
(rename-test (string-append
"#lang racket"
"\n"
"(define player%\n"
" (class object%\n"
" (init-field strategy player# *tiles)\n"
" (field [score (set)])\n"
"\n"
" (super-new)\n"
"\n"
" (define/private (put t pl)\n"
" (set! *tiles(remove t *tiles)))))\n")
80
"*tiles"
"tiles"
(string-append
"#lang racket"
"\n"
"(define player%\n"
" (class object%\n"
" (init-field strategy player# tiles)\n"
" (field [score (set)])\n"
"\n"
" (super-new)\n"
"\n"
" (define/private (put t pl)\n"
" (set! tiles(remove t tiles)))))\n"))))
(define (main) (define (main)
(fire-up-drscheme-and-run-tests (fire-up-drscheme-and-run-tests
@ -917,28 +1014,19 @@ trigger runtime errors in check syntax.
(define ((run-one-test save-dir) test) (define ((run-one-test save-dir) test)
(set! total-tests-run (+ total-tests-run 1)) (set! total-tests-run (+ total-tests-run 1))
(let* ([drs (wait-for-drscheme-frame)] (let* ([drs (wait-for-drscheme-frame)]
[defs (queue-callback/res (λ () (send drs get-definitions-text)))] [defs (queue-callback/res (λ () (send drs get-definitions-text)))])
[input (test-input test)] (clear-definitions drs)
(cond
[(test? test)
(let ([input (test-input test)]
[expected (test-expected test)] [expected (test-expected test)]
[arrows (test-arrows test)] [arrows (test-arrows test)]
[relative (find-relative-path save-dir (collection-path "mzlib"))]) [relative (find-relative-path save-dir (collection-path "mzlib"))])
(clear-definitions drs)
(cond (cond
[(dir-test? test) [(dir-test? test)
(insert-in-definitions drs (format input (path->string relative)))] (insert-in-definitions drs (format input (path->string relative)))]
[else (insert-in-definitions drs input)]) [else (insert-in-definitions drs input)])
(click-check-syntax-button drs) (click-check-syntax-and-check-errors drs test)
(wait-for-computation drs)
(when (queue-callback/res (λ () (send defs in-edit-sequence?)))
(error 'syncheck-test.rkt "still in edit sequence for ~s" input))
(let ([err (queue-callback/res (λ () (send drs syncheck:get-error-report-contents)))])
(when err
(fprintf (current-error-port)
"FAILED ~s\n error report window is visible:\n ~a\n"
input
err)))
;; need to check for syntax error here ;; need to check for syntax error here
(let ([got (get-annotated-output drs)]) (let ([got (get-annotated-output drs)])
@ -955,7 +1043,47 @@ trigger runtime errors in check syntax.
got got
arrows arrows
(queue-callback/res (λ () (send defs syncheck:get-bindings-table))) (queue-callback/res (λ () (send defs syncheck:get-bindings-table)))
input)))) input)))]
[(rename-test? test)
(insert-in-definitions drs (rename-test-input test))
(click-check-syntax-and-check-errors drs test)
(define menu-item
(queue-callback/res
(λ ()
(define defs (send drs get-definitions-text))
(define menu (send defs syncheck:build-popup-menu (rename-test-pos test) defs))
(define item-name (format "Rename ~a" (rename-test-old-name test)))
(define menu-item
(for/or ([x (in-list (send menu get-items))])
(and (is-a? x labelled-menu-item<%>)
(equal? (send x get-label) item-name)
x)))
(cond
[menu-item
menu-item]
[else
(fprintf (current-error-port)
"syncheck-test.rkt: rename test ~s didn't find menu item named ~s in ~s"
test
item-name
(map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send menu get-items)))
#f]))))
(when menu-item
(queue-callback (λ () (send menu-item command (make-object control-event% 'menu))))
(wait-for-new-frame drs)
(for ([x (in-string (rename-test-new-name test))])
(test:keystroke x))
(test:button-push "OK")
(define result
(queue-callback/res (λ ()
(define defs (send drs get-definitions-text))
(send defs get-text 0 (send defs last-position)))))
(unless (equal? result (rename-test-output test))
(fprintf (current-error-port)
"syncheck-test.rkt FAILED\n test ~s\n got ~s\n"
test
result)))])))
(define remappings (define remappings
@ -1044,6 +1172,19 @@ trigger runtime errors in check syntax.
(define (get-annotated-output drs) (define (get-annotated-output drs)
(queue-callback/res (λ () (get-string/style-desc (send drs get-definitions-text))))) (queue-callback/res (λ () (get-string/style-desc (send drs get-definitions-text)))))
(define (click-check-syntax-and-check-errors drs test)
(click-check-syntax-button drs)
(wait-for-computation drs)
(when (queue-callback/res (λ () (send (send drs get-definitions-text) in-edit-sequence?)))
(error 'syncheck-test.rkt "still in edit sequence for ~s" test))
(let ([err (queue-callback/res (λ () (send drs syncheck:get-error-report-contents)))])
(when err
(fprintf (current-error-port)
"FAILED ~s\n error report window is visible:\n ~a\n"
test
err))))
(define (click-check-syntax-button drs) (define (click-check-syntax-button drs)
(test:run-one (lambda () (send (send drs syncheck:get-button) command)))) (test:run-one (lambda () (send (send drs syncheck:get-button) command))))