(defpackage :agnostic-lizard-debugger-prototype
  (:use :common-lisp :agnostic-lizard-debugger-hooks)
  (:export
    #:make-debugged-thread
    #:*thread-debugger-hook-names*
    #:send-debugged-thread-command
    #:send-debugger-step-in
    #:send-debugger-step-over
    #:send-debugger-step-out))

(in-package :agnostic-lizard-debugger-prototype)

(defclass debugger-hooks-bt-state (debugger-hooks-state)
  ((debugger-hooks-lock :initarg :lock :initform (bordeaux-threads:make-lock)
                        :accessor debugger-hooks-lock)
   (debugger-hooks-condition-variable
     :initarg :condition-variable
     :initform (bordeaux-threads:make-condition-variable)
     :accessor debugger-hooks-condition-variable)
   (debugger-hooks-breakpoint-notifier
     :initarg :breakpoint-notifier
     :initform nil
     :accessor debugger-hooks-breakpoint-notifier)))

(defmethod debugger-hooks-assign ((object debugger-hooks-bt-state)
                                  &key
                                  (lock nil lockp)
                                  (condition-variable nil condition-variable-p)
                                  (breakpoint-notifier
                                    nil breakpoint-notifier-p)
                                  &allow-other-keys)
  (when lockp (setf (debugger-hooks-lock object) lock))
  (when condition-variable-p
    (setf (debugger-hooks-condition-variable object) condition-variable))
  (bordeaux-threads:with-lock-held ((debugger-hooks-lock object))
                                   (when breakpoint-notifier-p
                                     (setf 
                                       (debugger-hooks-breakpoint-notifier
                                         object)
                                       breakpoint-notifier))
                                   (call-next-method)))

(defvar *debugger-hook-data* nil)

(defun debugger-hook (&rest args &key position form marker
                            function-marker function result)
  (catch 'debugger-hook-result
         (let ((lock (debugger-hooks-lock *debugger-hooks-state*))
               (c-v (debugger-hooks-condition-variable *debugger-hooks-state*)))
           (bordeaux-threads:with-lock-held (lock)
             (setf (debugger-hooks-command *debugger-hooks-state*) nil)
             (if (debugger-hooks-breakpoint-notifier *debugger-hooks-state*)
               (apply (debugger-hooks-breakpoint-notifier *debugger-hooks-state*)
                      args)
               (progn
                 (format *trace-output* "Reached a breakpoint (~a ~a@~a):~%~s~%"
                         position marker function-marker form)
                 (when (find position '(:after :after-function))
                   (format *trace-output* "Result:~%~S~%" result))
                 (when function
                   (format *trace-output* "Function marker ~a is ~a~%"
                           function-marker function))))
             (loop with command := nil
                   do (setf command (debugger-hooks-command *debugger-hooks-state*))
                   when (eval `(let* ((*debugger-hook-data* ',args)) ,command))
                   return nil
                   do (setf (debugger-hooks-command *debugger-hooks-state*) nil)
                   do (bordeaux-threads:condition-wait c-v lock)))
           result)))

(defvar *thread-debugger-hook-names* (make-hash-table :test 'equal))

(defun make-debugged-thread (name thunk &key (active t)
                                   (callback #'debugger-hook))
  (let* ((name (or name (gensym)))
         (lock (bordeaux-threads:make-lock))
         (c-v (bordeaux-threads:make-condition-variable)))
    (bordeaux-threads:with-lock-held (lock)
      (let*((thread
              (bordeaux-threads:make-thread
                (lambda ()
                  (with-local-debugger-hook
                    (name :active active :callback callback
                          :class debugger-hooks-bt-state)
                    (bordeaux-threads:with-lock-held (lock)
                      (bordeaux-threads:condition-notify c-v))
                    (funcall thunk))
                  :name name))))
        (bordeaux-threads:condition-wait c-v lock)
        (setf (gethash thread *thread-debugger-hook-names*) name)
        thread))))

(defun send-debugged-thread-command (name command)
  (let* ((name (if (bordeaux-threads:threadp name)
                 (gethash name *thread-debugger-hook-names*)
                 name))
         (state (gethash name *local-debugger-hooks*)))
    (bordeaux-threads:with-lock-held ((debugger-hooks-lock state))
      (setf (debugger-hooks-command state) command)
      (bordeaux-threads:condition-notify
        (debugger-hooks-condition-variable state)))))

(defun send-debugger-step-in (name)
  (send-debugged-thread-command
    name `(progn (setf (debugger-hooks-callback *debugger-hooks-state*)
                       #'debugger-hook
                       (debugger-hooks-active *debugger-hooks-state*) t)
                 t)))

(defun send-debugger-step-over (name)
  (send-debugged-thread-command
    name `(progn
            (destructuring-bind (&key position marker result)
              *debugger-hook-data*
              (case position
                ((:before :before-function)
                 (setf (debugger-hooks-active *debugger-hooks-state*) t
                       (debugger-hooks-callback *debugger-hooks-state*)
                       (let ((old-marker marker))
                         (lambda (&rest args &key marker position
                                        form expanded-form)
                           (format t "~s~%" (list :step-over old-marker
                                                  position marker result
                                                  form expanded-form))
                           (if (or (eq marker old-marker)
                                   (eq position :before-control-transfer))
                             (apply #'debugger-hook args)
                             result)))))
                ((:before-control-transfer)
                 (setf (debugger-hooks-callback *debugger-hooks-state*)
                       #'debugger-hook
                       (debugger-hooks-active *debugger-hooks-state*) t))
                (t (setf (debugger-hooks-callback *debugger-hooks-state*)
                         #'debugger-hook
                         (debugger-hooks-active *debugger-hooks-state*) t))))
            t)))

(defun send-debugger-step-out (name)
  (send-debugged-thread-command
    name `(progn
            (destructuring-bind (&key function-marker position result)
              *debugger-hook-data*
              (case position
                ((:after-function)
                 (setf (debugger-hooks-callback *debugger-hooks-state*)
                       #'debugger-hook
                       (debugger-hooks-active *debugger-hooks-state*) t))
                (t (setf (debugger-hooks-active *debugger-hooks-state*) t
                         (debugger-hooks-callback *debugger-hooks-state*)
                         (let ((old-marker function-marker))
                           (lambda (&rest args &key position function-marker result)
                             (format t "~s~%" (list :step-out old-marker
                                                    position function-marker result))
                             (if (or (eq position :before-control-transfer)
                                     (and (eq function-marker old-marker)
                                          (eq position :after-function)))
                               (apply #'debugger-hook args)
                               result)))))))
            t)))

#+nil
(agnostic-lizard-debugger-prototype:make-debugged-thread
  'test-thread-debugger
  (agnostic-lizard-debugger-hooks:with-debugger-hook-calls
    (lambda ()
      (loop for x from 1 to 3 do (format t "~s~%" (* x x))))))

#+nil
(agnostic-lizard-debugger-prototype:send-debugged-thread-command
  'test-thread-debugger t)

#+nil
(agnostic-lizard-debugger-prototype:send-debugger-step-in
  'test-thread-debugger)

#+nil
(agnostic-lizard-debugger-prototype:send-debugger-step-over
  'test-thread-debugger)

#+nil
(agnostic-lizard-debugger-prototype:send-debugger-step-out
  'test-thread-debugger)

#+nil
(setf (agnostic-lizard-debugger-hooks:debugger-hooks-callback
        (gethash 'test-thread-debugger
                 agnostic-lizard-debugger-hooks:*local-debugger-hooks*))
      (lambda (&key result position function)
        (when (eq position :after-function)
          (format *trace-output* "Reached exit from ~a result:~%~s~%"
                  function result))
        result))
