From 518a9d2df1e3f5e133a726f81e6bab49a51aed17 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Tue, 17 Nov 2009 08:11:44 +0000
Subject: [PATCH] added path-up to scheme/require

svn: r16824
---
 collects/scheme/require.ss                  | 28 +++++++++++-
 collects/scribblings/reference/syntax.scrbl | 48 +++++++++++++++++++++
 2 files changed, 75 insertions(+), 1 deletion(-)

diff --git a/collects/scheme/require.ss b/collects/scheme/require.ss
index d2e27c83fb..0349b3df30 100644
--- a/collects/scheme/require.ss
+++ b/collects/scheme/require.ss
@@ -1,7 +1,8 @@
 #lang scheme/base
 
 (require (for-syntax scheme/base scheme/require-transform scheme/list
-                     "private/at-syntax.ss"))
+                     "private/at-syntax.ss")
+         "require-syntax.ss")
 
 (provide matching-identifiers-in)
 (define-syntax matching-identifiers-in
@@ -63,3 +64,28 @@
                       [else (error 'filtered-in "bad result: ~e" s2)])))
             imports)
            sources))]))))
+
+(provide path-up)
+(define-require-syntax (path-up stx)
+  (syntax-case stx ()
+    [(_ path-stx)
+     (let ([s (syntax-e #'path-stx)]) (and (string? s) (module-path? s)))
+     (let* ([src (syntax-source stx)]
+            [dirname (lambda (path)
+                       (let-values ([(dir name dir?) (split-path path)]) dir))]
+            [srcdir (if (and (path-string? src) (complete-path? src))
+                      (dirname src)
+                      (or (current-load-relative-directory) 
+                          (current-directory)))])
+       (define path (syntax-e #'path-stx))
+       (unless (complete-path? srcdir) (error 'path-up "internal error"))
+       (parameterize ([current-directory srcdir])
+         (let loop ([dir srcdir] [path (string->path path)])
+           (if (file-exists? path)
+             (datum->syntax stx (path->string path) stx)
+             (let ([dir (dirname dir)])
+               (if dir
+                 (loop dir (build-path 'up path))
+                 (raise-syntax-error 'path-up
+                                     "file no found in any parent directory"
+                                     stx #'path-stx)))))))]))
diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl
index 6522e404f4..2aafe83deb 100644
--- a/collects/scribblings/reference/syntax.scrbl
+++ b/collects/scribblings/reference/syntax.scrbl
@@ -1075,6 +1075,54 @@ aliens
   will get the @scheme[scheme/base] bindings that match the regexp,
   and renamed to use ``camel case.''}
 
+@defform[(path-up rel-string)]{
+
+This specifies a path to a module named @scheme[rel-string] in a
+similar way to using @scheme[rel-string] directly, except that if the
+required module file is not found there, it is searched in the parent
+directory (in @filepath{../@scheme[_rel-string]}), and then in
+the grand-parent directory, going all the way up to the root.  (Note
+that the usual caveats hold for a macro that depends on files that it
+looks for to determine its expansion: the resulting path becomes part
+of the compiled form.)
+
+This form is useful in setting up a ``project environment''.  For
+example, you can write a @filepath{config.ss} file in the root
+directory of your project with:
+@verbatim[#:indent 2]{
+  #lang scheme/base
+  (require scheme/require-syntax (for-syntax "utils/in-here.ss"))
+  ;; require form for my utilities
+  (provide utils-in)
+  (define-require-syntax utils-in in-here-transformer)
+}
+and in @filepath{utils/in-here.ss} in the root:
+@verbatim[#:indent 2]{
+  #lang scheme/base
+  (require scheme/runtime-path)
+  (provide in-here-transformer)
+  (define-runtime-path here ".")
+  (define (in-here-transformer stx)
+    (syntax-case stx ()
+      [(_ sym)
+       (identifier? #'sym)
+       (let ([path (build-path here (format "~a.ss" (syntax-e #'sym)))])
+         (datum->syntax stx `(file ,(path->string path)) stx))]))
+}
+Finally, you can use it via @scheme[path-up]:
+@schemeblock[
+  (require scheme/require (path-up "config.ss") (utils-in foo))]
+Note that the order of requires in this form is important, as each of
+the first two bind the identifier used in the following.
+
+An alternative in this scenario is to use @scheme[path-up] directly to
+get to the utility module:
+@schemeblock[
+  (require scheme/require (path-up "utils/foo.ss"))]
+but then you need to be careful with subdirectories that are called
+@filepath{utils}, which will override the one in the project's root.
+In other words, the previous method requires a single unique name.}
+
 @; --------------------
 
 @subsection{Additional @scheme[provide] Forms}