suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Allow `path-up' to take multiple paths.

Browse Source 
svn: r18415
This commit is contained in:
Sam Tobin-Hochstadt 2010-03-01 21:27:03 +00:00
parent 1c1a2dde38
commit 83cdaac011
2 changed files with 36 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/scheme/require.ss
View File

@ -68,26 +68,31 @@
(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)))
(syntax-case stx ()
[(_ path-stx ...)
(for/and ([ps (in-list (syntax->list #'(path-stx ...)))])
(let ([s (syntax-e ps)]) (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)] [pathstr path])
(if (file-exists? path)
(datum->syntax stx pathstr stx)
(let ([dir (dirname dir)])
(if dir
(loop dir (build-path 'up path)
(string-append "../" pathstr))
(raise-syntax-error 'path-up
"file no found in any parent directory"
stx #'path-stx)))))))]))
(dirname src)
(or (current-load-relative-directory)
(current-directory)))])
(with-syntax
([(paths ...)
(for/list ([ps (in-list (syntax->list #'(path-stx ...)))])
(define path (syntax-e ps))
(unless (complete-path? srcdir) (error 'path-up "internal error"))
(parameterize ([current-directory srcdir])
(let loop ([dir srcdir] [path (string->path path)] [pathstr path])
(if (file-exists? path)
(datum->syntax stx pathstr stx stx)
(let ([dir (dirname dir)])
(if dir
(loop dir (build-path 'up path)
(string-append "../" pathstr))
(raise-syntax-error 'path-up
"file no found in any parent directory"
stx ps)))))))])
(syntax/loc stx (combine-in paths ...))))]))

23
collects/scribblings/reference/syntax.scrbl
View File

@ -11,7 +11,8 @@
scheme/provide
scheme/nest
scheme/package
scheme/splicing))
scheme/splicing
scheme/runtime-path))
@(define require-eval (make-base-eval))
@(define syntax-eval
@ -1078,11 +1079,11 @@ aliens
will get the @scheme[scheme/base] bindings that match the regexp,
and renamed to use ``camel case.''}
@defform[(path-up rel-string)]{
@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
This specifies paths to module named by the @scheme[rel-string]s in a
similar way to using the @scheme[rel-string]s directly, except that if the
required module files are not found there, they are searched for 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
@ -1092,16 +1093,16 @@ 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
@schememod[
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
@schememod[
scheme/base
(require scheme/runtime-path)
(provide in-here-transformer)
(define-runtime-path here ".")
@ -1111,7 +1112,7 @@ and in @filepath{utils/in-here.ss} in the root:
(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))]