(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :asdf)
  (require :mcclim))

(cl:defpackage :asdf-browser
  (:use :clim-lisp :clim)
  (:export #:run-asdf-explorer))

(in-package :asdf-browser)

(define-application-frame asdf-browser ()
  ((current-system :accessor current-system :initform nil)
   (expanded-dependencies :accessor expanded-dependencies :initform (make-hash-table :test 'eql)))
  (:panes
   (system :application
           :incremental-redisplay t
           :initial-cursor-visibility nil
           :display-function #'display-system
           :scroll-bars t)
   (interactor :interactor
               :scroll-bars t))
  (:layouts
   (default (vertically ()
              (+fill+ system)
              (1/3 interactor)))))

(define-presentation-type asdf-component ())
(define-presentation-type asdf-module () :inherit-from 'asdf-component)
(define-presentation-type asdf-system () :inherit-from 'asdf-module)

(define-presentation-type asdf-dependencies ())

(defun display-system (frame stream)
  (when (current-system frame)
    (present (current-system frame) 'asdf-system :stream stream)))

(defun type-for-class (class)
  (if (eql class (find-class 'asdf:cl-source-file))
      :file
      (class-name class)))

;;; accepting

(define-presentation-method accept ((type asdf-system) stream view &key)
  (values
   (cdr  ; asdf stores stuff in the CAR
    (completing-from-suggestions (stream :partial-completers '(#\Space)
                                         :allow-any-input t)
      (maphash #'suggest asdf::*defined-systems*)))))

;;; presenting

(defun dependencies-expanded-p (component)
  (gethash component (expanded-dependencies *application-frame*)))
(defun (setf dependencies-expanded-p) (new-val component)
  (setf (gethash component (expanded-dependencies *application-frame*))
        new-val))

(defun component-dependencies (component operation)
  (mapcan (lambda (in-order-to)
            (destructuring-bind (op &rest c-names) in-order-to
              ;; TODO: look up components in the system/module/parent module (urgh!)
              (loop for c-name in c-names
                    append (list* (handler-case (list op (asdf:find-system c-name))
                                    (asdf:missing-component ()
                                      nil))
                     nil))))
   (remove operation (asdf:component-depends-on (make-instance operation) component)
           :test-not 'equal :key #'first)))

(define-presentation-method present (o (type asdf-dependencies) stream (view textual-view) &rest args &key &allow-other-keys)
  (cond
    ((dependencies-expanded-p o)
     (with-text-style (stream '(:sans-serif :bold 20))
       (format stream "dependencies~%"))
     (formatting-table (stream)
       (loop for (operation subcomponent) in (component-dependencies o 'asdf:load-op)
             do (formatting-row (stream)
                  (formatting-cell (stream :align-x :right)
                    (format stream "~A" operation))
                  (formatting-cell (stream :align-x :left)
                    (apply #'present subcomponent 'asdf-component :stream stream :view view args))))))
    (t
     (with-text-style (stream '(:sans-serif :bold 20))
       (format stream "dependencies (~A)~%" (length (component-dependencies o 'asdf:load-op)))))))

(define-presentation-method present (o (type asdf-module) stream (view textual-view) &rest args &key &allow-other-keys)
  (with-text-family (stream :sans-serif)
    (format stream "~A (~A)~%" (asdf:component-name o) (enough-namestring (asdf:component-pathname o)))
    (fresh-line stream)
    (apply #'present o 'asdf-dependencies :stream stream :view view args)
    (formatting-table (stream)
      (loop for subcomponent in (asdf:module-components o)
            do (formatting-row (stream)
                 (apply #'present subcomponent 'asdf-component :stream stream :view view args))))))

(define-presentation-method present (o (type asdf-component) stream (view textual-view) &rest args &key &allow-other-keys)
  (with-text-family (stream :sans-serif)
    ;; first, find the correct presentation method for this
    ;; component type. Not sure if this is entirely correct.
    (cl:etypecase o
      (asdf:system
       (apply #'present o 'asdf-system :stream stream :view view args))
      (asdf:module
       (apply #'present o 'asdf-module :stream stream :view view args))
      (asdf:component                ; it really is a simple component
       (formatting-cell (stream :align-x :right)
         (format stream "~A" (string-downcase (type-for-class (class-of o)))))
       (formatting-cell (stream :align-x :left)
         (format stream "~A" (asdf:component-name o)))))))

;;; translators

(define-presentation-to-command-translator browse-this-system
    (asdf-system com-browse-system asdf-browser
                 :gesture :select
                 :documentation "Browse this system")
    (object)
  (list object))

(define-presentation-to-command-translator toggle-expand-these-dependencies
    (asdf-dependencies com-expand-dependencies asdf-browser
                 :gesture :select
                 :documentation "Toggle this system's dependencies' expand state")
    (object)
  (list object))

(define-presentation-translator string-to-asdf-system
    (string asdf-system asdf-browser)
    (object)
  (list (asdf:find-system object)))

;;; commands

(define-asdf-browser-command (com-quit :name t :menu t ;; show in menu
                                       :keystroke (#\q :meta)) ;; a keystroke
    ()
  (frame-exit *application-frame*))

(define-asdf-browser-command (com-toggle-expand-dependencies
                              :menu nil) ((deps 'asdf-dependencies :prompt "Depencencies"))
  (setf (dependencies-expanded-p deps)
        (not (dependencies-expanded-p deps))))

(define-asdf-browser-command (com-browse-system
                              :menu t) ((system 'asdf-system :prompt "System"))
  (setf (current-system *application-frame*) system))

(define-asdf-browser-command (com-refresh
                              :menu t) ()
  (redisplay-frame-panes *application-frame*))

(defun run-asdf-explorer ()
  (let ((frame (make-application-frame 'asdf-browser)))
    (run-frame-top-level frame)))