(in-package #:user-side-compiler)

(defgeneric %direct-transform (obj to-type)
  (:method (obj to-type)
    (error "No direct transformation exists from ~A to ~A."
           (type-of obj) to-type)))

(defun transform-matches-p (transform-method from-class to-class)
  (declare (type standard-method transform-method)
           (type class from-class)
           (type class to-class))
  (let ((specs (c2mop:method-specializers transform-method)))
    (and (equal (first specs) from-class)
         (equal (c2mop:eql-specializer-object (second specs))
                (class-name to-class)))))

(defun direct-transform-exists-p (from-class to-class)
  (some (lambda (m)
          (transform-matches-p m from-class to-class))
        (c2mop:generic-function-methods #'%direct-transform)))

(defun transformations-from (from-type)
  (loop :with from-class := (find-class from-type)
        :for m :in (c2mop:generic-function-methods #'%direct-transform)
        :for specs := (c2mop:method-specializers m)
        :when (eql (first specs) from-class)
          :collect (c2mop:eql-specializer-object (second specs))))

(defun transform-path (from-type to-type)
  "Computes a list of intermediate types that can be transformed through to
get from FROM-TYPE to TO-TYPE. Returns T if a direct transformation exists
and NIL if no path exists."
  (do* ((to-class (find-class to-type))
        (backlinks '())
        (stack (list from-type))
        (current-type (first stack) (first stack))
        (path '()))
       ((or (null stack) (not (null path))) path)
    (cond ((eql :end-of-node current-type)
           (pop backlinks)
           (pop stack))
          ((direct-transform-exists-p (find-class current-type) to-class)
           (if (eql current-type from-type)
               (setf path t)
               (setf path (nreverse (cons current-type backlinks)))))
          (t
           (pop stack)
           (push :end-of-node stack)
           (unless (eql current-type from-type)
             (push current-type backlinks))
           (dolist (m (transformations-from current-type))
             (push m stack))))))

(defun transform (obj to-type)
  "When a valid transformation exists, it returns an object of type TO-TYPE
that has been somehow created using OBJ as a starting point."
  (let ((path (transform-path (type-of obj) to-type)))
    (if (listp path)
        (loop :for intermediate :in path
              :do (setf obj (%direct-transform obj intermediate))
              :finally (return (%direct-transform obj to-type)))
        (%direct-transform obj to-type))))

(defmacro define-transformation ((var-name (from-type to-type)) &body body)
  "Defines a transformation rule for objects going from FROM-TYPE to TO-TYPE.
Inside BODY, VAR-NAME is bound to the object being transformed. The body should
return the result of the transformation."
  (let ((ignorable-var (gensym)))
    `(defmethod %direct-transform ((,var-name ,from-type) (,ignorable-var (eql ',to-type)))
       (declare (ignore ,ignorable-var))
       ,@body)))