From 23cf6047ae320a1d666ddf6418bade67dfa95ada Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Tue, 2 Aug 2022 02:55:18 +0200
Subject: Add procedure relative-to.

---
 module/hnh/util/path.scm | 31 ++++++++++++++++++++++++++++++-
 1 file changed, 30 insertions(+), 1 deletion(-)

(limited to 'module')

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)))))))))))
-- 
cgit v1.2.3