From 153dd73f6b6eb342d8354b5565743cae7d31d1ff Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 28 Nov 2011 10:55:05 -0600 Subject: [PATCH] adjust drracket to clean up the code that sets the initial value of current-directory and current-load-relative-directory and to make current-directory's initial value be the user's home directory --- collects/drracket/private/debug.rkt | 6 +++-- collects/drracket/private/eval-helpers.rkt | 15 +++++++++++- collects/drracket/private/expanding-place.rkt | 7 +++--- collects/drracket/private/module-browser.rkt | 8 +++---- collects/drracket/private/syncheck/gui.rkt | 13 +++++------ .../drracket/private/syncheck/online-comp.rkt | 6 ++--- collects/drracket/private/unit.rkt | 23 ++++++++----------- collects/tests/drracket/module-lang-test.rkt | 9 +++++++- .../private/module-lang-test-utils.rkt | 11 ++++----- collects/tests/drracket/repl-test.rkt | 3 ++- doc/release-notes/drracket/HISTORY.txt | 14 +++++++---- 11 files changed, 67 insertions(+), 48 deletions(-) diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index a79079a7a6..a0a9c4bb5e 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -440,8 +440,10 @@ profile todo: (λ () (cond [(path? src) - (display (path->string (find-relative-path (current-directory) - (normalize-path src))) + (define-values (n-cd n-src) + (with-handlers ([exn:fail? (λ (x) (values (current-directory) src))]) + (values (normalize-path (current-directory)) (normalize-path src)))) + (display (path->string (find-relative-path n-cd n-src)) (current-error-port))] [else (display "" (current-error-port))]))] diff --git a/collects/drracket/private/eval-helpers.rkt b/collects/drracket/private/eval-helpers.rkt index a27569fdfa..bb84e87f8a 100644 --- a/collects/drracket/private/eval-helpers.rkt +++ b/collects/drracket/private/eval-helpers.rkt @@ -11,7 +11,20 @@ (provide set-basic-parameters/no-gui set-module-language-parameters (struct-out prefab-module-settings) - transform-module) + transform-module + get-init-dir) + +;; get-init-dir : (or/c path? #f) -> path? +;; returns the initial directory for a program +;; that is saved in 'path/f' (with #f indicating +;; an unsaved file) +(define (get-init-dir path/f) + (cond + [path/f + (let-values ([(base name dir?) (split-path path/f)]) + base)] + [else + (find-system-path 'home-dir)])) (struct prefab-module-settings (command-line-args diff --git a/collects/drracket/private/expanding-place.rkt b/collects/drracket/private/expanding-place.rkt index c311fcca59..3bd7682951 100644 --- a/collects/drracket/private/expanding-place.rkt +++ b/collects/drracket/private/expanding-place.rkt @@ -89,10 +89,9 @@ module-language-parallel-lock-client #:use-use-current-security-guard? #t) (log-info "expanding-place.rkt: 04 setting directories") - (when path - (let-values ([(base name dir?) (split-path path)]) - (current-directory base) - (current-load-relative-directory base))) + (let ([init-dir (get-init-dir path)]) + (current-directory init-dir) + (current-load-relative-directory init-dir)) (define sp (open-input-string program-as-string)) (port-count-lines! sp) (log-info "expanding-place.rkt: 05 installing security guard") diff --git a/collects/drracket/private/module-browser.rkt b/collects/drracket/private/module-browser.rkt index 8b7a87b52b..962eef5ca4 100644 --- a/collects/drracket/private/module-browser.rkt +++ b/collects/drracket/private/module-browser.rkt @@ -8,6 +8,7 @@ string-constants mrlib/graph "drsig.rkt" + "eval-helpers.rkt" racket/unit racket/async-channel setup/private/lib-roots @@ -855,11 +856,8 @@ (define init-dir (let* ([bx (box #f)] [filename (send (drracket:language:text/pos-text text/pos) get-filename bx)]) - (if (and filename - (not (unbox bx))) - (let-values ([(base name dir) (split-path filename)]) - base) - (current-directory)))) + (get-init-dir + (and (not (unbox bx)) filename)))) (define (init) (set! user-custodian (current-custodian)) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index c08f8a441b..6e57c51e3d 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -41,6 +41,7 @@ If the namespace does not, they are colored the unbound color. (for-syntax racket/base) (only-in ffi/unsafe register-finalizer) "../../syncheck-drracket-button.rkt" + "../../private/eval-helpers.rkt" "intf.rkt" "local-member-names.rkt" "colors.rkt" @@ -2018,13 +2019,11 @@ If the namespace does not, they are colored the unbound color. ;; sets the current-directory and current-load-relative-directory ;; based on the file saved in the definitions-text (define/private (set-directory definitions-text) - (let* ([tmp-b (box #f)] - [fn (send definitions-text get-filename tmp-b)]) - (unless (unbox tmp-b) - (when fn - (let-values ([(base name dir?) (split-path fn)]) - (current-directory base) - (current-load-relative-directory base)))))) + (define tmp-b (box #f)) + (define fn (send definitions-text get-filename tmp-b)) + (define dir (get-init-dir (and (not (unbox tmp-b)) fn))) + (current-directory dir) + (current-load-relative-directory dir)) ;; with-lock/edit-sequence : text (-> void) -> void ;; sets and restores some state of the definitions text diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index 7aeda8cd7d..d2ace36c1f 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class racket/place + "../../private/eval-helpers.rkt" "traversals.rkt" "local-member-names.rkt" "intf.rkt" @@ -64,10 +65,7 @@ (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)))) + (get-init-dir path))) (parameterize ([current-annotations obj]) (expanded-expression expanded) (expansion-completed)) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 683096e3a1..b1a3fb95bc 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -36,6 +36,7 @@ module browser threading seems wrong. "insert-large-letters.rkt" "get-defs.rkt" "local-member-names.rkt" + "eval-helpers.rkt" (prefix-in drracket:arrow: "../arrow.rkt") mred @@ -1200,12 +1201,10 @@ module browser threading seems wrong. (send (send frame get-current-tab) clear-execution-state))))) (define/public (get-directory) - (let ([filename (send defs get-filename)]) - (if (and (path? filename) - (file-exists? filename)) - (let-values ([(base _1 _2) (split-path (normalize-path filename))]) - base) - #f))) + (define bx (box #f)) + (define filename (send defs get-filename bx)) + (get-init-dir + (and (not (unbox bx)) filename))) (define/pubment (can-close?) (and (send defs can-close?) @@ -3370,13 +3369,11 @@ module browser threading seems wrong. ;; sets the current-directory and current-load-relative-directory ;; based on the file saved in the definitions-text (define/private (set-directory definitions-text) - (let* ([tmp-b (box #f)] - [fn (send definitions-text get-filename tmp-b)]) - (unless (unbox tmp-b) - (when fn - (let-values ([(base name dir?) (split-path fn)]) - (current-directory base) - (current-load-relative-directory base)))))) + (define tmp-b (box #f)) + (define fn (send definitions-text get-filename tmp-b)) + (define dir (get-init-dir (and (not (unbox tmp-b)) fn))) + (current-directory dir) + (current-load-relative-directory dir)) ; diff --git a/collects/tests/drracket/module-lang-test.rkt b/collects/tests/drracket/module-lang-test.rkt index f4151df669..e216bfbd5b 100644 --- a/collects/tests/drracket/module-lang-test.rkt +++ b/collects/tests/drracket/module-lang-test.rkt @@ -21,7 +21,9 @@ (provide #%module-begin [rename bug-datum #%datum])) (module module-lang-test-tmp4 racket/base (/ 888 2) - (provide (except-out (all-from-out racket/base) #%top-interaction)))) + (provide (except-out (all-from-out racket/base) #%top-interaction))) + (module module-lang-test-syn-error racket/base + (lambda))) (test @t{} #f @@ -370,6 +372,11 @@ (current-namespace (make-base-empty-namespace))} "(+ 1 2)" "3") +(test @t{#lang racket/base} + @t{(parameterize ([current-directory "/does/not/exists/well/it/better/not/anwyays"]) + (load @in-here{module-lang-test-syn-error.rkt}))} + ;; test to make sure that we don't get "exception raised by error display handler" + #rx"module-lang-test-syn-error.rkt:[0-9]+:[0-9]+: lambda: bad syntax in: \\(lambda\\)") (printf "starting drracket\n") (fire-up-drscheme-and-run-tests run-test) diff --git a/collects/tests/drracket/private/module-lang-test-utils.rkt b/collects/tests/drracket/private/module-lang-test-utils.rkt index e33534af7e..7f71e693d4 100644 --- a/collects/tests/drracket/private/module-lang-test-utils.rkt +++ b/collects/tests/drracket/private/module-lang-test-utils.rkt @@ -1,12 +1,12 @@ #lang racket/base (require "drracket-test-util.rkt" - mzlib/etc framework racket/string (for-syntax racket/base) racket/class) -(provide test t rx run-test in-here write-test-modules) +(provide test t rx run-test + in-here in-here/path write-test-modules) ;; utilities to use with scribble/reader (define t string-append) @@ -15,7 +15,7 @@ (define-struct test (definitions ; string interactions ; (union #f string) - result ; string + result ; (or/c string regexp) all? ; boolean (#t => compare all of the text between the 3rd and n-1-st line) error-ranges ; (or/c 'dont-test ; (-> (is-a?/c text) @@ -26,9 +26,8 @@ #:omit-define-syntaxes) -(define in-here - (let ([here (this-expression-source-directory)]) - (lambda (file) (format "~s" (path->string (build-path (find-system-path 'temp-dir) file)))))) +(define (in-here/path file) (path->string (build-path (find-system-path 'temp-dir) file))) +(define (in-here file) (format "~s" (in-here/path file))) (define tests '()) (define-syntax (test stx) diff --git a/collects/tests/drracket/repl-test.rkt b/collects/tests/drracket/repl-test.rkt index ca48777096..e22a15d651 100644 --- a/collects/tests/drracket/repl-test.rkt +++ b/collects/tests/drracket/repl-test.rkt @@ -1297,7 +1297,8 @@ This produces an ACK message (fprintf (current-error-port) "FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n" short-filename - program load-answer received-load)))))]) + program load-answer received-load) + (semaphore-wait (make-semaphore 0))))))]) (load-test tmp-load-short-filename (make-load-answer in-vector language-cust #f)) (when (file-exists? tmp-load3-filename) (delete-file tmp-load3-filename)) diff --git a/doc/release-notes/drracket/HISTORY.txt b/doc/release-notes/drracket/HISTORY.txt index 51f765e7fb..2cdba53592 100644 --- a/doc/release-notes/drracket/HISTORY.txt +++ b/doc/release-notes/drracket/HISTORY.txt @@ -1,13 +1,19 @@ - ------------------------------ Version 5.2.1 ------------------------------ + . The initial current-directory and current-load-relative-directory + for unsaved programs in DrRacket is now the user's home directory, + instead of whatever the current-directory was for the underlying + OS process. + . DrRacket no longer shows a stacktrace for syntax errors in the REPL. - . The preference that makes a single "(" keystroke insert "()" - (and similarly for [ { " and |) now only takes effect in Racket mode, - instead of taking effect in all of the modes, as it used to. + . The preference that makes a single "(" keystroke insert "()" (and + similarly for [ { " and |) now only takes effect in Racket mode, + instead of taking effect in all of the modes, as it used to. This + change is in service to a bugfix that makes the automatic opening + parentheses adjustment cooperate with the automatic balancing. ------------------------------ Version 5.2