Add dots.scm main

3 files changed, 143 insertions, 31 deletions

@@ -1,31 +0,0 @@
-My dotfiles
-there are many like them
-but these ones are mine
-
-----------
-Installing
-----------
-
-- ./dots.sh
-
-see ./dots.sh -h for more details
-
-I don't remember what -d means.
-
------------
-What's here
------------
-
-- bash / shell stuff
-- emacs
-- x stuff
-- various other repl type stuff
-
-------
-TO ADD
-------
-
-- i3 config
-- msmtp config (must remove PII)
-- keepassxc ?? (can it do the two part config thing?)
-- ... ?
\ No newline at end of file
@@ -0,0 +1,4 @@
+# dots by acdw
+
+these are my dotfiles.
+there are many like them but these ones is mine
@@ -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))