Install a complete tree

1 files changed, 92 insertions, 26 deletions

diff --git a/install.scm b/install.scm
index d5c42d9..57afda3 100755
--- a/install.scm
+++ b/install.scm
@@ -2,10 +2,11 @@
 -e main -s
 !#
 (use-modules (ice-9 popen)
-             (logging logger)
-             (logging port-log)
              (ice-9 ftw)
              (ice-9 match)
+             (ice-9 and-let-star)
+             (logging logger)
+             (logging port-log)
              (oop goops)
              (term ansi-color))
 
@@ -57,43 +58,108 @@
   (false-if-exception
    (eq? 'symlink (stat:type (lstat path)))))
 
-(define (clean-file full-dest)
-  (when (false-if-exception (lstat full-dest))
-    (log-msg 'WARN (string-append "Deleting previous file: " full-dest))
-    (delete-file full-dest)))
-
-(define (config-links src target)
+(define (clean-file full-dest dry-run)
+  (and-let* ((info (false-if-exception (lstat full-dest)))
+             (type (stat:type info))
+             (deleter (if (eq? type 'directory) rmdir delete-file))
+             (task (if dry-run "Would delete" "Deleting"))
+             (level (if dry-run 'INFO 'WARN)))
+    (log-msg level (format #f "~a ~a: ~a" task type full-dest))
+    (unless dry-run (deleter full-dest))))
+
+(define (rm-tree path dry-run)
+  (define (enter? a b c) #t)
+  (define (down name stat result) result)
+  (define (leaf name stat result)
+    (clean-file name dry-run)
+    result)
+  (define up leaf)
+  (define skip leaf)
+  ;; Ignore unreadable files/directories but warn the user.
+  (define (error name stat errno result)
+    (log-msg 'WARN
+             (format #f "~a: ~a: ~a~%"
+                     errno name (strerror errno)))
+    result)
+
+  (file-system-fold enter? leaf down up skip error
+                    (list 0)
+                    path))
+
+(define (config-links src target dry-run)
   (let ((src-path (expand-file src))
         (target-path (expand-file target)))
     (unless (and (symlink? target-path) (equal? (readlink target-path) src-path))
-      (clean-file target-path)
+      (clean-file target-path dry-run)
       (symlink src-path target-path)
-      (log-msg 'OK (string-append "Symlink" src " -> " target)))))
+      (log-msg 'OK (string-append "  Symlink " src " -> " target)))))
+
+(define (symlink-tree file-name target-path)
+  "Tree recursively symlinks target-path->file-name. The goal is to
+  have few symlinks, yet if in the target space there are some files
+  then symlink the files not the dir"
+
+  (define src-len (string-length file-name))
+
+  (define (enter? name stat result)
+    (let* ((subdir (substring name src-len))
+           (target-subdir (expand-file (string-append target-path subdir))))
+      (false-if-exception (eq? 'directory (stat:type (lstat target-subdir))))))
+
+  (define (leaf name stat result)
+    (let* ((subfile (substring name src-len))
+           (target-subfile (string-append target-path subfile)))
+      (config-links name target-subfile #f))
+
+    (set-car! result (1+ (car result)))
+    result)
+
+  (define (down name stat result)
+    (log-msg 'INFO (format #f "Inspecting ~a" name ))
+    (cons 0 result))
+  (define (up name stat result)
+    (let* ((subdir (substring name src-len))
+           (target-subdir (expand-file (string-append target-path subdir)))
+           (target-subdir-file-count (length (scandir target-subdir
+                                                      (lambda (x)
+                                                        (not (member x (list "." ".."))))))))
+      ;(format #t " up on ~a ~a ~a ~a ~%" result name target-subdir target-subdir-file-count)
+      (when (= (car result) target-subdir-file-count)
+        ;(format #t "~% Clear ~a because is identical to source" name)
+        (leaf name stat result)))
+
+    (list-set! result 1 (1+ (cadr result)))
+    (cdr result))
+  ;; Likewise for skipped directories.
+  (define skip leaf)
+
+  ;; Ignore unreadable files/directories but warn the user.
+  (define (error name stat errno result)
+    (log-msg 'WARN
+             (format #f "~a: ~a: ~a~%"
+                     errno name (strerror errno)))
+    result)
+
+  (file-system-fold enter? leaf down up skip error
+                    (list 0)
+                    file-name))
 
 (define (git-config)
   (log-msg 'INFO "Configuring git")
   (log-msg 'INFO " Symlink global config")
-  (config-links "git/global-gitconfig" "~/.gitconfig")
+  (config-links "git/global-gitconfig" "~/.gitconfig" #f)
   (log-msg 'INFO " Symlink Tribe29 config")
-  (config-links "git/tribe29" "~/git/.gitconfig"))
-
-(define (symlink-dir dir target-dir)
-  (let ((cur (getcwd)))
-    (chdir dir)
-    (map (lambda (cmd)
-           (config-links cmd (string-append target-dir cmd)))
-         (scandir "." (lambda (f) (eq? 'regular (stat:type (stat f))))))
-    (chdir cur)))
+  (config-links "git/tribe29" "~/git/.gitconfig" #f))
 
 (define (main args)
   (setup-logging)
   (log-msg 'INFO "Symlink PIM")
-  (config-links "calendars.conf" "~/.calendars.conf")
+  (config-links "calendars.conf" "~/.calendars.conf" #f)
   (git-config)
-  (config-links "dot-guile" "~/.guile")
-  (config-links "rofi" "~/.config/rofi")
-  (config-links "dot-zshrc" "~/.zshrc")
-  (config-links "gnupu/gpg-agent.conf" "~/.gnupg/gpg-agent")
-  (symlink-dir "bin" "~/.local/bin/")
+  (config-links "dot-guile" "~/.guile" #f)
+  (config-links "dot-zshrc" "~/.zshrc" #f)
+  (config-links "gnupu/gpg-agent.conf" "~/.gnupg/gpg-agent" #f)
+  (symlink-tree "bin" "~/.local/bin")
+  (symlink-tree "config" "~/.config")
 
   (shutdown-logging))