diff options
Diffstat (limited to 'install.scm')
-rwxr-xr-x | install.scm | 92 |
1 files changed, 92 insertions, 0 deletions
diff --git a/install.scm b/install.scm new file mode 100755 index 0000000..7922a48 --- /dev/null +++ b/install.scm @@ -0,0 +1,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) |