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

DrRacket: if any file in package X is open, treat X as "in development"

Browse Source 
... for the purpose of "populate 'compiled' directories" --- but only if
the user has write permission for the package directory.

This change may or may not be a good idea. The idea is that installed
packages generally should be treated in the same way as the main
"collects" tree (e.g., avoiding debugging instrumentation), but if you
happen to be developing a package, then you want it treated like things
that are not in the main "collects" tree. So, how do you pick? Maybe
opening a file in the package is a good way to pick.
This commit is contained in:
Matthew Flatt 2013-04-16 12:35:54 -06:00
parent 7e91a00648
commit 6fe2861877
4 changed files with 75 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/drracket/private/eval-helpers.rkt
View File

@ -2,6 +2,7 @@
(require racket/class
racket/draw
racket/list
racket/set
compiler/cm
setup/dirs
planet/config
@ -55,7 +56,9 @@
#;(namespace-attach-module orig-namespace ''#%foreign))
(define (set-module-language-parameters settings module-language-parallel-lock-client
(define (set-module-language-parameters settings
module-language-parallel-lock-client
currently-open-files
#: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)]
@ -68,6 +71,16 @@
(compile-context-preservation-enabled (prefab-module-settings-full-trace? settings))
(when (prefab-module-settings-compilation-on? settings)
(define open-pkgs
(for/fold ([s (set)]) ([path (in-list currently-open-files)])
(define pkg (path->pkg path))
(if (and pkg
(memq 'write
(file-or-directory-permissions (pkg-directory pkg))))
(set-add s pkg)
s)))
(for ([pkg (in-set open-pkgs)])
(log-info "DrRacket: enabling bytecode-file compilation for package ~s" pkg))
(define skip-path?
(let* ([cd (find-collects-dir)]
[no-dirs (if cd
@ -76,6 +89,7 @@
(λ (p) (or (file-stamp-in-paths p no-dirs)
(let ([pkg (path->pkg p)])
(and pkg
(not (set-member? open-pkgs pkg))
(file-stamp-in-paths p (list (pkg-directory pkg)))))))))
(define extra-compiled-file-path
(case (prefab-module-settings-annotations settings)

2
collects/drracket/private/expanding-place.rkt
View File

@ -62,6 +62,7 @@
(define response-pc (vector-ref message 2))
(define settings (vector-ref message 3))
(define pc-status-expanding-place (vector-ref message 4))
(define currently-open-files (vector-ref message 5))
(loop (new-job program-as-string path response-pc settings pc-status-expanding-place)
old-registry)]))))))
@ -120,6 +121,7 @@
(ep-log-info "expanding-place.rkt: 03 setting module language parameters")
(set-module-language-parameters settings
module-language-parallel-lock-client
null
#:use-use-current-security-guard? #t)
(ep-log-info "expanding-place.rkt: 04 setting directories")
(let ([init-dir (get-init-dir path)])

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

@ -331,10 +331,12 @@
(set! language-info #f)
(set! sandbox #f)
(run-in-user-thread
(λ ()
(set-module-language-parameters (module-language-settings->prefab-module-settings settings)
module-language-parallel-lock-client))))
(let ([currently-open-files (get-currently-open-files)])
(run-in-user-thread
(λ ()
(set-module-language-parameters (module-language-settings->prefab-module-settings settings)
module-language-parallel-lock-client
currently-open-files)))))
(define/override (get-one-line-summary)
(string-constant module-language-one-line-summary))
@ -1931,7 +1933,8 @@
filename/loc
(module-language-settings->prefab-module-settings settings)
(λ (res) (oc-finished res))
(λ (a b) (oc-status-message a b)))]
(λ (a b) (oc-status-message a b))
(get-currently-open-files))]
[else
(line-of-interest)
(send dirty/pending-tab set-oc-status
@ -2009,7 +2012,8 @@
filename
prefab-module-settings
show-results
tell-the-tab-show-bkg-running)
tell-the-tab-show-bkg-running
currently-open-files)
(unless expanding-place
(set! expanding-place (dynamic-place expanding-place.rkt 'start))
(place-channel-put expanding-place module-language-compile-lock)
@ -2028,7 +2032,8 @@
filename
pc-in
prefab-module-settings
pc-status-expanding-place))
pc-status-expanding-place
currently-open-files))
(place-channel-put expanding-place to-send)
(define us (current-thread))
(thread (λ ()
@ -2340,4 +2345,13 @@
(connect-to-prefs other-choice 'drracket:online-expansion:other-errors)
(for ([f (in-list (drracket:module-language-tools:get-online-expansion-pref-funcs))])
(f vp))
parent-vp))))
parent-vp)))
(define (get-currently-open-files)
(for*/list ([frame (in-list
(send (group:get-the-frame-group) get-frames))]
#:when (frame . is-a? . drracket:unit:frame%)
[tab (in-list (send frame get-tabs))]
[v (in-value (send (send tab get-defs) get-filename))]
#:when v)
v)))

39
collects/tests/drracket/populate-compiled.rkt
View File

@ -69,7 +69,8 @@
racket/gui/base
racket/class
racket/path
racket/file)
racket/file
framework/test)
(define (check-compiled compiled? path)
(unless (equal? compiled? (file-exists? path))
@ -88,10 +89,12 @@
(define popcomp-main-zo
(build-path dir "popcomp-pkg" "popcomp" "compiled" "drracket" "errortrace" "main_rkt.zo"))
(define popcomp2-main-zo
(build-path dir "popcomp2-pkg" "popcomp2" "compiled" "drracket" "errortrace" "main_rkt.zo"))
(check-compiled #t (build-path dir "compiled" "drracket" "errortrace" "y_rkt.zo"))
(check-compiled #f popcomp-main-zo)
(check-compiled #f (build-path dir "popcomp2-pkg" "popcomp2" "compiled" "drracket" "errortrace" "main_rkt.zo"))
(check-compiled #f popcomp2-main-zo)
;; Create a broken ".zo" file where it should not be used:
(make-directory* (path-only popcomp-main-zo))
@ -103,4 +106,34 @@
(do-execute drs)
(let* ([got (fetch-output drs)])
(unless (string=? "" got)
(error 'check-output "wrong output: ~s" got)))))))
(error 'check-output "wrong output: ~s" got)))
(delete-file popcomp-main-zo)
;; Open "main.rkt" in "popcomp-pkg", so now it should be compiled
;; when we run "x.rkt":
(test:menu-select "File" "New Tab")
(use-get/put-dialog (λ ()
(test:menu-select "File" "Open..."))
(build-path dir "popcomp-pkg" "popcomp" "main.rkt"))
(queue-callback/res (λ () (send drs change-to-tab (car (send drs get-tabs)))))
(do-execute drs)
(check-compiled #t popcomp-main-zo)
(check-compiled #f popcomp2-main-zo)
;; But if the "popcomp-pkg" directory is not writable, then
;; don't compile after all:
(delete-file popcomp-main-zo)
(file-or-directory-permissions (build-path dir "popcomp-pkg") #o555)
(do-execute drs)
(check-compiled #f popcomp-main-zo)
(check-compiled #f popcomp2-main-zo)
(file-or-directory-permissions (build-path dir "popcomp-pkg") #o777)))))