From fd2554d6fc423798cc8c8cccd3950aa90ce275e4 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 17 Dec 2011 22:30:46 -0700 Subject: [PATCH] removed unstable/path (moved code back to single use in web-server) --- collects/unstable/path.rkt | 79 ----------------- collects/unstable/scribblings/path.scrbl | 43 ---------- collects/unstable/scribblings/unstable.scrbl | 1 - .../unstable/tests/test-docs-complete.rkt | 1 - collects/web-server/private/util.rkt | 85 ++++++++++++++++++- 5 files changed, 81 insertions(+), 128 deletions(-) delete mode 100644 collects/unstable/path.rkt delete mode 100644 collects/unstable/scribblings/path.scrbl diff --git a/collects/unstable/path.rkt b/collects/unstable/path.rkt deleted file mode 100644 index c7d489b4be..0000000000 --- a/collects/unstable/path.rkt +++ /dev/null @@ -1,79 +0,0 @@ -#lang racket/base -(require racket/contract/base - unstable/list - unstable/contract) - -; explode-path* : path? -> (listof path?) -(define (explode-path* p) - (let loop ([p p] [r null]) - (cond - [(eq? 'relative p) r] - [(not p) r] - [else - (let-values ([(base name dir?) (split-path p)]) - (loop base (list* name r)))]))) -;; Eli: We already have `explode-path', this looks like it's doing the -;; same thing, except a little less useful. - -; strip-prefix-ups : (listof path-piece?) -> (listof path-piece?) -(define (strip-prefix-ups l) - (define prefix? (box #t)) - (filter (lambda (p) - (if (unbox prefix?) - (if (eq? 'up p) - #f - (begin #t - (set-box! prefix? #f))) - #t)) - l)) -;; Eli: This is bad. If I understand it correctly, this is what this -;; *should* have been: -;; (define (strip-prefix-ups l) -;; (if (and (pair? l) (eq? 'up (car l))) (strip-prefix-ups (cdr l)) l)) -;; or even: -;; (define (strip-prefix-ups l) -;; (match l [(cons 'up l) (strip-prefix-ups l)] [_ l])) -;; except that the above version manages to combine ugly and -;; obfuscated code, redundant mutation, redundant code (why is it a -;; box? why is there a (begin #t ...)?), and being extra slow. Oh, -;; and if this wasn't enough, there's exactly one place in the web -;; server that uses it. - -; path-without-base : path? path? -> (listof path-piece?) -(define (path-without-base base path) - (define b (explode-path* base)) - (define p (explode-path* path)) - (if (list-prefix? b p) - (list-tail p (length b)) - (error 'path-without-base "~a is not a prefix of ~a" base path))) -;; Eli: see my comment on `list-prefix?' -- it would make this trivial. -;; Also, if you want to look for a useful utility to add, search the code for -;; `relativize', which is a popular thing that gets written multiple times -;; and would be nice to have as a library. (But there are some differences -;; between them, I think.) - -;; build-path-unless-absolute : path-string? path-string? -> path? -(define (build-path-unless-absolute base path) - (if (absolute-path? path) - (build-path path) - (build-path base path))) -;; Eli: This looks completely unnecessary. I find the code much easier to -;; understand than the long name. - -(define (directory-part path) - (let-values ([(base name must-be-dir) (split-path path)]) - (cond - [(eq? 'relative base) (current-directory)] - [(not base) (error 'directory-part "~a is a top-level directory" path)] - [(path? base) base]))) -;; Eli: There is now a `file-name-from-path', which suggests that the name for -;; this should be `directory-name-from-path', but perhaps a new name is -;; better for both. Also, I find it questionable to return the current -;; directory in the first case. - -(provide/contract - [explode-path* (path-string? . -> . (listof path-piece?))] - [path-without-base (path-string? path-string? . -> . (listof path-piece?))] - [strip-prefix-ups ((listof path-piece?) . -> . (listof path-piece?))] - [directory-part (path-string? . -> . path?)] - [build-path-unless-absolute (path-string? path-string? . -> . path?)]) diff --git a/collects/unstable/scribblings/path.scrbl b/collects/unstable/scribblings/path.scrbl deleted file mode 100644 index 25e339a1ee..0000000000 --- a/collects/unstable/scribblings/path.scrbl +++ /dev/null @@ -1,43 +0,0 @@ -#lang scribble/doc -@(require scribble/base - scribble/manual - "utils.rkt" - (for-label unstable/path - unstable/contract - racket/contract - racket/base)) - -@title[#:tag "path"]{Path} - -@defmodule[unstable/path] - -@unstable-header[] - -@defproc[(explode-path* [p path-string?]) - (listof path-piece?)]{ - Like @racket[normalize-path], but does not resolve symlinks. -} - -@defproc[(path-without-base [base path-string?] - [p path-string?]) - (listof path-piece?)]{ - Returns, as a list, the portion of @racket[p] after @racket[base], - assuming @racket[base] is a prefix of @racket[p]. -} - -@defproc[(directory-part [p path-string?]) - path?]{ - Returns the directory part of @racket[p], returning @racket[(current-directory)] - if it is relative. -} - -@defproc[(build-path-unless-absolute [base path-string?] - [p path-string?]) - path?]{ - Prepends @racket[base] to @racket[p], unless @racket[p] is absolute. -} - -@defproc[(strip-prefix-ups [p (listof path-piece?)]) - (listof path-piece?)]{ - Removes all the prefix @racket[".."]s from @racket[p]. -} diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 0cf3b6347f..3f2f9753fc 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -93,7 +93,6 @@ Keep documentation and tests up to date. @include-section["parameter-group.scrbl"] @include-section["match.scrbl"] @include-section["net.scrbl"] -@include-section["path.scrbl"] @include-section["port.scrbl"] @include-section["pretty.scrbl"] @include-section["require.scrbl"] diff --git a/collects/unstable/tests/test-docs-complete.rkt b/collects/unstable/tests/test-docs-complete.rkt index 54ec423c70..2c042dfe8c 100644 --- a/collects/unstable/tests/test-docs-complete.rkt +++ b/collects/unstable/tests/test-docs-complete.rkt @@ -9,7 +9,6 @@ (check-docs (quote unstable/prop-contract)) (check-docs (quote unstable/pretty)) (check-docs (quote unstable/port)) -(check-docs (quote unstable/path)) (check-docs (quote unstable/mutated-vars)) (check-docs (quote unstable/match)) (check-docs (quote unstable/markparam) #:skip #rx"^deserialize-info:") diff --git a/collects/web-server/private/util.rkt b/collects/web-server/private/util.rkt index 3ddd8ea2b7..392a3af883 100644 --- a/collects/web-server/private/util.rkt +++ b/collects/web-server/private/util.rkt @@ -1,8 +1,10 @@ #lang racket/base +(require racket/contract/base + unstable/list + unstable/contract) (require unstable/bytes unstable/contract unstable/list - unstable/path unstable/string unstable/net/url) (provide @@ -10,12 +12,10 @@ unstable/bytes unstable/contract unstable/list - unstable/path unstable/string unstable/net/url)) -(require racket/contract/base - (for-syntax racket/base)) +;; -- ;; network-error: symbol string . values -> void ;; throws a formatted exn:fail:network @@ -34,3 +34,80 @@ (provide/contract [network-error (->* [symbol? string?] [] #:rest list? void?)] [exn->string (-> any/c string?)]) + +;; -- + +; explode-path* : path? -> (listof path?) +(define (explode-path* p) + (let loop ([p p] [r null]) + (cond + [(eq? 'relative p) r] + [(not p) r] + [else + (let-values ([(base name dir?) (split-path p)]) + (loop base (list* name r)))]))) +;; Eli: We already have `explode-path', this looks like it's doing the +;; same thing, except a little less useful. + +; strip-prefix-ups : (listof path-piece?) -> (listof path-piece?) +(define (strip-prefix-ups l) + (define prefix? (box #t)) + (filter (lambda (p) + (if (unbox prefix?) + (if (eq? 'up p) + #f + (begin #t + (set-box! prefix? #f))) + #t)) + l)) +;; Eli: This is bad. If I understand it correctly, this is what this +;; *should* have been: +;; (define (strip-prefix-ups l) +;; (if (and (pair? l) (eq? 'up (car l))) (strip-prefix-ups (cdr l)) l)) +;; or even: +;; (define (strip-prefix-ups l) +;; (match l [(cons 'up l) (strip-prefix-ups l)] [_ l])) +;; except that the above version manages to combine ugly and +;; obfuscated code, redundant mutation, redundant code (why is it a +;; box? why is there a (begin #t ...)?), and being extra slow. Oh, +;; and if this wasn't enough, there's exactly one place in the web +;; server that uses it. + +; path-without-base : path? path? -> (listof path-piece?) +(define (path-without-base base path) + (define b (explode-path* base)) + (define p (explode-path* path)) + (if (list-prefix? b p) + (list-tail p (length b)) + (error 'path-without-base "~a is not a prefix of ~a" base path))) +;; Eli: see my comment on `list-prefix?' -- it would make this trivial. +;; Also, if you want to look for a useful utility to add, search the code for +;; `relativize', which is a popular thing that gets written multiple times +;; and would be nice to have as a library. (But there are some differences +;; between them, I think.) + +;; build-path-unless-absolute : path-string? path-string? -> path? +(define (build-path-unless-absolute base path) + (if (absolute-path? path) + (build-path path) + (build-path base path))) +;; Eli: This looks completely unnecessary. I find the code much easier to +;; understand than the long name. + +(define (directory-part path) + (let-values ([(base name must-be-dir) (split-path path)]) + (cond + [(eq? 'relative base) (current-directory)] + [(not base) (error 'directory-part "~a is a top-level directory" path)] + [(path? base) base]))) +;; Eli: There is now a `file-name-from-path', which suggests that the name for +;; this should be `directory-name-from-path', but perhaps a new name is +;; better for both. Also, I find it questionable to return the current +;; directory in the first case. + +(provide/contract + [explode-path* (path-string? . -> . (listof path-piece?))] + [path-without-base (path-string? path-string? . -> . (listof path-piece?))] + [strip-prefix-ups ((listof path-piece?) . -> . (listof path-piece?))] + [directory-part (path-string? . -> . path?)] + [build-path-unless-absolute (path-string? path-string? . -> . path?)])