blob: b92de8cd97730c7be5656b6e0667245bc7266918 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
(define-module (hnh util path)
:use-module (srfi srfi-1)
:use-module (srfi srfi-71)
:use-module (hnh util)
:export (path-append
path-absolute?
path-join
path-split
file-hidden?
filename-extension
realpath
relative-to))
(define // file-name-separator-string)
(define /? file-name-separator?)
(define path-absolute? absolute-file-name?)
;; TODO remove intermidiate period components
;; e.x. /a/../b => /b
(define (path-append path . paths)
(fold (lambda (s done)
(string-append
done
(cond ((string-null? s) //)
((and (/? (string-first s))
(/? (string-last done)))
(string-drop s 1))
((or (/? (string-first s))
(/? (string-last done)))
s)
(else (string-append // s)))))
;; If first component is empty, add a leading slash to make
;; the path absolute. This isn't exactly correct if we have
;; drive letters, but on those system the user should make
;; sure that the first component of the path is non-empty.
(if (string-null? path)
// path)
paths))
(define (path-join lst) (apply path-append lst))
;; @example
;; (path-split "usr/lib/test")
;; ⇒ ("usr" "lib" "test")
;; (path-split "usr/lib/test/")
;; ⇒ ("usr" "lib" "test")
;; (path-split "/usr/lib/test")
;; ⇒ ("" "usr" "lib" "test")
;; (path-split "//usr////lib/test")
;; ⇒ ("" "usr" "lib" "test")
;; @end example
(define (path-split path)
(let ((head tail
(car+cdr
(reverse
(map reverse-list->string
(fold (lambda (c done)
(if (/? c)
(cons '() done)
(cons (cons c (car done)) (cdr done))))
'(())
(string->list path)))))))
(cons head (remove string-null? tail))))
(define (file-hidden? path)
(define base (basename path))
(and (not (string-null? base))
(char=? #\. (string-ref base 0))))
(define (filename-extension filename)
(let ((components (-> filename
;; Path split removes potential trailing directory separator
path-split last
basename
(string-split #\.))))
(if (>= 1 (length components))
"" (last components))))
(define (realpath filename)
(unless (string? filename)
(scm-error 'wrong-type-arg "realpath"
"filename not a string: ~a"
(list filename) #f))
(when (string-null? filename)
(scm-error 'wrong-type-arg "realpath"
"filename can't be empty"
#f #f))
(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)))))))))))
|
