diff options
| -rw-r--r-- | ccwl/utils.scm | 16 | ||||
| -rw-r--r-- | tests/utils.scm | 14 |
2 files changed, 29 insertions, 1 deletions
diff --git a/ccwl/utils.scm b/ccwl/utils.scm index 5d53639..f2d4260 100644 --- a/ccwl/utils.scm +++ b/ccwl/utils.scm @@ -31,6 +31,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-71) + #:use-module (ice-9 filesystem) #:use-module (ice-9 match) #:use-module (ccwl conditions) #:export (indent-level @@ -42,7 +43,8 @@ map2 foldn filter-mapi - call-with-current-directory)) + call-with-current-directory + resolve-file-syntax)) (define (indent-level port level) "Emit whitespaces to PORT corresponding to nesting LEVEL." @@ -350,3 +352,15 @@ current directory after @var{thunk} returns." (dynamic-wind (cut chdir curdir) thunk (cut chdir original-current-directory)))) + +(define (resolve-file-syntax file-path file-syntax) + "Resolve @var{file-path} relative to the file location of +@var{file-syntax}. If @var{file-syntax} has no source location, +resolve relative to the current directory." + (let ((source-file (assq-ref (syntax-source file-syntax) + 'filename))) + (if (file-name-absolute? file-path) + file-path + (expand-file-name file-path + (and source-file + (dirname (canonicalize-path source-file))))))) diff --git a/tests/utils.scm b/tests/utils.scm index 7ca73b8..735bea8 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -21,6 +21,7 @@ (srfi srfi-1) (srfi srfi-64) (srfi srfi-71) + (ice-9 filesystem) (ccwl conditions) (ccwl utils)) @@ -222,4 +223,17 @@ '((1 . 2) (3 . 4) (5 . 6)) (pairify (list 1 2 3 4 5 6 7))) +(test-equal "resolve file syntax relative path" + (expand-file-name "foo.scm" + (dirname (current-filename))) + (resolve-file-syntax "foo.scm" #'"foo.scm")) + +(test-equal "resolve file syntax absolute path" + "/foo/bar.scm" + (resolve-file-syntax "/foo/bar.scm" #'"/foo/bar.scm")) + +(test-equal "resolve file syntax relative to current directory" + (expand-file-name "foo.scm") + (resolve-file-syntax "foo.scm" (datum->syntax #f "foo.scm" #:source '()))) + (test-end "utils") |