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

fix `path->relative-string/setup'

Browse Source 
Need to make `path->relative-string/setup/pkg' have a better name
and be more accessible, though --- possibly replacing
`path->relative-string/setup'.
This commit is contained in:
Matthew Flatt 2013-06-22 06:28:25 -06:00
parent ede94761b3
commit b8591a5a98
5 changed files with 21 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-pkgs/racket-index/setup/scribble.rkt
View File

@ -210,7 +210,7 @@
(setup-printf
"removing"
"~a (documentation directory)"
(path->relative-string/setup p))
(path->relative-string/setup/pkg p))
(delete-directory/files p)))))
(define (can-build*? docs) (can-build? only-dirs docs))
@ -423,7 +423,7 @@
(unless one?
(setup-printf
"WARNING" "undefined tag in ~a:"
(path->relative-string/setup
(path->relative-string/setup/pkg
(doc-src-file (info-doc info))))
(set! one? #t))
(setup-printf #f " ~s" k)))])
@ -497,7 +497,7 @@
(if workerid (format "~a " workerid) "")
(if (info-rendered? i) "re-rendering" "rendering") )
"~a"
(path->relative-string/setup (doc-src-file (info-doc i)))))
(path->relative-string/setup/pkg (doc-src-file (info-doc i)))))
(define (update-info info response)
(match response
[#f (set-info-failed?! info #t)]
@ -851,7 +851,7 @@
"running")]
[else "skipping"]))
"~a"
(path->relative-string/setup (doc-src-file doc))))
(path->relative-string/setup/pkg (doc-src-file doc))))
(when force-out-of-date?
(for ([p (in-list info-out-files)])
@ -982,7 +982,7 @@
(if workerid (format "~a " workerid) "")
(if move? "moving" "syncing"))
"~a"
(path->relative-string/setup src-dir))
(path->relative-string/setup/pkg src-dir))
(when move?
(when (directory-exists? dest-dir)

2
pkgs/racket-pkgs/racket-test/tests/racket/setup.rktl
View File

@ -5,7 +5,7 @@
(require setup/path-to-relative)
(let ([missing "/some/inexistent/path"]
[collects (build-path (collection-path "racket") "foo.rkt")]
[collects (build-path (path-only (collection-file-path "main.rkt" "racket")) "foo.rkt")]
[relative "some/path"])
(define (test-both path/str expected-str [lib-expected expected-str])
(define str (if (string? path/str) path/str (path->string path/str)))

9
racket/lib/collects/setup/path-to-relative.rkt
View File

@ -7,7 +7,8 @@
(only-in planet/config [CACHE-DIR find-planet-dir]))
(provide make-path->relative-string
path->relative-string/library)
path->relative-string/library
path->relative-string/setup)
(define (make-path->relative-string
dirs [default (lambda (x) (if (path? x) (path->string x) x))])
@ -48,3 +49,9 @@
(list (cons find-collects-dir "<collects>/")
(cons find-user-collects-dir "<user-collects>/")
(cons find-planet-dir "<planet>/"))))
(define path->relative-string/setup
(make-path->relative-string
(list (cons find-collects-dir "")
(cons find-user-collects-dir "<user>/")
(cons find-planet-dir "<planet>/"))))

4
racket/lib/collects/setup/private/setup-relative.rkt
View File

@ -5,9 +5,9 @@
"../dirs.rkt"
"../path-to-relative.rkt")
(provide path->relative-string/setup)
(provide path->relative-string/setup/pkg)
(define path->relative-string/setup
(define path->relative-string/setup/pkg
(make-path->relative-string
(list (cons find-collects-dir "<collects>/")
(cons find-user-collects-dir "<user>/")

10
racket/lib/collects/setup/setup-unit.rkt
View File

@ -214,7 +214,7 @@
(error name-sym
"'name' result from collection ~e is not a string: ~e"
path x)))))
(define path-name (path->relative-string/setup path))
(define path-name (path->relative-string/setup/pkg path))
(when (info 'compile-subcollections (lambda () #f))
(setup-printf "WARNING"
"ignoring `compile-subcollections' entry in info ~a"
@ -635,7 +635,7 @@
(unless printed?
(set! printed? #t)
(setup-printf "deleting" "in ~a"
(path->relative-string/setup (cc-path cc)))))
(path->relative-string/setup/pkg (cc-path cc)))))
(for ([path paths])
(define full-path (build-path (cc-path cc) path))
(when (or (file-exists? full-path) (directory-exists? full-path))
@ -683,7 +683,7 @@
(define dep (build-path dir mode-dir (path-add-suffix name #".dep")))
(when (and (file-exists? dep) (file-exists? zo))
(set! did-something? #t)
(setup-printf "deleting" "~a" (path->relative-string/setup zo))
(setup-printf "deleting" "~a" (path->relative-string/setup/pkg zo))
(delete-file/record-dependency zo dependencies)
(delete-file/record-dependency dep dependencies))))
(when did-something? (loop dependencies)))
@ -832,7 +832,7 @@
(lambda (p where)
(set! gcs 2)
(setup-fprintf p #f " in ~a"
(path->relative-string/setup
(path->relative-string/setup/pkg
(path->complete-path where (cc-path cc)))))
(lambda ()
(define dir (cc-path cc))
@ -1047,7 +1047,7 @@
(define-values [base name dir?] (split-path info-path))
(make-directory* base)
(define p info-path)
(setup-printf "updating" "~a" (path->relative-string/setup p))
(setup-printf "updating" "~a" (path->relative-string/setup/pkg p))
(when (verbose)
(define ht0 (hash-ref ht-orig info-path))
(when ht0