;;
;; Utilities
;;

(define (parent-directory fname)
  (file-name-directory (directory-as-file-name fname)))

(define (create-directory&parents fname . rest)
  (let ((parent (parent-directory fname)))
    (if (not (file-exists? parent))
        (apply create-directory&parents parent rest))
    (if (not (file-exists? fname))
        (apply create-directory fname rest))))

;;
;; Regular expressions to match package names
;;

(define number-rx (rx (+ digit)))
(define version-rx (rx ,number-rx (* "." ,number-rx)))
(define package-name-rx (rx (+ (| alphanum ("_")))))
(define package-full-name-rx (rx (submatch ,package-name-rx)
                                 "-"
                                 (submatch ,version-rx)))

;;
;; Versions
;;
;; Versions are represented as lists of integers, the most significant
;; being at the head.

(define (version->string version)
  (string-join (map number->string version) "."))

(define string->version
  (let ((split-version (infix-splitter ".")))
    (lambda (version-string)
      (map string->number (split-version version-string)))))

(define (version-compare v1 v2)
  (cond ((and (null? v1) (null? v2)) 'equal)
        ((null? v1) 'smaller)
        ((null? v2) 'greater)
        (else (let ((v1h (car v1)) (v2h (car v2)))
                (cond ((< v1h v2h) 'smaller)
                      ((> v1h v2h) 'greater)
                      (else (version-compare (cdr v1) (cdr v2))))))))

(define (version<? v1 v2) (eq? (version-compare v1 v2) 'smaller))
(define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater))
(define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal))

;;
;; Packages
;;

(define-record-type package
  (make-package name version install-thunk)
  package?
  (name package:name)
  (version package:version)
  (install-thunk package:install-thunk))

;; List of all defined packages
(define packages '())

;; Add a package to the above list
(define (add-package pkg)
  (set! packages (cons pkg packages)))

(define-syntax define-package
  (syntax-rules ()
    ((define-package name version body ...)
     (add-package (make-package name
                                (quote version)
                                (lambda () body ...))))))

;;
;; Names of various directories/links
;;

;; Directory in which active versions of packages are "remembered".
(define (active-directory root)
  (absolute-file-name "active" root))

;; Directory in which packages are installed.
(define (installed-directory root)
  (absolute-file-name "installed" root))

(define (package-dir-name root pkg)
  (absolute-file-name (package:name pkg) (installed-directory root)))

(define (package-version-dir-name root pkg)
  (absolute-file-name (version->string (package:version pkg))
                      (package-dir-name root pkg)))

(define (active-link-name root pkg)
  (absolute-file-name (package:name pkg) (active-directory root)))

;;
;; Queries
;;

(define (packages-of dir)
  (with-cwd dir (filter file-directory? (directory-files))))

;; Get the name of all installed packages (without versions) as a list
;; of strings.
(define (installed-packages root)
  (packages-of (installed-directory root)))

;; Get the name of all active packages (without versions) as a list of
;; strings.
(define (active-packages root)
  (packages-of (active-directory root)))

;; Return the list of all installed packages and their version(s), as
;; a list of pairs. The CAR of each pair contains the name of the
;; package, the CDR contains the list of all available versions.
(define (installed-packages&versions root)
  (with-cwd (installed-directory root)
            (map (lambda (pkg-dir)
                   (cons pkg-dir
                         (map string->version (directory-files pkg-dir))))
                 (directory-files))))

(define (read-version pkg-link)
  (string->version (file-name-nondirectory (read-symlink pkg-link))))

;; Return the list of all active packages and their version, as a list
;; of pairs. The CAR of each pair contains the name of the package,
;; and the CDR contains the active version.
(define (active-packages&versions root)
  (with-cwd (active-directory root)
            (map (lambda (pkg-dir)
                   (cons pkg-dir (read-version pkg-dir)))
                 (directory-files))))

;; Return the active version of package NAME.
(define (active-version root name)
  (read-version (absolute-file-name name (active-directory root))))

;;
;; Actions
;;

;; Perform all actions required to make the given version of the
;; package active (i.e. the default version for that package).
(define (activate-package root pkg)
  (let ((lnk-name (active-link-name root pkg)))
    (if (and (file-exists? lnk-name) (file-symlink? lnk-name))
        (delete-file lnk-name))
    (create-symlink (package-version-dir-name root pkg) lnk-name)))

(define (target-absolute-dir root pkg dir)
  (absolute-file-name (directory-as-file-name dir)
                      (package-version-dir-name root pkg)))

(define (re-root-file file dir)
  (absolute-file-name (file-name-nondirectory (directory-as-file-name file))
                      dir))

(define (copy-file src target perms)
  (run (cp ,src ,target))
  (set-file-mode target (bitwise-and perms (bitwise-not (umask)))))

; (define (copy-file src target perms)
;   (format #t "copying ~a to ~a, perms ~a\n" src target perms))

;; Copy the list of FILES to the TARGET-DIR and set their permission
;; to PERMS masked by the current umask. The TARGET-DIR (default ".")
;; is relative to the package directory given by ROOT, NAME and
;; VERSION.
(define (install-files% root pkg files . rest)
  (let-optionals rest ((target-dir ".") (perms #o777))
    (let* ((target-abs-dir (target-absolute-dir root pkg target-dir)))
      (create-directory&parents target-abs-dir perms)
      (for-each (lambda (file)
                  (copy-file file (re-root-file file target-abs-dir) perms))
                files))))

;; Copy SRC-DIR and all its contents in TARGET-DIR, and set the
;; permission for everything to PERMS (default #o777), masked by the
;; current umask. The TARGET-DIR (default ".") is relative to the
;; package directory given by ROOT, NAME and VERSION.
(define (install-directory% root pkg src-dir . rest)
  (let-optionals rest ((target-dir ".") (perms #o777))
    (let* ((src-dir-name (file-name-nondirectory
                          (directory-as-file-name src-dir)))
           (full-target-dir (absolute-file-name src-dir-name target-dir))
           (target-abs-dir (target-absolute-dir root pkg full-target-dir)))
      (create-directory&parents target-abs-dir perms)
      (for-each
       (lambda (file)
         (let ((abs-file (absolute-file-name file src-dir)))
           (cond ((file-regular? abs-file)
                  (copy-file abs-file
                             (absolute-file-name file target-abs-dir)
                             perms))
                 ((file-directory? abs-file)
                  (install-directory% root pkg abs-file full-target-dir perms))
                 (else
                  (error "don't know what to do with file" abs-file)))))
       (directory-files src-dir #t)))))

(define *root* (make-fluid #f))
(define *package* (make-fluid #f))

(define (forward-args-prepend-fluids target-fn args)
  (apply target-fn (fluid *root*) (fluid *package*) args))

(define (install-file file . rest)
  (apply install-files (list file) rest))

(define (install-files . args)
  (forward-args-prepend-fluids install-files% args))

(define (install-directory . args)
  (forward-args-prepend-fluids install-directory% args))

(define (install-directories src-dirs . rest)
  (for-each (lambda (src-dir)
              (apply install-directory src-dir rest))
            src-dirs))

(define (install-package root pkg)
  (let-fluids *root* root
              *package* pkg
              (lambda ()
                ((package:install-thunk pkg)))))

(define options
 (list (option '(#\r "root") #t #f
               (lambda (option name arg root activate?)
                 (values arg activate?)))
       (option '(#\i "inactive") #f #f
               (lambda (option name arg root activate?)
                 (values root #f)))))

(define (install-main cmd-line)
  (let ((prog (car cmd-line))
        (args (cdr cmd-line)))
    (receive (root activate?)
             (args-fold args
                        options
                        (lambda (option name arg . seeds)
                          (error "Unknown option:" name))
                        (lambda (operand root activate?) ; operand
                          (error "No operands accepted" operand))
                        #f              ; default root
                        #t)             ; default activation
             (if (not root)
                 (error "No package root specified (use --root option)"))
             (load "pkg-def.scm")
             (for-each (lambda (pkg)
                         (install-package root pkg)
                         (if activate?
                             (activate-package root pkg)))
                       packages))))