;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (dotfiles)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (install-dotfiles))

(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))

  ;; Ignore the backup files that Emacs makes.
  (define ignore?
    (let ((patterns (map make-regexp '("~$" "^\\.#" "^#"))))
      (lambda (file)
	(let ((base (basename file)))
	  (any (cut regexp-exec <> base) patterns)))))

  (define (leaf name stat result)
    (if (ignore? name)
	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 (install-dotfiles src-dir dest-dir)
  "Symlink the dotfiles in SRC-DIR to DEST-DIR."
  
  (define (install-dotfile file)
    (let ((src-file (string-append src-dir "/" file))
	  (dest-file (string-append dest-dir "/" 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)))))

  (for-each install-dotfile (recursive-scandir src-dir)))