improved contract error messages so that they now always have absolute module references in them for blame information
svn: r11511
This commit is contained in:
Robby Findler
parent
37d54316a2
commit
5596aff30f
|
|
@ -176,7 +176,7 @@
|
||||||
[formatted-contract-sexp
|
[formatted-contract-sexp
|
||||||
(let ([one-line (format "~s" contract-sexp)])
|
(let ([one-line (format "~s" contract-sexp)])
|
||||||
(if (< (string-length one-line) 30)
|
(if (< (string-length one-line) 30)
|
||||||
(string-append one-line " ")
|
one-line
|
||||||
(let ([sp (open-output-string)])
|
(let ([sp (open-output-string)])
|
||||||
(newline sp)
|
(newline sp)
|
||||||
(parameterize ([pretty-print-print-line print-contract-liner]
|
(parameterize ([pretty-print-print-line print-contract-liner]
|
||||||
|
|
@ -184,13 +184,24 @@
|
||||||
(pretty-print contract-sexp sp))
|
(pretty-print contract-sexp sp))
|
||||||
(get-output-string sp))))]
|
(get-output-string sp))))]
|
||||||
[specific-blame
|
[specific-blame
|
||||||
(let ([datum (syntax->datum src-info)])
|
(cond
|
||||||
(if (symbol? datum)
|
[(syntax? src-info)
|
||||||
(format "on ~a" datum)
|
(let ([datum (syntax->datum src-info)])
|
||||||
""))])
|
(if (symbol? datum)
|
||||||
|
(format " on ~a" datum)
|
||||||
|
""))]
|
||||||
|
[(pair? src-info)
|
||||||
|
(format " on ~a" (list-ref src-info 1))]
|
||||||
|
[else ""])])
|
||||||
(string-append (format "~a~a broke the contract ~a~a; "
|
(string-append (format "~a~a broke the contract ~a~a; "
|
||||||
blame-src
|
blame-src
|
||||||
to-blame
|
(cond
|
||||||
|
[(and (pair? to-blame)
|
||||||
|
(pair? (cdr to-blame))
|
||||||
|
(null? (cddr to-blame))
|
||||||
|
(equal? 'quote (car to-blame)))
|
||||||
|
(format "'~s" (cadr to-blame))]
|
||||||
|
[else (format "~s" to-blame)])
|
||||||
formatted-contract-sexp
|
formatted-contract-sexp
|
||||||
specific-blame)
|
specific-blame)
|
||||||
msg)))
|
msg)))
|
||||||
|
|
@ -207,14 +218,16 @@
|
||||||
contract-sexp
|
contract-sexp
|
||||||
(apply format fmt args)))
|
(apply format fmt args)))
|
||||||
(current-continuation-marks)
|
(current-continuation-marks)
|
||||||
(if src-info
|
(cond
|
||||||
(list (make-srcloc
|
[(syntax? src-info)
|
||||||
(syntax-source src-info)
|
(list (make-srcloc
|
||||||
(syntax-line src-info)
|
(syntax-source src-info)
|
||||||
(syntax-column src-info)
|
(syntax-line src-info)
|
||||||
(syntax-position src-info)
|
(syntax-column src-info)
|
||||||
(syntax-span src-info)))
|
(syntax-position src-info)
|
||||||
'())
|
(syntax-span src-info)))]
|
||||||
|
[(srcloc? src-info) (list src-info)]
|
||||||
|
[else '()])
|
||||||
blame)))
|
blame)))
|
||||||
|
|
||||||
(define print-contract-liner
|
(define print-contract-liner
|
||||||
|
|
@ -226,9 +239,10 @@
|
||||||
2)
|
2)
|
||||||
0)))))
|
0)))))
|
||||||
|
|
||||||
;; src-info-as-string : (union syntax #f) -> string
|
;; src-info-as-string : (union srcloc syntax #f) -> string
|
||||||
(define (src-info-as-string src-info)
|
(define (src-info-as-string src-info)
|
||||||
(if (syntax? src-info)
|
(if (or (syntax? src-info)
|
||||||
|
(srcloc? src-info))
|
||||||
(let ([src-loc-str (build-src-loc-string src-info)])
|
(let ([src-loc-str (build-src-loc-string src-info)])
|
||||||
(if src-loc-str
|
(if src-loc-str
|
||||||
(string-append src-loc-str ": ")
|
(string-append src-loc-str ": ")
|
||||||
|
|
|
||||||
|
|
@ -9,6 +9,7 @@
|
||||||
known-good-contract?)
|
known-good-contract?)
|
||||||
|
|
||||||
(require setup/main-collects
|
(require setup/main-collects
|
||||||
|
syntax/private/modcollapse-noctc
|
||||||
(for-template scheme/base))
|
(for-template scheme/base))
|
||||||
|
|
||||||
(define (add-name-prop name stx)
|
(define (add-name-prop name stx)
|
||||||
|
|
@ -85,18 +86,28 @@
|
||||||
(cdr r)))
|
(cdr r)))
|
||||||
bs)))))
|
bs)))))
|
||||||
|
|
||||||
;; build-src-loc-string : syntax -> (union #f string)
|
;; build-src-loc-string : (or/c srcloc syntax) -> (union #f string)
|
||||||
(define (build-src-loc-string stx)
|
(define (build-src-loc-string stx)
|
||||||
(let* ([source (source->name (syntax-source stx))]
|
(let-values ([(source line col pos)
|
||||||
[line (syntax-line stx)]
|
(if (syntax? stx)
|
||||||
[col (syntax-column stx)]
|
(values (source->name (syntax-source stx))
|
||||||
[pos (syntax-position stx)]
|
(syntax-line stx)
|
||||||
[location (cond [(and line col) (format "~a:~a" line col)]
|
(syntax-column stx)
|
||||||
[pos (format "~a" pos)]
|
(syntax-position stx))
|
||||||
[else #f])])
|
(values (source->name
|
||||||
(if (and source location)
|
(resolved-module-path-name
|
||||||
(string-append source ":" location)
|
(module-path-index-resolve
|
||||||
(or location source))))
|
(syntax-source-module
|
||||||
|
(srcloc-source stx)))))
|
||||||
|
(srcloc-line stx)
|
||||||
|
(srcloc-column stx)
|
||||||
|
(srcloc-position stx)))])
|
||||||
|
(let ([location (cond [(and line col) (format "~a:~a" line col)]
|
||||||
|
[pos (format "~a" pos)]
|
||||||
|
[else #f])])
|
||||||
|
(if (and source location)
|
||||||
|
(string-append source ":" location)
|
||||||
|
(or location source)))))
|
||||||
|
|
||||||
(define o (current-output-port))
|
(define o (current-output-port))
|
||||||
|
|
||||||
|
|
@ -104,25 +115,21 @@
|
||||||
;; constructs a symbol for use in the blame error messages
|
;; constructs a symbol for use in the blame error messages
|
||||||
;; when blaming the module where stx's occurs.
|
;; when blaming the module where stx's occurs.
|
||||||
(define (module-source-as-symbol stx)
|
(define (module-source-as-symbol stx)
|
||||||
(let ([src-module (syntax-source-module stx)])
|
(let ([mpi (syntax-source-module stx)])
|
||||||
(cond
|
(cond
|
||||||
[(symbol? src-module) src-module]
|
[(not mpi)
|
||||||
[(module-path-index? src-module)
|
'top-level]
|
||||||
(let-values ([(path base) (module-path-index-split src-module)])
|
[else
|
||||||
;; we dont' normalize here, because we don't
|
;; note: the directory passed to collapse-module-path-index should be irrelevant
|
||||||
;; want to assume that the collection paths
|
(let ([collapsed (collapse-module-path-index mpi (current-directory))])
|
||||||
;; are set or the file system can be accessed.
|
(cond
|
||||||
(if path
|
[(path? collapsed)
|
||||||
(string->symbol
|
(let ([resolved (resolved-module-path-name (module-path-index-resolve mpi))])
|
||||||
(if (and (pair? path)
|
(cond
|
||||||
(eq? (car path) 'quote)
|
[(symbol? resolved) resolved]
|
||||||
(pair? (cdr path))
|
[else `(file ,(path->string resolved))]))]
|
||||||
(null? (cddr path)))
|
[else
|
||||||
(format "'~s" (cadr path))
|
collapsed]))])))
|
||||||
(format "~s" path)))
|
|
||||||
'top-level))]
|
|
||||||
[else 'top-level])))
|
|
||||||
|
|
||||||
|
|
||||||
(define build-struct-names
|
(define build-struct-names
|
||||||
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx)
|
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx)
|
||||||
|
|
|
||||||
|
|
@ -89,6 +89,16 @@ improve method arity mismatch contract violation error messages?
|
||||||
(string->symbol neg-blame-str)
|
(string->symbol neg-blame-str)
|
||||||
(quote-syntax ident)))])))))
|
(quote-syntax ident)))])))))
|
||||||
|
|
||||||
|
;; id->contract-src-info : identifier -> syntax
|
||||||
|
;; constructs the last argument to the -contract, given an identifier
|
||||||
|
(define-for-syntax (id->contract-src-info id)
|
||||||
|
#`(list (make-srcloc #,id
|
||||||
|
#,(syntax-line id)
|
||||||
|
#,(syntax-column id)
|
||||||
|
#,(syntax-position id)
|
||||||
|
#,(syntax-span id))
|
||||||
|
#,(format "~s" (syntax->datum id))))
|
||||||
|
|
||||||
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
||||||
(make-set!-transformer
|
(make-set!-transformer
|
||||||
(let ([saved-id-table (make-hasheq)])
|
(let ([saved-id-table (make-hasheq)])
|
||||||
|
|
@ -106,11 +116,11 @@ improve method arity mismatch contract violation error messages?
|
||||||
[pos-module-source pos-module-source])
|
[pos-module-source pos-module-source])
|
||||||
(syntax-local-introduce
|
(syntax-local-introduce
|
||||||
(syntax-local-lift-expression
|
(syntax-local-lift-expression
|
||||||
#'(-contract contract-id
|
#`(-contract contract-id
|
||||||
id
|
id
|
||||||
pos-module-source
|
pos-module-source
|
||||||
(module-source-as-symbol #'name)
|
(module-source-as-symbol #'name)
|
||||||
(quote-syntax name))))))])
|
#,(id->contract-src-info #'id))))))])
|
||||||
(when key
|
(when key
|
||||||
(hash-set! saved-id-table key lifted-id))
|
(hash-set! saved-id-table key lifted-id))
|
||||||
;; Expand to a use of the lifted expression:
|
;; Expand to a use of the lifted expression:
|
||||||
|
|
@ -666,8 +676,8 @@ improve method arity mismatch contract violation error messages?
|
||||||
(provide (rename-out [id-rename external-name]))))])
|
(provide (rename-out [id-rename external-name]))))])
|
||||||
|
|
||||||
(syntax-local-lift-module-end-declaration
|
(syntax-local-lift-module-end-declaration
|
||||||
#'(begin
|
#`(begin
|
||||||
(-contract contract-id id pos-module-source 'ignored #'id)
|
(-contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id))
|
||||||
(void)))
|
(void)))
|
||||||
|
|
||||||
(syntax (code id-rename)))))]))
|
(syntax (code id-rename)))))]))
|
||||||
|
|
@ -733,37 +743,30 @@ improve method arity mismatch contract violation error messages?
|
||||||
(define-syntax (-contract stx)
|
(define-syntax (-contract stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ a-contract to-check pos-blame-e neg-blame-e)
|
[(_ a-contract to-check pos-blame-e neg-blame-e)
|
||||||
(with-syntax ([src-loc (syntax/loc stx here)])
|
(let ([s (syntax/loc stx here)])
|
||||||
(syntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))]
|
(contract/proc a-contract to-check pos-blame-e neg-blame-e
|
||||||
|
(list (make-srcloc (quote-syntax #,s)
|
||||||
|
#,(syntax-line s)
|
||||||
|
#,(syntax-column s)
|
||||||
|
#,(syntax-position s)
|
||||||
|
#,(syntax-span s))
|
||||||
|
#f))))]
|
||||||
[(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
|
[(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(begin
|
(begin
|
||||||
(contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))]))
|
(contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))]))
|
||||||
|
|
||||||
(define (contract/proc a-contract-raw name pos-blame neg-blame src-info)
|
(define (contract/proc a-contract-raw name pos-blame neg-blame src-info)
|
||||||
(unless (or (contract? a-contract-raw)
|
(let ([a-contract (coerce-contract 'contract a-contract-raw)])
|
||||||
(and (procedure? a-contract-raw)
|
|
||||||
(procedure-arity-includes? a-contract-raw 1)))
|
(unless (or (and (list? src-info)
|
||||||
(error 'contract "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e ~e"
|
(= 2 (length src-info))
|
||||||
a-contract-raw
|
(srcloc? (list-ref src-info 0))
|
||||||
name
|
(or (string? (list-ref src-info 1))
|
||||||
pos-blame
|
(not (list-ref src-info 1))))
|
||||||
neg-blame
|
(syntax? src-info))
|
||||||
src-info))
|
(error 'contract "expected syntax or a list of two elements (srcloc and string or #f) as last argument, given: ~e, other args ~e ~e ~e ~e"
|
||||||
(let ([a-contract (if (contract? a-contract-raw)
|
|
||||||
a-contract-raw
|
|
||||||
(flat-contract a-contract-raw))])
|
|
||||||
(unless (and (symbol? neg-blame)
|
|
||||||
(symbol? pos-blame))
|
|
||||||
(error 'contract
|
|
||||||
"expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e"
|
|
||||||
neg-blame pos-blame
|
|
||||||
a-contract-raw
|
|
||||||
name
|
|
||||||
src-info))
|
|
||||||
(unless (syntax? src-info)
|
|
||||||
(error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e"
|
|
||||||
src-info
|
src-info
|
||||||
neg-blame
|
neg-blame
|
||||||
pos-blame
|
pos-blame
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,6 @@
|
||||||
#lang scribble/doc
|
#lang scribble/doc
|
||||||
@(require "mz.ss")
|
@(require "mz.ss")
|
||||||
|
@(require (for-label syntax/modcollapse))
|
||||||
|
|
||||||
@title[#:tag "contracts" #:style 'toc]{Contracts}
|
@title[#:tag "contracts" #:style 'toc]{Contracts}
|
||||||
|
|
||||||
|
|
@ -662,7 +663,7 @@ that definition.}
|
||||||
positive-blame-expr negative-blame-expr)
|
positive-blame-expr negative-blame-expr)
|
||||||
(contract contract-expr to-protect-expr
|
(contract contract-expr to-protect-expr
|
||||||
positive-blame-expr negative-blame-expr
|
positive-blame-expr negative-blame-expr
|
||||||
contract-source-expr)]]{
|
contract-source-info)]]{
|
||||||
|
|
||||||
The primitive mechanism for attaching a contract to a value. The
|
The primitive mechanism for attaching a contract to a value. The
|
||||||
purpose of @scheme[contract] is as a target for the expansion of some
|
purpose of @scheme[contract] is as a target for the expansion of some
|
||||||
|
|
@ -680,12 +681,31 @@ The values of @scheme[positive-blame-expr] and
|
||||||
blame for positive and negative positions of the contract specified by
|
blame for positive and negative positions of the contract specified by
|
||||||
@scheme[contract-expr].
|
@scheme[contract-expr].
|
||||||
|
|
||||||
If specified, @scheme[contract-source-expr], indicates where the
|
If specified, @scheme[contract-source-info], indicates where the
|
||||||
contract was assumed. Its value must be a syntax object specifying the
|
contract was assumed. Its value must be a either:
|
||||||
|
@itemize{
|
||||||
|
@item{a list of two elements: @scheme[srcloc] struct and
|
||||||
|
either a string or @scheme[#f]. The srcloc struct inidates
|
||||||
|
where the contract was assumed. Its @tt{source} field
|
||||||
|
should be a syntax object, and @scheme[module-path-index-resolve]
|
||||||
|
is called on it to extract the path of syntax object.
|
||||||
|
|
||||||
|
If the second element of
|
||||||
|
the list is not @scheme[#f], it is used as the name of the
|
||||||
|
identifier whose contract was assumed.}
|
||||||
|
|
||||||
|
@item{a syntax object specifying the
|
||||||
source location of the location where the contract was assumed. If the
|
source location of the location where the contract was assumed. If the
|
||||||
syntax object wraps a symbol, the symbol is used as the name of the
|
syntax object wraps a symbol, the symbol is used as the name of the
|
||||||
primitive whose contract was assumed. If absent, it defaults to the
|
primitive whose contract was assumed.}
|
||||||
source location of the @scheme[contract] expression.}
|
}
|
||||||
|
|
||||||
|
If absent, it defaults to the source location of the
|
||||||
|
@scheme[contract] expression with no identifying name.
|
||||||
|
|
||||||
|
The second form above is not recommended, because mzscheme strips
|
||||||
|
source location information from compiled files.
|
||||||
|
}
|
||||||
|
|
||||||
@; ------------------------------------------------------------------------
|
@; ------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
@ -967,20 +987,30 @@ name @scheme[sexp-name] when signaling a contract violation.}
|
||||||
|
|
||||||
@defparam[contract-violation->string
|
@defparam[contract-violation->string
|
||||||
proc
|
proc
|
||||||
(any/c any/c symbol? symbol? any/c string? . -> . string?)]{
|
(-> any/c any/c any/c any/c string? string?)]{
|
||||||
|
|
||||||
|
|
||||||
This is a parameter that is used when constructing a
|
This is a parameter that is used when constructing a
|
||||||
contract violation error. Its value is procedure that
|
contract violation error. Its value is procedure that
|
||||||
accepts six arguments: the value that the contract applies
|
accepts five arguments:
|
||||||
to, a syntax object representing the source location where
|
@itemize{
|
||||||
the contract was established, the names of the two parties
|
@item{the value that the contract applies to,}
|
||||||
to the contract (as symbols) where the first one is the
|
@item{a syntax object representing the source location where
|
||||||
guilty one, an sexpression representing the contract, and a
|
the contract was established, }
|
||||||
message indicating the kind of violation. The procedure then
|
@item{the name of the party that violated the contract, }
|
||||||
|
@item{an sexpression representing the contract, and }
|
||||||
|
@item{a message indicating the kind of violation.
|
||||||
|
}}
|
||||||
|
The procedure then
|
||||||
returns a string that is put into the contract error
|
returns a string that is put into the contract error
|
||||||
message. Note that the value is often already included in
|
message. Note that the value is often already included in
|
||||||
the message that indicates the violation.}
|
the message that indicates the violation.
|
||||||
|
|
||||||
|
If the contract was establised via
|
||||||
|
@scheme[provide/contract], the names of the party to the
|
||||||
|
contract will be sexpression versions of the module paths
|
||||||
|
(as returned by @scheme[collapse-module-path]).
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
@defform[(recursive-contract contract-expr)]{
|
@defform[(recursive-contract contract-expr)]{
|
||||||
|
|
|
||||||
|
|
@ -1,286 +1,26 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
(module modcollapse mzscheme
|
(require scheme/contract
|
||||||
(require (only mzlib/list filter)
|
"private/modcollapse-noctc.ss")
|
||||||
scheme/string
|
|
||||||
scheme/list
|
|
||||||
mzlib/contract
|
|
||||||
(only scheme/base regexp-split)
|
|
||||||
"private/modhelp.ss")
|
|
||||||
|
|
||||||
(define (collapse-module-path s relto-mp)
|
(define simple-rel-to-module-path-v/c
|
||||||
;; relto-mp should be a path, '(lib relative-path collection) or symbol,
|
(or/c (and/c module-path?
|
||||||
;; or '(file path) or a thunk that produces one of those
|
(or/c
|
||||||
|
symbol?
|
||||||
|
(cons/c (symbols 'lib) any/c)
|
||||||
|
(cons/c (symbols 'file) any/c)
|
||||||
|
(cons/c (symbols 'planet) any/c)
|
||||||
|
(cons/c (symbols 'quote) any/c)))
|
||||||
|
path?))
|
||||||
|
|
||||||
;; Used for 'lib paths, so it's always Unix-style
|
(define rel-to-module-path-v/c
|
||||||
(define (attach-to-relative-path-string elements relto)
|
(or/c simple-rel-to-module-path-v/c
|
||||||
(let ([elem-str
|
path?
|
||||||
(substring
|
(-> simple-rel-to-module-path-v/c)))
|
||||||
(apply string-append
|
|
||||||
(map (lambda (i)
|
|
||||||
(string-append
|
|
||||||
"/"
|
|
||||||
(cond [(bytes? i) (bytes->string/locale i)]
|
|
||||||
[(path? i) (path->string i)]
|
|
||||||
[(eq? i 'up) ".."]
|
|
||||||
[else i])))
|
|
||||||
(filter (lambda (x) (not (eq? x 'same)))
|
|
||||||
elements)))
|
|
||||||
1)])
|
|
||||||
(if (or (regexp-match #rx"^[.]/+[^/]*" relto)
|
|
||||||
(not (regexp-match #rx"/" relto)))
|
|
||||||
elem-str
|
|
||||||
(let ([m (regexp-match #rx"^(.*/)/*[^/]*$" relto)])
|
|
||||||
(string-append (cadr m) elem-str)))))
|
|
||||||
|
|
||||||
(define (simpler-relpath path)
|
(provide/contract
|
||||||
(let loop ([s (regexp-replace* #px"(?<![.])[.]/" path "")])
|
[collapse-module-path ((or/c module-path? path?) rel-to-module-path-v/c
|
||||||
(let ([s2 (regexp-replace #rx"([^/.]*)/[.][.]/" s "")])
|
. -> . simple-rel-to-module-path-v/c)]
|
||||||
(if (equal? s s2)
|
[collapse-module-path-index ((or/c symbol? module-path-index?)
|
||||||
s
|
rel-to-module-path-v/c
|
||||||
(loop s2)))))
|
. -> . simple-rel-to-module-path-v/c)])
|
||||||
|
|
||||||
(define (add-main s)
|
|
||||||
(if (regexp-match #rx"[.][^/]*$" s)
|
|
||||||
s
|
|
||||||
(string-append s "/main.ss")))
|
|
||||||
|
|
||||||
(define (combine-relative-elements elements)
|
|
||||||
|
|
||||||
(define (extract-base relto)
|
|
||||||
(let-values ([(base n d?) (split-path relto)])
|
|
||||||
(if (eq? base 'relative)
|
|
||||||
'same
|
|
||||||
(if (not base)
|
|
||||||
relto ; strange case: relto is a root directory
|
|
||||||
base))))
|
|
||||||
|
|
||||||
;; Used for 'file paths, so it's platform specific:
|
|
||||||
(define (attach-to-relative-path relto)
|
|
||||||
(apply build-path
|
|
||||||
(extract-base relto)
|
|
||||||
(map (lambda (i) (if (bytes? i) (bytes->path i) i))
|
|
||||||
elements)))
|
|
||||||
|
|
||||||
(when (procedure? relto-mp) (set! relto-mp (relto-mp)))
|
|
||||||
(when (symbol? relto-mp) (set! relto-mp `(lib ,(symbol->string relto-mp))))
|
|
||||||
(cond
|
|
||||||
[(or (path? relto-mp) (and (string? relto-mp) (ormap path? elements)))
|
|
||||||
(apply build-path
|
|
||||||
(extract-base relto-mp)
|
|
||||||
(map (lambda (x) (if (bytes? x) (bytes->path x) x))
|
|
||||||
elements))]
|
|
||||||
[(string? relto-mp)
|
|
||||||
(bytes->string/locale
|
|
||||||
(apply
|
|
||||||
bytes-append
|
|
||||||
(cond [(regexp-match #rx#"^(.*)/[^/]*$"
|
|
||||||
(string->bytes/locale relto-mp))
|
|
||||||
=> cadr]
|
|
||||||
[else #"."])
|
|
||||||
(map (lambda (e)
|
|
||||||
(cond [(eq? e 'same) #"/."]
|
|
||||||
[(eq? e 'up) #"/.."]
|
|
||||||
[else (bytes-append
|
|
||||||
#"/" (if (path? e) (path->bytes e) e))]))
|
|
||||||
elements)))]
|
|
||||||
[(eq? (car relto-mp) 'file)
|
|
||||||
(let ([path ((if (ormap path? elements) values path->string)
|
|
||||||
(attach-to-relative-path (cadr relto-mp)))])
|
|
||||||
(if (path? path) path `(file ,path)))]
|
|
||||||
[(eq? (car relto-mp) 'lib)
|
|
||||||
(let ([relto-mp (if (null? (cddr relto-mp))
|
|
||||||
;; old style => add 'mzlib
|
|
||||||
;; new style => add main.ss or split
|
|
||||||
(let ([m (regexp-match-positions #rx"[/]" (cadr relto-mp))])
|
|
||||||
(if m
|
|
||||||
;; new style: split
|
|
||||||
`(lib ,(substring (cadr relto-mp) (cdar m))
|
|
||||||
,(substring (cadr relto-mp) 0 (caar m)))
|
|
||||||
(if (regexp-match? #rx"[.]" (cadr relto-mp))
|
|
||||||
;; old style:
|
|
||||||
`(lib ,(cadr relto-mp) "mzlib")
|
|
||||||
;; new style, add "main.ss":
|
|
||||||
`(lib "main.ss" ,(cadr relto-mp)))))
|
|
||||||
;; already has at least two parts:
|
|
||||||
relto-mp)])
|
|
||||||
(let ([path (attach-to-relative-path-string
|
|
||||||
elements (apply string-append
|
|
||||||
(append
|
|
||||||
(map (lambda (s)
|
|
||||||
(string-append s "/"))
|
|
||||||
(cddr relto-mp))
|
|
||||||
(list (cadr relto-mp)))))])
|
|
||||||
(let ([simpler (simpler-relpath path)])
|
|
||||||
(let ([m (regexp-match #rx"^(.*)/([^/]*)$" simpler)])
|
|
||||||
(if m
|
|
||||||
(normalize-lib `(lib ,(caddr m) ,(cadr m)))
|
|
||||||
(error 'combine-relative-elements
|
|
||||||
"relative path escapes collection: ~s relative to ~s"
|
|
||||||
elements relto-mp))))))]
|
|
||||||
[(eq? (car relto-mp) 'planet)
|
|
||||||
(let ([relto-mp
|
|
||||||
;; make sure relto-mp is in long form:
|
|
||||||
(if (null? (cddr relto-mp))
|
|
||||||
(normalize-planet relto-mp)
|
|
||||||
relto-mp)])
|
|
||||||
(let ([pathstr (simpler-relpath
|
|
||||||
(attach-to-relative-path-string
|
|
||||||
elements
|
|
||||||
(apply string-append
|
|
||||||
(append
|
|
||||||
(map (lambda (s)
|
|
||||||
(string-append s "/"))
|
|
||||||
(cdddr relto-mp))
|
|
||||||
(list (cadr relto-mp))))))])
|
|
||||||
(normalize-planet `(planet ,pathstr ,(caddr relto-mp)))))]
|
|
||||||
[else (error 'combine-relative-elements
|
|
||||||
"don't know how to deal with: ~s" relto-mp)]))
|
|
||||||
|
|
||||||
(define (normalize-lib s)
|
|
||||||
(if (null? (cddr s))
|
|
||||||
;; single-string version:
|
|
||||||
(let ([e (cadr s)])
|
|
||||||
(cond
|
|
||||||
[(regexp-match? #rx"[.]" e)
|
|
||||||
;; It has a suffix:
|
|
||||||
(if (regexp-match? #rx"/" e)
|
|
||||||
;; It has a path, so it's fine:
|
|
||||||
s
|
|
||||||
;; No path, so add "mzlib/":
|
|
||||||
`(lib ,(string-append "mzlib/" e)))]
|
|
||||||
[(regexp-match? #rx"/" e)
|
|
||||||
;; It has a separator, so add a suffix:
|
|
||||||
`(lib ,(string-append e ".ss"))]
|
|
||||||
[else
|
|
||||||
;; No separator or suffix, so add "/main.ss":
|
|
||||||
`(lib ,(string-append e "/main.ss"))]))
|
|
||||||
;; multi-string version:
|
|
||||||
(if (regexp-match? #rx"[.]" (cadr s))
|
|
||||||
;; there's a suffix, so we can collapse to a single string:
|
|
||||||
`(lib ,(string-join (append (cddr s)
|
|
||||||
(list (cadr s)))
|
|
||||||
"/"))
|
|
||||||
;; No suffix, so we must keep the old style:
|
|
||||||
s)))
|
|
||||||
|
|
||||||
(define (normalize-planet s)
|
|
||||||
(cond
|
|
||||||
[(symbol? (cadr s))
|
|
||||||
;; normalize via string form:
|
|
||||||
(normalize-planet `(planet ,(symbol->string (cadr s))))]
|
|
||||||
[(null? (cddr s))
|
|
||||||
;; normalize to long form:
|
|
||||||
(let* ([strs (regexp-split #rx"/" (cadr s))])
|
|
||||||
(let ([owner (car strs)]
|
|
||||||
[pkg+vers (regexp-split #rx":" (cadr strs))]
|
|
||||||
[path (cddr strs)])
|
|
||||||
`(planet ,(if (null? path)
|
|
||||||
"main.ss"
|
|
||||||
(let ([str (car (last-pair path))])
|
|
||||||
(if (regexp-match? #rx"[.]" str)
|
|
||||||
str
|
|
||||||
(string-append str ".ss"))))
|
|
||||||
(,owner
|
|
||||||
,(string-append (car pkg+vers) ".plt")
|
|
||||||
,@(if (null? (cdr pkg+vers))
|
|
||||||
null
|
|
||||||
`(,(string->number (cadr pkg+vers))
|
|
||||||
. ,(if (null? (cddr pkg+vers))
|
|
||||||
null
|
|
||||||
(list
|
|
||||||
(let ([vers (caddr pkg+vers)])
|
|
||||||
(cond
|
|
||||||
[(regexp-match? #rx"<=" vers)
|
|
||||||
`(- ,(string->number (substring vers 2)))]
|
|
||||||
[(regexp-match? #rx">=" vers)
|
|
||||||
(string->number (substring vers 2))]
|
|
||||||
[(regexp-match? #rx"=" vers)
|
|
||||||
`(= ,(string->number (substring vers 1)))]
|
|
||||||
[(regexp-match #rx"(.*)-(.*)" vers)
|
|
||||||
=> (lambda (m)
|
|
||||||
`(,(string->number (cadr m))
|
|
||||||
,(string->number (caddr m))))]
|
|
||||||
[(string->number vers)
|
|
||||||
=> (lambda (n) n)]
|
|
||||||
[else (error 'collapse-module-path
|
|
||||||
"confused when normalizing planet path: ~e"
|
|
||||||
s)])))))))
|
|
||||||
,@(if (null? path)
|
|
||||||
null
|
|
||||||
(reverse (cdr (reverse path)))))))]
|
|
||||||
[else
|
|
||||||
;; Long form is the normal form, but see if we need to split up the
|
|
||||||
;; path elements:
|
|
||||||
(let ([base (cadr s)]
|
|
||||||
[rest (cdddr s)]
|
|
||||||
[split? (lambda (s)
|
|
||||||
(regexp-match? #rx"/" s))])
|
|
||||||
(if (or (split? base)
|
|
||||||
(ormap split? rest))
|
|
||||||
;; need to split some paths:
|
|
||||||
(let ([split (lambda (s)
|
|
||||||
(regexp-split #rx"/" s))])
|
|
||||||
(let ([bases (split base)]
|
|
||||||
[rests (map split rest)])
|
|
||||||
(list* (car s)
|
|
||||||
(last bases)
|
|
||||||
(caddr s)
|
|
||||||
(append
|
|
||||||
(apply append rests)
|
|
||||||
(drop-right bases 1)))))
|
|
||||||
;; already in normal form:
|
|
||||||
s))]))
|
|
||||||
|
|
||||||
(cond [(string? s)
|
|
||||||
;; Parse Unix-style relative path string
|
|
||||||
(combine-relative-elements (explode-relpath-string s))]
|
|
||||||
[(symbol? s)
|
|
||||||
;; Convert to `lib' form:
|
|
||||||
(normalize-lib `(lib ,(symbol->string s)))]
|
|
||||||
[(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
|
|
||||||
#f]
|
|
||||||
[(or (path? s) (eq? (car s) 'file))
|
|
||||||
(let ([p (if (path? s) s (cadr s))])
|
|
||||||
(if (absolute-path? p)
|
|
||||||
s
|
|
||||||
(let loop ([p p] [elements null])
|
|
||||||
(let-values ([(base name dir?) (split-path p)])
|
|
||||||
(cond [(eq? base 'relative)
|
|
||||||
(combine-relative-elements (cons name elements))]
|
|
||||||
[else (loop base (cons name elements))])))))]
|
|
||||||
[(eq? (car s) 'lib) (normalize-lib s)]
|
|
||||||
[(eq? (car s) 'planet) (normalize-planet s)]
|
|
||||||
[(eq? (car s) 'quote) s]
|
|
||||||
[else #f]))
|
|
||||||
|
|
||||||
(define (collapse-module-path-index mpi relto-mp)
|
|
||||||
(let-values ([(path base) (module-path-index-split mpi)])
|
|
||||||
(if path
|
|
||||||
(collapse-module-path
|
|
||||||
path
|
|
||||||
(if base
|
|
||||||
(collapse-module-path-index base relto-mp)
|
|
||||||
relto-mp))
|
|
||||||
relto-mp)))
|
|
||||||
|
|
||||||
(define simple-rel-to-module-path-v/c
|
|
||||||
(or/c (and/c module-path?
|
|
||||||
(or/c
|
|
||||||
symbol?
|
|
||||||
(cons/c (symbols 'lib) any/c)
|
|
||||||
(cons/c (symbols 'file) any/c)
|
|
||||||
(cons/c (symbols 'planet) any/c)
|
|
||||||
(cons/c (symbols 'quote) any/c)))
|
|
||||||
path?))
|
|
||||||
|
|
||||||
(define rel-to-module-path-v/c
|
|
||||||
(or/c simple-rel-to-module-path-v/c
|
|
||||||
path?
|
|
||||||
(-> simple-rel-to-module-path-v/c)))
|
|
||||||
|
|
||||||
(provide/contract
|
|
||||||
[collapse-module-path ((or/c module-path? 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)]))
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
|
|
||||||
(module modresolve mzscheme
|
(module modresolve mzscheme
|
||||||
(require mzlib/list
|
(require mzlib/list
|
||||||
mzlib/contract
|
|
||||||
"private/modhelp.ss")
|
"private/modhelp.ss")
|
||||||
|
|
||||||
(define (force-relto relto dir?)
|
(define (force-relto relto dir?)
|
||||||
|
|
@ -66,12 +65,16 @@
|
||||||
[relto relto]
|
[relto relto]
|
||||||
[else #f]))
|
[else #f]))
|
||||||
|
|
||||||
(define rel-to-path-string/thunk/#f
|
(provide resolve-module-path-index
|
||||||
(or/c path-string? (-> path-string?) false/c))
|
resolve-module-path)
|
||||||
|
#;
|
||||||
|
(begin
|
||||||
|
(define rel-to-path-string/thunk/#f
|
||||||
|
(or/c path-string? (-> path-string?) false/c))
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[resolve-module-path (module-path-v? rel-to-path-string/thunk/#f
|
[resolve-module-path (module-path-v? rel-to-path-string/thunk/#f
|
||||||
. -> . (or/c path? symbol?))]
|
. -> . (or/c path? symbol?))]
|
||||||
[resolve-module-path-index ((or/c symbol? module-path-index?)
|
[resolve-module-path-index ((or/c symbol? module-path-index?)
|
||||||
rel-to-path-string/thunk/#f
|
rel-to-path-string/thunk/#f
|
||||||
. -> . (or/c path? symbol?))]))
|
. -> . (or/c path? symbol?))])))
|
||||||
|
|
|
||||||
272
collects/syntax/private/modcollapse-noctc.ss
Normal file
272
collects/syntax/private/modcollapse-noctc.ss
Normal file
|
|
@ -0,0 +1,272 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
|
#|
|
||||||
|
|
||||||
|
This file is used by the contract system's
|
||||||
|
implementation, so it does not have contracts.
|
||||||
|
Use syntax/modcollapse instead.
|
||||||
|
|
||||||
|
|#
|
||||||
|
|
||||||
|
(require scheme/string
|
||||||
|
scheme/list
|
||||||
|
"modhelp.ss")
|
||||||
|
|
||||||
|
(define (collapse-module-path s relto-mp)
|
||||||
|
;; relto-mp should be a path, '(lib relative-path collection) or symbol,
|
||||||
|
;; or '(file path) or a thunk that produces one of those
|
||||||
|
|
||||||
|
;; Used for 'lib paths, so it's always Unix-style
|
||||||
|
(define (attach-to-relative-path-string elements relto)
|
||||||
|
(let ([elem-str
|
||||||
|
(substring
|
||||||
|
(apply string-append
|
||||||
|
(map (lambda (i)
|
||||||
|
(string-append
|
||||||
|
"/"
|
||||||
|
(cond [(bytes? i) (bytes->string/locale i)]
|
||||||
|
[(path? i) (path->string i)]
|
||||||
|
[(eq? i 'up) ".."]
|
||||||
|
[else i])))
|
||||||
|
(filter (lambda (x) (not (eq? x 'same)))
|
||||||
|
elements)))
|
||||||
|
1)])
|
||||||
|
(if (or (regexp-match #rx"^[.]/+[^/]*" relto)
|
||||||
|
(not (regexp-match #rx"/" relto)))
|
||||||
|
elem-str
|
||||||
|
(let ([m (regexp-match #rx"^(.*/)/*[^/]*$" relto)])
|
||||||
|
(string-append (cadr m) elem-str)))))
|
||||||
|
|
||||||
|
(define (simpler-relpath path)
|
||||||
|
(let loop ([s (regexp-replace* #px"(?<![.])[.]/" path "")])
|
||||||
|
(let ([s2 (regexp-replace #rx"([^/.]*)/[.][.]/" s "")])
|
||||||
|
(if (equal? s s2)
|
||||||
|
s
|
||||||
|
(loop s2)))))
|
||||||
|
|
||||||
|
(define (add-main s)
|
||||||
|
(if (regexp-match #rx"[.][^/]*$" s)
|
||||||
|
s
|
||||||
|
(string-append s "/main.ss")))
|
||||||
|
|
||||||
|
(define (combine-relative-elements elements)
|
||||||
|
|
||||||
|
(define (extract-base relto)
|
||||||
|
(let-values ([(base n d?) (split-path relto)])
|
||||||
|
(if (eq? base 'relative)
|
||||||
|
'same
|
||||||
|
(if (not base)
|
||||||
|
relto ; strange case: relto is a root directory
|
||||||
|
base))))
|
||||||
|
|
||||||
|
;; Used for 'file paths, so it's platform specific:
|
||||||
|
(define (attach-to-relative-path relto)
|
||||||
|
(apply build-path
|
||||||
|
(extract-base relto)
|
||||||
|
(map (lambda (i) (if (bytes? i) (bytes->path i) i))
|
||||||
|
elements)))
|
||||||
|
|
||||||
|
(when (procedure? relto-mp) (set! relto-mp (relto-mp)))
|
||||||
|
(when (symbol? relto-mp) (set! relto-mp `(lib ,(symbol->string relto-mp))))
|
||||||
|
(cond
|
||||||
|
[(or (path? relto-mp) (and (string? relto-mp) (ormap path? elements)))
|
||||||
|
(apply build-path
|
||||||
|
(extract-base relto-mp)
|
||||||
|
(map (lambda (x) (if (bytes? x) (bytes->path x) x))
|
||||||
|
elements))]
|
||||||
|
[(string? relto-mp)
|
||||||
|
(bytes->string/locale
|
||||||
|
(apply
|
||||||
|
bytes-append
|
||||||
|
(cond [(regexp-match #rx#"^(.*)/[^/]*$"
|
||||||
|
(string->bytes/locale relto-mp))
|
||||||
|
=> cadr]
|
||||||
|
[else #"."])
|
||||||
|
(map (lambda (e)
|
||||||
|
(cond [(eq? e 'same) #"/."]
|
||||||
|
[(eq? e 'up) #"/.."]
|
||||||
|
[else (bytes-append
|
||||||
|
#"/" (if (path? e) (path->bytes e) e))]))
|
||||||
|
elements)))]
|
||||||
|
[(eq? (car relto-mp) 'file)
|
||||||
|
(let ([path ((if (ormap path? elements) values path->string)
|
||||||
|
(attach-to-relative-path (cadr relto-mp)))])
|
||||||
|
(if (path? path) path `(file ,path)))]
|
||||||
|
[(eq? (car relto-mp) 'lib)
|
||||||
|
(let ([relto-mp (if (null? (cddr relto-mp))
|
||||||
|
;; old style => add 'mzlib
|
||||||
|
;; new style => add main.ss or split
|
||||||
|
(let ([m (regexp-match-positions #rx"[/]" (cadr relto-mp))])
|
||||||
|
(if m
|
||||||
|
;; new style: split
|
||||||
|
`(lib ,(substring (cadr relto-mp) (cdar m))
|
||||||
|
,(substring (cadr relto-mp) 0 (caar m)))
|
||||||
|
(if (regexp-match? #rx"[.]" (cadr relto-mp))
|
||||||
|
;; old style:
|
||||||
|
`(lib ,(cadr relto-mp) "mzlib")
|
||||||
|
;; new style, add "main.ss":
|
||||||
|
`(lib "main.ss" ,(cadr relto-mp)))))
|
||||||
|
;; already has at least two parts:
|
||||||
|
relto-mp)])
|
||||||
|
(let ([path (attach-to-relative-path-string
|
||||||
|
elements (apply string-append
|
||||||
|
(append
|
||||||
|
(map (lambda (s)
|
||||||
|
(string-append s "/"))
|
||||||
|
(cddr relto-mp))
|
||||||
|
(list (cadr relto-mp)))))])
|
||||||
|
(let ([simpler (simpler-relpath path)])
|
||||||
|
(let ([m (regexp-match #rx"^(.*)/([^/]*)$" simpler)])
|
||||||
|
(if m
|
||||||
|
(normalize-lib `(lib ,(caddr m) ,(cadr m)))
|
||||||
|
(error 'combine-relative-elements
|
||||||
|
"relative path escapes collection: ~s relative to ~s"
|
||||||
|
elements relto-mp))))))]
|
||||||
|
[(eq? (car relto-mp) 'planet)
|
||||||
|
(let ([relto-mp
|
||||||
|
;; make sure relto-mp is in long form:
|
||||||
|
(if (null? (cddr relto-mp))
|
||||||
|
(normalize-planet relto-mp)
|
||||||
|
relto-mp)])
|
||||||
|
(let ([pathstr (simpler-relpath
|
||||||
|
(attach-to-relative-path-string
|
||||||
|
elements
|
||||||
|
(apply string-append
|
||||||
|
(append
|
||||||
|
(map (lambda (s)
|
||||||
|
(string-append s "/"))
|
||||||
|
(cdddr relto-mp))
|
||||||
|
(list (cadr relto-mp))))))])
|
||||||
|
(normalize-planet `(planet ,pathstr ,(caddr relto-mp)))))]
|
||||||
|
[else (error 'combine-relative-elements
|
||||||
|
"don't know how to deal with: ~s" relto-mp)]))
|
||||||
|
|
||||||
|
(define (normalize-lib s)
|
||||||
|
(if (null? (cddr s))
|
||||||
|
;; single-string version:
|
||||||
|
(let ([e (cadr s)])
|
||||||
|
(cond
|
||||||
|
[(regexp-match? #rx"[.]" e)
|
||||||
|
;; It has a suffix:
|
||||||
|
(if (regexp-match? #rx"/" e)
|
||||||
|
;; It has a path, so it's fine:
|
||||||
|
s
|
||||||
|
;; No path, so add "mzlib/":
|
||||||
|
`(lib ,(string-append "mzlib/" e)))]
|
||||||
|
[(regexp-match? #rx"/" e)
|
||||||
|
;; It has a separator, so add a suffix:
|
||||||
|
`(lib ,(string-append e ".ss"))]
|
||||||
|
[else
|
||||||
|
;; No separator or suffix, so add "/main.ss":
|
||||||
|
`(lib ,(string-append e "/main.ss"))]))
|
||||||
|
;; multi-string version:
|
||||||
|
(if (regexp-match? #rx"[.]" (cadr s))
|
||||||
|
;; there's a suffix, so we can collapse to a single string:
|
||||||
|
`(lib ,(string-join (append (cddr s)
|
||||||
|
(list (cadr s)))
|
||||||
|
"/"))
|
||||||
|
;; No suffix, so we must keep the old style:
|
||||||
|
s)))
|
||||||
|
|
||||||
|
(define (normalize-planet s)
|
||||||
|
(cond
|
||||||
|
[(symbol? (cadr s))
|
||||||
|
;; normalize via string form:
|
||||||
|
(normalize-planet `(planet ,(symbol->string (cadr s))))]
|
||||||
|
[(null? (cddr s))
|
||||||
|
;; normalize to long form:
|
||||||
|
(let* ([strs (regexp-split #rx"/" (cadr s))])
|
||||||
|
(let ([owner (car strs)]
|
||||||
|
[pkg+vers (regexp-split #rx":" (cadr strs))]
|
||||||
|
[path (cddr strs)])
|
||||||
|
`(planet ,(if (null? path)
|
||||||
|
"main.ss"
|
||||||
|
(let ([str (last path)])
|
||||||
|
(if (regexp-match? #rx"[.]" str)
|
||||||
|
str
|
||||||
|
(string-append str ".ss"))))
|
||||||
|
(,owner
|
||||||
|
,(string-append (car pkg+vers) ".plt")
|
||||||
|
,@(if (null? (cdr pkg+vers))
|
||||||
|
null
|
||||||
|
`(,(string->number (cadr pkg+vers))
|
||||||
|
. ,(if (null? (cddr pkg+vers))
|
||||||
|
null
|
||||||
|
(list
|
||||||
|
(let ([vers (caddr pkg+vers)])
|
||||||
|
(cond
|
||||||
|
[(regexp-match? #rx"<=" vers)
|
||||||
|
`(- ,(string->number (substring vers 2)))]
|
||||||
|
[(regexp-match? #rx">=" vers)
|
||||||
|
(string->number (substring vers 2))]
|
||||||
|
[(regexp-match? #rx"=" vers)
|
||||||
|
`(= ,(string->number (substring vers 1)))]
|
||||||
|
[(regexp-match #rx"(.*)-(.*)" vers)
|
||||||
|
=> (lambda (m)
|
||||||
|
`(,(string->number (cadr m))
|
||||||
|
,(string->number (caddr m))))]
|
||||||
|
[(string->number vers)
|
||||||
|
=> (lambda (n) n)]
|
||||||
|
[else (error 'collapse-module-path
|
||||||
|
"confused when normalizing planet path: ~e"
|
||||||
|
s)])))))))
|
||||||
|
,@(if (null? path)
|
||||||
|
null
|
||||||
|
(reverse (cdr (reverse path)))))))]
|
||||||
|
[else
|
||||||
|
;; Long form is the normal form, but see if we need to split up the
|
||||||
|
;; path elements:
|
||||||
|
(let ([base (cadr s)]
|
||||||
|
[rest (cdddr s)]
|
||||||
|
[split? (lambda (s)
|
||||||
|
(regexp-match? #rx"/" s))])
|
||||||
|
(if (or (split? base)
|
||||||
|
(ormap split? rest))
|
||||||
|
;; need to split some paths:
|
||||||
|
(let ([split (lambda (s)
|
||||||
|
(regexp-split #rx"/" s))])
|
||||||
|
(let ([bases (split base)]
|
||||||
|
[rests (map split rest)])
|
||||||
|
(list* (car s)
|
||||||
|
(last bases)
|
||||||
|
(caddr s)
|
||||||
|
(append
|
||||||
|
(apply append rests)
|
||||||
|
(drop-right bases 1)))))
|
||||||
|
;; already in normal form:
|
||||||
|
s))]))
|
||||||
|
|
||||||
|
(cond [(string? s)
|
||||||
|
;; Parse Unix-style relative path string
|
||||||
|
(combine-relative-elements (explode-relpath-string s))]
|
||||||
|
[(symbol? s)
|
||||||
|
;; Convert to `lib' form:
|
||||||
|
(normalize-lib `(lib ,(symbol->string s)))]
|
||||||
|
[(and (or (not (pair? s)) (not (list? s))) (not (path? s)))
|
||||||
|
#f]
|
||||||
|
[(or (path? s) (eq? (car s) 'file))
|
||||||
|
(let ([p (if (path? s) s (cadr s))])
|
||||||
|
(if (absolute-path? p)
|
||||||
|
s
|
||||||
|
(let loop ([p p] [elements null])
|
||||||
|
(let-values ([(base name dir?) (split-path p)])
|
||||||
|
(cond [(eq? base 'relative)
|
||||||
|
(combine-relative-elements (cons name elements))]
|
||||||
|
[else (loop base (cons name elements))])))))]
|
||||||
|
[(eq? (car s) 'lib) (normalize-lib s)]
|
||||||
|
[(eq? (car s) 'planet) (normalize-planet s)]
|
||||||
|
[(eq? (car s) 'quote) s]
|
||||||
|
[else #f]))
|
||||||
|
|
||||||
|
(define (collapse-module-path-index mpi relto-mp)
|
||||||
|
(let-values ([(path base) (module-path-index-split mpi)])
|
||||||
|
(if path
|
||||||
|
(collapse-module-path
|
||||||
|
path
|
||||||
|
(if base
|
||||||
|
(collapse-module-path-index base relto-mp)
|
||||||
|
relto-mp))
|
||||||
|
relto-mp)))
|
||||||
|
|
||||||
|
(provide collapse-module-path
|
||||||
|
collapse-module-path-index)
|
||||||
|
|
@ -1,23 +1,20 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
(module modhelp mzscheme
|
(provide explode-relpath-string
|
||||||
(require mzlib/string)
|
module-path-v?
|
||||||
|
module-path-v-string?)
|
||||||
|
|
||||||
(provide explode-relpath-string
|
(define (explode-relpath-string p)
|
||||||
module-path-v?
|
(map (lambda (p)
|
||||||
module-path-v-string?)
|
(cond [(assoc p '((#"." . same) (#".." . up))) => cdr]
|
||||||
|
[else (bytes->path p)]))
|
||||||
|
(regexp-split #rx#"/+" (string->bytes/utf-8 p))))
|
||||||
|
|
||||||
(define (explode-relpath-string p)
|
(define (module-path-v-string? v)
|
||||||
(map (lambda (p)
|
(and (regexp-match? #rx"^[-a-zA-Z0-9./]+$" v)
|
||||||
(cond [(assoc p '((#"." . same) (#".." . up))) => cdr]
|
(not (regexp-match? #rx"^/" v))
|
||||||
[else (bytes->path p)]))
|
(not (regexp-match? #rx"/$" v))))
|
||||||
(regexp-split #rx#"/+" (string->bytes/utf-8 p))))
|
|
||||||
|
|
||||||
(define (module-path-v-string? v)
|
|
||||||
(and (regexp-match? #rx"^[-a-zA-Z0-9./]+$" v)
|
|
||||||
(not (regexp-match? #rx"^/" v))
|
|
||||||
(not (regexp-match? #rx"/$" v))))
|
|
||||||
|
|
||||||
(define (module-path-v? v)
|
|
||||||
(or (path? v)
|
|
||||||
(module-path? v))))
|
|
||||||
|
|
||||||
|
(define (module-path-v? v)
|
||||||
|
(or (path? v)
|
||||||
|
(module-path? v)))
|
||||||
Loading…
Reference in New Issue
Block a user