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

Added online expansion and compilation of files

Browse Source 
being edited in DrRacket (via places)

Added an API to let tools have access to that
  information (and compute more stuff)

Used that to make an online version of Check Syntax
  which led to a separately callable Check Syntax API.
This commit is contained in:
Robby Findler 2011-06-03 21:08:39 -07:00
parent 33cf3a167b
commit b972a0940d
34 changed files with 6601 additions and 5289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/drracket/check-syntax.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang at-exp racket/base
(require racket/contract
racket/class
"private/syncheck/traversals.rkt"
"private/syncheck/intf.rkt")
(provide/contract
[make-traversal
(-> namespace?
(or/c path-string? #f)
(values (->* (syntax?) ((-> syntax? void?)) void?)
(-> void?)))]
[syncheck-annotations<%>
interface?]
[current-annotations
(parameter/c (or/c #f (is-a?/c syncheck-annotations<%>)))]
[annotations-mixin
(and/c mixin-contract
(-> any/c (implementation?/c syncheck-annotations<%>)))])
;; methods in syncheck-annotations<%>
(provide
syncheck:find-source-object
syncheck:add-background-color
syncheck:add-require-open-menu
syncheck:add-docs-menu
syncheck:add-rename-menu
syncheck:add-arrow
syncheck:add-tail-arrow
syncheck:add-mouse-over-status
syncheck:add-jump-to-definition
syncheck:color-range)

3
collects/drracket/private/debug.rkt
View File

@ -37,7 +37,8 @@ profile todo:
[prefix drracket:unit: drracket:unit^]
[prefix drracket:language: drracket:language^]
[prefix drracket:language-configuration: drracket:language-configuration/internal^]
[prefix drracket:init: drracket:init^])
[prefix drracket:init: drracket:init^]
[prefix drracket: drracket:interface^])
(export drracket:debug^)
;

51
collects/drracket/private/drsig.rkt
View File

@ -4,6 +4,7 @@
(provide drracket:eval^
drracket:debug^
drracket:module-language^
drracket:module-language/int^
drracket:module-language-tools^
drracket:get-collection^
drracket:main^
@ -31,7 +32,8 @@
drracket:tool^
drracket:tool-cm^
drscheme:tool^
drscheme:tool-cm^)
drscheme:tool-cm^
drracket:interface^)
(define-signature drracket:modes-cm^
())
@ -90,16 +92,23 @@
(define-signature drracket:module-language^ extends drracket:module-language-cm^
(add-module-language
module-language-put-file-mixin))
(define-signature drracket:module-language/int^ extends drracket:module-language^
(module-language-online-expand-text-mixin
module-language-online-expand-frame-mixin
module-language-online-expand-tab-mixin))
(define-signature drracket:module-language-tools-cm^
(frame-mixin
frame<%>
tab-mixin
tab<%>
definitions-text-mixin
definitions-text<%>))
definitions-text-mixin))
(define-signature drracket:module-language-tools^ extends drracket:module-language-tools-cm^
(add-opt-out-toolbar-button))
(add-opt-out-toolbar-button
add-online-expansion-handler
;; the below should be hidden from tools
(struct online-expansion-handler (mod-path id local-handler))
get-online-expansion-handlers
no-more-online-expansion-handlers))
(define-signature drracket:get-collection-cm^ ())
(define-signature drracket:get-collection^ extends drracket:get-collection-cm^
@ -177,12 +186,9 @@
(define-signature drracket:unit-cm^
(tab%
tab<%>
frame%
frame<%>
definitions-canvas%
get-definitions-text%
definitions-text<%>
interactions-canvas%))
(define-signature drracket:unit^ extends drracket:unit-cm^
(open-drscheme-window
@ -196,10 +202,8 @@
add-search-help-desk-menu-item))
(define-signature drracket:frame-cm^
(<%>
mixin
basics-mixin
basics<%>))
(mixin
basics-mixin))
(define-signature drracket:frame^ extends drracket:frame-cm^
(create-root-menubar
add-keybindings-item
@ -234,8 +238,7 @@
(define-signature drracket:rep-cm^
(drs-bindings-keymap-mixin
text%
text<%>
context<%>))
text<%>))
(define-signature drracket:rep^ extends drracket:rep-cm^
(current-rep
current-language-settings
@ -332,6 +335,18 @@
(define-signature drracket:tracing^ extends drracket:tracing-cm^
(annotate))
(define-signature drracket:interface^
(frame:basics<%>
frame:<%>
unit:frame<%>
unit:definitions-text<%>
unit:tab<%>
rep:context<%>
module-language-tools:definitions-text<%>
module-language-tools:tab<%>
module-language-tools:frame<%>))
(define-signature drracket:tool-exports-cm^
())
(define-signature drracket:tool-exports^ extends drracket:tool-exports-cm^
@ -352,7 +367,8 @@
(open (prefix modes: drracket:modes-cm^))
(open (prefix tracing: drracket:tracing-cm^))
(open (prefix module-language: drracket:module-language-cm^))
(open (prefix module-language-tools: drracket:module-language-tools-cm^))))
(open (prefix module-language-tools: drracket:module-language-tools-cm^))
(open drracket:interface^)))
(define-signature drracket:tool-cm^
((open (prefix drracket: no-prefix:tool-cm^))))
@ -372,7 +388,8 @@
(open (prefix modes: drracket:modes^))
(open (prefix tracing: drracket:tracing^))
(open (prefix module-language: drracket:module-language^))
(open (prefix module-language-tools: drracket:module-language-tools^))))
(open (prefix module-language-tools: drracket:module-language-tools^))
(open drracket:interface^)))
(define-signature drracket:tool^
((open (prefix drracket: no-prefix:tool^))))

97
collects/drracket/private/eval-helpers.rkt Normal file
View File

@ -0,0 +1,97 @@
#lang racket/base
(require racket/class
racket/draw
racket/list
compiler/cm
setup/dirs
planet/config
(prefix-in *** '#%foreign) ;; just to make sure it is here
)
(provide set-basic-parameters/no-gui
set-module-language-parameters
(struct-out prefab-module-settings)
transform-module)
(struct prefab-module-settings
(command-line-args
collection-paths
compilation-on?
full-trace?
annotations)
#:prefab)
(define orig-namespace (current-namespace))
(define (set-basic-parameters/no-gui)
(let ([cust (current-custodian)])
(define (drracket-plain-exit-handler arg)
(custodian-shutdown-all cust))
(exit-handler drracket-plain-exit-handler))
(current-thread-group (make-thread-group))
(current-command-line-arguments #())
(current-pseudo-random-generator (make-pseudo-random-generator))
(current-evt-pseudo-random-generator (make-pseudo-random-generator))
(read-curly-brace-as-paren #t)
(read-square-bracket-as-paren #t)
(error-print-width 250)
(current-ps-setup (make-object ps-setup%))
(current-namespace (make-base-empty-namespace))
;; is this wise?
#;(namespace-attach-module orig-namespace ''#%foreign))
(define (set-module-language-parameters settings module-language-parallel-lock-client
#:use-use-current-security-guard? [use-current-security-guard? #f])
(current-command-line-arguments (prefab-module-settings-command-line-args settings))
(let* ([default (current-library-collection-paths)]
[cpaths (append-map (λ (x) (if (symbol? x) default (list x)))
(prefab-module-settings-collection-paths settings))])
(when (null? cpaths)
(fprintf (current-error-port)
"WARNING: your collection paths are empty!\n"))
(current-library-collection-paths cpaths))
(compile-context-preservation-enabled (prefab-module-settings-full-trace? settings))
(when (prefab-module-settings-compilation-on? settings)
(case (prefab-module-settings-annotations settings)
[(none)
(use-compiled-file-paths
(cons (build-path "compiled" "drracket")
(use-compiled-file-paths)))]
[(debug)
(use-compiled-file-paths
(cons (build-path "compiled" "drracket" "errortrace")
(use-compiled-file-paths)))])
(parallel-lock-client module-language-parallel-lock-client)
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler
#t
#:security-guard (and use-current-security-guard?
(current-security-guard))))
(let* ([cd (find-collects-dir)]
[no-dirs (if cd
(list (CACHE-DIR) cd)
(list (CACHE-DIR)))])
(manager-skip-file-handler
(λ (p) (file-stamp-in-paths p no-dirs))))))
(define (transform-module filename stx raise-hopeless-syntax-error)
(define-values (mod name lang body)
(syntax-case stx ()
[(module name lang . body)
(eq? 'module (syntax-e #'module))
(values #'module #'name #'lang #'body)]
[_ (raise-hopeless-syntax-error
(string-append "only a module expression is allowed, either\n"
" #lang <language-name>\n or\n"
" (module <name> <language> ...)\n")
stx)]))
(define name* (syntax-e name))
(unless (symbol? name*)
(raise-hopeless-syntax-error "bad syntax in name position of module"
stx name))
(let* (;; rewrite the module to use the racket/base version of `module'
[mod (datum->syntax #'here 'module mod)]
[expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)])
(values name lang expr)))

24
collects/drracket/private/eval.rkt
View File

@ -6,9 +6,11 @@
racket/class
syntax/toplevel
framework
"eval-helpers.rkt"
"drsig.rkt")
;; to ensure this guy is loaded (and the snipclass installed) in the drscheme namespace & eventspace
;; to ensure this guy is loaded (and the snipclass installed)
;; in the drracket namespace & eventspace
;; these things are for effect only!
(require mrlib/cache-image-snip
(prefix-in image-core: mrlib/image-core))
@ -166,22 +168,7 @@
(define (set-basic-parameters snip-classes #:gui-modules? [gui-modules? #t])
(for-each (λ (snip-class) (send (get-the-snip-class-list) add snip-class))
snip-classes)
(let ([cust (current-custodian)])
(define (drracket-plain-exit-handler arg)
(custodian-shutdown-all cust))
(exit-handler drracket-plain-exit-handler))
(current-thread-group (make-thread-group))
(current-command-line-arguments #())
(current-pseudo-random-generator (make-pseudo-random-generator))
(current-evt-pseudo-random-generator (make-pseudo-random-generator))
(read-curly-brace-as-paren #t)
(read-square-bracket-as-paren #t)
(error-print-width 250)
(current-ps-setup (make-object ps-setup%))
(current-namespace (make-empty-namespace))
(set-basic-parameters/no-gui)
(for-each (λ (x) (namespace-attach-module drracket:init:system-namespace x))
to-be-copied-module-names)
(when gui-modules?
@ -196,8 +183,7 @@
;; these module specs are copied over to each new user's namespace
(define to-be-copied-module-specs
(list 'racket/base
''#%foreign
(list ''#%foreign
'(lib "mzlib/pconvert-prop.rkt")
'(lib "planet/terse-info.rkt")))

207
collects/drracket/private/expanding-place.rkt Normal file
View File

@ -0,0 +1,207 @@
#lang racket/base
(require racket/place
"eval-helpers.rkt"
compiler/cm)
(provide start)
(struct job (cust response-pc))
;; key : any (used by equal? for comparision, but back in the main place)
(struct handler (key proc))
(define handlers '())
(define module-language-parallel-lock-client
'uninitialized-module-language-parallel-lock-client)
(define (start p)
;; get the module-language-compile-lock in the initial message
(set! module-language-parallel-lock-client
(compile-lock->parallel-lock-client
(place-channel-get p)))
;; get the handlers in a second message
(set! handlers (for/list ([lst (place-channel-get p)])
(define file (list-ref lst 0))
(define id (list-ref lst 1))
(handler lst (dynamic-require file id))))
(let loop ([current-job #f])
(sync
(handle-evt
p
(λ (message)
(cond
[(eq? message 'abort)
(when current-job (abort-job current-job))
(loop #f)]
[(vector? message)
(when current-job (abort-job current-job))
(define program-as-string (vector-ref message 0))
(define path (vector-ref message 1))
(define response-pc (vector-ref message 2))
(define settings (vector-ref message 3))
(loop (new-job program-as-string path response-pc settings))]))))))
(define (abort-job job)
(custodian-shutdown-all (job-cust job))
(place-channel-put (job-response-pc job) #f))
(struct exn:access exn:fail ())
(define (new-job program-as-string path response-pc settings)
(define cust (make-custodian))
(define exn-chan (make-channel))
(define result-chan (make-channel))
(define normal-termination (make-channel))
(define abnormal-termination (make-channel))
(define the-source (or path "unsaved editor"))
(define orig-cust (current-custodian))
(define thd
(parameterize ([current-custodian cust])
(thread
(λ ()
(log-info "expanding-place.rkt: starting thread")
(define sema (make-semaphore 0))
(set-basic-parameters/no-gui)
(set-module-language-parameters settings
module-language-parallel-lock-client
#:use-use-current-security-guard? #t)
(when path
(let-values ([(base name dir?) (split-path path)])
(current-directory base)
(current-load-relative-directory base)))
(define sp (open-input-string program-as-string))
(port-count-lines! sp)
(install-security-guard) ;; must come after the call to set-module-language-parameters
(uncaught-exception-handler
(λ (exn)
(parameterize ([current-custodian orig-cust])
(thread
(λ ()
(channel-put normal-termination #t)
(semaphore-post sema)
(channel-put exn-chan exn))))
(semaphore-wait sema)
((error-escape-handler))))
(log-info "expanding-place.rkt: starting read-syntax")
(define stx
(parameterize ([read-accept-reader #t])
(read-syntax the-source sp)))
(log-info "expanding-place.rkt: read")
(when (syntax? stx) ;; could be eof
(define-values (name lang transformed-stx)
(transform-module path
(namespace-syntax-introduce stx)
raise-hopeless-syntax-error))
(log-info "expanding-place.rkt: starting expansion")
(define expanded (expand transformed-stx))
(log-info "expanding-place.rkt: expanded")
(define handler-results
(for/list ([handler (in-list handlers)])
(list (handler-key handler)
((handler-proc handler) expanded
path
the-source))))
(log-info "expanding-place.rkt: handlers finished")
(parameterize ([current-custodian orig-cust])
(thread
(λ ()
(channel-put normal-termination #t)
(semaphore-post sema)
(channel-put result-chan handler-results))))
(semaphore-wait sema))))))
(thread
(λ ()
(sync
(handle-evt
normal-termination
(λ (x) (void)))
(handle-evt
(thread-dead-evt thd)
(λ (x) (channel-put abnormal-termination #t))))))
(thread
(λ ()
(sync
(handle-evt
abnormal-termination
(λ (val)
(place-channel-put
response-pc
(vector 'abnormal-termination))))
(handle-evt
result-chan
(λ (val)
(place-channel-put response-pc (vector 'handler-results val))))
(handle-evt
exn-chan
(λ (exn)
(place-channel-put
response-pc
(cond
[(exn:access? exn)
(vector 'access-violation (exn-message exn))]
[(and (exn:fail:read? exn)
(andmap (λ (srcloc) (equal? (srcloc-source srcloc) the-source))
(exn:fail:read-srclocs exn)))
;; figure the syntax colorer can deal
;; with these better than we can
(vector 'no-errors)]
[else
(vector
'exn
(trim-message
(if (exn? exn)
(regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message exn) " ")
(format "uncaught exn: ~s" exn)))
(if (exn:srclocs? exn)
(sort
(filter
values
(for/list ([srcloc ((exn:srclocs-accessor exn) exn)])
(and (srcloc? srcloc)
(equal? the-source (srcloc-source srcloc))
(srcloc-position srcloc)
(srcloc-span srcloc)
(vector (srcloc-position srcloc)
(srcloc-span srcloc)))))
<
#:key (λ (x) (vector-ref x 0)))
'()))])))))))
(job cust response-pc))
(define (raise-hopeless-syntax-error . args)
(apply raise-syntax-error '|Module Language| args))
(define (install-security-guard)
(current-security-guard
(make-security-guard
(current-security-guard)
(λ (prim path whats)
(when (or (member 'write whats)
(member 'execute whats)
(member 'delete whats))
(raise (exn:access (format "~a: forbidden ~a access to ~a" prim whats path)
(current-continuation-marks)))))
(λ (prim target port what)
(raise (exn:access (format "~a: forbidden ~a access to ~a:~a" prim what target port)
(current-continuation-marks))))
(λ (prim path1 path2)
(raise (exn:access (format "~a: forbidden to link ~a to ~a" prim path1 path2)
(current-continuation-marks)))))))
;; trim-message : string -> string[200 chars max]
(define (trim-message str)
(cond
[(<= (string-length str) 200)
str]
[else
(define prefix-len 99)
(define suffix-len 98)
(define middle "...")
;; (+ prefix-len suffix-len (string-length middle)) must be 200 (or less)
(string-append (substring str 0 prefix-len)
middle
(substring str (- (string-length str) suffix-len) (string-length str)))]))

15
collects/drracket/private/frame.rkt
View File

@ -16,16 +16,15 @@
[prefix drracket:app: drracket:app^]
[prefix help: drracket:help-desk^]
[prefix drracket:multi-file-search: drracket:multi-file-search^]
[prefix drracket:init: drracket:init^])
[prefix drracket:init: drracket:init^]
[prefix drracket: drracket:interface^])
(export (rename drracket:frame^
[-mixin mixin]))
(define basics<%> (interface (frame:standard-menus<%>)))
(define last-keybindings-planet-attempt "")
(define basics-mixin
(mixin (frame:standard-menus<%>) (basics<%>)
(mixin (frame:standard-menus<%>) (drracket:frame:basics<%>)
(define/override (on-subwindow-char receiver event)
(let ([user-key? (send (keymap:get-user)
@ -588,14 +587,8 @@
(update-bindings)
(send f show #t)))
(define <%>
(interface (frame:editor<%> basics<%> frame:text-info<%>)
get-show-menu
update-shown
add-show-menu-items))
(define -mixin
(mixin (frame:editor<%> frame:text-info<%> basics<%>) (<%>)
(mixin (frame:editor<%> frame:text-info<%> drracket:frame:basics<%>) (drracket:frame:<%>)
(inherit get-editor get-menu% get-menu-bar)
(define show-menu #f)
(define/public get-show-menu (λ () show-menu))

21
collects/drracket/private/get-extend.rkt
View File

@ -8,6 +8,7 @@
[prefix drracket:rep: drracket:rep^]
[prefix drracket:debug: drracket:debug^]
[prefix drracket:tracing: drracket:tracing^]
[prefix drracket:module-language: drracket:module-language/int^]
[prefix drracket:module-language-tools: drracket:module-language-tools^])
(export drracket:get/extend^)
@ -45,11 +46,12 @@
built)))))
(define (get-base-tab%)
(drracket:module-language-tools:tab-mixin
(drracket:tracing:tab-mixin
(drracket:debug:test-coverage-tab-mixin
(drracket:debug:profile-tab-mixin
drracket:unit:tab%)))))
(drracket:module-language:module-language-online-expand-tab-mixin
(drracket:module-language-tools:tab-mixin
(drracket:tracing:tab-mixin
(drracket:debug:test-coverage-tab-mixin
(drracket:debug:profile-tab-mixin
drracket:unit:tab%))))))
(define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%))
@ -82,10 +84,11 @@
(make-extender get-base-interactions-text% 'interactions-text%))
(define (get-base-definitions-text%)
(drracket:module-language-tools:definitions-text-mixin
(drracket:debug:test-coverage-definitions-text-mixin
(drracket:debug:profile-definitions-text-mixin
(drracket:unit:get-definitions-text%)))))
(drracket:module-language:module-language-online-expand-text-mixin
(drracket:module-language-tools:definitions-text-mixin
(drracket:debug:test-coverage-definitions-text-mixin
(drracket:debug:profile-definitions-text-mixin
(drracket:unit:get-definitions-text%))))))
(define-values (extend-definitions-text get-definitions-text)
(make-extender get-base-definitions-text% 'definitions-text%))

133
collects/drracket/private/interface.rkt Normal file
View File

@ -0,0 +1,133 @@
#lang racket/unit
#|
This file has names with partial prefixes built into them
because the interfaces here used to be in other files, but
that was causing circular dependencies; the interfaces
were moved here to break the cycle, but the names should
remain the same for tools that use them.
|#
(require "drsig.rkt"
"local-member-names.rkt"
racket/class
framework)
(import)
(export drracket:interface^)
(define frame:basics<%> (interface (frame:standard-menus<%>)))
(define frame:<%>
(interface (frame:editor<%> frame:basics<%> frame:text-info<%>)
get-show-menu
update-shown
add-show-menu-items))
(define unit:frame<%>
(interface (frame:<%>
frame:searchable-text<%>
frame:delegate<%>
frame:open-here<%>)
get-insert-menu
get-special-menu
get-interactions-text
get-definitions-text
get-interactions-canvas
get-definitions-canvas
get-button-panel
execute-callback
get-current-tab
open-in-new-tab
close-current-tab
on-tab-change
enable-evaluation
disable-evaluation
get-definitions/interactions-panel-parent
register-capability-menu-item
ensure-rep-shown
ensure-rep-hidden
ensure-defs-shown
get-language-menu
register-toolbar-button
register-toolbar-buttons
unregister-toolbar-button
get-tabs))
(define unit:definitions-text<%>
(interface ()
begin-metadata-changes
end-metadata-changes
get-tab
get-next-settings
after-set-next-settings
set-needs-execution-message))
(define rep:context<%>
(interface ()
ensure-rep-shown ;; (interactions-text -> void)
;; make the rep visible in the frame
repl-submit-happened ;; (-> boolean)
;; notify the context that an evaluation is about to
;; happen in the REPL (so it can show a warning about
;; the language/etc is out of sync if neccessary).
enable-evaluation ;; (-> void)
;; make the context enable all methods of evaluation
;; (disable buttons, menus, etc)
disable-evaluation ;; (-> void)
;; make the context disable all methods of evaluation
;; (disable buttons, menus, etc)
set-breakables ;; (union thread #f) (union custodian #f) -> void
;; the context might initiate breaks or kills to
;; the thread passed to this function
get-breakables ;; -> (values (union thread #f) (union custodian #f))
;; returns the last values passed to set-breakables.
reset-offer-kill ;; (-> void)
;; the next time the break button is pushed, it will only
;; break. (if the break button is clicked twice without
;; this method being called in between, it will offer to
;; kill the user's program)
update-running ;; (boolean -> void)
;; a callback to indicate that the repl may have changed its running state
;; use the repls' get-in-evaluation? method to find out what the current state is.
clear-annotations ;; (-> void)
;; clear any error highlighting context
get-directory ;; (-> (union #f string[existing directory]))
;; returns the directory that should be the default for
;; the `current-directory' and `current-load-relative-directory'
;; parameters in the repl.
))
(define unit:tab<%>
(interface (rep:context<%>)
get-frame
get-defs
get-ints
get-visible-defs
set-visible-defs
set-visible-ints
set-focus-d/i
get-i
set-i
break-callback
is-current-tab?
get-enabled
on-close
can-close?
toggle-log))
(define module-language-tools:definitions-text<%> (interface () move-to-new-language))
(define module-language-tools:tab<%> (interface ()))
(define module-language-tools:frame<%> (interface ()))

2
collects/drracket/private/language-configuration.rkt
View File

@ -56,7 +56,7 @@
[prefix drracket:app: drracket:app^]
[prefix drracket:tools: drracket:tools^]
[prefix drracket:help-desk: drracket:help-desk^]
[prefix drracket:module-language: drracket:module-language^])
[prefix drracket:module-language: drracket:module-language/int^])
(export drracket:language-configuration/internal^)
;; settings-preferences-symbol : symbol

22
collects/drracket/private/link.rkt
View File

@ -22,7 +22,8 @@
"tracing.rkt"
"get-extend.rkt"
"help-desk.rkt"
"module-language-tools.rkt")
"module-language-tools.rkt"
"interface.rkt")
(provide drracket@)
@ -39,11 +40,12 @@
drracket:eval^
drracket:modes^
drracket:tracing^
drracket:module-language^
drracket:module-language-tools^)
(link init@ tools@ tools-drs@ modes@ text@ eval@ frame@ rep@ language@
module-overview@ unit@ debug@ multi-file-search@ get-extend@
language-configuration@ font@ module-language@ module-language-tools@
drracket:module-language/int^
drracket:module-language-tools^
drracket:interface^)
(link interface@ init@ tools@ tools-drs@ modes@ text@ eval@ frame@ rep@ language@
module-overview@ module-language@ unit@ debug@ multi-file-search@ get-extend@
language-configuration@ font@ module-language-tools@
help-desk@ tracing@ app@
main@))
@ -65,8 +67,9 @@
(prefix drracket:eval: drracket:eval^)
(prefix drracket:modes: drracket:modes^)
(prefix drracket:tracing: drracket:tracing^)
(prefix drracket:module-language: drracket:module-language^)
(prefix drracket:module-language: drracket:module-language/int^)
(prefix drracket:module-language-tools: drracket:module-language-tools^)
(prefix drracket: drracket:interface^)
(prefix drscheme:debug: drracket:debug^)
(prefix drscheme:unit: drracket:unit^)
@ -79,6 +82,7 @@
(prefix drscheme:eval: drracket:eval^)
(prefix drscheme:modes: drracket:modes^)
(prefix drscheme:tracing: drracket:tracing^)
(prefix drscheme:module-language: drracket:module-language^)
(prefix drscheme:module-language-tools: drracket:module-language-tools^))
(prefix drscheme:module-language: drracket:module-language/int^)
(prefix drscheme:module-language-tools: drracket:module-language-tools^)
(prefix drscheme: drracket:interface^))
drracket-unit@))

15
collects/drracket/private/local-member-names.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang racket/base
(require racket/class)
(provide (all-defined-out))
(define-local-member-name
get-visible-defs
set-visible-defs
set-focus-d/i
get-i
set-i
insert-auto-text)
;; from module-language-tools.rkt
(define-local-member-name when-initialized #;move-to-new-language get-in-module-language?)

5
collects/drracket/private/main.rkt
View File

@ -18,7 +18,7 @@
[prefix drracket:get/extend: drracket:get/extend^]
[prefix drracket:language-configuration: drracket:language-configuration/internal^]
[prefix drracket:language: drracket:language^]
[prefix drracket:module-language: drracket:module-language^]
[prefix drracket:module-language: drracket:module-language/int^]
[prefix drracket:tools: drracket:tools^]
[prefix drracket:debug: drracket:debug^]
[prefix drracket:frame: drracket:frame^]
@ -522,6 +522,9 @@
(or settings (send lang default-settings)))))))))
;; preferences initialization
(preferences:set-default 'drracket:online-compilation #t boolean?)
(drr:set-default 'drracket:multi-file-search:recur? #t boolean?)
(drr:set-default 'drracket:multi-file-search:filter? #t boolean?)
(drr:set-default 'drracket:multi-file-search:filter-regexp "\\.(rkt.?|scrbl|ss|scm)$" string?)

45
collects/drracket/private/module-language-tools.rkt
View File

@ -7,20 +7,20 @@
racket/unit
racket/class
racket/gui/base
"drsig.rkt")
"drsig.rkt"
"local-member-names.rkt")
(define op (current-output-port))
(define (oprintf . args) (apply fprintf op args))
(define-unit module-language-tools@
(import [prefix drracket:unit: drracket:unit^]
[prefix drracket:module-language: drracket:module-language^]
[prefix drracket:module-language: drracket:module-language/int^]
[prefix drracket:language: drracket:language^]
[prefix drracket:language-configuration: drracket:language-configuration^])
[prefix drracket:language-configuration: drracket:language-configuration^]
[prefix drracket: drracket:interface^])
(export drracket:module-language-tools^)
(define-local-member-name when-initialized move-to-new-language get-in-module-language?)
(define-struct opt-out-toolbar-button (make-button id) #:transparent)
(define opt-out-toolbar-buttons '())
@ -29,10 +29,8 @@
(cons (make-opt-out-toolbar-button make-button id)
opt-out-toolbar-buttons)))
(define tab<%> (interface ()))
(define tab-mixin
(mixin (drracket:unit:tab<%>) (tab<%>)
(mixin (drracket:unit:tab<%>) (drracket:module-language-tools:tab<%>)
(inherit get-frame)
(define toolbar-buttons '())
(define/public (get-lang-toolbar-buttons) toolbar-buttons)
@ -48,9 +46,8 @@
(λ (l) toolbar-buttons)))))
(super-new)))
(define frame<%> (interface ()))
(define frame-mixin
(mixin (drracket:unit:frame<%>) (frame<%>)
(mixin (drracket:unit:frame<%>) (drracket:module-language-tools:frame<%>)
(inherit unregister-toolbar-button get-definitions-text)
(define toolbar-button-panel #f)
@ -90,9 +87,8 @@
(when (send defs get-in-module-language?)
(send defs move-to-new-language))))))
(define definitions-text<%> (interface ()))
(define definitions-text-mixin
(mixin (text:basic<%> drracket:unit:definitions-text<%>) (definitions-text<%>)
(mixin (text:basic<%> drracket:unit:definitions-text<%>) (drracket:module-language-tools:definitions-text<%>)
(inherit get-next-settings)
(define in-module-language? #f) ;; true when we are in the module language
(define hash-lang-last-location #f) ;; non-false when we know where the hash-lang line ended
@ -242,4 +238,27 @@
(super-new)
(set! in-module-language?
(is-a? (drracket:language-configuration:language-settings-language (get-next-settings))
drracket:module-language:module-language<%>)))))
drracket:module-language:module-language<%>))))
(define no-more-online-expansion-handlers? #f)
(define (no-more-online-expansion-handlers) (set! no-more-online-expansion-handlers? #t))
(struct online-expansion-handler (mod-path id local-handler))
(define online-expansion-handlers '())
(define (get-online-expansion-handlers)
(cond
[no-more-online-expansion-handlers?
online-expansion-handlers]
[else
(error 'get-online-expansion-handlers
"online-expansion-handlers can still be registered")]))
(define (add-online-expansion-handler mod-path id local-handler)
(cond
[no-more-online-expansion-handlers?
(error 'add-online-expansion-handler
"no more online-expansion-handlers can be registered; got ~e ~e ~e"
mod-path id local-handler)]
[else
(set! online-expansion-handlers
(cons (online-expansion-handler mod-path id local-handler)
online-expansion-handlers))])))

640
collects/drracket/private/module-language.rkt
View File

@ -7,6 +7,8 @@
racket/path
racket/contract
racket/sandbox
racket/runtime-path
racket/math
mred
compiler/embed
compiler/cm
@ -15,8 +17,18 @@
string-constants
planet/config
setup/dirs
racket/place
"drsig.rkt"
"rep.rkt")
"rep.rkt"
"eval-helpers.rkt"
"local-member-names.rkt")
(define-runtime-path expanding-place.rkt "expanding-place.rkt")
(define sc-online-expansion-running (string-constant online-expansion-running))
(define sc-only-raw-text-files-supported (string-constant only-raw-text-files-supported))
(define sc-abnormal-termination (string-constant abnormal-termination))
(define sc-jump-to-error (string-constant jump-to-error))
(define op (current-output-port))
(define (oprintf . args) (apply fprintf op args))
@ -26,8 +38,10 @@
[prefix drracket:language: drracket:language^]
[prefix drracket:unit: drracket:unit^]
[prefix drracket:rep: drracket:rep^]
[prefix drracket:init: drracket:init^])
(export drracket:module-language^)
[prefix drracket:init: drracket:init^]
[prefix drracket:module-language-tools: drracket:module-language-tools^]
[prefix drracket: drracket:interface^])
(export drracket:module-language/int^)
(define module-language<%>
(interface ()
@ -52,6 +66,13 @@
(define-struct (module-language-settings drracket:language:simple-settings)
(collection-paths command-line-args auto-text compilation-on? full-trace?))
(define (module-language-settings->prefab-module-settings settings)
(prefab-module-settings (module-language-settings-command-line-args settings)
(module-language-settings-collection-paths settings)
(module-language-settings-compilation-on? settings)
(module-language-settings-full-trace? settings)
(drracket:language:simple-settings-annotations settings)))
(define default-compilation-on? #t)
(define default-full-trace? #t)
(define default-auto-text "#lang racket\n")
@ -245,40 +266,8 @@
(run-in-user-thread
(λ ()
(current-command-line-arguments
(module-language-settings-command-line-args settings))
(let* ([default (current-library-collection-paths)]
[cpaths (append-map (λ (x) (if (symbol? x) default (list x)))
(module-language-settings-collection-paths
settings))])
(when (null? cpaths)
(fprintf (current-error-port)
"WARNING: your collection paths are empty!\n"))
(current-library-collection-paths cpaths))
(compile-context-preservation-enabled (module-language-settings-full-trace? settings))
(when (module-language-settings-compilation-on? settings)
(let ([annotations (drracket:language:simple-settings-annotations settings)])
(case annotations
[(none)
(use-compiled-file-paths
(cons (build-path "compiled" "drracket")
(use-compiled-file-paths)))]
[(debug)
(use-compiled-file-paths
(cons (build-path "compiled" "drracket" "errortrace")
(use-compiled-file-paths)))]))
(parallel-lock-client module-language-parallel-lock-client)
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler #t))
(let* ([cd (find-collects-dir)]
[no-dirs (if cd
(list (CACHE-DIR) cd)
(list (CACHE-DIR)))])
(manager-skip-file-handler
(λ (p) (file-stamp-in-paths p no-dirs))))))))
(set-module-language-parameters (module-language-settings->prefab-module-settings settings)
module-language-parallel-lock-client))))
(define/override (get-one-line-summary)
(string-constant module-language-one-line-summary))
@ -327,13 +316,20 @@
(raise-hopeless-exception
e "invalid module text"))])
(super-thunk))])
(when (eof-object? expr) (raise-hopeless-syntax-error))
(when (eof-object? expr)
(raise-hopeless-syntax-error (string-append
"There must be a valid module in the\n"
"definitions window. Try starting your program with\n"
"\n"
" #lang racket\n"
"\n"
"and clicking ‘Run’.")))
(let ([more (super-thunk)])
(unless (eof-object? more)
(raise-hopeless-syntax-error
"there can only be one expression in the definitions window"
more)))
(transform-module path expr)))
(transform-module path expr raise-hopeless-syntax-error)))
(define modspec (or path `',(syntax-e name)))
(define (check-interactive-language)
(unless (memq '#%top-interaction (namespace-mapped-symbols))
@ -341,7 +337,7 @@
#f #f ; no error message, just a suffix
(format "~s does not support a REPL (no #%top-interaction)"
(syntax->datum lang)))))
;; We're about to send the module expression to drscheme now, the rest
;; We're about to send the module expression to drracket now, the rest
;; of the setup is done in `front-end/finished-complete-program' below,
;; so use `repl-init-thunk' to store an appropriate continuation for
;; this setup. Once we send the expression, we'll be called again only
@ -516,16 +512,8 @@
(define (raise-hopeless-syntax-error . error-args)
(with-handlers ([exn:fail? raise-hopeless-exception])
(apply raise-syntax-error '|Module Language|
(if (null? error-args)
(list (string-append
"There must be a valid module in the\n"
"definitions window. Try starting your program with\n"
"\n"
" #lang racket\n"
"\n"
"and clicking ‘Run’."))
error-args))))
error-args)))
;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void))
(define (module-language-config-panel parent)
(define new-parent
@ -742,30 +730,6 @@
(send save-stacktrace-on-check-box set-value (module-language-settings-full-trace? settings))
(update-buttons)]))
;; transform-module : (union #f path) syntax
;; -> (values syntax[name-of-module] syntax[lang-of-module] syntax[module])
;; = User =
(define (transform-module filename stx)
(define-values (mod name lang body)
(syntax-case stx ()
[(module name lang . body)
(eq? 'module (syntax-e #'module))
(values #'module #'name #'lang #'body)]
[_ (raise-hopeless-syntax-error
(string-append "only a module expression is allowed, either\n"
" #lang <language-name>\n or\n"
" (module <name> <language> ...)\n")
stx)]))
(define name* (syntax-e name))
(unless (symbol? name*)
(raise-hopeless-syntax-error "bad syntax in name position of module"
stx name))
(when filename (check-filename-matches filename name* stx))
(let* (;; rewrite the module to use the racket/base version of `module'
[mod (datum->syntax #'here 'module mod)]
[expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)])
(values name lang expr)))
;; get-filename : port -> (union string #f)
;; extracts the file the definitions window is being saved in, if any.
(define (get-filename port)
@ -786,34 +750,506 @@
filename))))))]
[else #f])))
;; check-filename-matches : path datum syntax -> void
(define (check-filename-matches filename datum unexpanded-stx)
(when #f ; we don't check filename matching anymore
(let-values ([(base name dir?) (split-path filename)])
(let ([expected (string->symbol
(path->string (path-replace-suffix name #"")))])
(unless (equal? expected datum)
(raise-hopeless-syntax-error
(format
"module name doesn't match saved filename, got ~s and expected ~s"
datum
expected)
unexpanded-stx))))))
(define-local-member-name
show-bkg-running
frame-show-bkg-running
restart-place
set-expand-error
update-frame-expand-error
expand-error-next
expand-error-prev)
(define module-language-online-expand-tab-mixin
(mixin (drracket:unit:tab<%>) ()
(inherit get-frame)
(define bkg-label "")
(define bkg-colors '())
(define bkg-state 'nothing)
(define/public (add-bkg-running-color id color label)
(set! bkg-colors
(sort
(cons (list id color label) bkg-colors)
string<=? #:key (compose symbol->string car))))
(define/public (remove-bkg-running-color id)
(set! bkg-colors (filter (λ (x) (not (eq? (car x) id))) bkg-colors))
(send (get-frame) frame-show-bkg-running (get-colors) (get-label)))
(define/public (get-bkg-running)
(values (get-colors) (get-label)))
(define/public (show-bkg-running state label)
(set! bkg-state state)
(set! bkg-label label)
(send (get-frame) frame-show-bkg-running (get-colors) (get-label)))
(define/private (get-colors)
(case bkg-state
[(running) (list "blue")]
[(nothing) (if (null? bkg-colors)
#f
(map (λ (x) (list-ref x 1)) bkg-colors))]
[(failed) (list "red")]
[else (error 'show-bkg-running "unknown state ~s\n" bkg-state)]))
(define/private (get-label)
(if (eq? bkg-state 'nothing)
(if (null? bkg-colors)
#f
(map (λ (x) (list-ref x 2)) bkg-colors))
(list bkg-label)))
(super-new)))
(define module-language-online-expand-frame-mixin
(mixin (frame:basic<%> frame:info<%> drracket:unit:frame<%>) ()
(inherit get-info-panel get-current-tab)
(define expand-error-parent-panel #f)
(define expand-error-panel #f)
(define expand-error-message #f)
(define expand-error-button-parent-panel #f)
(define expand-error-single-child #f)
(define expand-error-multiple-child #f)
(define colors #f)
(define tooltip-labels #f)
(super-new)
(define/override (make-root-area-container cls parent)
(set! expand-error-parent-panel
(super make-root-area-container vertical-panel% parent))
(define root (make-object cls expand-error-parent-panel))
(set! expand-error-panel
(new horizontal-panel%
[stretchable-height #f]
[parent expand-error-parent-panel]))
(set! expand-error-message (new message% [parent expand-error-panel] [stretchable-width #t] [label "hi"]))
(set! expand-error-button-parent-panel
(new vertical-panel%
[stretchable-width #f]
[stretchable-height #f]
[parent expand-error-panel]))
(set! expand-error-single-child
(new button%
[parent expand-error-button-parent-panel]
[stretchable-width #t]
[label sc-jump-to-error]
[callback (λ (b evt) (send (send (get-current-tab) get-defs) expand-error-next))]))
(set! expand-error-multiple-child
(new horizontal-panel% [parent expand-error-button-parent-panel]))
(new button%
[label "<"]
[callback (λ (b evt) (send (send (get-current-tab) get-defs) expand-error-prev))]
[parent expand-error-multiple-child])
(new message%
[parent expand-error-multiple-child]
[label sc-jump-to-error])
(new button%
[label ">"]
[callback (λ (b evt) (send (send (get-current-tab) get-defs) expand-error-next))]
[parent expand-error-multiple-child])
(send expand-error-button-parent-panel change-children (λ (l) (list expand-error-single-child)))
(send expand-error-parent-panel change-children (λ (l) (remq expand-error-panel l)))
root)
(define expand-error-msg #f)
(define expand-error-srcloc-count 0)
(define/public (set-expand-error msg srcloc-count)
(unless (and (equal? expand-error-msg msg)
(equal? expand-error-srcloc-count srcloc-count))
(set! expand-error-msg msg)
(set! expand-error-srcloc-count srcloc-count)
(cond
[expand-error-msg
(send expand-error-message set-label expand-error-msg)
(send expand-error-parent-panel change-children
(λ (l) (append (remq expand-error-panel l) (list expand-error-panel))))
(send expand-error-button-parent-panel change-children
(λ (l) (cond
[(= srcloc-count 0) '()]
[(= srcloc-count 1)
(list expand-error-single-child)]
[else
(list expand-error-multiple-child)])))]
[else
(send expand-error-parent-panel change-children
(λ (l) (remq expand-error-panel l)))])))
(define/augment (on-tab-change from-tab to-tab)
(send (send to-tab get-defs) restart-place)
(send (send to-tab get-defs) update-frame-expand-error)
(inner (void) on-tab-change from-tab to-tab))
(define/override (on-activate active?)
(define defs (send (get-current-tab) get-defs))
(when active?
(send defs restart-place))
(super on-activate active?))
(define/public (frame-show-bkg-running new-colors labels)
(unless (equal? tooltip-labels labels)
(set! tooltip-labels labels)
(update-tooltip))
(unless (equal? new-colors colors)
(set! colors new-colors)
(send running-canvas refresh)))
(define tooltip-frame #f)
(define/private (show-tooltip)
(cond
[tooltip-labels
(unless tooltip-frame
(set! tooltip-frame
(new (class frame%
(define/override (on-subwindow-event r evt)
(cond
[(send evt button-down?)
(hide-tooltip)
#t]
[else #f]))
(super-new [style '(no-resize-border no-caption float)]
[label ""]
[stretchable-width #f]
[stretchable-height #f] ))))
(new yellow-message% [parent tooltip-frame]))
(send (car (send tooltip-frame get-children)) set-lab tooltip-labels)
(send tooltip-frame reflow-container)
(define-values (rx ry) (send running-canvas client->screen 0 0))
(send tooltip-frame move (- rx (send tooltip-frame get-width)) (- ry (send tooltip-frame get-height)))
(send tooltip-frame show #t)]
[else
(when tooltip-frame
(send tooltip-frame show #f))]))
(define/private (update-tooltip)
(when tooltip-frame
(cond
[tooltip-labels
(when (send tooltip-frame is-shown?)
;; just call this, as it updates the tooltip label already
(show-tooltip))]
[else
(send tooltip-frame show #f)])))
(define/private (hide-tooltip)
(when tooltip-frame
(send tooltip-frame show #f)))
(define running-canvas
(new (class canvas%
(inherit get-dc popup-menu refresh)
(define/override (on-paint)
(let ([dc (get-dc)])
(when colors
(send dc set-smoothing 'aligned)
(send dc set-pen "black" 1 'transparent)
(define len (length colors))
(for ([color (in-list colors)]
[i (in-naturals)])
(send dc set-brush color 'solid)
(send dc draw-arc 0 0 10 10
(* 2 pi (/ i len))
(* 2 pi (/ (+ i 1) len)))))))
(define cb-proc (λ (sym new-val)
(set! colors #f)
(refresh)))
(preferences:add-callback 'drracket:online-compilation cb-proc #t)
(define/override (on-event evt)
(cond
[(send evt button-down?)
(define menu (new popup-menu%))
(define on? (preferences:get 'drracket:online-compilation))
(new menu-item%
[parent menu]
[label (if on?
"Disable online compilation"
"Enable online compilation")]
[callback
(λ args
(preferences:set 'drracket:online-compilation (not on?)))])
(popup-menu menu (send evt get-x) (send evt get-y))]
[(send evt entering?)
(show-tooltip)]
[(send evt leaving?)
(hide-tooltip)]))
(super-new [style '(transparent)]
[parent (get-info-panel)]
[stretchable-width #f]
[stretchable-height #f]
[min-width 10]
[min-height 10]))))))
(define yellow-message%
(class canvas%
(inherit get-dc refresh get-client-size
min-width min-height
get-parent)
(define labels '(""))
(define/public (set-lab _ls)
(unless (equal? labels _ls)
(set! labels _ls)
(update-size)
(refresh)))
(define/private (update-size)
(define dc (get-dc))
(send dc set-font small-control-font)
(define-values (w h _1 _2) (send dc get-text-extent (car labels)))
(send (get-parent) begin-container-sequence)
(min-width (+ 5 (inexact->exact (ceiling w))))
(min-height (+ 5 (* (length labels) (inexact->exact (ceiling h)))))
(send (get-parent) end-container-sequence)
(send (get-parent) reflow-container))
(define/override (on-paint)
(define dc (get-dc))
(send dc set-font small-control-font)
(define-values (w h) (get-client-size))
(define-values (tw th _1 _2) (send dc get-text-extent (car labels)))
(send dc set-pen "black" 1 'transparent)
(send dc set-brush "LemonChiffon" 'solid)
(send dc set-pen "black" 1 'solid)
(send dc draw-rectangle 0 0 (- w 1) (- h 1))
(for ([label (in-list labels)]
[i (in-naturals)])
(send dc draw-text label 2 (+ 2 (* i th)))))
(super-new [stretchable-width #f] [stretchable-height #f])))
(define expanding-place
(and (>= (processor-count) 1)
(dynamic-place expanding-place.rkt 'start)))
(define place-initialized? #f)
(define pending-thread #f)
(define (send-to-place editor-contents filename prefab-module-settings show-results)
(when expanding-place
(unless place-initialized?
(set! place-initialized? #t)
(place-channel-put expanding-place module-language-compile-lock)
(place-channel-put expanding-place
(for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
(drracket:module-language-tools:online-expansion-handler-id o-e-h)))))
(set! pending-thread
(thread (λ ()
(define-values (pc-in pc-out) (place-channel))
(define to-send
(vector-immutable editor-contents
filename
pc-in
prefab-module-settings))
(place-channel-put expanding-place to-send)
(define res (place-channel-get pc-out))
(when res
(let ([t (current-thread)])
(queue-callback
(λ ()
(when (eq? t pending-thread)
(set! pending-thread #f)
(show-results res)))))))))))
(define (stop-place-running)
(when expanding-place
(when pending-thread
(place-channel-put expanding-place 'abort)
(set! pending-thread #f))))
(define module-language-online-expand-text-mixin
(mixin (text:basic<%>
drracket:unit:definitions-text<%>
drracket:module-language-tools:definitions-text<%>) ()
(inherit last-position find-first-snip get-top-level-window get-filename
get-tab highlight-range get-canvas
set-position get-start-position get-end-position)
(define compilation-out-of-date? #f)
(define tmr (new timer% [notify-callback (lambda () (send-off))]))
(define cb-proc (λ (sym new-val)
(when new-val
(queue-callback (λ () (buffer-modified))))))
(preferences:add-callback 'drracket:online-compilation cb-proc #t)
(define/private (buffer-modified)
(let ([tlw (get-top-level-window)])
(when expanding-place
(when (in-module-language tlw)
(send (get-tab) show-bkg-running 'nothing #f)
(stop-place-running)
(set! compilation-out-of-date? #t)
(when (preferences:get 'drracket:online-compilation)
(when (eq? (send tlw get-current-tab) (get-tab))
(send tmr stop)
(send tmr start 250 #t)))))))
(define/public (restart-place)
(stop-place-running)
(when compilation-out-of-date?
(send tmr start 250 #t)))
(define/private (send-off)
(define tlw (get-top-level-window))
;; make sure the frame's current tab is still this one
;; (we may get #f for the tlw when the tab has been switched)
(when (and tlw (eq? (send tlw get-current-tab) (get-tab)))
(define settings (in-module-language tlw))
(when settings
(define-values (editor-contents filename) (fetch-data-to-send))
(when editor-contents
(send-to-place editor-contents
filename
(module-language-settings->prefab-module-settings settings)
(λ (res) (show-results res)))
(when status-line-open?
(clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error))
(send (get-tab) show-bkg-running 'running sc-online-expansion-running)))))
(define/private (fetch-data-to-send)
(define str (make-string (last-position) #\space))
(let/ec k
(let loop ([s (find-first-snip)]
[i 0])
(cond
[(not s) (void)]
[(is-a? s string-snip%)
(define size (send s get-count))
(send s get-text! str 0 size i)
(loop (send s next) (+ i size))]
[else
(send (get-tab) show-bkg-running 'failed sc-only-raw-text-files-supported)
(k #f #f)]))
(define fn (let* ([b (box #f)]
[n (get-filename b)])
(and (not (unbox b))
n)))
(values str fn)))
(define status-line-open? #f)
(define clear-old-error void)
(define error-message-str #f)
(define error-message-srclocs '())
(define/private (reset-frame-expand-error)
(set! error-message-str #f)
(set! error-message-srclocs '())
(update-frame-expand-error))
(define/public (update-frame-expand-error)
(send (send (get-tab) get-frame) set-expand-error
error-message-str
(length error-message-srclocs)))
(define/public (expand-error-next)
(define candidates (filter (λ (error-message-srcloc)
(> (- (vector-ref error-message-srcloc 0) 1)
(get-end-position)))
error-message-srclocs))
(cond
[(null? candidates)
(unless (null? error-message-srclocs)
(jump-to (car error-message-srclocs)))]
[else
(jump-to (car candidates))]))
(define/public (expand-error-prev)
(define candidates (filter (λ (error-message-srcloc)
(< (+ (vector-ref error-message-srcloc 0)
(vector-ref error-message-srcloc 1)
-1)
(get-start-position)))
error-message-srclocs))
(cond
[(null? candidates)
(unless (null? error-message-srclocs)
(jump-to (last error-message-srclocs)))]
[else
(jump-to (last candidates))]))
(define/private (jump-to vec)
(set-position (- (vector-ref vec 0) 1))
(define cnvs (get-canvas))
(when cnvs (send cnvs focus)))
(define/private (show-results res)
(set! compilation-out-of-date? #f)
(case (vector-ref res 0)
[(exn)
(define tlw (send (get-tab) get-frame))
(send (get-tab) show-bkg-running 'nothing #f)
(clear-old-error)
(set! error-message-str (vector-ref res 1))
(set! error-message-srclocs (vector-ref res 2))
(set! clear-old-error
(for/fold ([clear void])
([range (in-list (vector-ref res 2))])
(define pos (vector-ref range 0))
(define span (vector-ref range 1))
(define clear-next (highlight-range (- pos 1) (+ pos span -1) "Gold" #f 'high))
(lambda () (clear) (clear-next))))
(update-frame-expand-error)]
[(access-violation)
(send (get-tab) show-bkg-running 'failed (gui-utils:format-literal-label "~a" (vector-ref res 1)))
(clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)]
[(abnormal-termination)
(send (get-tab) show-bkg-running 'failed sc-abnormal-termination)
(clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)]
[(no-errors)
(send (get-tab) show-bkg-running 'nothing #f)
(clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)]
[(handler-results)
(clear-old-error)
(set! clear-old-error void)
(reset-frame-expand-error)
;; inform the installed handlers that something has come back
(for ([key-val (in-list (vector-ref res 1))])
(define that-key (list-ref key-val 0))
(define val (list-ref key-val 1))
(for ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))])
(define this-key (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h)
(drracket:module-language-tools:online-expansion-handler-id o-e-h)))
(when (equal? this-key that-key)
((drracket:module-language-tools:online-expansion-handler-local-handler o-e-h) this val))))
(send (get-tab) show-bkg-running 'nothing #f)]
[else
(error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)]))
(define/override (move-to-new-language)
;; this is here to get things running for the initital tab in a new frame
(super move-to-new-language)
(buffer-modified))
(define/augment (after-insert start end)
(buffer-modified)
(inner (void) after-insert start end))
(define/augment (after-delete start end)
(buffer-modified)
(inner (void) after-delete start end))
(define/augment (after-load-file success?)
(buffer-modified)
(inner (void) after-load-file success?))
(super-new)))
(define module-language-put-file-mixin
(mixin (text:basic<%>) ()
(inherit get-text last-position get-character get-top-level-window)
(define/override (put-file directory default-name)
(let ([tlw (get-top-level-window)])
(if (and tlw
(is-a? tlw drracket:unit:frame<%>))
(let* ([definitions-text (send tlw get-definitions-text)]
[module-language?
(is-a? (drracket:language-configuration:language-settings-language
(send definitions-text get-next-settings))
module-language<%>)]
[module-default-filename
(and module-language? (get-module-filename))])
(if (in-module-language tlw)
(let ([module-default-filename (get-module-filename)])
(super put-file directory module-default-filename))
(super put-file directory default-name))))
@ -875,7 +1311,17 @@
(super-new)))
(define module-language-compile-lock (make-compile-lock))
(define module-language-parallel-lock-client
(compile-lock->parallel-lock-client
(make-compile-lock))))
module-language-compile-lock))
;; in-module-language : top-level-window<%> -> module-language-settings or #f
(define (in-module-language tlw)
(and tlw
(is-a? tlw drracket:unit:frame<%>)
(let ([settings (send (send tlw get-definitions-text) get-next-settings)])
(and (is-a? (drracket:language-configuration:language-settings-language settings)
module-language<%>)
(drracket:language-configuration:language-settings-settings settings))))))

3
collects/drracket/private/multi-file-search.rkt
View File

@ -10,7 +10,8 @@
"drsig.rkt")
(import [prefix drracket:frame: drracket:frame^]
[prefix drracket:unit: drracket:unit^])
[prefix drracket:unit: drracket:unit^]
[prefix drracket: drracket:interface^])
(export drracket:multi-file-search^)
;; multi-file-search : -> void

68
collects/drracket/private/rep.rkt
View File

@ -79,17 +79,18 @@ TODO
(parameterize-break #f (current-break-parameterization)))
(define-unit rep@
(import (prefix drracket:init: drracket:init^)
(prefix drracket:language-configuration: drracket:language-configuration/internal^)
(prefix drracket:language: drracket:language^)
(prefix drracket:app: drracket:app^)
(prefix drracket:frame: drracket:frame^)
(prefix drracket:unit: drracket:unit^)
(prefix drracket:text: drracket:text^)
(prefix drracket:help-desk: drracket:help-desk^)
(prefix drracket:debug: drracket:debug^)
(import [prefix drracket:init: drracket:init^]
[prefix drracket:language-configuration: drracket:language-configuration/internal^]
[prefix drracket:language: drracket:language^]
[prefix drracket:app: drracket:app^]
[prefix drracket:frame: drracket:frame^]
[prefix drracket:unit: drracket:unit^]
[prefix drracket:text: drracket:text^]
[prefix drracket:help-desk: drracket:help-desk^]
[prefix drracket:debug: drracket:debug^]
[prefix drracket:eval: drracket:eval^]
[prefix drracket:module-language: drracket:module-language^])
[prefix drracket:module-language: drracket:module-language/int^]
[prefix drracket: drracket:interface^])
(export (rename drracket:rep^
[-text% text%]
[-text<%> text<%>]))
@ -141,51 +142,6 @@ TODO
insert-prompt
get-context))
(define context<%>
(interface ()
ensure-rep-shown ;; (interactions-text -> void)
;; make the rep visible in the frame
repl-submit-happened ;; (-> boolean)
;; notify the context that an evaluation is about to
;; happen in the REPL (so it can show a warning about
;; the language/etc is out of sync if neccessary).
enable-evaluation ;; (-> void)
;; make the context enable all methods of evaluation
;; (disable buttons, menus, etc)
disable-evaluation ;; (-> void)
;; make the context disable all methods of evaluation
;; (disable buttons, menus, etc)
set-breakables ;; (union thread #f) (union custodian #f) -> void
;; the context might initiate breaks or kills to
;; the thread passed to this function
get-breakables ;; -> (values (union thread #f) (union custodian #f))
;; returns the last values passed to set-breakables.
reset-offer-kill ;; (-> void)
;; the next time the break button is pushed, it will only
;; break. (if the break button is clicked twice without
;; this method being called in between, it will offer to
;; kill the user's program)
update-running ;; (boolean -> void)
;; a callback to indicate that the repl may have changed its running state
;; use the repls' get-in-evaluation? method to find out what the current state is.
clear-annotations ;; (-> void)
;; clear any error highlighting context
get-directory ;; (-> (union #f string[existing directory]))
;; returns the directory that should be the default for
;; the `current-directory' and `current-load-relative-directory'
;; parameters in the repl.
))
(define sized-snip<%>
(interface ((class->interface snip%))
;; get-character-width : -> number
@ -553,7 +509,7 @@ TODO
(define/public (set-definitions-text dt) (set! definitions-text dt))
(define/public (get-definitions-text) definitions-text)
(unless (is-a? context context<%>)
(unless (is-a? context drracket:rep:context<%>)
(error 'drracket:rep:text%
"expected an object that implements drracket:rep:context<%> as initialization argument, got: ~e"
context))

57
collects/drracket/private/syncheck/annotate.rkt
View File

@ -1,19 +1,15 @@
#lang racket/base
(require racket/class
racket/gui/base
framework
"intf.rkt")
(provide color color-range
find-source-editor
find-source-editor/defs
get-defs-text)
find-source-editor/defs)
;; color : syntax[original] str -> void
;; colors the syntax with style-name's style
(define (color stx style-name mode)
(let ([source (find-source-editor stx)])
(when (and (is-a? source text%)
(syntax-position stx)
(when (and (syntax-position stx)
(syntax-span stx))
(let ([pos (- (syntax-position stx) 1)]
[span (syntax-span stx)])
@ -22,56 +18,17 @@
;; color-range : text start finish style-name
;; colors a range in the text based on `style-name'
(define (color-range source start finish style-name mode)
(let ([style (send (send source get-style-list)
find-named-style
style-name)])
(apply-style/remember source start finish style mode)))
(define defs (current-annotations))
(when defs
(send defs syncheck:color-range source start finish style-name mode)))
;; find-source-editor : stx -> editor or false
(define (find-source-editor stx)
(let ([defs-text (get-defs-text)])
(let ([defs-text (current-annotations)])
(and defs-text
(find-source-editor/defs stx defs-text))))
;; find-source-editor : stx text -> editor or false
(define (find-source-editor/defs stx defs-text)
(cond
[(not (syntax-source stx)) #f]
[(and (symbol? (syntax-source stx))
(text:lookup-port-name (syntax-source stx)))
=> values]
[else
(let txt-loop ([text defs-text])
(cond
[(and (is-a? text text:basic<%>)
(send text port-name-matches? (syntax-source stx)))
text]
[else
(let snip-loop ([snip (send text find-first-snip)])
(cond
[(not snip)
#f]
[(and (is-a? snip editor-snip%)
(send snip get-editor))
(or (txt-loop (send snip get-editor))
(snip-loop (send snip next)))]
[else
(snip-loop (send snip next))]))]))]))
;; get-defs-text : -> text or false
(define (get-defs-text)
(currently-processing-definitions-text))
(send defs-text syncheck:find-source-object stx))
;; apply-style/remember : (is-a?/c editor<%>) number number style% symbol -> void
(define (apply-style/remember ed start finish style mode)
(let ([outermost (find-outermost-editor ed)])
(and (is-a? outermost syncheck-text<%>)
(send outermost syncheck:apply-style/remember ed start finish style mode))))
(define (find-outermost-editor ed)
(let loop ([ed ed])
(let ([admin (send ed get-admin)])
(if (is-a? admin editor-snip-editor-admin<%>)
(let* ([enclosing-snip (send admin get-snip)]
[enclosing-snip-admin (send enclosing-snip get-admin)])
(loop (send enclosing-snip-admin get-editor)))
ed))))

70
collects/drracket/private/syncheck/colors.rkt
View File

@ -1,8 +1,4 @@
#lang racket/base
(require string-constants/string-constant
framework
racket/class
racket/gui/base)
(provide (all-defined-out))
(define cs-my-obligation-color "my obligations")
@ -13,10 +9,14 @@
(define lexically-bound-variable-style-pref 'drracket:check-syntax:lexically-bound)
(define imported-variable-style-pref 'drracket:check-syntax:imported)
(define set!d-variable-style-pref 'drracket:check-syntax:set!d)
(define unused-require-style-pref 'drracket:check-syntax:unused-require)
(define free-variable-style-pref 'drracket:check-syntax:free-variable)
(define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref))
(define imported-variable-style-name (symbol->string imported-variable-style-pref))
(define set!d-variable-style-name (symbol->string set!d-variable-style-pref))
(define unused-require-style-name (symbol->string unused-require-style-pref))
(define free-variable-style-name (symbol->string free-variable-style-pref))
(define my-obligation-style-pref 'drracket:check-syntax:my-obligation-style-pref)
(define their-obligation-style-pref 'drracket:check-syntax:their-obligation-style-pref)
@ -28,65 +28,3 @@
(define unk-obligation-style-name (symbol->string unk-obligation-style-pref))
(define both-obligation-style-name (symbol->string both-obligation-style-pref))
(define error-style-name (scheme:short-sym->style-name 'error))
;(define constant-style-name (scheme:short-sym->style-name 'constant))
(define (syncheck-add-to-preferences-panel parent)
(color-prefs:build-color-selection-panel parent
lexically-bound-variable-style-pref
lexically-bound-variable-style-name
(string-constant cs-lexical-variable))
(color-prefs:build-color-selection-panel parent
imported-variable-style-pref
imported-variable-style-name
(string-constant cs-imported-variable))
(color-prefs:build-color-selection-panel parent
set!d-variable-style-pref
set!d-variable-style-name
(string-constant cs-set!d-variable))
(color-prefs:build-color-selection-panel parent
my-obligation-style-pref
my-obligation-style-name
cs-my-obligation-color)
(color-prefs:build-color-selection-panel parent
their-obligation-style-pref
their-obligation-style-name
cs-their-obligation-color)
(color-prefs:build-color-selection-panel parent
unk-obligation-style-pref
unk-obligation-style-name
cs-unk-obligation-color)
(color-prefs:build-color-selection-panel parent
both-obligation-style-pref
both-obligation-style-name
cs-both-obligation-color))
(color-prefs:register-color-preference lexically-bound-variable-style-pref
lexically-bound-variable-style-name
(make-object color% 81 112 203)
(make-object color% 50 163 255))
(color-prefs:register-color-preference set!d-variable-style-pref
set!d-variable-style-name
(send the-color-database find-color "firebrick")
(send the-color-database find-color "pink"))
(color-prefs:register-color-preference imported-variable-style-pref
imported-variable-style-name
(make-object color% 68 0 203)
(make-object color% 166 0 255))
(color-prefs:register-color-preference my-obligation-style-pref
my-obligation-style-name
(send the-color-database find-color "firebrick")
(send the-color-database find-color "pink"))
(color-prefs:register-color-preference their-obligation-style-pref
their-obligation-style-name
(make-object color% 0 116 0)
(send the-color-database find-color "limegreen"))
(color-prefs:register-color-preference unk-obligation-style-pref
unk-obligation-style-name
(send the-color-database find-color "black")
(send the-color-database find-color "white"))
(color-prefs:register-color-preference both-obligation-style-pref
both-obligation-style-name
(make-object color% 139 142 28)
(send the-color-database find-color "khaki"))

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

@ -19,12 +19,16 @@ If the namespace does not, they are colored the unbound color.
(require string-constants
racket/unit
racket/match
racket/contract
racket/class
racket/list
racket/promise
racket/pretty
racket/dict
racket/set
racket/runtime-path
racket/place
data/interval-map
drracket/tool
syntax/toplevel
@ -41,10 +45,12 @@ If the namespace does not, they are colored the unbound color.
net/uri-codec
browser/external
(for-syntax racket/base)
(only-in ffi/unsafe register-finalizer)
"../../syncheck-drracket-button.rkt"
"intf.rkt"
"colors.rkt"
"traversals.rkt")
"traversals.rkt"
"annotate.rkt")
(provide tool@)
(define orig-output-port (current-output-port))
@ -64,11 +70,90 @@ If the namespace does not, they are colored the unbound color.
(define cs-mode-menu-show-client-obligations (string-constant cs-mode-menu-show-client-obligations))
(define cs-mode-menu-show-syntax (string-constant cs-mode-menu-show-syntax))
(define cs-syncheck-running "Check Syntax Running")
(preferences:set-default 'drracket:syncheck-mode 'default-mode
(λ (x) (memq x '(default-mode
my-obligations-mode
client-obligations-mode))))
(define (syncheck-add-to-preferences-panel parent)
(color-prefs:build-color-selection-panel parent
lexically-bound-variable-style-pref
lexically-bound-variable-style-name
(string-constant cs-lexical-variable))
(color-prefs:build-color-selection-panel parent
imported-variable-style-pref
imported-variable-style-name
(string-constant cs-imported-variable))
(color-prefs:build-color-selection-panel parent
set!d-variable-style-pref
set!d-variable-style-name
(string-constant cs-set!d-variable))
(color-prefs:build-color-selection-panel parent
unused-require-style-pref
unused-require-style-name
(string-constant cs-unused-require))
(color-prefs:build-color-selection-panel parent
free-variable-style-pref
free-variable-style-name
(string-constant cs-free-variable))
(color-prefs:build-color-selection-panel parent
my-obligation-style-pref
my-obligation-style-name
cs-my-obligation-color)
(color-prefs:build-color-selection-panel parent
their-obligation-style-pref
their-obligation-style-name
cs-their-obligation-color)
(color-prefs:build-color-selection-panel parent
unk-obligation-style-pref
unk-obligation-style-name
cs-unk-obligation-color)
(color-prefs:build-color-selection-panel parent
both-obligation-style-pref
both-obligation-style-name
cs-both-obligation-color))
(color-prefs:register-color-preference lexically-bound-variable-style-pref
lexically-bound-variable-style-name
(make-object color% 81 112 203)
(make-object color% 50 163 255))
(color-prefs:register-color-preference set!d-variable-style-pref
set!d-variable-style-name
(send the-color-database find-color "firebrick")
(send the-color-database find-color "pink"))
(color-prefs:register-color-preference unused-require-style-pref
unused-require-style-name
(send the-color-database find-color "red")
(send the-color-database find-color "pink"))
(color-prefs:register-color-preference free-variable-style-pref
free-variable-style-name
(send the-color-database find-color "red")
(send the-color-database find-color "pink"))
(color-prefs:register-color-preference imported-variable-style-pref
imported-variable-style-name
(make-object color% 68 0 203)
(make-object color% 166 0 255))
(color-prefs:register-color-preference my-obligation-style-pref
my-obligation-style-name
(send the-color-database find-color "firebrick")
(send the-color-database find-color "pink"))
(color-prefs:register-color-preference their-obligation-style-pref
their-obligation-style-name
(make-object color% 0 116 0)
(send the-color-database find-color "limegreen"))
(color-prefs:register-color-preference unk-obligation-style-pref
unk-obligation-style-name
(send the-color-database find-color "black")
(send the-color-database find-color "white"))
(color-prefs:register-color-preference both-obligation-style-pref
both-obligation-style-name
(make-object color% 139 142 28)
(send the-color-database find-color "khaki"))
(define tool@
(unit
(import drracket:tool^)
@ -201,6 +286,7 @@ If the namespace does not, they are colored the unbound color.
(when (and st
(is-a? st drracket:unit:definitions-text<%>))
(let ([tab (send st get-tab)])
(send (send tab get-frame) set-syncheck-running-mode #f)
(send tab syncheck:clear-error-message)
(send tab syncheck:clear-highlighting))))))
@ -217,12 +303,12 @@ If the namespace does not, they are colored the unbound color.
(let* ([cursor-arrow (make-object cursor% 'arrow)])
(class* super% (syncheck-text<%>)
(inherit set-cursor get-admin invalidate-bitmap-cache set-position
get-pos/text position-location
get-pos/text get-pos/text-dc-location position-location
get-canvas last-position dc-location-to-editor-location
find-position begin-edit-sequence end-edit-sequence
highlight-range unhighlight-range
paragraph-end-position first-line-currently-drawn-specially?)
;; arrow-records : (U #f hash[text% => arrow-record])
;; arrow-record = interval-map[(listof arrow-entry)]
;; arrow-entry is one of
@ -418,6 +504,27 @@ If the namespace does not, they are colored the unbound color.
(hash-set! style-mapping mode (cons (list txt start finish style)
(hash-ref style-mapping mode '())))))
(define/public (syncheck:color-range source start finish style-name mode)
(when (is-a? source text%)
(define (apply-style/remember ed start finish style mode)
(let ([outermost (find-outermost-editor ed)])
(and (is-a? outermost syncheck-text<%>)
(send outermost syncheck:apply-style/remember ed start finish style mode))))
(define (find-outermost-editor ed)
(let loop ([ed ed])
(let ([admin (send ed get-admin)])
(if (is-a? admin editor-snip-editor-admin<%>)
(let* ([enclosing-snip (send admin get-snip)]
[enclosing-snip-admin (send enclosing-snip get-admin)])
(loop (send enclosing-snip-admin get-editor)))
ed))))
(let ([style (send (send source get-style-list)
find-named-style
style-name)])
(apply-style/remember source start finish style mode))))
;; add-to-cleanup/apply-style : (is-a?/c text%) number number style% symbol -> boolean
(define/private (add-to-cleanup/apply-style txt start finish style)
(cond
@ -429,15 +536,142 @@ If the namespace does not, they are colored the unbound color.
#t]
[else #f]))
(define/public (syncheck:add-menu text start-pos end-pos key make-menu)
(define/public (syncheck:add-require-open-menu text start-pos end-pos file)
(define (make-require-open-menu file)
(λ (menu)
(let-values ([(base name dir?) (split-path file)])
(instantiate menu-item% ()
(label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name)))
(parent menu)
(callback (λ (x y) (fw:handler:edit-file file))))
(void))))
(syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file)))
(define/public (syncheck:add-docs-menu text start-pos end-pos id the-label path tag)
(syncheck:add-menu
text start-pos end-pos id
(λ (menu)
(instantiate menu-item% ()
(parent menu)
(label (gui-utils:format-literal-label "~a" the-label))
(callback
(λ (x y)
(let* ([url (path->url path)]
[url2 (if tag
(make-url (url-scheme url)
(url-user url)
(url-host url)
(url-port url)
(url-path-absolute? url)
(url-path url)
(url-query url)
tag)
url)])
(send-url (url->string url2)))))))))
(define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?)
(define (make-menu menu)
(let ([name-to-offer (format "~a" id-as-sym)])
(instantiate menu-item% ()
(parent menu)
(label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer))
(callback
(λ (x y)
(let ([frame-parent (find-menu-parent menu)])
(rename-callback name-to-offer
frame-parent)))))))
;; rename-callback : string
;; (and/c syncheck-text<%> definitions-text<%>)
;; (list source number number)
;; (listof id-set)
;; (union #f (is-a?/c top-level-window<%>))
;; -> void
;; callback for the rename popup menu item
(define (rename-callback name-to-offer parent)
(let ([new-str
(fw:keymap:call/text-keymap-initializer
(λ ()
(get-text-from-user
(string-constant cs-rename-id)
(fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer)
parent
name-to-offer)))])
(when new-str
(define new-sym (format "~s" (string->symbol new-str)))
(define dup-name? (name-dup? new-sym))
(define do-renaming?
(or (not dup-name?)
(equal?
(message-box/custom
(string-constant check-syntax)
(fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error)
new-sym)
(string-constant cs-rename-anyway)
(string-constant cancel)
#f
parent
'(stop default=2))
1)))
(when do-renaming?
(unless (null? to-be-renamed/poss)
(let ([txts (list this)])
(define positions-to-rename
(remove-duplicates
(sort to-be-renamed/poss
>
#:key cadr)))
(begin-edit-sequence)
(for ([info (in-list positions-to-rename)])
(define source-editor (list-ref info 0))
(define start (list-ref info 1))
(define end (list-ref info 2))
(when (is-a? source-editor text%)
(unless (memq source-editor txts)
(send source-editor begin-edit-sequence)
(set! txts (cons source-editor txts)))
(send source-editor delete start end #f)
(send source-editor insert new-sym start start #f)))
(invalidate-bitmap-cache)
(for ([txt (in-list txts)])
(send txt end-edit-sequence))))))))
;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>)
(define (find-menu-parent menu)
(let loop ([menu menu])
(cond
[(is-a? menu menu-bar%) (send menu get-frame)]
[(is-a? menu popup-menu%)
(let ([target (send menu get-popup-target)])
(cond
[(is-a? target editor<%>)
(let ([canvas (send target get-canvas)])
(and canvas
(send canvas get-top-level-window)))]
[(is-a? target window<%>)
(send target get-top-level-window)]
[else #f]))]
[(is-a? menu menu-item<%>) (loop (send menu get-parent))]
[else #f])))
(for ([loc (in-list to-be-renamed/poss)])
(define source (list-ref loc 0))
(define start (list-ref loc 1))
(define fin (list-ref loc 2))
(syncheck:add-menu source start fin id-as-sym make-menu)))
(define/private (syncheck:add-menu text start-pos end-pos key make-menu)
(when arrow-records
(when (and (<= 0 start-pos end-pos (last-position)))
(add-to-range/key text start-pos end-pos make-menu key #t))))
(add-to-range/key text start-pos end-pos make-menu key (and key #t)))))
(define/public (syncheck:add-background-color text color start fin key)
(define/public (syncheck:add-background-color text start fin color)
(when arrow-records
(when (is-a? text text:basic<%>)
(add-to-range/key text start fin (make-colored-region color text start fin) key #f))))
(add-to-range/key text start fin (make-colored-region color text start fin) #f #f))))
;; syncheck:add-arrow : symbol text number number text number number boolean -> void
;; pre: start-editor, end-editor are embedded in `this' (or are `this')
@ -445,13 +679,13 @@ If the namespace does not, they are colored the unbound color.
end-text end-pos-left end-pos-right
actual? level)
(when arrow-records
(let* ([arrow (make-var-arrow #f #f #f #f
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)])
(when (add-to-bindings-table
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right)
(when (add-to-bindings-table
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right)
(let ([arrow (make-var-arrow #f #f #f #f
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)])
(add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
(add-to-range/key end-text end-pos-left end-pos-right arrow #f #f)))))
@ -469,8 +703,9 @@ If the namespace does not, they are colored the unbound color.
;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void
(define/public (syncheck:add-mouse-over-status text pos-left pos-right str)
(when arrow-records
(add-to-range/key text pos-left pos-right str #f #f)))
(let ([str (gui-utils:format-literal-label "~a" str)])
(when arrow-records
(add-to-range/key text pos-left pos-right str #f #f))))
;; add-to-range/key : text number number any any boolean -> void
;; adds `key' to the range `start' - `end' in the editor
@ -634,7 +869,18 @@ If the namespace does not, they are colored the unbound color.
(for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text
tail-arrow-to-pos tail-arrow-to-text))
(define last-known-mouse-x #f)
(define last-known-mouse-y #f)
(define/override (on-event event)
(cond
[(send event leaving?)
(set! last-known-mouse-x #f)
(set! last-known-mouse-y #f)]
[else
(set! last-known-mouse-x (send event get-x))
(set! last-known-mouse-y (send event get-y))])
(if arrow-records
(cond
[(send event leaving?)
@ -650,36 +896,7 @@ If the namespace does not, they are colored the unbound color.
(super on-event event)]
[(or (send event moving?)
(send event entering?))
(let-values ([(pos text) (get-pos/text event)])
(cond
[(and pos (is-a? text text%))
(unless (and (equal? pos cursor-location)
(eq? cursor-text text))
(set! cursor-location pos)
(set! cursor-text text)
(let* ([arrow-record (hash-ref arrow-records cursor-text #f)]
[eles (and arrow-record (interval-map-ref arrow-record cursor-location null))])
(unless (equal? cursor-eles eles)
(set! cursor-eles eles)
(update-docs-background eles)
(when eles
(update-status-line eles)
(for ([ele (in-list eles)])
(cond [(arrow? ele)
(update-arrow-poss ele)]))
(invalidate-bitmap-cache)))))]
[else
(update-docs-background #f)
(let ([f (get-top-level-window)])
(when f
(send f update-status-line 'drracket:check-syntax:mouse-over #f)))
(when (or cursor-location cursor-text)
(set! cursor-location #f)
(set! cursor-text #f)
(set! cursor-eles #f)
(invalidate-bitmap-cache))]))
(syncheck:update-drawn-arrows)
(super on-event event)]
[(send event button-down? 'right)
(define menu
@ -694,6 +911,40 @@ If the namespace does not, they are colored the unbound color.
(super on-event event)])]
[else (super on-event event)])
(super on-event event)))
(define/public (syncheck:update-drawn-arrows)
(let-values ([(pos text) (if (and last-known-mouse-x last-known-mouse-y)
(get-pos/text-dc-location last-known-mouse-x last-known-mouse-y)
(values #f #f))])
(cond
[(and pos (is-a? text text%))
(unless (and (equal? pos cursor-location)
(eq? cursor-text text))
(set! cursor-location pos)
(set! cursor-text text)
(let* ([arrow-record (hash-ref arrow-records cursor-text #f)]
[eles (and arrow-record (interval-map-ref arrow-record cursor-location null))])
(unless (equal? cursor-eles eles)
(set! cursor-eles eles)
(update-docs-background eles)
(when eles
(update-status-line eles)
(for ([ele (in-list eles)])
(cond [(arrow? ele)
(update-arrow-poss ele)]))
(invalidate-bitmap-cache)))))]
[else
(update-docs-background #f)
(let ([f (get-top-level-window)])
(when f
(send f update-status-line 'drracket:check-syntax:mouse-over #f)))
(when (or cursor-location cursor-text)
(set! cursor-location #f)
(set! cursor-text #f)
(set! cursor-eles #f)
(invalidate-bitmap-cache))])))
(define/public (syncheck:build-popup-menu pos text)
(and pos
@ -1002,7 +1253,31 @@ If the namespace does not, they are colored the unbound color.
(for ((txt (in-list edit-sequences)))
(send txt end-edit-sequence))))
(define/public (syncheck:find-source-object stx)
(cond
[(not (syntax-source stx)) #f]
[(and (symbol? (syntax-source stx))
(text:lookup-port-name (syntax-source stx)))
=> values]
[else
(let txt-loop ([text this])
(cond
[(and (is-a? text text:basic<%>)
(send text port-name-matches? (syntax-source stx)))
text]
[else
(let snip-loop ([snip (send text find-first-snip)])
(cond
[(not snip)
#f]
[(and (is-a? snip editor-snip%)
(send snip get-editor))
(or (txt-loop (send snip get-editor))
(snip-loop (send snip next)))]
[else
(snip-loop (send snip next))]))]))]))
(super-new)))))
(define syncheck-frame<%>
@ -1095,6 +1370,96 @@ If the namespace does not, they are colored the unbound color.
(list check-syntax-button)
'())))))
;; set-syncheck-running-mode : (or/c (box boolean?) 'button #f) -> boolean
;; records how a particular check syntax is being played out in the editor right now.
;; - #f means nothing is currently running.
;; - 'button means someone clicked the check syntax button (or the menu item or keyboard shortcut...)
;; - the boxed boolean means that a trace is being replayed from the other place.
;; if the box is set to #f, then the trace replay will be stopped.
;; if #f is returned, then the mode change is not allowed; this only happens when
;; a box is passed in
(define/public (set-syncheck-running-mode mode)
(cond
[(not mode)
(when (box? current-syncheck-running-mode)
(set-box! current-syncheck-running-mode #f))
(set! current-syncheck-running-mode #f)
#t]
[(box? mode)
(cond
[(eq? current-syncheck-running-mode 'button)
#f]
[(eq? mode current-syncheck-running-mode)
;; this shouldn't happen, I think
#t]
[else
(when (box? current-syncheck-running-mode)
(set-box! current-syncheck-running-mode #f))
(set! current-syncheck-running-mode mode)
#t])]
[(eq? 'button mode)
(when (box? current-syncheck-running-mode)
(set-box! current-syncheck-running-mode #f))
(set! current-syncheck-running-mode mode)
#t]
[else
(error 'set-syncheck-running-mode "unknown new mode ~s\n" mode)]))
(define current-syncheck-running-mode #f)
(define/public (replay-compile-comp-trace defs-text val)
(define bx (box #t))
(when (set-syncheck-running-mode bx)
(send (send defs-text get-tab) add-bkg-running-color 'syncheck "forestgreen" cs-syncheck-running)
(send defs-text syncheck:init-arrows)
(let loop ([val val]
[i 0])
(cond
[(null? val)
(send defs-text syncheck:update-drawn-arrows)
(send (send defs-text get-tab) remove-bkg-running-color 'syncheck)
(set-syncheck-running-mode #f)]
[(= i 500)
(queue-callback
(λ ()
(when (unbox bx)
(loop (cdr val) 0)))
#f)]
[else
(process-trace-element defs-text (car val))
(loop (cdr val) (+ i 1))]))))
(define/private (process-trace-element defs-text x)
;; using 'defs-text' all the time is wrong in the case of embedded editors,
;; but they already don't work and we've arranged for them to not appear here ....
(match x
[`(syncheck:add-arrow ,start-text ,start-pos-left ,start-pos-right
,end-text ,end-pos-left ,end-pos-right
,actual? ,level)
(send defs-text syncheck:add-arrow
defs-text start-pos-left start-pos-right
defs-text end-pos-left end-pos-right
actual? level)]
[`(syncheck:add-tail-arrow ,from-text ,from-pos ,to-text ,to-pos)
(send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)]
[`(syncheck:add-mouse-over-status ,text ,pos-left ,pos-right ,str)
(send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)]
[`(syncheck:add-background-color ,text ,color ,start ,fin)
(send defs-text syncheck:add-background-color defs-text color start fin)]
[`(syncheck:add-jump-to-definition ,text ,start ,end ,id ,filename)
(send defs-text syncheck:add-jump-to-definition defs-text start end id filename)]
[`(syncheck:add-require-open-menu ,text ,start-pos ,end-pos ,file)
(send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)]
[`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,tag)
(send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path tag)]
[`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id)
(define (name-dup? name) (place-channel-put/get name-dup-pc (list name-dup-id name)))
(define to-be-renamed/poss/fixed
(for/list ([lst (in-list to-be-renamed/poss)])
(list defs-text (list-ref lst 1) (list-ref lst 2))))
(send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed
name-dup?)]))
(define/augment (enable-evaluation)
(send check-syntax-button enable #t)
(send mode-menu-item1 enable #t)
@ -1224,165 +1589,212 @@ If the namespace does not, they are colored the unbound color.
(open-status-line 'drracket:check-syntax:status)
(update-status-line 'drracket:check-syntax:status status-init)
(ensure-rep-hidden)
(let-values ([(expanded-expression expansion-completed) (make-traversal)])
(let* ([definitions-text (get-definitions-text)]
[interactions-text (get-interactions-text)]
[drs-eventspace (current-eventspace)]
[the-tab (get-current-tab)])
(let-values ([(old-break-thread old-custodian) (send the-tab get-breakables)])
(let* ([user-namespace #f]
[user-directory #f]
[user-custodian #f]
[normal-termination? #f]
[show-error-report/tab
(λ () ; =drs=
(send the-tab turn-on-error-report)
(send (send the-tab get-error-report-text) scroll-to-position 0)
(when (eq? (get-current-tab) the-tab)
(show-error-report)))]
[cleanup
(λ () ; =drs=
(send the-tab set-breakables old-break-thread old-custodian)
(send the-tab enable-evaluation)
(close-status-line 'drracket:check-syntax:status)
;; do this with some lag ... not great, but should be okay.
(let ([err-port (send (send the-tab get-error-report-text) get-err-port)])
(thread
(λ ()
(flush-output err-port)
(queue-callback
(λ ()
(unless (= 0 (send (send the-tab get-error-report-text) last-position))
(show-error-report/tab))))))))]
[kill-termination
(λ ()
(unless normal-termination?
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ ()
(send the-tab syncheck:clear-highlighting)
(cleanup)
(custodian-shutdown-all user-custodian))))))]
[error-display-semaphore (make-semaphore 0)]
[uncaught-exception-raised
(λ () ;; =user=
(set! normal-termination? #t)
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ () ;; =drs=
(yield error-display-semaphore) ;; let error display go first
(send the-tab syncheck:clear-highlighting)
(cleanup)
(custodian-shutdown-all user-custodian)))))]
[error-port (send (send the-tab get-error-report-text) get-err-port)]
[output-port (send (send the-tab get-error-report-text) get-out-port)]
[init-proc
(λ () ; =user=
(send the-tab set-breakables (current-thread) (current-custodian))
(set-directory definitions-text)
(current-error-port error-port)
(current-output-port output-port)
(error-display-handler
(λ (msg exn) ;; =user=
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ () ;; =drs=
;; this has to come first or else the positioning
;; computations in the highlight-errors/exn method
;; will be wrong by the size of the error report box
(show-error-report/tab)
;; a call like this one also happens in
;; drracket:debug:error-display-handler/stacktrace
;; but that call won't happen here, because
;; the rep is not in the current-rep parameter
(send interactions-text highlight-errors/exn exn))))
(drracket:debug:error-display-handler/stacktrace
msg
exn
'()
#:definitions-text definitions-text)
(semaphore-post error-display-semaphore)))
(error-print-source-location #f) ; need to build code to render error first
(uncaught-exception-handler
(let ([oh (uncaught-exception-handler)])
(λ (exn)
(uncaught-exception-raised)
(oh exn))))
(update-status-line 'drracket:check-syntax:status status-expanding-expression)
(set! user-custodian (current-custodian))
(set! user-directory (current-directory)) ;; set by set-directory above
(set! user-namespace (current-namespace)))])
(send the-tab disable-evaluation) ;; this locks the editor, so must be outside.
(define definitions-text-copy
(new (class text:basic%
;; overriding get-port-name like this ensures
;; that the resulting syntax objects are connected
;; to the actual definitions-text, not this copy
(define/override (get-port-name)
(send definitions-text get-port-name))
(super-new))))
(define settings (send definitions-text get-next-settings))
(define module-language?
(is-a? (drracket:language-configuration:language-settings-language settings)
drracket:module-language:module-language<%>))
(send definitions-text copy-self-to definitions-text-copy)
(with-lock/edit-sequence
definitions-text-copy
(define definitions-text (get-definitions-text))
(define interactions-text (get-interactions-text))
(define drs-eventspace (current-eventspace))
(define the-tab (get-current-tab))
(define-values (old-break-thread old-custodian) (send the-tab get-breakables))
;; set by the init-proc
(define expanded-expression void)
(define expansion-completed void)
(define user-custodian #f)
(define normal-termination? #f)
(define show-error-report/tab
(λ () ; =drs=
(send the-tab turn-on-error-report)
(send (send the-tab get-error-report-text) scroll-to-position 0)
(when (eq? (get-current-tab) the-tab)
(show-error-report))))
(define cleanup
(λ () ; =drs=
(send the-tab set-breakables old-break-thread old-custodian)
(send the-tab enable-evaluation)
(set-syncheck-running-mode #f)
(close-status-line 'drracket:check-syntax:status)
;; do this with some lag ... not great, but should be okay.
(let ([err-port (send (send the-tab get-error-report-text) get-err-port)])
(thread
(λ ()
(flush-output err-port)
(queue-callback
(λ ()
(unless (= 0 (send (send the-tab get-error-report-text) last-position))
(show-error-report/tab)))))))))
(define kill-termination
(λ ()
(unless normal-termination?
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ ()
(send the-tab clear-annotations)
(send the-tab reset-offer-kill)
(send (send the-tab get-defs) syncheck:init-arrows)
(drracket:eval:expand-program
#:gui-modules? #f
(drracket:language:make-text/pos definitions-text-copy 0 (send definitions-text-copy last-position))
settings
(not module-language?)
init-proc
kill-termination
(λ (sexp loop) ; =user=
(cond
[(eof-object? sexp)
(set! normal-termination? #t)
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ () ; =drs=
(with-lock/edit-sequence
definitions-text
(λ ()
(parameterize ([currently-processing-definitions-text definitions-text])
(expansion-completed user-namespace user-directory)
(send (send (get-current-tab) get-defs) set-syncheck-mode mode)
(update-menu-status (get-current-tab))
(send definitions-text syncheck:sort-bindings-table))))
(cleanup)
(custodian-shutdown-all user-custodian))))]
[else
(send the-tab syncheck:clear-highlighting)
(cleanup)
(custodian-shutdown-all user-custodian)))))))
(define error-display-semaphore (make-semaphore 0))
(define uncaught-exception-raised
(λ () ;; =user=
(set! normal-termination? #t)
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ () ;; =drs=
(yield error-display-semaphore) ;; let error display go first
(send the-tab syncheck:clear-highlighting)
(cleanup)
(custodian-shutdown-all user-custodian))))))
(define error-port (send (send the-tab get-error-report-text) get-err-port))
(define output-port (send (send the-tab get-error-report-text) get-out-port))
(define init-proc
(λ () ; =user=
(send the-tab set-breakables (current-thread) (current-custodian))
(set-directory definitions-text)
(current-error-port error-port)
(current-output-port output-port)
(error-display-handler
(λ (msg exn) ;; =user=
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ () ;; =drs=
;; this has to come first or else the positioning
;; computations in the highlight-errors/exn method
;; will be wrong by the size of the error report box
(show-error-report/tab)
;; a call like this one also happens in
;; drracket:debug:error-display-handler/stacktrace
;; but that call won't happen here, because
;; the rep is not in the current-rep parameter
(send interactions-text highlight-errors/exn exn))))
(drracket:debug:error-display-handler/stacktrace
msg
exn
'()
#:definitions-text definitions-text)
(semaphore-post error-display-semaphore)))
(error-print-source-location #f) ; need to build code to render error first
(uncaught-exception-handler
(let ([oh (uncaught-exception-handler)])
(λ (exn)
(uncaught-exception-raised)
(oh exn))))
(update-status-line 'drracket:check-syntax:status status-expanding-expression)
(set!-values (expanded-expression expansion-completed)
(make-traversal (current-namespace)
(current-directory))) ;; set by set-directory above
(set! user-custodian (current-custodian))))
(set-syncheck-running-mode 'button)
(send the-tab disable-evaluation) ;; this locks the editor, so must be outside.
(define definitions-text-copy
(new (class text:basic%
;; overriding get-port-name like this ensures
;; that the resulting syntax objects are connected
;; to the actual definitions-text, not this copy
(define/override (get-port-name)
(send definitions-text get-port-name))
(super-new))))
(define settings (send definitions-text get-next-settings))
(define module-language?
(is-a? (drracket:language-configuration:language-settings-language settings)
drracket:module-language:module-language<%>))
(send definitions-text copy-self-to definitions-text-copy)
(with-lock/edit-sequence
definitions-text-copy
(λ ()
(send the-tab clear-annotations)
(send the-tab reset-offer-kill)
(send (send the-tab get-defs) syncheck:init-arrows)
(drracket:eval:expand-program
#:gui-modules? #f
(drracket:language:make-text/pos definitions-text-copy 0 (send definitions-text-copy last-position))
settings
(not module-language?)
init-proc
kill-termination
(λ (sexp loop) ; =user=
(cond
[(eof-object? sexp)
(set! normal-termination? #t)
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ () ; =drs=
(with-lock/edit-sequence
definitions-text
(λ ()
(parameterize ([current-annotations definitions-text])
(expansion-completed))
(send (send (get-current-tab) get-defs) set-syncheck-mode mode)
(update-menu-status (get-current-tab))
(send definitions-text syncheck:sort-bindings-table)))
(cleanup)
(custodian-shutdown-all user-custodian))))]
[else
(open-status-line 'drracket:check-syntax:status)
(unless module-language?
(update-status-line 'drracket:check-syntax:status status-eval-compile-time)
(eval-compile-time-part-of-top-level sexp))
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ () ; =drs=
(with-lock/edit-sequence
definitions-text
(λ ()
(open-status-line 'drracket:check-syntax:status)
(unless module-language?
(update-status-line 'drracket:check-syntax:status status-eval-compile-time)
(eval-compile-time-part-of-top-level sexp))
(parameterize ([current-eventspace drs-eventspace])
(queue-callback
(λ () ; =drs=
(with-lock/edit-sequence
definitions-text
(λ ()
(open-status-line 'drracket:check-syntax:status)
(update-status-line 'drracket:check-syntax:status status-coloring-program)
(parameterize ([currently-processing-definitions-text definitions-text])
(expanded-expression user-namespace user-directory sexp jump-to-id))
(close-status-line 'drracket:check-syntax:status))))))
(update-status-line 'drracket:check-syntax:status status-expanding-expression)
(close-status-line 'drracket:check-syntax:status)
(loop)]))))))))))]))
(update-status-line 'drracket:check-syntax:status status-coloring-program)
(parameterize ([current-annotations definitions-text])
(expanded-expression sexp (if jump-to-id (make-visit-id jump-to-id) void)))
(close-status-line 'drracket:check-syntax:status))))))
(update-status-line 'drracket:check-syntax:status status-expanding-expression)
(close-status-line 'drracket:check-syntax:status)
(loop)]))))))]))
(define (make-visit-id jump-to-id)
(λ (vars)
(when jump-to-id
(for ([id (in-list (syntax->list vars))])
(let ([binding (identifier-binding id 0)])
(when (pair? binding)
(let ([nominal-source-id (list-ref binding 3)])
(when (eq? nominal-source-id jump-to-id)
(let ([stx id])
(let ([src (find-source-editor stx)]
[pos (syntax-position stx)]
[span (syntax-span stx)])
(when (and (is-a? src text%)
pos
span)
(send src begin-edit-sequence)
;; try to scroll so stx's location is
;; near the top of the visible region
(let ([admin (send src get-admin)])
(when admin
(let ([wb (box 0.0)]
[hb (box 0.0)]
[xb (box 0.0)]
[yb (box 0.0)])
(send admin get-view #f #f wb hb)
(send src position-location (- pos 1) xb yb #t #f #t)
(let ([w (unbox wb)]
[h (unbox hb)]
[x (unbox xb)]
[y (unbox yb)])
(send src scroll-editor-to
(max 0 (- x (* .1 w)))
(max 0 (- y (* .1 h)))
w h
#t
'none)))))
(send src set-position (- pos 1) (+ pos span -1))
(send src end-edit-sequence))))))))))))
;; set-directory : text -> void
;; sets the current-directory and current-load-relative-directory
@ -1506,4 +1918,14 @@ If the namespace does not, they are colored the unbound color.
(drracket:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t)
(drracket:get/extend:extend-definitions-text make-syncheck-text%)
(drracket:get/extend:extend-unit-frame unit-frame-mixin #f)
(drracket:get/extend:extend-tab tab-mixin)))
(drracket:get/extend:extend-tab tab-mixin)
(drracket:module-language-tools:add-online-expansion-handler
compile-comp.rkt
'go
(λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window)
replay-compile-comp-trace
defs-text
val)))))
(define-runtime-path compile-comp.rkt "online-comp.rkt")

60
collects/drracket/private/syncheck/intf.rkt
View File

@ -1,18 +1,24 @@
#lang racket/base
(require racket/class
racket/promise
setup/xref
scribble/xref)
setup/xref)
(define-local-member-name
syncheck:init-arrows
syncheck:clear-arrows
syncheck:arrows-visible?
syncheck:add-menu
syncheck:find-source-object
syncheck:add-background-color
syncheck:add-docs-menu
syncheck:color-range
syncheck:add-require-open-menu
syncheck:add-rename-menu
syncheck:add-arrow
syncheck:add-tail-arrow
syncheck:add-mouse-over-status
syncheck:add-jump-to-definition
syncheck:sort-bindings-table
syncheck:jump-to-next-bound-occurrence
syncheck:jump-to-binding-occurrence
@ -37,16 +43,24 @@
get-syncheck-mode
update-menu-status)
(define syncheck-text<%>
(define syncheck-annotations<%>
(interface ()
syncheck:init-arrows
syncheck:clear-arrows
syncheck:arrows-visible?
syncheck:add-menu
syncheck:find-source-object
syncheck:add-background-color
syncheck:add-require-open-menu
syncheck:add-docs-menu
syncheck:add-rename-menu
syncheck:add-arrow
syncheck:add-tail-arrow
syncheck:add-mouse-over-status
syncheck:add-jump-to-definition
syncheck:color-range))
(define syncheck-text<%>
(interface (syncheck-annotations<%>)
syncheck:init-arrows
syncheck:clear-arrows
syncheck:arrows-visible?
syncheck:sort-bindings-table
syncheck:get-bindings-table
syncheck:jump-to-next-bound-occurrence
@ -56,7 +70,7 @@
;; use this to communicate the frame being
;; syntax checked w/out having to add new
;; parameters to all of the functions
(define currently-processing-definitions-text (make-parameter #f))
(define current-annotations (make-parameter #f))
(define xref (if (getenv "PLTDRXREFDELAY")
(begin
@ -69,19 +83,41 @@
(delay/idle (load-collections-xref))))
(define (get-xref) (force xref))
(define annotations-mixin
(mixin () (syncheck-annotations<%>)
(define/public (syncheck:find-source-object stx) #f)
(define/public (syncheck:add-background-color source start end color) (void))
(define/public (syncheck:add-require-open-menu source color start end key) (void))
(define/public (syncheck:add-rename-menu text start-pos end-pos key id-as-sym id-sets rename-ht get-ids) (void))
(define/public (syncheck:add-docs-menu text start-pos end-pos key the-label path tag) (void))
(define/public (syncheck:add-arrow start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)
(void))
(define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) (void))
(define/public (syncheck:add-mouse-over-status text pos-left pos-right str) (void))
(define/public (syncheck:add-jump-to-definition text start end id filename) (void))
(define/public (syncheck:color-range source start finish style-name mode) (void))
(super-new)))
(provide syncheck-text<%>
currently-processing-definitions-text
syncheck-annotations<%>
current-annotations
annotations-mixin
get-xref
;; methods
syncheck:init-arrows
syncheck:clear-arrows
syncheck:arrows-visible?
syncheck:add-menu
syncheck:add-arrow
syncheck:add-tail-arrow
syncheck:add-mouse-over-status
syncheck:add-jump-to-definition
syncheck:add-docs-menu
syncheck:add-require-open-menu
syncheck:add-rename-menu
syncheck:add-background-color
syncheck:sort-bindings-table
syncheck:jump-to-next-bound-occurrence
syncheck:jump-to-binding-occurrence
@ -92,6 +128,8 @@
;syncheck:error-report-visible? ;; test suite uses this one.
;syncheck:get-bindings-table ;; test suite uses this one.
syncheck:clear-error-message
syncheck:color-range
syncheck:find-source-object
hide-error-report
get-error-report-text

63
collects/drracket/private/syncheck/online-comp.rkt Normal file
View File

@ -0,0 +1,63 @@
#lang racket/base
(require racket/class
racket/place
"traversals.rkt"
"intf.rkt")
(provide go)
(define obj%
(class (annotations-mixin object%)
(init-field src)
(define trace '())
(define-values (remote local) (place-channel))
(define table (make-hash))
(thread
(λ ()
(with-handlers ((exn:fail? (λ (x) (eprintf "online-comp.rkt: thread failed ~a\n" (exn-message x)))))
(let loop ()
(define id/name (place-channel-get local))
(define id (list-ref id/name 0))
(define name (list-ref id/name 1))
(define res ((hash-ref table id) name))
(place-channel-put local res)))))
(define/override (syncheck:find-source-object stx)
(and (equal? src (syntax-source stx))
src))
(define-syntax-rule
(log name)
(define/override (name . args)
(set! trace (cons (cons 'name args) trace))))
; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up
; (log syncheck:add-mouse-over-status) ;; we don't log these as they require space in the window
(log syncheck:add-arrow)
(log syncheck:add-tail-arrow)
(log syncheck:add-background-color)
(log syncheck:add-require-open-menu)
(log syncheck:add-docs-menu)
(log syncheck:add-jump-to-definition)
(define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?)
(define id (hash-count table))
(hash-set! table id dup-name?)
(set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id)
trace)))
(define/public (get-trace) (reverse trace))
(super-new)))
(void (get-xref)) ;; do this now so that it doesn't get killed during a call to 'go'
(define (go expanded path the-source)
(define obj (new obj% [src the-source]))
(define-values (expanded-expression expansion-completed)
(make-traversal (current-namespace)
(if path
(let-values ([(base name dir) (split-path path)])
base)
(current-directory))))
(parameterize ([current-annotations obj])
(expanded-expression expanded)
(expansion-completed))
(send obj get-trace))

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

@ -6,30 +6,15 @@
"contract-traversal.rkt"
string-constants
racket/unit
racket/contract
racket/set
racket/class
racket/list
racket/pretty
drracket/tool
syntax/toplevel
syntax/boundmap
mrlib/switchable-button
(prefix-in drracket:arrow: drracket/arrow)
(prefix-in fw: framework/framework)
mred
framework
setup/xref
scribble/xref
scribble/manual-struct
net/url
net/uri-codec
browser/external
(for-syntax racket/base)
"../../syncheck-drracket-button.rkt")
(for-syntax racket/base))
(provide make-traversal)
(provide make-traversal)
;
@ -51,13 +36,13 @@
;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void)
;; (namespace string[directory] -> void))
;; make-traversal : namespace string[directory] -> (values (syntax (union #f syntax) -> void)
;; (-> void))
;; returns a pair of functions that close over some state that
;; represents the top-level of a single program. The first value
;; is called once for each top-level expression and the second
;; value is called once, after all expansion is complete.
(define (make-traversal)
(define (make-traversal user-namespace user-directory)
(let* ([tl-low-binders (make-id-set)]
[tl-high-binders (make-id-set)]
[tl-low-varrefs (make-id-set)]
@ -73,7 +58,7 @@
[tl-require-for-templates (make-hash)]
[tl-require-for-labels (make-hash)]
[expanded-expression
(λ (user-namespace user-directory sexp jump-to-id)
(λ (sexp [visit-id void])
(parameterize ([current-load-relative-directory user-directory])
(let ([is-module? (syntax-case sexp (module)
[(module . rest) #t]
@ -95,7 +80,7 @@
[require-for-templates (make-hash)]
[require-for-labels (make-hash)])
(annotate-basic sexp
user-namespace user-directory jump-to-id
user-namespace user-directory visit-id
low-binders high-binders
varrefs high-varrefs
varsets high-varsets
@ -121,7 +106,7 @@
(annotate-contracts sexp low-binders binding-inits))]
[else
(annotate-basic sexp
user-namespace user-directory jump-to-id
user-namespace user-directory visit-id
tl-low-binders tl-high-binders
tl-low-varrefs tl-high-varrefs
tl-low-varsets tl-high-varsets
@ -133,7 +118,7 @@
tl-require-for-templates
tl-require-for-labels)]))))]
[expansion-completed
(λ (user-namespace user-directory)
(λ ()
(parameterize ([current-load-relative-directory user-directory])
(annotate-variables user-namespace
user-directory
@ -164,7 +149,7 @@
;; hash-table[require-spec -> syntax] (three of them)
;; -> void
(define (annotate-basic sexp
user-namespace user-directory jump-to-id
user-namespace user-directory visit-id
low-binders high-binders
low-varrefs high-varrefs
low-varsets high-varsets
@ -174,16 +159,7 @@
requires require-for-syntaxes require-for-templates require-for-labels)
(let ([tail-ht (make-hasheq)]
[maybe-jump
(λ (vars)
(when jump-to-id
(for-each (λ (id)
(let ([binding (identifier-binding id 0)])
(when (pair? binding)
(let ([nominal-source-id (list-ref binding 3)])
(when (eq? nominal-source-id jump-to-id)
(jump-to id))))))
(syntax->list vars))))])
[maybe-jump (λ (vars) (visit-id vars))])
(let level-loop ([sexp sexp]
[high-level? #f])
@ -491,10 +467,7 @@
require-for-templates
require-for-labels)
(let ([rename-ht
;; hash-table[(list source number number) -> (listof syntax)]
(make-hash)]
[unused-requires (make-hash)]
(let ([unused-requires (make-hash)]
[unused-require-for-syntaxes (make-hash)]
[unused-require-for-templates (make-hash)]
[unused-require-for-labels (make-hash)]
@ -528,8 +501,7 @@
(λ (var varsets)
(when (syntax-original? var)
(color-variable var 0 varsets)
(document-variable var 0)
(record-renamable-var rename-ht var)))])
(document-variable var 0)))])
(for-each (λ (vars)
(for-each (λ (var) (handle-var-bind var high-varsets))
vars))
@ -546,7 +518,6 @@
(when (syntax-original? var)
(document-variable var index))
(connect-identifier var
rename-ht
binders
unused/phases
requires/phases
@ -568,7 +539,6 @@
(lambda (var)
;; no color variable
(connect-identifier var
rename-ht
low-binders
unused/phases
requires/phases
@ -577,7 +547,6 @@
user-directory
#f)
(connect-identifier var
rename-ht
high-binders
unused/phases
requires/phases
@ -586,7 +555,6 @@
user-directory
#f)
(connect-identifier var
rename-ht
template-binders ;; dummy; always empty
unused/phases
requires/phases
@ -595,7 +563,6 @@
user-directory
#f)
(connect-identifier var
rename-ht
label-binders ;; dummy; always empty
unused/phases
requires/phases
@ -610,7 +577,7 @@
(λ (vars)
(for-each
(λ (var)
(color/connect-top rename-ht user-namespace user-directory low-binders var))
(color/connect-top user-namespace user-directory low-binders var))
vars))
(get-idss low-tops))
@ -618,7 +585,7 @@
(λ (vars)
(for-each
(λ (var)
(color/connect-top rename-ht user-namespace user-directory high-binders var))
(color/connect-top user-namespace user-directory high-binders var))
vars))
(get-idss high-tops))
@ -627,22 +594,25 @@
(color-unused require-for-syntaxes unused-require-for-syntaxes)
(color-unused requires unused-requires)
(hash-for-each rename-ht (lambda (k stxs) (make-rename-menu k rename-ht id-sets)))))
;; record-renamable-var : rename-ht syntax -> void
(define (record-renamable-var rename-ht stx)
(let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))])
(hash-set! rename-ht
key
(cons stx (hash-ref rename-ht key '())))))
(make-rename-menus id-sets)))
;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void
(define (color-unused requires unused)
(hash-for-each
unused
(λ (k v)
(for-each (λ (stx) (color stx error-style-name 'default-mode))
(for-each (λ (stx)
(define defs-text (current-annotations))
(define source-editor (find-source-editor stx))
(when (and defs-text source-editor)
(define pos (syntax-position stx))
(define span (syntax-span stx))
(when (and pos span)
(define start (- pos 1))
(define fin (+ start span))
(send defs-text syncheck:add-background-color
source-editor start fin "firebrick")))
(color stx unused-require-style-name 'default-mode))
(hash-ref requires k)))))
;; connect-identifier : syntax
@ -656,14 +626,12 @@
;; boolean
;; -> void
;; adds arrows and rename menus for binders/bindings
(define (connect-identifier var rename-ht all-binders
(define (connect-identifier var all-binders
unused/phases requires/phases
phase-level user-namespace user-directory actual?)
(connect-identifier/arrow var all-binders
unused/phases requires/phases
phase-level user-namespace user-directory actual?)
(when (and actual? (get-ids all-binders var))
(record-renamable-var rename-ht var)))
phase-level user-namespace user-directory actual?))
;; id-level : integer-or-#f-or-'lexical identifier -> symbol
(define (id-level phase-level id)
@ -723,7 +691,7 @@
source-id
filename))))
(add-mouse-over var
(fw:gui-utils:format-literal-label
(format
(string-constant cs-mouse-over-import)
(syntax-e var)
req-path))
@ -775,7 +743,7 @@
[else #f]))))
;; color/connect-top : namespace directory id-set syntax -> void
(define (color/connect-top rename-ht user-namespace user-directory binders var)
(define (color/connect-top user-namespace user-directory binders var)
(let ([top-bound?
(or (get-ids binders var)
(parameterize ([current-namespace user-namespace])
@ -784,8 +752,8 @@
#t)))])
(if top-bound?
(color var lexically-bound-variable-style-name 'default-mode)
(color var error-style-name 'default-mode))
(connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t)))
(color var free-variable-style-name 'default-mode))
(connect-identifier var binders #f #f 0 user-namespace user-directory #t)))
;; color-variable : syntax phase-level module-identifier-mapping -> void
(define (color-variable var phase-level varsets)
@ -818,7 +786,7 @@
(define (connect-syntaxes from to actual? level)
(let ([from-source (find-source-editor from)]
[to-source (find-source-editor to)]
[defs-text (get-defs-text)])
[defs-text (current-annotations)])
(when (and from-source to-source defs-text)
(let ([pos-from (syntax-position from)]
[span-from (syntax-span from)]
@ -840,7 +808,7 @@
;; this area shows up in the status line.
(define (add-mouse-over stx str)
(let* ([source (find-source-editor stx)]
[defs-text (get-defs-text)])
[defs-text (current-annotations)])
(when (and defs-text
source
(syntax-position stx)
@ -856,7 +824,7 @@
;; to the definition of the id.
(define (add-jump-to-definition stx id filename)
(let ([source (find-source-editor stx)]
[defs-text (get-defs-text)])
[defs-text (current-annotations)])
(when (and source
defs-text
(syntax-position stx)
@ -870,19 +838,6 @@
id
filename)))))
;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>))
(define (find-syncheck-text text)
(let loop ([text text])
(cond
[(is-a? text syncheck-text<%>) text]
[else
(let ([admin (send text get-admin)])
(and (is-a? admin editor-snip-editor-admin<%>)
(let* ([enclosing-editor-snip (send admin get-snip)]
[editor-snip-admin (send enclosing-editor-snip get-admin)]
[enclosing-editor (send editor-snip-admin get-editor)])
(loop enclosing-editor))))])))
;; annotate-tail-position/last : (listof syntax) -> void
(define (annotate-tail-position/last orig-stx stxs tail-ht)
(unless (null? stxs)
@ -909,10 +864,10 @@
(λ (require-spec)
(when (syntax-original? require-spec)
(let ([source (find-source-editor require-spec)])
(when (and (is-a? source text%)
(when (and source
(syntax-position require-spec)
(syntax-span require-spec))
(let ([defs-text (get-defs-text)])
(let ([defs-text (current-annotations)])
(when defs-text
(let* ([start (- (syntax-position require-spec) 1)]
[end (+ start (syntax-span require-spec))]
@ -920,11 +875,8 @@
user-namespace
user-directory)])
(when file
(send defs-text syncheck:add-menu
source
start end
#f
(make-require-open-menu file)))))))))))
(send defs-text syncheck:add-require-open-menu
source start end file))))))))))
;; get-require-filename : sexp-or-module-path-index namespace string[directory] -> filename or #f
;; finds the filename corresponding to the require in stx
@ -955,16 +907,6 @@
(k rkt-path/f))
ss-path))))))
;; make-require-open-menu : path -> menu -> void
(define (make-require-open-menu file)
(λ (menu)
(let-values ([(base name dir?) (split-path file)])
(instantiate menu-item% ()
(label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name)))
(parent menu)
(callback (λ (x y) (fw:handler:edit-file file))))
(void))))
;; possible-suffixes : (listof string)
;; these are the suffixes that are checked for the reverse
;; module-path mapping.
@ -1106,40 +1048,6 @@
[(box? stx-e)
(loop (unbox stx-e) (unbox datum))]
[else (void)]))])))))
;; jump-to : syntax -> void
(define (jump-to stx)
(let ([src (find-source-editor stx)]
[pos (syntax-position stx)]
[span (syntax-span stx)])
(when (and (is-a? src text%)
pos
span)
(send src begin-edit-sequence)
;; try to scroll so stx's location is
;; near the top of the visible region
(let ([admin (send src get-admin)])
(when admin
(let ([wb (box 0.0)]
[hb (box 0.0)]
[xb (box 0.0)]
[yb (box 0.0)])
(send admin get-view #f #f wb hb)
(send src position-location (- pos 1) xb yb #t #f #t)
(let ([w (unbox wb)]
[h (unbox hb)]
[x (unbox xb)]
[y (unbox yb)])
(send src scroll-editor-to
(max 0 (- x (* .1 w)))
(max 0 (- y (* .1 h)))
w h
#t
'none)))))
(send src set-position (- pos 1) (+ pos span -1))
(send src end-edit-sequence))))
;; hash-table[syntax -o> (listof syntax)] -> void
(define (add-tail-ht-links tail-ht)
@ -1189,7 +1097,7 @@
(define (add-tail-ht-link from-stx to-stx)
(let* ([to-src (find-source-editor to-stx)]
[from-src (find-source-editor from-stx)]
[defs-text (get-defs-text)])
[defs-text (current-annotations)])
(when (and to-src from-src defs-text)
(let ([from-pos (syntax-position from-stx)]
[to-pos (syntax-position to-stx)])
@ -1202,7 +1110,7 @@
(define (add-tail-link? from-stx to-stx)
(let* ([to-src (find-source-editor to-stx)]
[from-src (find-source-editor from-stx)]
[defs-text (get-defs-text)])
[defs-text (current-annotations)])
(and to-src from-src defs-text
(let ([from-pos (syntax-position from-stx)]
[to-pos (syntax-position to-stx)])
@ -1230,7 +1138,7 @@
;; document-variable : stx[identifier,original] phase-level -> void
(define (document-variable stx phase-level)
(let ([defs-text (currently-processing-definitions-text)])
(let ([defs-text (current-annotations)])
(when defs-text
(let ([binding-info (identifier-binding stx phase-level)])
(when (and (pair? binding-info)
@ -1238,50 +1146,36 @@
(syntax-span stx))
(let* ([start (- (syntax-position stx) 1)]
[fin (+ start (syntax-span stx))]
[source-editor (find-source-editor stx)]
[xref (get-xref)])
(when (and xref source-editor)
(let ([definition-tag (xref-binding->definition-tag xref binding-info #f)])
(when definition-tag
(let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
(when path
(let ([index-entry (xref-tag->index-entry xref definition-tag)])
(when index-entry
(send defs-text syncheck:add-background-color
source-editor "navajowhite" start fin (syntax-e stx))
(send defs-text syncheck:add-menu
source-editor
start
fin
(syntax-e stx)
(λ (menu)
(instantiate menu-item% ()
(parent menu)
(label (build-docs-label (entry-desc index-entry)))
(callback
(λ (x y)
(let* ([url (path->url path)]
[url2 (if tag
(make-url (url-scheme url)
(url-user url)
(url-host url)
(url-port url)
(url-path-absolute? url)
(url-path url)
(url-query url)
tag)
url)])
(send-url (url->string url2)))))))))))))))))))))
[source-editor (find-source-editor stx)])
(when source-editor
(let ([xref (get-xref)])
(when xref
(let ([definition-tag (xref-binding->definition-tag xref binding-info #f)])
(when definition-tag
(let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
(when path
(let ([index-entry (xref-tag->index-entry xref definition-tag)])
(when index-entry
(send defs-text syncheck:add-background-color
source-editor start fin "navajowhite")
(send defs-text syncheck:add-docs-menu
source-editor
start
fin
(syntax-e stx)
(build-docs-label (entry-desc index-entry))
path
tag))))))))))))))))
(define (build-docs-label desc)
(let ([libs (exported-index-desc-from-libs desc)])
(cond
[(null? libs)
(fw:gui-utils:format-literal-label
(format
(string-constant cs-view-docs)
(exported-index-desc-name desc))]
[else
(fw:gui-utils:format-literal-label
(format
(string-constant cs-view-docs-from)
(format
(string-constant cs-view-docs)
@ -1310,141 +1204,44 @@
; ;;;
;; make-rename-menu : (list source number number) rename-ht (listof id-set) -> void
(define (make-rename-menu key rename-ht id-sets)
(let* ([source (list-ref key 0)]
[pos (list-ref key 1)]
[span (list-ref key 2)]
[defs-text (currently-processing-definitions-text)]
[example-id
;; we know that there is at least one there b/c that's how make-rename-menu is called
(car (hash-ref rename-ht key))]
[id-as-sym (syntax-e example-id)])
;; make-rename-menus : (listof id-set) -> void
(define (make-rename-menus id-sets)
(define id-to-sets (make-module-identifier-mapping))
(let ([defs-text (current-annotations)])
(when defs-text
(let ([source-editor (find-source-editor example-id)])
(when (is-a? source-editor text%)
(let* ([start (- pos 1)]
[fin (+ start span)])
(send defs-text syncheck:add-menu
source-editor
start
fin
id-as-sym
(λ (menu)
(let ([name-to-offer (format "~a" id-as-sym)])
(instantiate menu-item% ()
(parent menu)
(label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer))
(callback
(λ (x y)
(let ([frame-parent (find-menu-parent menu)])
(rename-callback name-to-offer
defs-text
key
id-sets
rename-ht
frame-parent))))))))))))))
;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>)
(define (find-menu-parent menu)
(let loop ([menu menu])
(cond
[(is-a? menu menu-bar%) (send menu get-frame)]
[(is-a? menu popup-menu%)
(let ([target (send menu get-popup-target)])
(cond
[(is-a? target editor<%>)
(let ([canvas (send target get-canvas)])
(and canvas
(send canvas get-top-level-window)))]
[(is-a? target window<%>)
(send target get-top-level-window)]
[else #f]))]
[(is-a? menu menu-item<%>) (loop (send menu get-parent))]
[else #f])))
;; rename-callback : string
;; (and/c syncheck-text<%> definitions-text<%>)
;; (list source number number)
;; (listof id-set)
;; rename-ht
;; (union #f (is-a?/c top-level-window<%>))
;; -> void
;; callback for the rename popup menu item
(define (rename-callback name-to-offer defs-text key id-sets rename-ht parent)
(let ([new-str
(fw:keymap:call/text-keymap-initializer
(λ ()
(get-text-from-user
(string-constant cs-rename-id)
(fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer)
parent
name-to-offer)))])
(when new-str
(define new-sym (format "~s" (string->symbol new-str)))
(define src-locs (make-hash))
(define all-stxs (make-hash))
(let loop ([key key])
(unless (hash-ref src-locs key #f)
(hash-set! src-locs key #t)
(for ([stx (in-list (hash-ref rename-ht key))])
(for ([id-set (in-list id-sets)])
(for ([stx (in-list (or (get-ids id-set stx) '()))])
(hash-set! all-stxs stx #t)
(loop (list (syntax-source stx)
(syntax-position stx)
(syntax-span stx))))))))
(define to-be-renamed (hash-map all-stxs (λ (k v) k)))
(define do-renaming?
(or (not (name-duplication? to-be-renamed id-sets new-sym))
(equal?
(message-box/custom
(string-constant check-syntax)
(fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error)
new-sym)
(string-constant cs-rename-anyway)
(string-constant cancel)
#f
parent
'(stop default=2))
1)))
(when do-renaming?
(unless (null? to-be-renamed)
(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)
(for ([info (in-list positions-to-rename)])
(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%)
(unless (memq source-editor txts)
(send source-editor begin-edit-sequence)
(set! txts (cons source-editor txts)))
(let* ([start (- position 1)]
[end (+ start span)])
(send source-editor delete start end #f)
(send source-editor insert new-sym start start #f))))
(send defs-text invalidate-bitmap-cache)
(for ([txt (in-list txts)])
(send txt end-edit-sequence))))))))
;; 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.
(define (name-duplication? to-be-renamed id-sets new-str)
(let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str)))
to-be-renamed)])
(for*/or ([id-set (in-list id-sets)]
[new-id (in-list new-ids)])
(get-ids id-set new-id))))
(for ([id-set (in-list id-sets)])
(for-each-ids
id-set
(λ (vars)
(for ([var (in-list vars)])
(define ed (find-source-editor var))
(when ed
(define pos (syntax-position var))
(define span (syntax-span var))
(define start (- pos 1))
(define fin (+ start span))
(define loc (list ed start fin))
(module-identifier-mapping-put!
id-to-sets
var
(set-add (module-identifier-mapping-get id-to-sets var set)
loc)))))))
(module-identifier-mapping-for-each
id-to-sets
(λ (id locs)
(define (name-dup? new-str)
(and (for/or ([id-set (in-list id-sets)])
(for/or ([id (in-list (or (get-ids id-set id) '()))])
(let ([new-id (datum->syntax id (string->symbol new-str))])
(for/or ([id-set (in-list id-sets)])
(get-ids id-set new-id)))))
#t))
(define loc-lst (set->list locs))
(define id-as-sym (syntax-e id))
(send defs-text syncheck:add-rename-menu
id-as-sym
loc-lst
name-dup?))))))
;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original])
;; removes duplicates, based on the source locations of the identifiers
@ -1507,3 +1304,6 @@
(define (for-each-ids mapping f)
(module-identifier-mapping-for-each mapping (λ (x y) (f y))))

3
collects/drracket/private/tools-drs.rkt
View File

@ -36,7 +36,8 @@ This file sets up the right lexical environment to invoke the tools that want to
[prefix drscheme:modes: drracket:modes^]
[prefix drscheme:tracing: drracket:tracing^]
[prefix drscheme:module-language: drracket:module-language^]
[prefix drscheme:module-language-tools: drracket:module-language-tools^])
[prefix drscheme:module-language-tools: drracket:module-language-tools^]
[prefix drscheme: drracket:interface^])
(export drracket:tools-drs^)
(define-syntax (wrap-tool-inputs stx)

4
collects/drracket/private/tools.rkt
View File

@ -30,7 +30,8 @@
[prefix drracket:tracing: drracket:tracing^]
[prefix drracket:module-language: drracket:module-language^]
[prefix drracket:module-language-tools: drracket:module-language-tools^]
[prefix drracket:tools-drs: drracket:tools-drs^])
[prefix drracket:tools-drs: drracket:tools-drs^]
[prefix drracket: drracket:interface^])
(export drracket:tools^)
;; An installed-tool is
@ -451,6 +452,7 @@
;; run-phases : -> void
(define (run-phases phase1-extras phase2-extras)
(drracket:module-language-tools:no-more-online-expansion-handlers)
(let* ([after-phase1 (run-one-phase 'phase1
(string-constant tool-error-phase1)
successfully-loaded-tool-phase1

3
collects/drracket/private/tracing.rkt
View File

@ -18,7 +18,8 @@
(import [prefix drracket:frame: drracket:frame^]
[prefix drracket:rep: drracket:rep^]
[prefix drracket:init: drracket:init^]
[prefix drracket:unit: drracket:unit^])
[prefix drracket:unit: drracket:unit^]
[prefix drracket: drracket:interface^])
(export drracket:tracing^)
(define-local-member-name

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

File diff suppressed because it is too large Load Diff

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

@ -101,6 +101,31 @@ all of the names in the tools library, for use defining keybindings
out. The default is the empty list, meaning that all opt-out buttons appear.
})
(proc-doc/names
drracket:module-language-tools:add-online-expansion-handler
(-> path-string? symbol? (-> (is-a?/c drracket:unit:definitions-text<%>) any/c any) void?)
(mod-path id local-handler)
@{Registers a pair of procedures with DrRacket's online expansion machinery.
The first two arguments name a procedure in a module that is loaded by
@racket[dynamic-require] is a separate place. When DrRacket detects that
the editor has been modified, it sends the contents of the editor over to
that separate place, @racket[expand]s the program there, and then supplies
the fully expanded object to that first procedure. (The procedure is called
in the same context as the expansion process.)
Note that the thread that calls this procedure may be
killed at anytime: DrRacket may kill it when the user types in the buffer
(in order to start a new expansion), but bizarro code may also create a separate
thread during expansion that lurks around and then mutates arbitrary things.
The result of the procedure is expected to be something that can be sent
across a @racket[place-channel], which is then sent back to the original
place where DrRacket itself is running and passed to the @racket[local-handler]
argument. At this point, the only code running is trusted code (DrRacket itself
and other tools), but any long running computations may freeze DrRacket's GUI,
since this procedure is invoked on DrRacket's eventspace's handler thread.})
(proc-doc/names
drracket:module-language:add-module-language
(-> any)

184
collects/scribblings/tools/tools.scrbl
View File

@ -9,7 +9,9 @@
(for-label racket/unit racket/contract)
(for-label racket/base racket/gui)
(for-label framework/framework)
(for-label drracket/syncheck-drracket-button))
(for-label drracket/syncheck-drracket-button
drracket/check-syntax)
scribble/extract)
(define (File x) @tt[x])
(define (FileFirst x) @tt[x]) ;; indexing missing
@ -66,8 +68,8 @@ help being early clients for DrRacket plugins.
Plugins are designed for major extensions in DrRacket's
functionality. To extend the appearance
or the functionality the DrRacket window (say, to annotate
programs in certain ways, to add buttons to the DrRacket
frame or to add additional languages to DrRacket) use a
programs in certain ways or to add buttons to the DrRacket
frame) use a
tool. The Macro Stepper, the Syntax Checker, the Stepper,
and the teaching languages are all implemented as tools.
@ -575,6 +577,182 @@ for a list of the capabilities registered by default.
Check Syntax is a part of the DrRacket collection, but is implemented via the tools API.
@subsection{Accessing Check Syntax Programmatically}
@defmodule[drracket/check-syntax]
@defproc[(make-traversal [namespace namespace?]
[path (or/c #f path-string?)])
(values (->* (syntax?) ((-> (and/c syntax?
(λ (x)
(define lst (syntax->list x))
(and lst (andmap identifier? lst))))
void?))
void?)
(-> void?))]{
This function creates some local state about a traversal of syntax objects
and returns two functions. The first one should be called with each of the
syntax objects that make up a program (there will be only one if the program
is a module) and then the second one should be called to indicate there are no
more.
The optional argument to the first function is called for each sequence
of binding identifiers encountered in @racket[define-values], @racket[define-syntaxes],
and @racket[define-values-for-syntax].
During the dynamic extent of the call to the two result functions, the value
of the @racket[current-annotations] parameter is consulted and various
methods are invoked in the corresponding object (if any), to indicate
what has been found in the syntax object.
}
@defparam[current-annotations ca (or/c #f (is-a?/c syncheck-annotations<%>))]{
The methods of the value of this parameter are invoked by the functions returned
from @racket[make-traversal].
}
@definterface[syncheck-annotations<%> ()]{
Classes implementing this interface are
accceptors of information about a traversal
of syntax objects. See @racket[make-traversal].
Do not implement this interface directly, as it
is liable to change without warning. Instead, use
the @racket[annotations-mixin] and override
the methods you're interested in. The
@racket[annotations-mixin] will keep in sync
with this interface, providing methods that
ignore their arguments.
@defmethod[(syncheck:find-source-object [stx syntax?]) (or/c #f (not/c #f))]{
This should return @racket[#f] if the source of this syntax object is
uninteresting for annotations (if, for example, the only interesting
annotations are those in the original file and this is a syntax object
introduced by a macro and thus has a source location from some other file).
Otherwise, it should return some (non-@racket[#f])
value that will then be passed to one of the other methods below as
a @racket[_source-obj] argument.
}
@defmethod[(syncheck:add-background-color [source-obj (not/c #f)]
[start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[color string?])
void?]{
Called to indicate that the color @racket[color] should be drawn on the background of
the given range in the editor, when the mouse moves over it. This method is typically
called in conjuction with some other method that provides some other annotation
on the source.
}
@defmethod[(syncheck:add-require-open-menu [source-obj (not/c #f)]
[start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[file path-string?])
void?]{
Called to indicate that there is a @racket[require] at the location from @racket[start] to @racket[end],
and that it corresponds to @racket[file]. Check Syntax adds a popup menu.
}
@defmethod[(syncheck:add-docs-menu [source-obj (not/c #f)]
[start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[id symbol?]
[label any/c]
[path any/c]
[tag any/c])
void?]{
Called to indicate that there is something that has documentation between the range @racket[start] and @racket[end]. The
documented identifier's name is given by @racket[id] and the docs are found in the html file @racket[path] at the
html tag @racket[tag]. The @racket[label] argument describes the binding for use in the menu item (although it may
be longer than 200 characters).
}
@defmethod[(syncheck:add-rename-menu [id symbol?]
[all-ids (listof (list/c (not/c #f) exact-nonnegative-integer? exact-nonnegative-integer?))]
[new-name-interferes? (-> symbol boolean?)])
void?]{
Called to indicate that there is a variable that can be renamed. The
identifier's name is @racket[id] and all of the occurrences of the identifier are given in the
list @racket[all-ids]. The @racket[new-name-interferes?] procedure determines if a potential name would
interfere with the existing bindings.
}
@defmethod[(syncheck:add-arrow [start-source-obj (not/c #f)]
[start-left exact-nonnegative-integer?]
[start-right exact-nonnegative-integer?]
[end-source-obj (not/c #f)]
[end-left exact-nonnegative-integer?]
[end-right exact-nonnegative-integer?]
[actual? boolean?]
[phase-level (or/c exact-nonnegative-integer? #f)])
void?]{
Called to indicate that there should be an arrow between the locations described by the first six arguments.
The @racket[phase-level] argument indicates the phase of the binding and the @racket[actual?] argument
indicates if the binding is a real one, or a predicted one from a syntax template (predicted bindings
are drawn with question marks in Check Syntax).
}
@defmethod[(syncheck:add-tail-arrow [from-source-obj (not/c #f)]
[from-pos exact-nonnegative-integer?]
[to-source-obj (not/c #f)]
[to-pos exact-nonnegative-integer?])
void?]{
Called to indicate that there are two expressions, beginning at @racket[from-pos] and @racket[to-pos]
that are in tail position with respect to each other.
}
@defmethod[(syncheck:add-mouse-over-status [source-obj (not/c #f)]
[pos-left exact-nonnegative-integer?]
[pos-right exact-nonnegative-integer?]
[str string?])
void?]{
Called to indicate that the message in @racket[str] should be shown when the mouse passes over the given position.
}
@defmethod[(syncheck:add-jump-to-definition [source-obj (not/c #f)]
[start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[id any/c]
[filename path-string?])
void?]{
Called to indicate that there is some identifier at the given location (named @racket[id]) that
is defined in the file @racket[filename].
}
@defmethod[(syncheck:color-range [source-obj (not/c #f)]
[start exact-nonnegative-integer?]
[finish exact-nonnegative-integer?]
[style-name any/c]
[mode any/c])
void?]{
Called to indicate that the given location should be colored according to the style @racket[style-name] when
in @racket[mode]. The mode either indicates regular check syntax or is used indicate blame for potential contract
violations (and still experimental).
}
}
@defmixin[annotations-mixin () (syncheck-annotations<%>)]{
Supplies all of the methods in @racket[syncheck-annotations<%>]
with default behavior. Be sure to use this mixin to future-proof
your code and then override the methods you're interested in.
}
@(define-syntax-rule
(syncheck-method-id x ...)
(begin @defidform[x]{Bound to an identifier created with @racket[define-local-member-name]
that is used in @racket[syncheck-annotations<%>].}
...))
@syncheck-method-id[syncheck:find-source-editor
syncheck:add-background-color
syncheck:add-require-open-menu
syncheck:add-docs-menu
syncheck:add-rename-menu
syncheck:add-arrow
syncheck:add-tail-arrow
syncheck:add-mouse-over-status
syncheck:add-jump-to-definition
syncheck:color-range]
@subsection{Check Syntax Button}
@defmodule[drracket/syncheck-drracket-button]
@defthing[syncheck-drracket-button

38
collects/scribblings/tools/unit.scrbl
View File

@ -132,27 +132,45 @@ Calls the definitions text's
@defmethod[#:mode override
(set-breakables [thread (or/c thread? false/c)]
[custodian (or/c custodian? false/c)])
void?]{}}
void?]{}
@defmethod[#:mode public-final
(add-bkg-running-color [id symbol?]
[color (or/c string? (is-a?/c color%))]
[label string?])
void?]{
Sets the color of the circle in the bottom-right corner of the
DrRacket window to @racket[color] with the tooltip window that
appears over it containing @racket[label]. If multiple coors are
registered they are all shown.
See also @method[drracket:unit:tab<%> remove-bkg-running-color].
}
@defmethod[#:mode public-final
(remove-bkg-running-color [id symbol?])
void?]{
Removes the color and label added with @racket[id].
See also @method[drracket:unit:tab<%> add-bkg-running-color].
}
}
@defclass[drracket:unit:tab% object% (drracket:unit:tab<%>)]{
The base class that implements the tab's functionality.
@defconstructor/make[()]{}
@defmethod[#:mode override
(clear-annotations)
void?]{
Clears any error highlighting.
}}
Clears any error highlighting.
}
}
@defmixin[drracket:unit:program-editor-mixin (text% editor:basic<%>) ()]{

9
collects/string-constants/private/english-string-constants.rkt
View File

@ -216,6 +216,12 @@ please adhere to these guidelines:
(cs-mode-menu-show-client-obligations "Client Contract Obligations")
(cs-mode-menu-show-syntax "Syntactic Categories")
;; the online check syntax status messages (mouse over the bottom right of drracket's window to see the messages during online expansion's various phases)
(online-expansion-running "Online expansion running")
(only-raw-text-files-supported "Only pure text files supported")
(abnormal-termination "Online expansion terminated abnormally")
(jump-to-error "Jump to Error")
;;; info bar at botttom of drscheme frame
(collect-button-label "GC")
(read-only "Read only")
@ -223,7 +229,8 @@ please adhere to these guidelines:
(overwrite "Overwrite")
(running "running")
(not-running "not running")
;;; misc
(welcome-to-something "Welcome to ~a")

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

@ -133,7 +133,7 @@ trigger runtime errors in check syntax.
(" ([" default-color)
("x" lexically-bound-variable)
(" " default-color)
("x" error)
("x" free-variable)
("]) " default-color)
("x" lexically-bound-variable)
(")" default-color))
@ -153,13 +153,13 @@ trigger runtime errors in check syntax.
'(("(" default-color)
("#%top" imported-syntax)
(" . " default-color)
("x" error)
("x" free-variable)
(")" default-color)))
(build-test "(set! x 1)"
'(("(" default-color)
("set!" imported-syntax)
(" " default-color)
("x" error)
("x" free-variable)
(" " default-color)
("1" constant)
(")" default-color)))
@ -195,7 +195,7 @@ trigger runtime errors in check syntax.
(build-test "object%"
'(("object%" imported-syntax))) ; used to be lexically-bound-variable
(build-test "unbound-id"
'(("unbound-id" error)))
'(("unbound-id" free-variable)))
(build-test "(define bd 1) bd"
'(("(" default-color)
("define" imported-syntax)
@ -221,9 +221,9 @@ trigger runtime errors in check syntax.
(")" default-color)))
(build-test "(f x)"
'(("(" default-color)
("f" error)
("f" free-variable)
(" " default-color)
("x" error)
("x" free-variable)
(")" default-color)))
(build-test "(define-syntax (f stx) (syntax 1))"
'(("(" default-color)
@ -287,19 +287,19 @@ trigger runtime errors in check syntax.
'(("(" default-color)
("module" imported-syntax)
(" m " default-color)
("mzscheme" error)
("mzscheme" unused-require)
(")" default-color)))
(build-test "(require-for-syntax mzscheme)"
'(("(" default-color)
("require-for-syntax" imported-syntax)
(" " default-color)
("mzscheme" error)
("mzscheme" unused-require)
(")" default-color)))
(build-test "(require mzlib/list)"
'(("(" default-color)
("require" imported-syntax)
(" " default-color)
("mzlib/list" error)
("mzlib/list" unused-require)
(")" default-color)))
(build-test "(module m mzscheme (provide x) (define x 1))"
'(("(" default-color)
@ -336,7 +336,7 @@ trigger runtime errors in check syntax.
(" m mzscheme (" default-color)
("require" imported-syntax)
(" " default-color)
("mzlib/list" error)
("mzlib/list" unused-require)
("))" default-color))
(list '((10 18) (20 27))))
@ -542,7 +542,7 @@ trigger runtime errors in check syntax.
("(" default-color)
("1" constant)
(" ," default-color)
("x" error)
("x" free-variable)
(" " default-color)
("2" constant)
(")" default-color)))
@ -864,7 +864,7 @@ trigger runtime errors in check syntax.
(build-test "#lang scheme/base\n(require scheme)\n(define-syntax m (lambda (x) #'1))"
'(("#lang " default-color)
("scheme/base" error)
("scheme/base" unused-require)
("\n(" default-color)
("require" imported)
(" scheme)\n(" default-color)

3
collects/tests/drracket/test-docs-complete.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket/base
(require rackunit/docs-complete)
(check-docs 'drracket/check-syntax)

7
collects/typed-scheme/base-env/base-types-extra.rkt
View File

@ -12,10 +12,15 @@
;; special type names that are not bound to particular types
(define-other-types
-> case-> U Rec All Opaque Vector
#;-> case-> U Rec All Opaque Vector
Parameterof List List* Class Values Instance Refinement
pred)
(define-syntax ->
(lambda (stx)
(raise-syntax-error 'type-check "type name used out of context" stx)))
(provide ->)
(provide (rename-out [All ∀]
[U Un]
[-> →]