Add procedure relative-to.

3 files changed, 72 insertions, 1 deletions

diff --git a/doc/ref/guile/util-path.texi b/doc/ref/guile/util-path.texi
index 2a53ba91..cf99a170 100644
--- a/doc/ref/guile/util-path.texi
+++ b/doc/ref/guile/util-path.texi
@@ -43,3 +43,20 @@ Returns the extension of the filename, or the empty string if none exists.
 Equivalent of realpath(3). Absolute file names are returned as is,
 while relative filenames gets expanded to absolute filenames.
 @end defun
+
+@defun relative-to base path
+Returns @var{path} as a relative path relative to @var{base}.
+
+base must be non-empty
+@example
+(relative-to "/some" "/some/path")
+;; ⇒ "path"
+
+(relative-to "/some" "/other/path/")
+;; ⇒ "../path"
+
+(relative-to "/a/b/c" "/a/b")
+;; ⇒ "/a/b"
+@end example
+
+@end defun
diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm
index 0c8af48a..ed2d9f24 100644
--- a/module/hnh/util/path.scm
+++ b/module/hnh/util/path.scm
@@ -8,7 +8,8 @@
            path-split
            file-hidden?
            filename-extension
-           realpath))
+           realpath
+           relative-to))
 
 (define // file-name-separator-string)
 (define /? file-name-separator?)
@@ -90,3 +91,31 @@
   (if (absolute-file-name? filename)
       filename
       (path-append (getcwd) filename)))
+
+
+(define (relative-to base path)
+  ;; (typecheck base string?)
+  ;; (typecheck path string?)
+
+  (when (string-null? base)
+    (error "Base can't be empty" ))
+
+  (let ((base (if (absolute-file-name? base)
+                  base
+                  (path-append (getcwd) base))))
+
+    (cond ((equal? '("") base) path)
+          ((not (absolute-file-name? path))
+           (path-append base path))
+          (else
+           (let loop ((a (path-split base))
+                      (b (path-split path)))
+             (cond
+              ((null? a) (path-join b))
+              ((null? b) path)
+              ((string=? (car a) (car b)) (loop (cdr a) (cdr b)))
+              (else
+               (path-join
+                (append
+                 (make-list (length a) "..")
+                 (drop b (length a)))))))))))
diff --git a/tests/test/util.scm b/tests/test/util.scm
index 1de96a37..ab50898a 100644
--- a/tests/test/util.scm
+++ b/tests/test/util.scm
@@ -14,6 +14,7 @@
                         path-split
                         file-hidden?
                         realpath
+                        relative-to
                         filename-extension)))
 
 (test-equal "when"
@@ -295,6 +296,30 @@
    (lambda () (realpath "/home/hugo"))))
 
 
+(test-group "Relative to"
+
+  (test-group "With relative child"
+    (test-equal "/some/path" (relative-to "/some" "path")))
+
+  ;; Relative parent just adds (getcwd) to start of parent,
+  ;; but this is "hard" to test.
+  ;; (test-group "With relative parent")
+
+  (test-group "With absolute child"
+    (test-error 'misc-error (relative-to "" "/some/path"))
+    (test-equal "some/path" (relative-to "/" "/some/path"))
+    (test-group "Without trailing slashes"
+      (test-equal "path" (relative-to "/some" "/some/path"))
+      (test-equal "../path" (relative-to "/some" "/other/path")))
+    (test-group "With trailing slashes"
+      (test-equal "path" (relative-to "/some" "/some/path/"))
+      (test-equal "../path" (relative-to "/some" "/other/path/"))))
+
+  (test-equal "/a/b" (relative-to "/a/b/c" "/a/b"))
+
+  )
+
+
 (test-equal "Extension of simple file"
   "txt" (filename-extension "file.txt"))