From 56236c0e1aed4166fac8bd5908f28ddc5f928c96 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 19 May 2015 09:02:17 -0400
Subject: Update dotfiles with new Guile-based installer.

---
 install.scm | 92 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 92 insertions(+)
 create mode 100755 install.scm

(limited to 'install.scm')

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