(in-package :smoke)

(defclass cxx-generic-function (standard-generic-function)
  ((gf-methods :initform nil :type list
               :accessor gf-methods
               :documentation "gf for different argument counts."))
  (:metaclass closer-mop:funcallable-standard-class)
  (:documentation "gf that can be overloaded by argument count."))

(defclass cxx-method-generic-function (standard-generic-function)
  ((generic-function :accessor cxx-generic-function
                     :initarg :cxx-generic-function
                     :type cxx-generic-function
                     :documentation "Contains the generic function."))
  (:metaclass closer-mop:funcallable-standard-class)
  (:documentation "Generic function of a specify argument count."))



(defun make-lambda (argument-count)
  "Returns a lambda expression for ARGUMENT-COUNT arguments."
  (declare ((integer 0) argument-count))
  (loop for i from 0 below argument-count
       collect (intern (format nil "A~A" i))))

(defun argument-count (generic-function)
  "Returns the number of arguments to GENERIC-FUNCTION."
  (length (closer-mop:generic-function-lambda-list generic-function)))

(defun find-generic-function-by-argument-count (cxx-generic-function argument-count)
  "Returns the generic function of CXX-GENERIC-FUNCTION that takes
ARGUMENT-COUNT arguments, or false when no such function exists."
  (declare (cxx-generic-function cxx-generic-function)
           ((integer 0) argument-count)
           (values (or cxx-method-generic-function null)))
  (find-if #'(lambda (gf)
               (= argument-count (argument-count gf)))
           (gf-methods cxx-generic-function)))

(defun cxx-method-generic-function-name (cxx-generic-function argument-count)
  (let ((*package* (find-package :cxx)))
    (symbolicate (closer-mop:generic-function-name cxx-generic-function)
                 #\/ (write-to-string argument-count))))

(defun ensure-gf-by-argument-count (cxx-generic-function argument-count)
  "Returns the generic-function of CXX-GENERIC-FUNCTION that takes
ARGUMENT-COUNT arguments. When none exists, one is created."
  (declare (cxx-generic-function cxx-generic-function)
           ((integer 0) argument-count))
  (or (find-generic-function-by-argument-count cxx-generic-function
                                               argument-count)
      (let* ((name (cxx-method-generic-function-name cxx-generic-function
                                                     argument-count))
             (gf (make-instance 'cxx-method-generic-function
                                :name name
                                :cxx-generic-function cxx-generic-function
                                :lambda-list (make-lambda argument-count))))
        (setf (fdefinition name) gf)
        (push gf (gf-methods cxx-generic-function))
        gf)))

(defun method-argument-count (method)
  "Returns the number of arguments of METHOD."
  (length (closer-mop:method-lambda-list method)))
                             
(defun lambda-list-keywords-p (lambda-list)
  "Returns true when LAMBDA-LIST contains a lambda list keyword
and false otherwise."
  (not (null (intersection lambda-list-keywords lambda-list))))

(defun check-cxx-method-argument-list (method)
  "Signals an error when METHOD contains lambda list keywords."
  (assert (not (lambda-list-keywords-p (closer-mop:method-lambda-list method)))
          ()
          "The method ~A must not contain lambda list keywords." method))

(defun push-method (method cxx-generic-function)
  "Adds METHOD to a cxx-method-generic-function of CXX-GENERIC-FUNCTION."
  (declare (optimize (speed 3)))
  (let ((generic-function (ensure-gf-by-argument-count
                           cxx-generic-function
                           (method-argument-count method))))
    (add-method generic-function method)))

(defun unpush-method (method)
  "Removes METHOD from its generic-function."
  (let ((generic-function (closer-mop:method-generic-function method)))
    (when generic-function
      (remove-method generic-function method))))
    ;(when (null (closer-mop:generic-function-methods generic-function))
    ;  TODO
                 
(defmethod no-applicable-method ((gf cxx-method-generic-function) &rest args)
  (apply #'no-applicable-method (cxx-generic-function gf) args))

#+sbcl
(defmethod closer-mop:compute-applicable-methods-using-classes ((gf cxx-generic-function) classes)
  (let ((gf2 (find-generic-function-by-argument-count gf (length classes))))
    (if gf2
        (values (list gf2) t)
        (values nil t))))

(defmethod closer-mop:compute-discriminating-function ((cxx-generic-function cxx-generic-function))
  (declare (optimize (speed 3)))
  ;; Special case no methods, since it will apply to all cxx generic functions
  ;; on start up and the eval stuff is slower.
  (if (null (gf-methods cxx-generic-function))
      #'(lambda (&rest args)
          (apply #'no-applicable-method cxx-generic-function args))
      (eval 
       `#'(lambda (&rest args)
            (case (length args)
              ,@(loop for gf in (gf-methods cxx-generic-function)
                   collect `(,(argument-count gf)
                              (apply ,gf args)))
              (t (apply #'no-applicable-method ,cxx-generic-function args)))))))


#+sbcl
(defmethod compute-applicable-methods ((gf cxx-generic-function) arguments)
  ;; -using-classes only cares about the number of arguments;
  ;; thus no the to actually pass the classes.
  (closer-mop:compute-applicable-methods-using-classes gf arguments))
  
(defun update-method (generic-function action method)
  "Updates GENERIC-FUNCTION when METHOD has been added or removed;
and updates the dependents."
  (declare (generic-function generic-function)
           ((member add-method remove-method) action)
           (standard-method method)
           (optimize (speed 3)))
  (closer-mop:set-funcallable-instance-function
   generic-function
   (closer-mop:compute-discriminating-function generic-function))
  (closer-mop:map-dependents
   (class-of generic-function)
   #'(lambda (dependent)
       (closer-mop:update-dependent (class-of generic-function)
                                    dependent
                                    action method))))

(defmethod add-method ((gf cxx-generic-function) method)
  (declare (optimize (speed 3)))
  (push-method method gf)
  (update-method gf 'add-method method))

(defmethod remove-method ((gf cxx-generic-function) method)
  (unpush-method method)
  (update-method gf 'remove-method method))

#|
(defun cxx-dispatch-compiler-macro (cxx-generic-function)
  "Returns a compiler-macro form for CXX-GENERIC-FUNCTION that
precomputes the dispatching for the argument count, if possible."
  ;; FIXME only applies when a defmethod with the right argument count
  ;;  has been defined, which is almost never.
  `(define-compiler-macro ,(closer-mop:generic-function-name cxx-generic-function)
       (&whole form object &rest args)
     (let ((name (cxx-method-generic-function-name (fdefinition (first form))
                                                   (1+ (length args)))))
       (if (fboundp name)
           `(,name ,object ,@args)
           form))))

(defmethod initialize-instance :after ((gf cxx-generic-function) &key &allow-other-keys)
  (eval (cxx-dispatch-compiler-macro gf)))
|#