;;;; client.lisp

(in-package #:quicklisp-client)

(defvar *quickload-verbose* nil
  "When NIL, show terse output when quickloading a system. Otherwise,
  show normal compile and load output.")

(defvar *quickload-prompt* nil
  "When NIL, quickload systems without prompting for enter to
  continue, otherwise proceed directly without user intervention.")

(defvar *quickload-explain* t)

(define-condition system-not-quickloadable (error)
  ((system
    :initarg :system
    :reader not-quickloadable-system)))

(defgeneric quickload (systems &key verbose prompt explain &allow-other-keys)
  (:documentation
   "Load SYSTEMS the quicklisp way. SYSTEMS is a designator for a list
   of things to be loaded.")
  (:method (systems &key
            (prompt *quickload-prompt*)
            (verbose *quickload-verbose*) &allow-other-keys)
    (unless (consp systems)
      (setf systems (list systems)))
    (dolist (thing systems systems)
      (flet ((ql ()
               (autoload-system-and-dependencies thing :prompt prompt)))
        (if verbose
            (ql)
            (call-with-quiet-compilation #'ql))))))

(defmethod quickload :around (systems &key verbose prompt explain
                                      &allow-other-keys)
  (declare (ignorable systems verbose prompt explain))
  (with-consistent-dists
    (call-next-method)))

(defun system-list ()
  (provided-systems t))

(defun update-dist (dist &key (prompt t))
  (when (stringp dist)
    (setf dist (find-dist dist)))
  (let ((new (available-update dist)))
    (cond (new
           (show-update-report dist new)
           (when (or (not prompt) (press-enter-to-continue))
             (update-in-place dist new)))
          ((not (subscribedp dist))
           (format t "~&You are not subscribed to ~S."
                   (name dist)))
          (t
           (format t "~&You already have the latest version of ~S: ~A.~%"
                   (name dist)
                   (version dist))))))

(defun update-all-dists (&key (prompt t))
  (let ((dists (remove-if-not 'subscribedp (all-dists))))
    (format t "~&~D dist~:P to check.~%" (length dists))
    (dolist (old dists)
      (with-simple-restart (skip "Skip update of dist ~S" (name old))
        (update-dist old :prompt prompt)))))

(defun available-dist-versions (name)
  (available-versions (find-dist-or-lose name)))

(defun help ()
  "For help with Quicklisp, see http://www.quicklisp.org/beta/")

(defun uninstall (system-name)
  (let ((system (find-system system-name)))
    (cond (system
           (ql-dist:uninstall system))
          (t
           (warn "Unknown system ~S" system-name)
           nil))))

(defun uninstall-dist (name)
  (let ((dist (find-dist name)))
    (when dist
      (ql-dist:uninstall dist))))

(defun write-asdf-manifest-file (output-file
                                 &key (if-exists :rename-and-delete))
  "Write a list of system file pathnames to OUTPUT-FILE, one per line,
in order of descending QL-DIST:PREFERENCE."
  (when (or (eql output-file nil)
            (eql output-file t))
    (setf output-file (qmerge "manifest.txt")))
  (with-open-file (stream output-file
                          :direction :output
                          :if-exists if-exists)
    (with-consistent-dists
      ;; FIXME: Should avoid emitting lines for systems with system
      ;; files with a pathname-name that does not match the system
      ;; name. They're not normally loadable anyway.
      (let ((systems (provided-systems t)))
        (dolist (system (sort systems #'>
                              :key #'preference))
          ;; FIXME: find-asdf-system-file does another find-system
          ;; behind the scenes. Bogus. Should be a better way to go
          ;; from system object to system file.
          (let* ((system-file (find-asdf-system-file (name system)))
                 (enough (and system-file (enough-namestring system-file
                                                             output-file)))
                 (native (and enough (native-namestring enough))))
            (when native
              (format stream "~A~%" native)))))))
  (probe-file output-file))

(defun where-is-system (name)
  "Return the pathname to the source directory of ASDF system with the
given NAME, or NIL if no system by that name can be found known."
  (let ((system (asdf:find-system name nil)))
    (when system
      (asdf:system-source-directory system))))
