;;;; An implementation of a kind of generic function. This is not
;;;; terribly CLOSy, as it does not support inheritance. What we have
;;;; is a method selection routine that works on arbitrary types.
;;;; Some effort has been made to emulate CLOS's primary method
;;;; selection.

(in-package :def)

(defvar *genfuns* (make-hash-table :test #'eq)
  "Mapping from symbol names to GENFUN instances.")

(defclass genfun ()
  ((name
    :reader genfun-name
    :initarg :name 
    :type symbol)
   (methods
    :accessor genfun-methods
    :type (or null cons)
    :initform nil
    :documentation
    "A sorted association list, keyed by TYPE SPECIFIER, storing
    S-EXPRESSIONS representing the method implementation for that
    type. This list is sorted in topological order according the
    natural order on the type keys.")
   (lambda-list
    :reader genfun-lambda-list
    :initarg :lambda-list
    :type (or null cons)
    :documentation
    "The lambda list for this generic function")
   (docstring
    :reader genfun-docstring
    :initarg :docstring
    :type (or null string))))

(defun type-specifier-p (thing)
  (ignore-errors
   (typep nil thing)
   t))

(deftype lambda-list-option-term ()
  '(member cl:&rest cl:&aux cl:&optional cl:&key))

(defun expand-generic-function-def (generic)
  (let ((vars
          (method-sig-vars (genfun-lambda-list generic)))
        (types
          (gensym "TYPES-")))
    `(defun ,(genfun-name generic) ,(genfun-lambda-list generic)
       ,(genfun-docstring generic)
       (let ((,types (mapcar #'type-of (list ,@vars)))) 
         (cond
           ,@(loop :for (signature . body) :in (genfun-methods generic)
                   :collect `((every #'subtypep ,types ',signature) ,@body) :into clauses
                   :finally
                      (return (nconc clauses
                                 (list
                                  `(t (error "No implementation of ~s for ~s"
                                            ',(genfun-name generic)
                                            ,types)))))))))))
(defun method-signature (lambda-list)
  (loop
    :for param :in lambda-list
    :until (typep param 'lambda-list-option-term)
    :when (and (listp param) (= 2 (length param)))
      :do (assert (type-specifier-p (second param)) ()
                  "~s is not a valid type-specifier"
                  (second param))
      :and :collect (second param)
    :else
      :collect 't))

(defun method-sig-vars (gen-lambda-list)
  (loop :for x :in gen-lambda-list
        :until (typep x 'lambda-list-option-term)
        :collect x))

(defun sig-before-p (sig1 sig2)
  (let* ((before (mapcar #'subtypep sig1 sig2))
         (after (mapcar #'subtypep sig2 sig1)))
    (or (every #'identity before)
        (and (find 't before) (find 't after)
             (< (position 't before) (position 't after))))))

(defun add-meth (gen spec)
  (with-slots (methods) gen
    (push spec methods)
    (setf methods (sort methods #'sig-before-p :key #'car))))


(defun method-lambda-list-matches-generic (mll gll)
  (and (= (length mll) (length gll))
       (loop :for m :in mll
             :for g :in gll
             :for mvar := (if (consp m) (first m) m)
             :for gvar := (if (consp g) (first g) g)
             :always (string-equal mvar gvar))))

(defmacro generic (name lambda-list &optional docstring)
  "Define a generic function with optional docstring"
  (expand-generic-function-def
   (setf (gethash name *genfuns*)
         (make-instance 'genfun
           :name name
           :lambda-list lambda-list
           :docstring docstring))))

(defmacro method (name lambda-list &body body)
  "Define a method on the generic function called NAME, which must exist already."
  (let ((gen (gethash name *genfuns*)))
    (unless gen
      (error "Unknown GENFUN named ~s" name))
    (unless (method-lambda-list-matches-generic lambda-list (genfun-lambda-list gen))
      (error "Method lambda-list ~s does not match generic function ~s"
             lambda-list (genfun-lambda-list gen)))
    (let* ((sig
             (method-signature lambda-list))
           (bound
             (assoc sig (genfun-methods gen) :test #'equalp)))
      (if bound
          (rplacd bound body)
          (add-meth gen (cons sig body)))
      (expand-generic-function-def gen))))