utils: Add resolve-file-syntax.

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