blob: 7922a48858614994a57de091ba8337ca000f0108 (
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
|
#!/usr/bin/guile --no-auto-compile
!#
(use-modules (ice-9 ftw)
(ice-9 i18n)
(ice-9 match)
(srfi srfi-1)
(srfi srfi-11)
(srfi srfi-26))
(define (recursive-scandir dir)
"Return a list of all the file names in DIR, recursively."
(define (components file)
(string-split file #\/))
(define suffix
(let ((prefix-length (length (components dir))))
(lambda (file)
(string-join (drop (components file) prefix-length) "/"))))
(define enter? (const #t))
(define (leaf name stat result)
(cons (suffix name) result))
;; No-op
(define (down name stat result) result)
(define (up name stat result) result)
(define (skip name stat result) result)
(define (error name stat errno result) result)
(let-values (((files discard)
(file-system-fold enter? leaf down up skip error '() dir)))
(sort files string-locale<?)))
(define (mkdir-p dir)
"Create directory DIR and all its ancestors."
(define absolute?
(string-prefix? "/" dir))
(define not-slash
(char-set-complement (char-set #\/)))
(let loop ((components (string-tokenize dir not-slash))
(root (if absolute?
""
".")))
(match components
((head tail ...)
(let ((path (string-append root "/" head)))
(catch 'system-error
(lambda ()
(mkdir path)
(loop tail path))
(lambda args
(if (= EEXIST (system-error-errno args))
(loop tail path)
(apply throw args))))))
(() #t))))
(define (symlink? file)
"Return #t if FILE is a symbolic link."
(eq? (stat:type (lstat file)) 'symlink))
(define (already-linked? src-file dest-file)
"Return #t if SRC-FILE is a symbolic link to DEST-FILE."
(and (symlink? dest-file)
(string=? (readlink dest-file) src-file)))
(define %home (getenv "HOME"))
(define %dotfiles-dir
(string-append (getcwd) "/dotfiles"))
(define (install-dotfile file)
"Create a symlink to FILE in the current user's home directory."
(let ((src-file (string-append %dotfiles-dir "/" file))
(dest-file (string-append %home "/" file)))
(cond
((not (file-exists? dest-file))
(format #t "~a → ~a~%" file dest-file)
(mkdir-p (dirname dest-file))
(symlink src-file dest-file))
((already-linked? src-file dest-file)
(format #t "~a already installed~%" file))
(else
(error "destination file already exists: " dest-file)))))
(define %dotfiles
(recursive-scandir "dotfiles"))
(for-each install-dotfile %dotfiles)
|
