(defpackage :slynk-trace-dialog
  (:use :cl :slynk-api)
  (:export #:clear-trace-tree
           #:dialog-toggle-trace
           #:dialog-trace
           #:dialog-traced-p
           #:dialog-untrace
           #:dialog-untrace-all
           #:inspect-trace-part
           #:report-partial-tree
           #:report-specs
           #:report-total
           #:report-specs
           #:trace-format
           #:still-inside
           #:exited-non-locally
           #:*record-backtrace*
           #:*traces-per-report*
           #:*dialog-trace-follows-trace*
           #:instrument

           #:pprint-trace-part
           #:describe-trace-part
           #:trace-part-or-lose
           #:inspect-trace
           #:trace-or-lose
           #:trace-arguments-or-lose
           #:trace-location))

(in-package :slynk-trace-dialog)

(defparameter *record-backtrace* nil
  "Record a backtrace of the last 20 calls for each trace.

Beware that this may have a drastic performance impact on your
program.")

(defparameter *traces-per-report* 150
  "Number of traces to report to emacs in each batch.")

(defparameter *dialog-trace-follows-trace* nil)

(defvar *traced-specs* '())

(defparameter *visitor-idx* 0)

(defparameter *visitor-key* nil)

(defvar *unfinished-traces* '())


;;;; `trace-entry' model
;;;;
(defvar *traces* (make-array 1000 :fill-pointer 0
                                  :adjustable t))

(defvar *trace-lock* (slynk-backend:make-lock :name "slynk-trace-dialog lock"))

(defvar *current-trace-by-thread* (make-hash-table))

(defclass trace-entry ()
  ((id         :reader   id-of)
   (children   :accessor children-of :initform nil)
   (backtrace  :accessor backtrace-of :initform (when *record-backtrace*
                                                  (useful-backtrace)))

   (spec       :initarg  :spec      :accessor spec-of
               :initform (error "must provide a spec"))
   (function   :initarg  :function  :accessor function-of)
   (args       :initarg  :args      :reader args-of
               :initform (error "must provide args"))
   (printed-args)
   (parent     :initarg  :parent    :reader   parent-of
               :initform (error "must provide a parent, even if nil"))
   (retlist    :initarg  :retlist   :accessor retlist-of
               :initform 'still-inside)
   (printed-retlist :initform ":STILL-INSIDE")))

(defmethod initialize-instance :after ((entry trace-entry) &key)
  (with-slots (parent id printed-args args) entry
    (if parent
        (nconc (children-of parent) (list entry)))
    (setf printed-args
          (mapcar (lambda (arg)
                    (present-for-emacs arg #'slynk-pprint-to-line))
                  args))
    (slynk-backend:call-with-lock-held
     *trace-lock*
     (lambda ()
       (setf (slot-value entry 'id) (fill-pointer *traces*))
       (vector-push-extend entry *traces*)))))

(defmethod print-object ((entry trace-entry) stream)
  (print-unreadable-object (entry stream)
    (format stream "~a=~a" (id-of entry) (spec-of entry))))

(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside)))

(defun trace-arguments (trace-id)
  (values-list (args-of (trace-or-lose trace-id))))

(defun useful-backtrace ()
  (slynk-backend:call-with-debugging-environment
   (lambda ()
     (loop for i from 0
           for frame in (slynk-backend:compute-backtrace 0 20)
           collect (list i (slynk::frame-to-string frame))))))

(defun current-trace ()
  (gethash (slynk-backend:current-thread) *current-trace-by-thread*))

(defun (setf current-trace) (trace)
  (setf (gethash (slynk-backend:current-thread) *current-trace-by-thread*)
        trace))


;;;; Helpers
;;;;
(defun describe-trace-for-emacs (trace)
  (with-slots (id args parent spec printed-args retlist printed-retlist) trace
    `(,id
      ,(and parent (id-of parent))
      ,(cons (string-downcase (present-for-emacs spec)) spec)
      ,(loop for arg in args
             for printed-arg in printed-args
             for i from 0
             collect (list i printed-arg))
      ,(loop for retval in (slynk::ensure-list retlist)
             for printed-retval in (slynk::ensure-list printed-retlist)
             for i from 0
             collect (list i printed-retval)))))


;;;; slyfuns
;;;;
(defslyfun trace-format (format-spec &rest format-args)
  "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace."
  (let* ((line (apply #'format nil format-spec format-args)))
    (make-instance 'trace-entry :spec line
                                :args format-args
                                :parent (current-trace)
                                :retlist nil)))

(defslyfun trace-or-lose (id)
  (when (<= 0 id (1- (length *traces*)))
    (or (aref *traces* id)
        (error "No trace with id ~a" id))))

(defslyfun report-partial-tree (key)
  (unless (equal key *visitor-key*)
    (setq *visitor-idx* 0
          *visitor-key* key))
  (let* ((recently-finished
           (loop with i = 0
                 for trace in *unfinished-traces*
                 while (< i *traces-per-report*)
                 when (completed-p trace)
                   collect trace
                   and do
                     (incf i)
                     (setq *unfinished-traces*
                           (remove trace *unfinished-traces*))))
         (new (loop for i
                      from (length recently-finished)
                        below *traces-per-report*
                    while (< *visitor-idx* (length *traces*))
                    for trace = (aref *traces* *visitor-idx*)
                    collect trace
                    unless (completed-p trace)
                      do (push trace *unfinished-traces*)
                    do (incf *visitor-idx*))))
    (list
     (mapcar #'describe-trace-for-emacs
             (append recently-finished new))
     (- (length *traces*) *visitor-idx*)
     key)))

(defslyfun report-specs ()
  (mapcar (lambda (spec)
            (cons (string-downcase (present-for-emacs spec))
                  spec))
          (sort (copy-list *traced-specs*)
                #'string<
                :key #'princ-to-string)))

(defslyfun report-total ()
  (length *traces*))

(defslyfun clear-trace-tree ()
  (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*)
        *visitor-key* nil
        *unfinished-traces* nil)
  (slynk-backend:call-with-lock-held
   *trace-lock*
   (lambda () (setf (fill-pointer *traces*) 0)))
  nil)

(defslyfun trace-part-or-lose (id part-id type)
  (let* ((trace (trace-or-lose id))
         (l (ecase type
              (:arg (args-of trace))
              (:retval (slynk::ensure-list (retlist-of trace))))))
    (or (nth part-id l)
        (error "Cannot find a trace part with id ~a and part-id ~a"
               id part-id))))

(defslyfun trace-arguments-or-lose (trace-id)
  (values-list (args-of (trace-or-lose trace-id))))

(defslyfun inspect-trace-part (trace-id part-id type)
  (slynk::inspect-object
   (trace-part-or-lose trace-id part-id type)))

(defslyfun pprint-trace-part (trace-id part-id type)
  (slynk::slynk-pprint (list (trace-part-or-lose trace-id part-id type))))

(defslyfun describe-trace-part (trace-id part-id type)
  (slynk::describe-to-string (trace-part-or-lose trace-id part-id type)))

(defslyfun inspect-trace (trace-id)
  (slynk::inspect-object (trace-or-lose trace-id)))

(defslyfun trace-location (trace-id)
  (slynk-backend:find-source-location (function-of (trace-or-lose trace-id))))

(defslyfun dialog-trace (spec)
  (let ((function nil))
    (flet ((before-hook (args)
             (setf (current-trace) (make-instance 'trace-entry
                                                  :spec      spec
                                                  :function  (or function
                                                                 spec)
                                                  :args      args
                                                  :parent    (current-trace))))
           (after-hook (returned-values)
             (let ((trace (current-trace)))
               (when trace
                 (with-slots (retlist parent printed-retlist) trace
                   ;; the current trace might have been wiped away if the
                   ;; user cleared the tree in the meantime. no biggie,
                   ;; don't do anything.
                   ;;
                   (setf retlist returned-values
                         printed-retlist
                         (mapcar (lambda (obj)
                                   (present-for-emacs obj #'slynk-pprint-to-line))
                                 (slynk::ensure-list retlist))
                         (current-trace) parent))))))
      (when (dialog-traced-p spec)
        (warn "~a is apparently already traced! Untracing and retracing." spec)
        (dialog-untrace spec))
      (setq function
            (slynk-backend:wrap spec 'trace-dialog
                                :before #'before-hook
                                :after #'after-hook))
      (pushnew spec *traced-specs*)
      (format nil "~a is now traced for trace dialog" spec))))

(defslyfun dialog-untrace (spec)
  (with-simple-restart
      (continue "Never mind, i really want this trace to go away")
    (slynk-backend:unwrap spec 'trace-dialog))
  (setq *traced-specs* (remove spec *traced-specs* :test #'equal))
  (format nil "~a is now untraced for trace dialog" spec))

(defslyfun dialog-toggle-trace (spec)
  (if (dialog-traced-p spec)
      (dialog-untrace spec)
      (dialog-trace spec)))

(defslyfun dialog-traced-p (spec)
  (find spec *traced-specs* :test #'equal))

(defslyfun dialog-untrace-all ()
  (let ((regular (length (trace)))
        (dialog (length *traced-specs*)))
    (untrace)
    (mapcar #'dialog-untrace *traced-specs*)
    (cons regular dialog)))




;;;; Hook onto emacs
;;;;
(setq slynk:*after-toggle-trace-hook*
      (lambda (spec traced-p)
        (when *dialog-trace-follows-trace*
          (cond (traced-p
                 (dialog-trace spec)
                 "traced for trace dialog as well")
                (t
                 (dialog-untrace spec)
                 "untraced for the trace dialog as well")))))


;;;; Instrumentation
;;;;
(defmacro instrument (x &optional (id (gensym "EXPLICIT-INSTRUMENT-")) )
  (let ((values-sym (gensym)))
    `(let ((,values-sym (multiple-value-list ,x)))
       (trace-format (format nil "~a: ~a" ',id "~a => ~{~a~^, ~}") ',x
                     ,values-sym)
       (values-list ,values-sym))))

(provide :slynk/trace-dialog)
