From b57ac15729899892387cf04efed3aca5e2f43ae8 Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Sun, 14 Jul 2024 21:28:33 -0500
Subject: Add dots.scm

---
 dots.scm | 139 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 139 insertions(+)
 create mode 100755 dots.scm

(limited to 'dots.scm')

diff --git a/dots.scm b/dots.scm
new file mode 100755
index 0000000..e22e7f8
--- /dev/null
+++ b/dots.scm
@@ -0,0 +1,139 @@
+;;; dots/dots.scm --- dots management tool
+;; by Case Duckworth
+
+(import scheme (chicken base)
+        (chicken file)
+        (chicken file posix)
+        (chicken pathname)
+        (chicken process-context)
+        (chicken string))
+
+(define QUIET (make-parameter #f))
+(define NORUN (make-parameter #f))
+(define FORCE (make-parameter #f))
+(define DOTSD
+  (make-parameter
+   (let ((exec-dir (pathname-directory (executable-pathname))))
+     (if (and exec-dir (not (substring-index "csi" exec-dir)))
+         exec-dir
+         (pathname-directory (program-name))))))
+
+(define usage-string
+  (string-append
+   "dots/dots: install dotfiles
+Usage: dots/dots [-h] [-q] [-n] [-f] [-x] [-d] [-D DIR] [FILE...]
+Flags:
+  -h    Show this help and exit
+  -q    Don't print what's happening
+  -n    *Only* print what would happen
+  -f    Force links with ln -f
+  -d    Link from FILE *to* the dots dir.
+        Default: link from FILE to $HOME.
+Options:
+  -D DIR
+        Define DIR as the dotfile-directory.
+        Default: The script's directory (" (DOTSD) ")
+Parameters:
+  FILE  File or directory to link.
+"))
+
+(define (getfiles files)
+  ;; find all of the files in FILES, descending directories
+  (let loop ((files files)
+             (lst '()))
+    (if (null? files) (if (list? lst) lst (list lst))
+        (let ((this (car files)))
+          (if (or (substring-index "README" this) ; Ignore these files
+                  (substring-index "dots" this))
+              (loop files lst)
+              ;; Add the current file to the list recursively
+              (loop (cdr files)
+                    (if (directory-exists? this)
+                        (append (find-files this
+                                            test: (complement directory?))
+                                lst)
+                        (cons this lst))))))))
+
+(define (mklink from to)
+  (let ((to-dir (pathname-directory to)))
+    (cond
+     ((not (file-exists? from))
+      (die 3 "Cannot find" from))
+     ((not (file-exists? to))
+      (echo "* ln" from to)
+      #;(file-link from to))
+     ((and (FORCE) (file-exists? to))
+      (echo "* ln -f" from to)
+      #;(file-link from to))
+     (else (echo to "exists: skipping")))))
+
+(define (homify files)
+  (for-each (lambda (f)
+              (mklink f (make-pathname
+                         (get-environment-variable "HOME")
+                         "" ; is this smart?
+                         (string-intersperse
+                          (receive (_ _ els) (decompose-directory f) els)
+                          "/"))))
+            (getfiles files)))
+
+(define (dotify files)
+  (for-each (lambda (f)
+              (mklink f (make-pathname
+                         (DOTSD) (substring f (+ 1 (substring-index "." f))))))
+            (getfiles files)))
+
+(define (main args)
+  (let loop ((action homify)
+             (args args))
+    (if (null? args)
+        (die 1 "Need at least one file argument")
+        (begin
+          (cond
+           ((not (string=? "-" (substring (car args) 0 1))) ; End of flags
+            (action args)
+            (exit 0))
+           ((or (string=? (car args) "-h")
+                (string=? (car args) "-help"))
+            (die 0 usage-string))
+           ((or (string=? (car args) "-q")
+                (string=? (car args) "-quiet"))
+            (QUIET #t))
+           ((or (string=? (car args) "-n")
+                (string=? (car args) "-norun"))
+            (NORUN #t))
+           ((or (string=? (car args) "-f")
+                (string=? (car args) "-force"))
+            (FORCE #t))
+           ((or (string=? (car args) "-d")
+                (string=? (car args) "-dotify"))
+            (set! action dotify))
+           ((or (string=? (car args) "-D")
+                (string=? (car args) "-dotsdir"))
+            (when (null? (cdr args))
+              (die 4 "-D needs an argument"))
+            (DOTSD (cadr args))
+            (loop action (cddr args)))
+           (else (die 2 "Unknown argument: " (car args))))
+          (loop action (cdr args))))))
+
+(define (echo . strs)
+  (unless (QUIET)
+    (parameterize ((current-output-port (current-error-port)))
+      (display (string-intersperse strs " "))
+      (newline))))
+
+(define (die exit-code . message)
+  (cond-expand
+    ((or compiling chicken-script)
+     (parameterize ((current-output-port (current-error-port)))
+       (display (string-intersperse message " "))
+       (newline)
+       (display usage-string)
+       (exit exit-code)))
+    (else (error message))))
+
+(cond-expand
+  ((or compiling chicken-script)
+   (main (command-line-arguments)))
+  (else))
-- 
cgit 1.4.1-21-gabe81