#+xcvb (module (:depends-on ("names" "computations")))

(in-package :xcvb)

(declaim (optimize (speed 2) (safety 3) (debug 3) (compilation-speed 0)))

(defgeneric next-traversal (env spec))
(defgeneric dependency-already-included-p (env grain))
(defgeneric issue-dependency (env grain))

(defgeneric issue-build-command (env command))

(defgeneric issue-link-element (env element))

(defgeneric traversed-dependencies (env))

(defgeneric traversed-build-commands (env))

(defgeneric traversed-link-elements (env command))

(defgeneric build-command-issued-p (env command))

(defgeneric link-element-issued-p (env element))

(defgeneric graph-for (env spec)
  (:documentation "Build the dependency graph for given dependency, return the node for it"))

(defgeneric graph-for-atom (env atom))

(defgeneric graph-for-build-module-grain (env grain))

(defgeneric graph-for-lisp (env name))
(defgeneric graph-for-fasls (env name))
(defgeneric graph-for-fasl (env name))
(defgeneric graph-for-cfasl (env name))

(defgeneric graph-for-lisp-object (env name))

(defgeneric graph-for-dynamic-library (env name))
(defgeneric graph-for-static-library (env name))
(defgeneric graph-for-build-libraries (env name))

(defgeneric graph-for-build (env name))
(defgeneric graph-for-compile-build (env name))
(defgeneric graph-for-build-named (env name))
(defgeneric graph-for-image (env name))

(defgeneric graph-for-image-grain (env name pre-image-name dependencies &key))

(defgeneric graph-for-executable (env name))

(defgeneric graph-for-source (env name &key in))
(defgeneric graph-for-asdf (env name))
(defgeneric graph-for-require (env name))

(defgeneric ensure-grain-generated (env grain))

(defgeneric tweak-dependency (env dep))

(defgeneric linking-traversal-p (env))

(defclass traversal (simple-print-object-mixin)

  ((image-setup
    :accessor image-setup
    :documentation "xcvb-driver-command options to setup the image for the current world")
   (grain-names

    :initform nil
    :initarg :grain-names
    :reader traversed-grain-names-r
    :documentation "grain names in the stack of things we try to create -- to avoid circularities")

   ;; do we also need them as a set? possibly... to be measured.

   ;; we might benefit from a pure functional set implementation; maybe use fare-utils:pure of FSet

   (issued-dependencies
    :initform (make-hashset :test 'equal)
    :accessor issued-dependencies
    :documentation "dependencies issued as part of current computation, as a set")

   (traversed-dependencies-r

    :initform nil
    :accessor traversed-dependencies-r
    :documentation "dependencies issued as part of the current computation, in reverse order")))

(defmethod graph-for ((env traversal) spec)

  (log-format 10 "Producing graph-for ~S" spec)

  (let ((current-grains-r (reverse (traversed-grain-names-r env))))

    (let ((mem (member spec current-grains-r :test 'equal)))
      (when mem
	(user-error
	 "There is a circularity in the dependencies:~%~{ ~S~%  includes~%~} ~S~%"
	 mem (first mem)))))

  (let ((grain (do-graph-for (next-traversal env spec) spec)))
    (if (typep grain 'buildable-grain)

	(ensure-grain-generated env grain)

	(user-error "Grain ~S for ~S is not buildable" grain spec))

    grain))

(defmethod ensure-grain-generated (env (grain buildable-grain))
  (let ((generator (grain-generator grain)))

    (when (and generator (not (and (slot-boundp grain 'computation)
                                   (grain-computation grain))))

      (run-generator (next-traversal env (fullname grain)) generator))))

(defun do-graph-for (env spec)
  (call-with-grain-registration
   spec
   #'(lambda () (graph-for-dispatcher env spec))))

(defmethod next-traversal ((env traversal) spec)

  (make-instance
   (class-of env)
   :grain-names (cons spec (traversed-grain-names-r env))))

(defmethod traversed-dependencies ((env traversal))

  (reverse (traversed-dependencies-r env)))

(defmethod dependency-already-included-p :before (env grain)

  (check-type env traversal)

  (check-type grain grain))

(defmethod dependency-already-included-p ((env traversal) grain)

  (gethash grain (issued-dependencies env)))

(defmethod issue-dependency :before (env grain)

  (check-type env traversal)

  (check-type grain grain))

(defmethod issue-dependency ((env traversal) grain)

  ;; Note: long dependency lists do not mix well with pretty-print.

  (log-format-pp 10 "Issuing dependency for ~A" grain)

  (setf (gethash grain (issued-dependencies env)) t)
  (push grain (traversed-dependencies-r env)))

(defun call-with-dependency-loading (env grain thunk)
  (unless (dependency-already-included-p env grain)
    (issue-dependency env grain)
    (funcall thunk)))

(defmacro with-dependency-loading ((env grain) &body body)
  `(call-with-dependency-loading ,env ,grain (lambda () ,@body)))

(define-simple-dispatcher graph-for #'graph-for-atom :generic t)

(defmethod traversed-build-commands ((env traversal))

  (reverse (traversed-build-commands-r env)))

(defmethod build-command-issued-p ((env traversal) command)

  (values (gethash command (issued-build-commands env))))

(define-graph-for :asdf ((env traversal) system-name)

  (declare (ignorable env))

  (make-asdf-grain :name system-name
                   :implementation *lisp-implementation-type*))

(define-graph-for :require ((env traversal) name)

  (declare (ignorable env))

  (make-require-grain :name name))

(defun handle-target (fullname)

  (let* ((target (if fullname

                   (or (resolve-absolute-module-name fullname)
                       (resolve-asdf-name fullname))

                   (let* ((build-file (probe-file "build.xcvb"))

                          (build-module-grain

                           (and build-file (pathname-build build-file))))

                     ;; Question: should we make the below error cases warnings,
                     ;; and override conflicts with the current build?

                     ;; NB: User can put . in front of his CL_SOURCE_REGISTRY
                     ;; if that's what he wants.

                     (etypecase build-module-grain
                       (build-module-grain
                        build-module-grain)
                       (null

                        (user-error "No build specified, and no build.xcvb in the current directory"))

                       (invalid-build-registry-entry

                        (user-error "Implicitly specified build.xcvb in current directory ~

                                but it is invalid:~%~A~&"

                                    (invalid-build-reason build-module-grain)))))))

         (build (typecase target
                  ((or lisp-module-grain executable-grain) (build-module-grain-for target))
                  (asdf-grain nil)
                  (t

                    (user-error "User requested build ~S but it can't be found.~%~

			    You may check available builds with xcvb ssr.~%" fullname))))

         (name (fullname target))
         (dep (etypecase target

                (build-module-grain `(:build ,name))

                (lisp-module-grain `(:fasl ,(second name)))