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