diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 3b240aaa11..2a550eed1e 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -9,7 +9,7 @@ (provide raise-contract-error guilty-party contract-violation->string - coerce-contract + coerce-contract flat-contract/predicate? flat-contract? @@ -176,7 +176,7 @@ [formatted-contract-sexp (let ([one-line (format "~s" contract-sexp)]) (if (< (string-length one-line) 30) - (string-append one-line " ") + one-line (let ([sp (open-output-string)]) (newline sp) (parameterize ([pretty-print-print-line print-contract-liner] @@ -184,13 +184,24 @@ (pretty-print contract-sexp sp)) (get-output-string sp))))] [specific-blame - (let ([datum (syntax->datum src-info)]) - (if (symbol? datum) - (format "on ~a" datum) - ""))]) + (cond + [(syntax? src-info) + (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; " 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 specific-blame) msg))) @@ -207,14 +218,16 @@ contract-sexp (apply format fmt args))) (current-continuation-marks) - (if src-info - (list (make-srcloc - (syntax-source src-info) - (syntax-line src-info) - (syntax-column src-info) - (syntax-position src-info) - (syntax-span src-info))) - '()) + (cond + [(syntax? src-info) + (list (make-srcloc + (syntax-source src-info) + (syntax-line src-info) + (syntax-column src-info) + (syntax-position src-info) + (syntax-span src-info)))] + [(srcloc? src-info) (list src-info)] + [else '()]) blame))) (define print-contract-liner @@ -226,9 +239,10 @@ 2) 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) - (if (syntax? src-info) + (if (or (syntax? src-info) + (srcloc? src-info)) (let ([src-loc-str (build-src-loc-string src-info)]) (if src-loc-str (string-append src-loc-str ": ") diff --git a/collects/scheme/private/contract-helpers.ss b/collects/scheme/private/contract-helpers.ss index 2e5fe567ff..f8cd4266ab 100644 --- a/collects/scheme/private/contract-helpers.ss +++ b/collects/scheme/private/contract-helpers.ss @@ -9,6 +9,7 @@ known-good-contract?) (require setup/main-collects + syntax/private/modcollapse-noctc (for-template scheme/base)) (define (add-name-prop name stx) @@ -85,18 +86,28 @@ (cdr r))) 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) - (let* ([source (source->name (syntax-source stx))] - [line (syntax-line stx)] - [col (syntax-column stx)] - [pos (syntax-position stx)] - [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)))) + (let-values ([(source line col pos) + (if (syntax? stx) + (values (source->name (syntax-source stx)) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx)) + (values (source->name + (resolved-module-path-name + (module-path-index-resolve + (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)) @@ -104,25 +115,21 @@ ;; constructs a symbol for use in the blame error messages ;; when blaming the module where stx's occurs. (define (module-source-as-symbol stx) - (let ([src-module (syntax-source-module stx)]) + (let ([mpi (syntax-source-module stx)]) (cond - [(symbol? src-module) src-module] - [(module-path-index? src-module) - (let-values ([(path base) (module-path-index-split src-module)]) - ;; we dont' normalize here, because we don't - ;; want to assume that the collection paths - ;; are set or the file system can be accessed. - (if path - (string->symbol - (if (and (pair? path) - (eq? (car path) 'quote) - (pair? (cdr path)) - (null? (cddr path))) - (format "'~s" (cadr path)) - (format "~s" path))) - 'top-level))] - [else 'top-level]))) - + [(not mpi) + 'top-level] + [else + ;; note: the directory passed to collapse-module-path-index should be irrelevant + (let ([collapsed (collapse-module-path-index mpi (current-directory))]) + (cond + [(path? collapsed) + (let ([resolved (resolved-module-path-name (module-path-index-resolve mpi))]) + (cond + [(symbol? resolved) resolved] + [else `(file ,(path->string resolved))]))] + [else + collapsed]))]))) (define build-struct-names (lambda (name-stx fields omit-sel? omit-set? srcloc-stx) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 764c3d7c80..d9ad79b93d 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -89,6 +89,16 @@ improve method arity mismatch contract violation error messages? (string->symbol neg-blame-str) (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) (make-set!-transformer (let ([saved-id-table (make-hasheq)]) @@ -106,11 +116,11 @@ improve method arity mismatch contract violation error messages? [pos-module-source pos-module-source]) (syntax-local-introduce (syntax-local-lift-expression - #'(-contract contract-id + #`(-contract contract-id id pos-module-source (module-source-as-symbol #'name) - (quote-syntax name))))))]) + #,(id->contract-src-info #'id))))))]) (when key (hash-set! saved-id-table key lifted-id)) ;; 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]))))]) (syntax-local-lift-module-end-declaration - #'(begin - (-contract contract-id id pos-module-source 'ignored #'id) + #`(begin + (-contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id)) (void))) (syntax (code id-rename)))))])) @@ -733,37 +743,30 @@ improve method arity mismatch contract violation error messages? (define-syntax (-contract stx) (syntax-case stx () [(_ a-contract to-check pos-blame-e neg-blame-e) - (with-syntax ([src-loc (syntax/loc stx here)]) - (syntax/loc stx - (contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))] + (let ([s (syntax/loc stx here)]) + (quasisyntax/loc stx + (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) (syntax/loc stx (begin (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) - (unless (or (contract? a-contract-raw) - (and (procedure? a-contract-raw) - (procedure-arity-includes? a-contract-raw 1))) - (error 'contract "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e ~e" - a-contract-raw - name - pos-blame - neg-blame - src-info)) - (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" + (let ([a-contract (coerce-contract 'contract a-contract-raw)]) + + (unless (or (and (list? src-info) + (= 2 (length src-info)) + (srcloc? (list-ref src-info 0)) + (or (string? (list-ref src-info 1)) + (not (list-ref src-info 1)))) + (syntax? 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" src-info neg-blame pos-blame diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 0f3bfa247d..494112a36f 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc @(require "mz.ss") +@(require (for-label syntax/modcollapse)) @title[#:tag "contracts" #:style 'toc]{Contracts} @@ -662,7 +663,7 @@ that definition.} positive-blame-expr negative-blame-expr) (contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr - contract-source-expr)]]{ + contract-source-info)]]{ The primitive mechanism for attaching a contract to a value. The 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 @scheme[contract-expr]. -If specified, @scheme[contract-source-expr], indicates where the -contract was assumed. Its value must be a syntax object specifying the +If specified, @scheme[contract-source-info], indicates where 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 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 -source location of the @scheme[contract] expression.} +primitive whose contract was assumed.} +} + +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 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 contract violation error. Its value is procedure that -accepts six arguments: the value that the contract applies -to, a syntax object representing the source location where -the contract was established, the names of the two parties -to the contract (as symbols) where the first one is the -guilty one, an sexpression representing the contract, and a -message indicating the kind of violation. The procedure then +accepts five arguments: +@itemize{ +@item{the value that the contract applies to,} +@item{a syntax object representing the source location where +the contract was established, } +@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 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)]{ diff --git a/collects/syntax/modcollapse.ss b/collects/syntax/modcollapse.ss index 33e3654e24..a9db3765b3 100644 --- a/collects/syntax/modcollapse.ss +++ b/collects/syntax/modcollapse.ss @@ -1,286 +1,26 @@ +#lang scheme/base -(module modcollapse mzscheme - (require (only mzlib/list filter) - scheme/string - scheme/list - mzlib/contract - (only scheme/base regexp-split) - "private/modhelp.ss") +(require scheme/contract + "private/modcollapse-noctc.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 +(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?)) - ;; 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 rel-to-module-path-v/c + (or/c simple-rel-to-module-path-v/c + path? + (-> simple-rel-to-module-path-v/c))) - (define (simpler-relpath path) - (let loop ([s (regexp-replace* #px"(?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)])) +(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)]) \ No newline at end of file diff --git a/collects/syntax/modresolve.ss b/collects/syntax/modresolve.ss index 82b33e979d..ab038baf56 100644 --- a/collects/syntax/modresolve.ss +++ b/collects/syntax/modresolve.ss @@ -1,7 +1,6 @@ (module modresolve mzscheme (require mzlib/list - mzlib/contract "private/modhelp.ss") (define (force-relto relto dir?) @@ -66,12 +65,16 @@ [relto relto] [else #f])) - (define rel-to-path-string/thunk/#f - (or/c path-string? (-> path-string?) false/c)) - - (provide/contract - [resolve-module-path (module-path-v? rel-to-path-string/thunk/#f - . -> . (or/c path? symbol?))] - [resolve-module-path-index ((or/c symbol? module-path-index?) - rel-to-path-string/thunk/#f - . -> . (or/c path? symbol?))])) + (provide resolve-module-path-index + resolve-module-path) + #; + (begin + (define rel-to-path-string/thunk/#f + (or/c path-string? (-> path-string?) false/c)) + + (provide/contract + [resolve-module-path (module-path-v? rel-to-path-string/thunk/#f + . -> . (or/c path? symbol?))] + [resolve-module-path-index ((or/c symbol? module-path-index?) + rel-to-path-string/thunk/#f + . -> . (or/c path? symbol?))]))) diff --git a/collects/syntax/private/modcollapse-noctc.ss b/collects/syntax/private/modcollapse-noctc.ss new file mode 100644 index 0000000000..bd1957d79e --- /dev/null +++ b/collects/syntax/private/modcollapse-noctc.ss @@ -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 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) diff --git a/collects/syntax/private/modhelp.ss b/collects/syntax/private/modhelp.ss index 8e0f274626..140580de6e 100644 --- a/collects/syntax/private/modhelp.ss +++ b/collects/syntax/private/modhelp.ss @@ -1,23 +1,20 @@ +#lang scheme/base -(module modhelp mzscheme - (require mzlib/string) +(provide explode-relpath-string + module-path-v? + module-path-v-string?) - (provide explode-relpath-string - module-path-v? - module-path-v-string?) +(define (explode-relpath-string p) + (map (lambda (p) + (cond [(assoc p '((#"." . same) (#".." . up))) => cdr] + [else (bytes->path p)])) + (regexp-split #rx#"/+" (string->bytes/utf-8 p)))) - (define (explode-relpath-string p) - (map (lambda (p) - (cond [(assoc p '((#"." . same) (#".." . up))) => cdr] - [else (bytes->path p)])) - (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-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))) \ No newline at end of file