collapse-module-path-index: support relative module path flattening
Unlike `collapse-module-path`, it makes sense for `collapse-module-path-index` to convert a relative module path index to a plain module path. In other words, `collapse-module-path-index` can convert a module path index to a module path.
This commit is contained in:
Matthew Flatt
parent
d74b0a6bf4
commit
7bee7bbadc
|
|
@ -16,7 +16,7 @@
|
|||
@defproc[(collapse-module-path [module-path-v module-path?]
|
||||
[rel-to-module-path-v (or/c module-path?
|
||||
(-> module-path?))])
|
||||
(or/c path? module-path?)]{
|
||||
module-path?]{
|
||||
|
||||
Returns a ``simplified'' module path by combining
|
||||
@racket[module-path-v] with @racket[rel-to-module-path-v], where the
|
||||
|
|
@ -31,8 +31,8 @@ The result can be a path if @racket[module-path-v] contains a path
|
|||
element that is needed for the result, or if
|
||||
@racket[rel-to-module-path-v] is a non-string path that is needed for
|
||||
the result. Similarly, the result can be @racket['submod] wrapping a
|
||||
path. Otherwise, the result is a module path in the sense of
|
||||
@racket[module-path?].
|
||||
path. Otherwise, the result is a module path (in the sense of
|
||||
@racket[module-path?]) that is not a plain filesystem path.
|
||||
|
||||
When the result is a @racket['lib] or @racket['planet] module path, it
|
||||
is normalized so that equivalent module paths are represented by
|
||||
|
|
@ -49,15 +49,25 @@ base.
|
|||
|
||||
}
|
||||
|
||||
@defproc[(collapse-module-path-index [module-path-index module-path-index?]
|
||||
[rel-to-module-path-v (or/c module-path?
|
||||
(-> module-path?))])
|
||||
(or/c path? module-path?)]{
|
||||
@defproc*[([(collapse-module-path-index [module-path-index module-path-index?]
|
||||
[rel-to-module-path-v (or/c module-path?
|
||||
(-> module-path?))])
|
||||
module-path?]
|
||||
[(collapse-module-path-index [module-path-index module-path-index?])
|
||||
module-path?])]{
|
||||
|
||||
Like @racket[collapse-module-path], but the input is a @techlink[#:doc
|
||||
refman]{module path index}; in this case, the
|
||||
@racket[rel-to-module-path-v] base is used where the module path index
|
||||
contains the ``self'' index.}
|
||||
Like @racket[collapse-module-path] when given two arguments, but the
|
||||
input is a @techlink[#:doc refman]{module path index}; in this case,
|
||||
the @racket[rel-to-module-path-v] base is used where the module path
|
||||
index contains the ``self'' index.
|
||||
|
||||
When given a single argument, @racket[collapse-module-path-index]
|
||||
returns a module path that is relative if the given module path index
|
||||
is relative. The resulting module path is not necessarily normalized.
|
||||
|
||||
@history[#:changed "6.1.1.8" @elem{Added the one-argument variant for
|
||||
collapsing a relative module path
|
||||
index.}]}
|
||||
|
||||
|
||||
@close-eval[evaluator]
|
||||
|
|
|
|||
124
pkgs/racket-test/tests/syntax/modcollapse.rkt
Normal file
124
pkgs/racket-test/tests/syntax/modcollapse.rkt
Normal file
|
|
@ -0,0 +1,124 @@
|
|||
#lang racket/base
|
||||
(require syntax/modcollapse)
|
||||
|
||||
(define (check got expected)
|
||||
(unless (equal? got expected)
|
||||
(error 'check "failed: ~s vs. ~s" got expected)))
|
||||
|
||||
(define here-dir (find-system-path 'temp-dir))
|
||||
(define here (build-path here-dir "dummy.rkt"))
|
||||
|
||||
(define self (module-path-index-join #f #f))
|
||||
|
||||
(define (check-collapse p expected [relative-expected expected])
|
||||
(check (collapse-module-path p here)
|
||||
expected)
|
||||
|
||||
(define i (module-path-index-join p self))
|
||||
(check (collapse-module-path-index i here)
|
||||
expected)
|
||||
(check (collapse-module-path-index i)
|
||||
relative-expected)
|
||||
|
||||
(define i2 (module-path-index-join p #f))
|
||||
(check (collapse-module-path-index i2 here)
|
||||
expected)
|
||||
(check (collapse-module-path-index i2)
|
||||
relative-expected))
|
||||
|
||||
(check-collapse "local.rkt"
|
||||
(build-path here-dir "local.rkt")
|
||||
"local.rkt")
|
||||
|
||||
(check-collapse (string->path "local.rkt")
|
||||
(build-path here-dir "local.rkt")
|
||||
(string->path "local.rkt"))
|
||||
|
||||
(check-collapse (path->complete-path "local.rkt")
|
||||
(path->complete-path "local.rkt"))
|
||||
|
||||
(check-collapse '(file "local.rkt")
|
||||
(build-path here-dir "local.rkt")
|
||||
'(file "local.rkt"))
|
||||
|
||||
(define (check-racket-lib p)
|
||||
(check-collapse p '(lib "racket/main.rkt")))
|
||||
(check-racket-lib 'racket)
|
||||
(check-racket-lib '(lib "racket"))
|
||||
(check-racket-lib '(lib "racket/main.rkt"))
|
||||
|
||||
(check-collapse '(planet foo/bar)
|
||||
'(planet "main.rkt" ("foo" "bar.plt")))
|
||||
|
||||
(check-collapse '(submod "." test)
|
||||
`(submod ,here test)
|
||||
'(submod "." test))
|
||||
|
||||
(define rel-rel (module-path-index-join
|
||||
"apple.rkt"
|
||||
(module-path-index-join
|
||||
"banana.rkt"
|
||||
self)))
|
||||
(check (collapse-module-path-index rel-rel)
|
||||
"apple.rkt")
|
||||
(check (collapse-module-path-index rel-rel
|
||||
here)
|
||||
(build-path here-dir "apple.rkt"))
|
||||
|
||||
(define rel-rel/p (module-path-index-join
|
||||
"apple.rkt"
|
||||
(module-path-index-join
|
||||
(string->path "banana.rkt")
|
||||
self)))
|
||||
(check (collapse-module-path-index rel-rel/p)
|
||||
(build-path 'same "apple.rkt"))
|
||||
(check (collapse-module-path-index rel-rel/p
|
||||
here)
|
||||
(build-path here-dir "apple.rkt"))
|
||||
|
||||
(define rel-rel/f (module-path-index-join
|
||||
"apple.rkt"
|
||||
(module-path-index-join
|
||||
'(file "banana.rkt")
|
||||
self)))
|
||||
(check (collapse-module-path-index rel-rel/f)
|
||||
(build-path 'same "apple.rkt"))
|
||||
(check (collapse-module-path-index rel-rel/f
|
||||
here)
|
||||
(build-path here-dir "apple.rkt"))
|
||||
|
||||
(define rel/f-rel (module-path-index-join
|
||||
'(file "apple.rkt")
|
||||
(module-path-index-join
|
||||
"banana.rkt"
|
||||
self)))
|
||||
(check (collapse-module-path-index rel/f-rel)
|
||||
(build-path 'same "apple.rkt"))
|
||||
(check (collapse-module-path-index rel/f-rel
|
||||
here)
|
||||
(build-path here-dir "apple.rkt"))
|
||||
|
||||
|
||||
(define submod-submod (module-path-index-join
|
||||
'(submod ".." test)
|
||||
(module-path-index-join
|
||||
'(submod "." inner)
|
||||
self)))
|
||||
(check (collapse-module-path-index submod-submod)
|
||||
'(submod "." inner ".." test))
|
||||
(check (collapse-module-path-index submod-submod
|
||||
here)
|
||||
`(submod ,here test))
|
||||
|
||||
(define submod-submod-foo (module-path-index-join
|
||||
'(submod ".." test)
|
||||
(module-path-index-join
|
||||
'(submod "." inner)
|
||||
(module-path-index-join
|
||||
"foo.rkt"
|
||||
self))))
|
||||
(check (collapse-module-path-index submod-submod-foo)
|
||||
'(submod "foo.rkt" inner ".." test))
|
||||
(check (collapse-module-path-index submod-submod-foo
|
||||
here)
|
||||
`(submod ,(build-path here-dir "foo.rkt") test))
|
||||
|
|
@ -30,6 +30,9 @@
|
|||
[collapse-module-path (module-path?
|
||||
rel-to-module-path-v/c
|
||||
. -> . simple-rel-to-module-path-v/c)]
|
||||
[collapse-module-path-index ((or/c symbol? module-path-index?)
|
||||
rel-to-module-path-v/c
|
||||
. -> . simple-rel-to-module-path-v/c)])
|
||||
[collapse-module-path-index (case->
|
||||
(module-path-index?
|
||||
. -> . module-path?)
|
||||
((or/c symbol? module-path-index?)
|
||||
rel-to-module-path-v/c
|
||||
. -> . simple-rel-to-module-path-v/c))])
|
||||
|
|
|
|||
|
|
@ -330,36 +330,141 @@ Use syntax/modcollapse instead.
|
|||
(normalize-submod `(submod ,(normalize-recur (cadr s)) ,@relto-submod ,@(cddr s)))])]
|
||||
[else #f])))
|
||||
|
||||
(define (collapse-module-path-index mpi relto-mp)
|
||||
(define (force-relto relto-mp)
|
||||
(if (procedure? relto-mp)
|
||||
(relto-mp)
|
||||
relto-mp))
|
||||
(let-values ([(path base) (module-path-index-split mpi)])
|
||||
(if path
|
||||
(collapse-module-path
|
||||
path
|
||||
(lambda ()
|
||||
(cond
|
||||
[(module-path-index? base)
|
||||
(collapse-module-path-index base relto-mp)]
|
||||
[(resolved-module-path? base)
|
||||
(let ([n (resolved-module-path-name base)])
|
||||
(if (pair? n)
|
||||
(if (path? (car n))
|
||||
(cons 'submod n)
|
||||
(list* 'submod `(quote ,(car n)) (cdr n)))
|
||||
(if (path? n)
|
||||
n
|
||||
`(quote ,n))))]
|
||||
[else (force-relto relto-mp)])))
|
||||
(let ([r (force-relto relto-mp)]
|
||||
[sm (module-path-index-submodule mpi)])
|
||||
(if sm
|
||||
(if (and (pair? r) (eq? (car r) 'submod))
|
||||
(append r sm)
|
||||
(list* 'submod r sm))
|
||||
r)))))
|
||||
(define collapse-module-path-index
|
||||
(case-lambda
|
||||
[(mpi)
|
||||
(collapse-module-path-index/relative mpi)]
|
||||
[(mpi relto-mp)
|
||||
(define (force-relto relto-mp)
|
||||
(if (procedure? relto-mp)
|
||||
(relto-mp)
|
||||
relto-mp))
|
||||
(let-values ([(path base) (module-path-index-split mpi)])
|
||||
(if path
|
||||
(collapse-module-path
|
||||
path
|
||||
(lambda ()
|
||||
(cond
|
||||
[(module-path-index? base)
|
||||
(collapse-module-path-index base relto-mp)]
|
||||
[(resolved-module-path? base)
|
||||
(let ([n (resolved-module-path-name base)])
|
||||
(if (pair? n)
|
||||
(if (path? (car n))
|
||||
(cons 'submod n)
|
||||
(list* 'submod `(quote ,(car n)) (cdr n)))
|
||||
(if (path? n)
|
||||
n
|
||||
`(quote ,n))))]
|
||||
[else (force-relto relto-mp)])))
|
||||
(let ([r (force-relto relto-mp)]
|
||||
[sm (module-path-index-submodule mpi)])
|
||||
(if sm
|
||||
(if (and (pair? r) (eq? (car r) 'submod))
|
||||
(append r sm)
|
||||
(list* 'submod r sm))
|
||||
r))))]))
|
||||
|
||||
(define (collapse-module-path-index/relative mpi)
|
||||
(define relative?
|
||||
(let loop ([mpi mpi])
|
||||
(define-values (path base) (module-path-index-split mpi))
|
||||
(let path-loop ([path path])
|
||||
(cond
|
||||
[(not path)
|
||||
(not base)]
|
||||
[(symbol? path)
|
||||
#f]
|
||||
[(and (pair? path)
|
||||
(or (eq? (car path) 'lib)
|
||||
(eq? (car path) 'planet)
|
||||
(eq? (car path) 'quote)))
|
||||
#f]
|
||||
[(and (pair? path)
|
||||
(eq? (car path) 'submod)
|
||||
(not (or (equal? (cadr path) ".")
|
||||
(equal? (cadr path) ".."))))
|
||||
(path-loop (cadr path))]
|
||||
[(and (pair? path)
|
||||
(eq? (car path) 'file)
|
||||
(complete-path? (cadr path)))
|
||||
#f]
|
||||
[(and (path? path)
|
||||
(complete-path? path))
|
||||
#f]
|
||||
[else
|
||||
(or (not base)
|
||||
(and (module-path-index? base)
|
||||
(loop base)))]))))
|
||||
|
||||
(if relative?
|
||||
(let loop ([mpi mpi])
|
||||
(define-values (s base) (if mpi
|
||||
(module-path-index-split mpi)
|
||||
(values #f #f)))
|
||||
(cond
|
||||
[(not s) #f]
|
||||
[else
|
||||
(define full-prev (loop base))
|
||||
(cond
|
||||
[(not full-prev)
|
||||
s]
|
||||
[else
|
||||
(define prev (if (and (pair? full-prev)
|
||||
(eq? 'submod (car full-prev)))
|
||||
(cadr full-prev)
|
||||
full-prev))
|
||||
(let s-loop ([s s])
|
||||
(cond
|
||||
[(string? s)
|
||||
;; Unix-style relative path string
|
||||
(cond
|
||||
[(string? prev)
|
||||
(define l (drop-right (explode-relpath-string s) 1))
|
||||
(if (null? l)
|
||||
s
|
||||
(string-join (append
|
||||
(for/list ([e (in-list l)])
|
||||
(case e
|
||||
[(same) "."]
|
||||
[(up) ".."]
|
||||
[else e]))
|
||||
(list s))
|
||||
"/"))]
|
||||
[(path? prev)
|
||||
(define-values (base name dir?) (split-path prev))
|
||||
(apply build-path (if (path? base) base 'same) (explode-relpath-string s))]
|
||||
[else ; `(file ,...)
|
||||
(define-values (base name dir?) (split-path (cadr prev)))
|
||||
(apply build-path (if (path? base) base 'same) (explode-relpath-string s))])]
|
||||
[(and (pair? s) (eq? 'file (car s)))
|
||||
(build-path
|
||||
(let-values ([(base name dir?)
|
||||
(split-path
|
||||
(cond
|
||||
[(string? prev) prev]
|
||||
[(path? prev) prev]
|
||||
[else ; `(file ,...)
|
||||
(cadr prev)]))])
|
||||
(if (path? base) base 'same))
|
||||
(cadr s))]
|
||||
[(eq? (car s) 'submod)
|
||||
(define (as-submod p sm)
|
||||
(if (and (pair? p) (eq? 'submod (car p)))
|
||||
(append p sm)
|
||||
`(submod ,p ,@sm)))
|
||||
(cond
|
||||
[(equal? (cadr s) ".")
|
||||
(as-submod full-prev (cddr s))]
|
||||
[(equal? (cadr s) "..")
|
||||
(as-submod full-prev (cdr s))]
|
||||
[else
|
||||
(as-submod (s-loop (cadr s)) (cddr s))])]))])]))
|
||||
(collapse-module-path-index
|
||||
mpi
|
||||
(lambda ()
|
||||
(error 'collapse-module-path-index
|
||||
"internal error: should not have needed a base path")))))
|
||||
|
||||
(provide collapse-module-path
|
||||
collapse-module-path-index)
|
||||
|
|
|
|||
|
|
@ -3928,6 +3928,7 @@ Scheme_Object *scheme_make_modidx(Scheme_Object *path,
|
|||
Scheme_Object *resolved)
|
||||
{
|
||||
Scheme_Modidx *modidx;
|
||||
Scheme_Object *subpath;
|
||||
|
||||
if (SCHEME_MODNAMEP(path))
|
||||
return path;
|
||||
|
|
@ -3945,13 +3946,16 @@ Scheme_Object *scheme_make_modidx(Scheme_Object *path,
|
|||
modidx->path = path;
|
||||
|
||||
/* base is needed only for relative-path strings,
|
||||
`file' forms, and `(submod "." ...)' forms: */
|
||||
if (SCHEME_CHAR_STRINGP(path)
|
||||
|| (SCHEME_PAIRP(path)
|
||||
&& SAME_OBJ(file_symbol, SCHEME_CAR(path)))
|
||||
|| (SCHEME_PAIRP(path)
|
||||
&& SAME_OBJ(submod_symbol, SCHEME_CAR(path))
|
||||
&& SCHEME_CHAR_STRINGP(SCHEME_CAR(SCHEME_CDR(path)))))
|
||||
`file' forms, path literals, and `(submod ...)' forms: */
|
||||
if (SCHEME_PAIRP(path)
|
||||
&& SAME_OBJ(submod_symbol, SCHEME_CAR(path)))
|
||||
subpath = SCHEME_CAR(SCHEME_CDR(path));
|
||||
else
|
||||
subpath = path;
|
||||
if (SCHEME_CHAR_STRINGP(subpath)
|
||||
|| (SCHEME_PAIRP(subpath)
|
||||
&& SAME_OBJ(file_symbol, SCHEME_CAR(subpath)))
|
||||
|| SCHEME_PATHP(subpath))
|
||||
modidx->base = base_modidx;
|
||||
else
|
||||
modidx->base = scheme_false;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user