(in-package :cl-dot)

(defun list-no-nil (&rest args)
  (remove nil args))

(defun boldify-edge (object)
  (make-instance 'attributed :object object
                 :attributes '(:style :bold)))

(defun attributify-edge (object &rest attribute-plist)
  (make-instance 'attributed :object object
                 :attributes attribute-plist))

(defmethod object-node ((object null))
  nil)

(defmethod object-node :around ((object sb-c::node))
  (let ((node (call-next-method)))
    (values node (sb-c::block-number (sb-c::block-or-lose object)))))

(defmethod object-node :around ((object sb-c::ctran))
  (let ((node (call-next-method)))
    (values node (sb-c::block-number (sb-c::block-or-lose object)))))

(defmethod object-node :around ((object sb-c::cblock))
  (let ((node (call-next-method)))
    (values node (sb-c::block-number (sb-c::block-or-lose object)))))

;; COMPONENT
(defmethod object-node ((object sb-c:component))
  nil)

(defmethod object-knows-of ((c sb-c:component))
  (list* (sb-c::component-head c)
         (sb-c::component-lambdas c)))


;; CBLOCK
(defmethod object-node ((c sb-c::cblock))
  (make-instance 'cluster-node
                 :attributes `(:label ,(format nil "Block ~A" (sb-c::block-number c)))))

(defmethod object-points-to ((c sb-c::cblock))
  nil #+nil (sb-c::block-succ c))

(defmethod object-knows-of ((c sb-c::cblock))
  (append (sb-c::block-pred c) (sb-c::block-succ c)))

;; CLAMBDA
(defmethod object-node ((c sb-c::clambda))
  (make-instance 'node
                 :attributes `(:label ,(format nil "Lambda ~A"
                                               (sb-c::lambda-%source-name c)))))

(defmethod object-points-to ((c sb-c::clambda))
  (sb-c::lambda-vars c))

;; LAMBDA-VAR
(defmethod object-node ((c sb-c::lambda-var))
  (make-instance 'node
                 :attributes `(:label ,(format nil "Var ~A"
                                               (sb-c::lambda-var-%source-name c)))))

(defmethod object-knows-of ((c sb-c::lambda-var))
  (sb-c::lambda-var-refs c))

;; REF
(defmethod object-node ((c sb-c::ref))
  (make-instance 'node
                 :attributes (list :label "REF"
                                   :fillcolor "#ddffbb"
                                   :style :filled
                                   :shape :diamond)))

(defmethod object-points-to ((c sb-c::ref))
  (list-no-nil (sb-c::ref-leaf c)
               (boldify-edge (sb-c::ref-next c))))

(defmethod object-knows-of ((c sb-c::ref))
  (list-no-nil (sb-c::ref-prev c)
               (sb-c::ref-lvar c)))

;; CTRAN
(defmethod object-node ((c sb-c::ctran))
  (make-instance 'node
                 :attributes `(:label ,(format nil "CTRAN ~D ~A"
                                               (sb-c::cont-num c)
                                               (sb-c::ctran-kind c)))))

(defmethod object-points-to ((c sb-c::ctran))
  (list-no-nil (boldify-edge (sb-c::ctran-next c))
               (sb-c::ctran-use c)))

;; BIND
(defmethod object-node ((c sb-c::bind))
  (make-instance 'node
                 :attributes `(:label ,(format nil "BIND"))))

(defmethod object-points-to ((c sb-c::bind))
  (list-no-nil (sb-c::bind-next c)))

(defmethod object-knows-of ((c sb-c::bind))
  (list-no-nil (sb-c::bind-prev c)))

;; GLOBAL-VAR
(defmethod object-node ((c sb-c::global-var))
  (make-instance 'node
                 :attributes (list :label (format nil "GLOBAL-VAR\\n~A\\n~A"
                                                  (sb-c::global-var-%source-name c)
                                                  (sb-c::global-var-kind c))
                                   :shape :box)))

(defmethod object-knows-of ((c sb-c::global-var))
  (sb-c::global-var-refs c))

;; CONSTANT
(defmethod object-node ((c sb-c::constant))
  (make-instance 'node
                 :attributes (list :label (format nil "CONSTANT"
                                                  #+nil (sb-c::lvar-source c)
                                                  #+nil (sb-c::constant-value c))
                                   :style :filled
                                   :fillcolor "#ffffee"
                                   :shape :box)))

(defmethod object-knows-of ((c sb-c::constant))
  (sb-c::constant-refs c))

;; ENTRY
(defmethod object-node ((c sb-c::entry))
  (make-instance 'node
                 :attributes `(:label ,(format nil "ENTRY"))))

(defmethod object-points-to ((c sb-c::entry))
  ;; cleanup
  (list-no-nil (sb-c::entry-next c)))

(defmethod object-knows-of ((c sb-c::entry))
  (list-no-nil (sb-c::entry-prev c)))

;; COMBINATION
(defmethod object-node ((c sb-c::basic-combination))
  (make-instance 'node
                 :attributes (list :label (format nil "~(~A~A ~A\\n~A~)"
                                                  (if (sb-c::node-tail-p c) "tail " "")
                                                  (sb-c::basic-combination-kind c)
                                                  (type-of c)
                                                  (sb-c::lvar-fun-name (sb-c::basic-combination-fun c)))
                                   :shape :octagon
                                   :style :filled
                                   :fillcolor "#ccffff")))

(defmethod object-points-to ((c sb-c::basic-combination))
  (apply #'list-no-nil
         (boldify-edge (sb-c::basic-combination-next c))
         (attributify-edge (sb-c::basic-combination-lvar c) :style :bold :color "#9999ff")
         (attributify-edge (sb-c::basic-combination-fun c) :style :bold :color "#0000ff")
         (sb-c::basic-combination-args c)))

(defmethod object-knows-of ((c sb-c::basic-combination))
  (list* (sb-c::basic-combination-prev c)
         (sb-c::basic-combination-args c)))

;; LVAR
(defmethod object-node ((c sb-c::lvar))
  (let ((combination-result-p (let ((use (sb-c::principal-lvar-use c)))
                                (typep use 'sb-c::basic-combination)))
        (combination-fun-p (let ((dest (sb-c::lvar-dest c)))
                             (and (typep dest 'sb-c::basic-combination)
                                  (eq (sb-c::basic-combination-fun dest) c))))
        (leaf (let ((ref (sb-c::lvar-uses c)))
                (when (sb-c::ref-p ref)
                  (let ((leaf (sb-c::ref-leaf ref)))
                    (when (sb-c::leaf-has-source-name-p leaf)
                      (sb-c::leaf-source-name leaf)))))))
    (make-instance 'node
                   :attributes (list :label (format nil "~A ~A"
                                                    (cond
                                                      (combination-fun-p "FUN LVAR")
                                                      (t "LVAR"))
                                                    leaf)
                                     :style :filled
                                     :fillcolor "#ffcc99"
                                     :shape :hexagon))))

(defmethod object-points-to ((c sb-c::lvar))
  (let ((dest (sb-c::lvar-dest c)))
    (list-no-nil dest))
    #+nil
    (cond
      ((typep dest 'sb-c::basic-combination)
       (if (member c (sb-c::basic-combination-args dest))
           nil
           (list-no-nil (sb-c::lvar-dest c))))
      (t (list-no-nil (sb-c::lvar-dest c))))))

(defmethod object-pointed-to-by ((c sb-c::lvar))
  (let ((uses (sb-c::lvar-uses c)))
    (remove-if #'(lambda (x) (typep x 'sb-c::basic-combination))
               (if (listp uses)
                   uses
                   (list-no-nil uses)))))

;; CIF
(defmethod object-node ((c sb-c::cif))
  (make-instance 'node
                 :attributes `(:label ,(format nil "CIF"))))

(defmethod object-points-to ((c sb-c::cif))
  (list-no-nil (sb-c::if-next c)
               (sb-c::if-test c)
               (sb-c::if-consequent c)
               (sb-c::if-alternative c)))

(defmethod object-knows-of ((c sb-c::cif))
  (list-no-nil (sb-c::if-prev c)))

;; CRETURN
(defmethod object-node ((c sb-c::creturn))
  (make-instance 'node
                 :attributes `(:label ,(format nil "CRETURN"))))

(defmethod object-points-to ((c sb-c::creturn))
  (list-no-nil (sb-c::return-next c)))

(defmethod object-knows-of ((c sb-c::creturn))
  (list-no-nil (sb-c::return-prev c)
               (sb-c::return-result c)))

;; CAST
(defmethod object-node ((c sb-c::cast))
  (make-instance 'node
                 :attributes (list :label "CAST"
                                   :style :filled
                                   :fillcolor "#ffccff")))

;; CSET
(defmethod object-node ((c sb-c::cset))
  (make-instance 'node
                 :attributes '(:label "CSET")))

(defmethod object-points-to ((c sb-c::cset))
  (list (sb-c::set-value c)))