diff --git a/pkgs/racket-doc/pkg/scribblings/strip.scrbl b/pkgs/racket-doc/pkg/scribblings/strip.scrbl index 5339385c40..a0069ae9bc 100644 --- a/pkgs/racket-doc/pkg/scribblings/strip.scrbl +++ b/pkgs/racket-doc/pkg/scribblings/strip.scrbl @@ -215,21 +215,23 @@ with the same file/directory omissions and updates as @command-ref{create}.} @defproc[(generate-stripped-directory [mode (or/c 'source 'binary 'binary-lib 'built)] - [src-dir (and/c path-string? directory-exists?)] - [dest-dir (and/c path-string? directory-exists?)]) + [src-dir path-string?] + [dest-dir path-string?]) void?]{ Copies @racket[src-dir] to @racket[dest-dir] with file/directory omissions and updates corresponding to the creation of a @tech{source package}, @tech{binary package}, @tech{binary library package}, or @tech{built package} as indicated -by @racket[mode].} Note, @racket[generate-stripped-directory] does not compile or render source files +by @racket[mode]. The given @racket[src-dir] and @racket[dest-dir] must both exist already. + +Note that @racket[generate-stripped-directory] does not compile or render source files found in the @racket[src-dir]. To perform precompilation or rendering before stripping the source directory, -use @exec{raco setup} or @exec{raco make}. +use @exec{raco setup} or @exec{raco make}.} @defproc[(check-strip-compatible [mode (or/c 'source 'binary 'binary-lib 'built)] [pkg-name string?] - [dir (and/c path-string? directory-exists?)] + [dir path-string?] [error (string? . -> . any)]) any]{ diff --git a/pkgs/racket-test/tests/pkg/tests-api.rkt b/pkgs/racket-test/tests/pkg/tests-api.rkt index acb96b8af8..f19e73a5cf 100644 --- a/pkgs/racket-test/tests/pkg/tests-api.rkt +++ b/pkgs/racket-test/tests/pkg/tests-api.rkt @@ -14,35 +14,37 @@ (define pkg-dest-path (build-path tmp-dir "pkg-strip")) (make-directory pkg-dest-path) + (define rx:does-not-exist #rx"directory does not exist") + ;; Giving path to nonexistent directory should raise a contract exception. - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (check-strip-compatible 'source "pkg-strip" "does not exist" error))) + (check-exn rx:does-not-exist (lambda () (check-strip-compatible 'source "pkg-strip" "does not exist" error))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (check-strip-compatible 'binary "pkg-strip" "does not exist" error))) + (check-exn rx:does-not-exist (lambda () (check-strip-compatible 'binary "pkg-strip" "does not exist" error))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (check-strip-compatible 'binary-lib "pkg-strip" "does not exist" error))) + (check-exn rx:does-not-exist (lambda () (check-strip-compatible 'binary-lib "pkg-strip" "does not exist" error))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (check-strip-compatible 'built "pkg-strip" "does not exist" error))) + (check-exn rx:does-not-exist (lambda () (check-strip-compatible 'built "pkg-strip" "does not exist" error))) ;; Path to existing directory should succeed. (check-not-exn (lambda () (check-strip-compatible 'source "pkg-strip" pkg-path error))) ;; Giving path to nonexistent src directory should raise a contract exception. - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'source 5 pkg-dest-path))) + (check-exn exn:fail:contract? (lambda () (generate-stripped-directory 'source 5 pkg-dest-path))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'binary "does not exist" pkg-dest-path))) + (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'binary "does not exist" pkg-dest-path))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'binary-lib "does not exist" pkg-dest-path))) + (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'binary-lib "does not exist" pkg-dest-path))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'built "does not exist" pkg-dest-path))) + (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'built "does not exist" pkg-dest-path))) ;; Giving path to nonexistent dest directory should raise a contract exception. - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'source pkg-path "does not exist"))) + (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'source pkg-path "does not exist"))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'binary pkg-path "does not exist"))) + (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'binary pkg-path "does not exist"))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'binary-lib pkg-path "does not exist"))) + (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'binary-lib pkg-path "does not exist"))) - (check-exn #rx"expected: \\(and/c path-string\\? directory-exists\\?\\)" (lambda () (generate-stripped-directory 'built pkg-path "does not exist"))) + (check-exn rx:does-not-exist (lambda () (generate-stripped-directory 'built pkg-path "does not exist"))) ;; Paths to existing src and dest directories should succeed. (check-not-exn (lambda () (generate-stripped-directory 'source pkg-path pkg-dest-path))) diff --git a/racket/collects/pkg/strip.rkt b/racket/collects/pkg/strip.rkt index dd9eb583eb..30584905e9 100644 --- a/racket/collects/pkg/strip.rkt +++ b/racket/collects/pkg/strip.rkt @@ -21,11 +21,9 @@ (define strip-binary-compile-info (make-parameter #t)) (define (check-strip-compatible mode pkg dir error) - (unless (and (path-string? dir) (directory-exists? dir)) - (raise-argument-error - 'check-strip-compatible - "(and/c path-string? directory-exists?)" - dir)) + (unless (path-string? dir) + (raise-argument-error 'check-strip-compatible "path-string?" dir)) + (check-directory-exists 'check-strip-compatible "" dir) (define i (get-info/full dir)) (define raw-status (and i @@ -64,17 +62,12 @@ (define (generate-stripped-directory mode dir dest-dir #:check-status? [check-status? #t]) - (unless (and (path-string? dir) (directory-exists? dir)) - (raise-argument-error - 'generate-stripped-directory - "(and/c path-string? directory-exists?)" - dir)) - - (unless (and (path-string? dest-dir) (directory-exists? dest-dir)) - (raise-argument-error - 'generate-stripped-directory - "(and/c path-string? directory-exists?)" - dest-dir)) + (unless (path-string? dir) + (raise-argument-error 'generate-stripped-directory "path-string?" dir)) + (unless (path-string? dest-dir) + (raise-argument-error 'generate-stripped-directory "path-string?" dest-dir)) + (check-directory-exists 'generate-stripped-directory "source " dir) + (check-directory-exists 'generate-stripped-directory "destination " dest-dir) (define drop-keep-ns (make-base-namespace)) (define (add-drop+keeps dir base drops keeps) @@ -487,3 +480,14 @@ (for ([f (in-list (directory-list dest-dir #:build? #t))]) (when (directory-exists? f) (create-info-as-needed mode f 'collection)))])) + +(define (check-directory-exists who which dir) + (unless (directory-exists? dir) + (raise (exn:fail:filesystem + (format (string-append + "~a: destination ~adirectory does not exist\n" + " path: ~a") + who + which + dir) + (current-continuation-marks)))))