diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index ef89bfcc1c..13a89a2559 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -21,7 +21,7 @@ improve method arity mismatch contract violation error messages? "blame.ss") (define-syntax-parameter current-contract-region - (λ (stx) #'(quote-module-source))) + (λ (stx) #'(quote-module-path))) (define-syntax (contract stx) (syntax-case stx () diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index 37066b509e..ff3ca246fd 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -46,9 +46,9 @@ #`(contract contract-id id pos-module-source - (quote-module-source) + (quote-module-path) 'external-id - (quote-srcloc id #:module-source pos-module-source))))))]) + (quote-srcloc id))))))]) (when key (hash-set! saved-id-table key lifted-id)) ;; Expand to a use of the lifted expression: @@ -646,7 +646,7 @@ (with-syntax ([code (quasisyntax/loc stx (begin - (define pos-module-source (quote-module-source)) + (define pos-module-source (quote-module-path)) #,@(if no-need-to-check-ctrct? (list) @@ -665,7 +665,7 @@ #`(begin (unless extra-test (contract contract-id id pos-module-source 'ignored 'id - (quote-srcloc id #:module-source pos-module-source))) + (quote-srcloc id))) (void))) (syntax (code id-rename))))))])) diff --git a/collects/setup/private/path-utils.ss b/collects/setup/private/path-utils.ss index 0a0669e8f7..54a86cae4f 100644 --- a/collects/setup/private/path-utils.ss +++ b/collects/setup/private/path-utils.ss @@ -3,7 +3,7 @@ (require setup/dirs setup/main-collects setup/path-relativize - scheme/list + unstable/dirs (rename-in planet/config [CACHE-DIR planet-dir])) (provide doc-path path->name) @@ -31,29 +31,10 @@ ;; clear from the context what path is shown. (To be used only for ;; human-readable output.) Generalized for any base directory and an ;; indicative prefix. -(define (path->rel path find-base) - ((if (not find-base) - path->main-collects-relative - (let-values ([(path->rel rel->path) - (make-relativize find-base 'rel 'path->rel 'rel->path)]) - path->rel)) - path)) (define (path->name path #:prefix [prefix #f] #:base [find-base #f]) - (define (try find-base prefix) - (define rel (path->rel path find-base)) - (and (pair? rel) - (let* ([p (append-map (lambda (p) (list #"/" p)) (cdr rel))] - [p (if (null? p) - "" - (bytes->string/utf-8 (apply bytes-append (cdr p))))]) - (if prefix (format "<~a>/~a" prefix p) p)))) - (define (->string) (if (string? path) path (path->string path))) - (if (not (complete-path? path)) - (->string) - (or (try find-base prefix) - ;; by default (both optionals missing) try the user - ;; collections and planet too - (and (not (or prefix find-base)) - (or (try find-user-collects-dir 'user) - (try planet-dir 'planet))) - (->string)))) + (path->directory-relative-string + path + #:dirs (cond + [find-base (list (cons find-base prefix))] + [prefix (list (cons find-collects-dir prefix))] + [else setup-relative-directories]))) diff --git a/collects/unstable/dirs.ss b/collects/unstable/dirs.ss new file mode 100644 index 0000000000..4ce8a4ea83 --- /dev/null +++ b/collects/unstable/dirs.ss @@ -0,0 +1,68 @@ +#lang scheme/base + +;; Unstable library by: Carl Eastlund +;; intended for use in scheme/contract, so don't try to add contracts! + +(require scheme/dict + setup/path-relativize + setup/dirs + (only-in planet/config [CACHE-DIR find-planet-dir])) + +(provide path->directory-relative-string + library-relative-directories + setup-relative-directories) + +(define library-relative-directories + (list (cons find-collects-dir 'collects) + (cons find-user-collects-dir 'user) + (cons find-planet-dir 'planet))) + +(define setup-relative-directories + (list (cons find-collects-dir #f) + (cons find-user-collects-dir 'user) + (cons find-planet-dir 'planet))) + +(define (path->directory-relative-string + path + #:default [default (if (path? path) (path->string path) path)] + #:dirs [dirs library-relative-directories]) + + (unless (path-string? path) + (error 'path->directory-relative-string + "expected a path or a string (first argument); got: ~e" path)) + + (unless (dict? dirs) + (error 'path->directory-relative-string + "expected a dictionary (#:dirs keyword argument); got: ~e" dirs)) + + (let/ec return + + (when (complete-path? path) + (for ([(find-dir dir-name) (in-dict dirs)]) + + (unless (and (procedure? find-dir) + (procedure-arity-includes? find-dir 0)) + (error 'path->directory-relative-string + "expected keys in dictionary to be thunks (~a); got: ~e" + "#:dirs keyword argument" + find-dir)) + + (let () + + (define-values [ path->relative relative->path ] + (make-relativize find-dir + 'relative + 'path->relative + 'relative->path)) + (define exploded + (with-handlers ([exn:fail? (lambda (e) #f)]) + (path->relative path))) + (when (list? exploded) + (let* ([relative (path->string + (apply build-path + (map bytes->path-element (cdr exploded))))]) + (return + (if dir-name + (format "<~a>/~a" dir-name relative) + (format "~a" relative)))))))) + default)) diff --git a/collects/unstable/location.ss b/collects/unstable/location.ss index 0a32cc9aca..028b820b4d 100644 --- a/collects/unstable/location.ss +++ b/collects/unstable/location.ss @@ -1,6 +1,9 @@ #lang scheme/base -(require (for-syntax scheme/base unstable/srcloc)) +(require unstable/srcloc + (for-syntax scheme/base + unstable/srcloc + unstable/dirs)) (provide quote-srcloc quote-source-file @@ -9,74 +12,58 @@ quote-character-position quote-character-span quote-module-path - quote-module-source quote-module-name) (define-syntax (quote-srcloc stx) (syntax-case stx () [(_) #`(quote-srcloc #,stx)] [(_ loc) - (with-syntax ([(arg ...) (build-source-location-list #'loc)]) - #'(make-srcloc (quote arg) ...))] - [(_ loc #:module-source alt-src) - (with-syntax ([(src arg ...) (build-source-location-list #'loc)]) - (with-syntax ([alt-src (if (syntax-source-module #'loc) - #'alt-src - #'(quote src))]) - #'(make-srcloc alt-src (quote arg) ...)))])) + (let* ([src (build-source-location #'loc)]) + (cond + [(and + (path-string? (srcloc-source src)) + (path->directory-relative-string (srcloc-source src) #:default #f)) + => + (lambda (rel) + (with-syntax ([src rel] + [line (srcloc-line src)] + [col (srcloc-column src)] + [pos (srcloc-position src)] + [span (srcloc-span src)]) + #'(make-srcloc 'src 'line 'col 'pos 'span)))] + [else #'(build-source-location (quote-syntax loc))]))])) -(define-syntax (quote-source-file stx) - (syntax-case stx () - [(_) #`(quote-source-file #,stx)] - [(_ loc) #`(quote #,(source-location-source #'loc))])) +(define-syntax-rule (define-quote-srcloc-accessors [name accessor] ...) + (define-syntaxes [ name ... ] + (values + (lambda (stx) + (syntax-case stx () + [(_) #`(name #,stx)] + [(_ loc) #`(accessor (quote-srcloc loc))])) + ...))) -(define-syntax (quote-line-number stx) - (syntax-case stx () - [(_) #`(quote-line-number #,stx)] - [(_ loc) #`(quote #,(source-location-line #'loc))])) - -(define-syntax (quote-column-number stx) - (syntax-case stx () - [(_) #`(quote-column-number #,stx)] - [(_ loc) #`(quote #,(source-location-column #'loc))])) - -(define-syntax (quote-character-position stx) - (syntax-case stx () - [(_) #`(quote-character-position #,stx)] - [(_ loc) #`(quote #,(source-location-position #'loc))])) - -(define-syntax (quote-character-span stx) - (syntax-case stx () - [(_) #`(quote-character-span #,stx)] - [(_ loc) #`(quote #,(source-location-span #'loc))])) +(define-quote-srcloc-accessors + [quote-source-file source-location-source] + [quote-line-number source-location-line] + [quote-column-number source-location-column] + [quote-character-position source-location-position] + [quote-character-span source-location-span]) (define-syntax-rule (quote-module-name) - (variable-reference->module-name (#%variable-reference))) + (module-source->module-name + (variable-reference->module-source + (#%variable-reference)))) (define-syntax-rule (quote-module-path) - (variable-reference->module-path (#%variable-reference))) + (module-source->module-path + (variable-reference->module-source + (#%variable-reference)))) -(define-syntax-rule (quote-module-source) - (variable-reference->module-src (#%variable-reference))) +(define (module-source->module-name src) + (or src 'top-level)) -(define (variable-reference->module-path var) - (module-name->module-path - (variable-reference->module-name var))) - -(define (variable-reference->module-name var) - (let* ([rmp (variable-reference->resolved-module-path var)]) - (if (resolved-module-path? rmp) - (resolved-module-path-name rmp) - rmp))) - -(define (module-name->module-path name) +(define (module-source->module-path src) (cond - [(path? name) `(file ,(path->string name))] - [(symbol? name) `(quote ,name)] + [(path? src) `(file ,(path->string src))] + [(symbol? src) `(quote ,src)] [else 'top-level])) - -(define (variable-reference->module-src var) - (let ([v (variable-reference->module-source var)]) - (if v - (make-resolved-module-path v) - 'top-level))) diff --git a/collects/unstable/scribblings/dirs.scrbl b/collects/unstable/scribblings/dirs.scrbl new file mode 100644 index 0000000000..271498b501 --- /dev/null +++ b/collects/unstable/scribblings/dirs.scrbl @@ -0,0 +1,86 @@ +#lang scribble/manual +@(require scribble/eval "utils.ss" (for-label scheme unstable/dirs)) + +@(define unsyntax #f) + +@(define (new-evaluator) + (let* ([e (make-base-eval)]) + (e '(require (for-syntax scheme/base) + unstable/dirs)) + e)) + +@(define evaluator (new-evaluator)) + +@(define reference-path + '(lib "scribblings/reference/reference.scrbl")) + +@title[#:tag "dirs"]{Directories} + +@defmodule[unstable/dirs] + +@unstable[@author+email["Carl Eastlund" "cce@ccs.neu.edu"]] + +This library defines utilities dealing with the directory paths used by the +PLT Scheme distribution. + +@defproc[(path->directory-relative-string + [path path-string?] + [#:default default any/c (if (path? path) (path->string path) path)] + [#:dirs dirs + (listof (cons/c (-> path?) any/c)) + library-relative-directories]) + (or/c string? (one-of/c default))]{ + +Produces a string rendering of @scheme[path], replacing distribution-specific +paths (normally: collections, user-installed collections, or PLanet cache) with +short abbreviations. + +The set of paths and their abbreviations may be overridden by the +@scheme[#:dirs] option, which accepts an association list. Its keys must be +thunks which produce a path. Its values may be either @scheme[#f] for no +abbreviation (the directory prefix is simply omitted) or any other value to be +@scheme[display]ed in the output. For instance, @filepath{document.txt} +relative to a path abbreviated @scheme["path"] would be rendered as +@scheme["/document.txt"]. + +If the path is not relative to one of the given directories, the default return +value is a string rendering of the unmodified path. This default may be +overridden by providing @scheme[default]. + +@defexamples[#:eval evaluator +(path->directory-relative-string + (build-path "source" "project.rkt")) +(path->directory-relative-string + (build-path (current-directory) "source" "project.rkt")) +(path->directory-relative-string + (build-path "/" "source" "project.rkt")) +(path->directory-relative-string + (build-path "/" "source" "project.rkt") + #:default #f) +(path->directory-relative-string + (build-path "/" "source" "project.rkt") + #:dirs (list + (cons (lambda () (build-path "/" "source")) + 'src))) +] + +} + +@defthing[library-relative-directories (listof (cons (-> path?) any/c))]{ + +Represents the default directory substitutions for +@scheme[path->directory-relative-string]. By default, the collections directory +is replaced by @schemeresult[collects], the user-installed collections directory +is replaced by @schemeresult[user], and the PLaneT cache is replaced by +@schemeresult[planet]. + +} + +@defthing[setup-relative-directories (listof (cons (-> path?) any/c))]{ + +Represents the directory substitutions used by @exec{setup-plt}. The +collections directory is omitted, the user-installed collections directory is +replaced by @schemeresult[user], and the PLaneT cache is replaced by +@schemeresult[planet]. + +} diff --git a/collects/unstable/scribblings/srcloc.scrbl b/collects/unstable/scribblings/srcloc.scrbl index 19e54ac0e6..afbea445de 100644 --- a/collects/unstable/scribblings/srcloc.scrbl +++ b/collects/unstable/scribblings/srcloc.scrbl @@ -169,6 +169,25 @@ position and span, if both are numbers) or @scheme[#f]. } +@defproc[(update-source-location + [loc source-location?] + [#:source source any/c] + [#:line line (or/c exact-nonnegative-integer? #f)] + [#:column column (or/c exact-positive-integer? #f)] + [#:position position (or/c exact-nonnegative-integer? #f)] + [#:span span (or/c exact-positive-integer? #f)]) + source-location?]{ +Produces a modified version of @scheme[loc], replacing its fields with +@scheme[source], @scheme[line], @scheme[column], @scheme[position], and/or +@scheme[span], if given. + +@examples[#:eval evaluator +(update-source-location #f #:source 'here) +(update-source-location (list 'there 1 2 3 4) #:line 20 #:column 79) +(update-source-location (vector 'everywhere 1 2 3 4) #:position #f #:span #f) +] +} + @deftogether[( @defproc[(source-location->string [loc source-location?]) string?]{} @defproc[(source-location->prefix [loc source-location?]) string?]{} @@ -217,11 +236,9 @@ definition itself and quoting the source location of the macro's arguments. Quotes the source location of @scheme[form] as a @scheme[srcloc] structure, using the location of the whole @scheme[(quote-srcloc)] -expression if no @scheme[expr] is given. When @scheme[expr] has a -source module (in the sense of @scheme[syntax-source-module]), the -module's source path is used form source location, unless a -@scheme[#:module-source expr] is specified, in which case -@scheme[expr] provides the source. +expression if no @scheme[expr] is given. Uses relative directories +for paths found within the collections tree, the user's collections directory, +or the PLaneT cache. @defexamples[#:eval (new-evaluator) (quote-srcloc) @@ -272,80 +289,44 @@ the whole macro application if no @scheme[form] is given. } -@defform[(quote-module-path)]{ +@deftogether[( +@defform[(quote-module-name)] +@defform[(quote-module-path)] +)]{ -Quotes a module path suitable for use with @scheme[require] which -refers to the module in which the macro application occurs. If executed at the -top level, it may return @scheme['top-level], or it may return a valid module -path if the current namespace was constructed by @scheme[module->namespace] -(such as at the DrScheme interactions window). +Quote the name of the module in which the form is compiled. The +@scheme[quote-module-name] form produces a string or a symbol, while +@scheme[quote-module-path] produces a @tech[#:doc reference-path]{module path}. -The @scheme[quote-module-path] form operates by creating a @tech[#:doc reference-path]{variable -reference} (see @scheme[#%variable-reference]) at the point of its application. -It thus automatically describes its final expanded position, rather than the -module of any macro definition that happens to use it. +These forms use relative names for modules found in the collections or PLaneT +cache; their results are suitable for printing, but not for accessing libraries +programmatically, such as via @scheme[dynamic-require]. @defexamples[#:eval (new-evaluator) -(quote-module-path) (module A scheme (require unstable/location) - (define-syntax-rule (here) (quote-module-path)) - (define a (here)) - (provide a here)) + (define-syntax-rule (name) (quote-module-name)) + (define-syntax-rule (path) (quote-module-path)) + (define a-name (name)) + (define a-path (path)) + (provide (all-defined-out))) (require 'A) -a +a-name +a-path (module B scheme (require unstable/location) (require 'A) - (define b (here)) - (provide b)) + (define b-name (name)) + (define b-path (path)) + (provide (all-defined-out))) (require 'B) -b +b-name +b-path +(quote-module-name) +(quote-module-path) [current-namespace (module->namespace (quote 'A))] +(quote-module-name) (quote-module-path) ] } - -@defform[(quote-module-source)]{ - -Like @scheme[quote-module-path], but for the enclosing module's source -name, rather than its module path. The module path and source name are -typically the same, but they can be different. For example, a source -file whose name ends with @filepath{.ss} corresponds to a resolved -module path ending with @filepath{.rkt}. The value produced by -@scheme[(quote-module-source)] is either @scheme['top-level] or a -resolved module path, even though the latter may correspond to a -source file rather than a module path.} - -@defform[(quote-module-name)]{ - -Quotes the name (@tech[#:doc reference-path]{path} or @tech[#:doc -reference-path]{symbol}) of the module in which the macro application occurs, or -@scheme[#f] if it occurs at the top level. As with @scheme[quote-module-path], -@scheme[quote-module-name] uses a @tech[#:doc reference-path]{variable -reference}, so a top level namespace created by @scheme[module->namespace] will -be treated as a module, and the macro will always produce the module name of its -final expanded position. - -@defexamples[#:eval (new-evaluator) -(quote-module-name) -(module A scheme - (require unstable/location) - (define-syntax-rule (here) (quote-module-name)) - (define a (here)) - (provide a here)) -(require 'A) -a -(module B scheme - (require unstable/location) - (require 'A) - (define b (here)) - (provide b)) -(require 'B) -b -[current-namespace (module->namespace (quote 'A))] -(quote-module-name) -] - -} diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index c2b86387dc..b28d1b7ceb 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -73,6 +73,7 @@ Keep documentation and tests up to date. @include-section["bytes.scrbl"] @include-section["contract.scrbl"] +@include-section["dirs.scrbl"] @include-section["exn.scrbl"] @include-section["file.scrbl"] @include-section["list.scrbl"] diff --git a/collects/unstable/srcloc.ss b/collects/unstable/srcloc.ss index 9a1a625ba9..f83d80835a 100644 --- a/collects/unstable/srcloc.ss +++ b/collects/unstable/srcloc.ss @@ -3,8 +3,6 @@ ;; Unstable library by: Carl Eastlund ;; intended for use in scheme/contract, so don't try to add contracts! -(require setup/main-collects) - (provide ;; type predicates @@ -30,6 +28,9 @@ source-location-span source-location-end + ;; update + update-source-location + ;; rendering source-location->string source-location->prefix @@ -57,18 +58,30 @@ (define (source-location-line x) (process-source-location x good-line bad! 'source-location-line)) -(define (source-location-position x) - (process-source-location x good-position bad! 'source-location-position)) - (define (source-location-column x) (process-source-location x good-column bad! 'source-location-column)) +(define (source-location-position x) + (process-source-location x good-position bad! 'source-location-position)) + (define (source-location-span x) (process-source-location x good-span bad! 'source-location-span)) (define (source-location-end x) (process-source-location x good-end bad! 'source-location-end)) +(define dont-update + (string->uninterned-symbol "Don't update!")) + +(define (update-source-location x + #:source [src dont-update] + #:line [line dont-update] + #:column [col dont-update] + #:position [pos dont-update] + #:span [span dont-update]) + (process-source-location x (good-update src line col pos span) bad! + 'update-source-location)) + (define (source-location->string x [s ""]) (process-source-location x (good-string s) bad! 'source-location->string)) @@ -111,6 +124,28 @@ (define (good-span x src line col pos span) span) (define (good-end x src line col pos span) (and pos span (+ pos span))) +(define ((good-update src2 line2 col2 pos2 span2) x src1 line1 col1 pos1 span1) + (let* ([src (if (eq? src2 dont-update) src1 src2)] + [line (if (eq? line2 dont-update) line1 line2)] + [col (if (eq? col2 dont-update) col1 col2)] + [pos (if (eq? pos2 dont-update) pos1 pos2)] + [span (if (eq? span2 dont-update) span1 span2)]) + (if (and (eq? src src1) + (eq? line line1) + (eq? col col1) + (eq? pos pos1) + (eq? span span1)) + x + (rebuild x src line col pos span)))) + +(define (rebuild x src line col pos span) + (cond + [(syntax? x) (datum->syntax x (syntax-e x) (list src line col pos span) x x)] + [(srcloc? x) (make-srcloc src line col pos span)] + [(vector? x) (vector src line col pos span)] + [(or (list? x) src line col pos span) (list src line col pos span)] + [else #f])) + (define (good-srcloc x src line col pos span) (if (srcloc? x) x (make-srcloc src line col pos span))) @@ -128,14 +163,7 @@ (define ((good-string default) x src line col pos span) (format "~a~a" - (cond [(resolved-module-path? src) - (let ([p (resolved-module-path-name src)]) - (if (path? p) - (collects-path p) - p))] - [(path? src) (collects-path src)] - [(not src) default] - [else src]) + (or src default) (if line (if col (format ":~a.~a" line col) @@ -146,16 +174,6 @@ (format "::~a" pos)) "")))) -(define (collects-path path) - (let* ([rel - (with-handlers ([exn:fail? (lambda (exn) path)]) - (path->main-collects-relative path))]) - (if (pair? rel) - (apply build-path - (bytes->path #"") - (map bytes->path-element (cdr rel))) - rel))) - (define ((good-prefix default) x src line col pos span) (let ([str ((good-string default) x src line col pos span)]) (if (string=? str "") "" (string-append str ": ")))) @@ -257,10 +275,8 @@ (syntax-span x))) (define (syntax-get-source x) - (cond - [(syntax-source-module x #t) => - (lambda (src) src)] - [else (syntax-source x)])) + (or (syntax-source x) + (syntax-source-module x #t))) (define (process-list x good bad name) (cond