* unstable/srcloc.ss

Added `update-source-location', which provides keyword-based functional update
for source location representations.

Removed automatic collection-relative printing for source locations.

* unstable/location.ss

Made `quote-srcloc' and its related forms all automatically use source locations
relative to collections and/or planet, where appropriate, and to compute
source locations dynamically if they cannot be made relative.

Removed #:module-source argument from `quote-srcloc'.

Changed `quote-module-path' and `quote-module-name' to use source file name
extensions.

Removed `quote-module-source'.  I'm not sure what the use case is for
generating a resolved module path that doesn't correspond to a real module.

* unstable/dirs.ss

Implemented `path->directory-relative-string' for rendering a path to a string
that is relative to one of a list of given directories, with associated
abbreviations for each.

* unstable/scribblings/unstable.scrbl
* unstable/scribblings/srcloc.scrbl
* unstable/scribblings/dirs.scrbl

Documented the above changes.

* scheme/contract/private/provide.ss
* scheme/contract/private/base.ss

Changed contract forms to always blame a module path where appropriate.

Removed use of #:module-source option for `quote-srcloc'.

* setup/private/path-utils.ss

Updated `path->name' to use more general `path->directory-relative-string'.

svn: r18816

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 ()

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))))))]))

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)
+  (path->directory-relative-string
-    (define rel (path->rel path find-base))
+   path
-    (and (pair? rel)
+   #:dirs (cond
-         (let* ([p (append-map (lambda (p) (list #"/" p)) (cdr rel))]
+           [find-base (list (cons find-base prefix))]
-                [p (if (null? p)
+           [prefix (list (cons find-collects-dir prefix))]
-                     ""
+           [else setup-relative-directories])))
-                     (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))))

collects/unstable/dirs.ss

@@ -0,0 +1,68 @@
+#lang scheme/base
+
+;; Unstable library by: Carl Eastlund <cce@ccs.neu.edu>
+;; 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))

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)])
+     (let* ([src (build-source-location #'loc)])
-       #'(make-srcloc (quote arg) ...))]
+       (cond
-    [(_ loc #:module-source alt-src)
+        [(and
-     (with-syntax ([(src arg ...) (build-source-location-list #'loc)])
+          (path-string? (srcloc-source src))
-       (with-syntax ([alt-src (if (syntax-source-module #'loc)
+          (path->directory-relative-string (srcloc-source src) #:default #f))
-                                  #'alt-src
+         =>
-                                  #'(quote src))])
+         (lambda (rel)
-         #'(make-srcloc alt-src (quote arg) ...)))]))
+           (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)
+(define-syntax-rule (define-quote-srcloc-accessors [name accessor] ...)
-  (syntax-case stx ()
+  (define-syntaxes [ name ... ]
-    [(_) #`(quote-source-file #,stx)]
+    (values
-    [(_ loc) #`(quote #,(source-location-source #'loc))]))
+     (lambda (stx)
+       (syntax-case stx ()
+         [(_) #`(name #,stx)]
+         [(_ loc) #`(accessor (quote-srcloc loc))]))
+     ...)))
 
-(define-syntax (quote-line-number stx)
+(define-quote-srcloc-accessors
-  (syntax-case stx ()
+  [quote-source-file source-location-source]
-    [(_) #`(quote-line-number #,stx)]
+  [quote-line-number source-location-line]
-    [(_ loc) #`(quote #,(source-location-line #'loc))]))
+  [quote-column-number source-location-column]
-
+  [quote-character-position source-location-position]
-(define-syntax (quote-column-number stx)
+  [quote-character-span source-location-span])
-  (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-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)
+(define (module-source->module-name src)
-  (variable-reference->module-src (#%variable-reference)))
+  (or src 'top-level))
 
-(define (variable-reference->module-path var)
+(define (module-source->module-path src)
-  (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)
   (cond
-   [(path? name) `(file ,(path->string name))]
+   [(path? src) `(file ,(path->string src))]
-   [(symbol? name) `(quote ,name)]
+   [(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)))

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["<path>/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].
+
+}

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
+expression if no @scheme[expr] is given.  Uses relative directories
-source module (in the sense of @scheme[syntax-source-module]), the
+for paths found within the collections tree, the user's collections directory,
-module's source path is used form source location, unless a
+or the PLaneT cache.
-@scheme[#:module-source expr] is specified, in which case
-@scheme[expr] provides the source.
 
 @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
+Quote the name of the module in which the form is compiled.  The
-refers to the module in which the macro application occurs.  If executed at the
+@scheme[quote-module-name] form produces a string or a symbol, while
-top level, it may return @scheme['top-level], or it may return a valid module
+@scheme[quote-module-path] produces a @tech[#:doc reference-path]{module path}.
-path if the current namespace was constructed by @scheme[module->namespace]
-(such as at the DrScheme interactions window).
 
-The @scheme[quote-module-path] form operates by creating a @tech[#:doc reference-path]{variable
+These forms use relative names for modules found in the collections or PLaneT
-reference} (see @scheme[#%variable-reference]) at the point of its application.
+cache; their results are suitable for printing, but not for accessing libraries
-It thus automatically describes its final expanded position, rather than the
+programmatically, such as via @scheme[dynamic-require].
-module of any macro definition that happens to use it.
 
 @defexamples[#:eval (new-evaluator)
-(quote-module-path)
 (module A scheme
   (require unstable/location)
-  (define-syntax-rule (here) (quote-module-path))
+  (define-syntax-rule (name) (quote-module-name))
-  (define a (here))
+  (define-syntax-rule (path) (quote-module-path))
-  (provide a here))
+  (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))
+  (define b-name (name))
-  (provide b))
+  (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)
-]
-
-}

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"]

collects/unstable/srcloc.ss

@@ -3,8 +3,6 @@
 ;; Unstable library by: Carl Eastlund <cce@ccs.neu.edu>
 ;; 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)
+          (or src default)
-                 (let ([p (resolved-module-path-name src)])
-                   (if (path? p)
-                       (collects-path p)
-                       p))]
-                [(path? src) (collects-path src)]
-                [(not src) default]
-                [else src])
           (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 #"<collects>")
-             (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
+  (or (syntax-source x)
-   [(syntax-source-module x #t) =>
+      (syntax-source-module x #t)))
-    (lambda (src) src)]
-   [else (syntax-source x)]))
 
 (define (process-list x good bad name)
   (cond