Working breakpoint with gud goto

gudap.el

@@ -48,30 +48,67 @@
     :accessor gudap--process)
    (-expected-bytes
     :accessor gudap--expected-bytes)
-   (-sent-requests
-    :initform (make-hash-table)
-    :accessor gudap--sent-requests) ;; seq to request command
    (gud-buffer
     :initarg :gud-buffer
     :accessor gudap-gud-buffer)
    (next-seq
-    :initform 0
+    :initform 1
-    :accessor gudap--next-seq)))
+    :accessor gudap--next-seq)
+   (initialized
+    :initform nil
+    :accessor gudap-initialized)
+   (breakpoints ;; file path to list of plists (:line lineNum)
+    :initform (make-hash-table :test 'equal)
+    :accessor gudap-breakpoints)
+   (capabilities
+    :accessor gudap-capabilities)
+   (request-args ;; map of req_seq to list of request arguments
+    :initform (make-hash-table)
+    :accessor gudap-request-args)))
 
-(defvar gudap-server-programs
+(defvar gudap-server-programs-and-launch
   '(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug"))
     (c++-mode . "lldb-vscode")))
 
+(defvar gudap-active-server nil)
+
+(defun gudap--buffer-line ()
+  (save-restriction
+    (widen)
+    (+ (count-lines (point-min) (point))
+       (if (bolp) 1 0))))
+
+(defun gudap--gud-break ()
+  (interactive)
+  (let* ((server gudap-active-server)
+	 (file-path (buffer-file-name))
+	 (old-breakpoints (gethash file-path (gudap-breakpoints server)))
+	 (new-breakpoints (cons (list :line (gudap--buffer-line)) old-breakpoints)))
+    (gudap-send-request
+     server
+     'setBreakpoints
+     (list :source (gudap--dap-type-source file-path)
+	   :breakpoints (vconcat new-breakpoints)
+	   :lines (vconcat (mapcar (lambda (bp) (plist-get bp :line)) new-breakpoints))))))
+
+(defun gudap--dap-type-sourcebreak (line)
+  (list :line line))
+
+(defun gudap--dap-type-source (&optional path)
+  (let ((path (or path
+		  (buffer-file-name))))
+    (list :path path)))
+
 (defun gudap (server-command)
-  (gudap--connect server-command))
+  (gudap--connect server-command)
+  (defalias 'gud-break 'gudap--gud-break))
 
 (defun gudap--connect (server-command)
   (let* ((nickname server-command)
 	 (readable-name (format "GUDAP (%s)" nickname))
 	 (gud-buffer (gud-common-init "cat"
 				      (lambda (_file args) args)
-				      #'identity
+				      #'identity))
-				      (lambda (m) (gudap--message "%s" m))))
 	 (dap-proc  (make-process :name            readable-name
 				  :buffer          (generate-new-buffer readable-name)
 				  :command         (list server-command)
@@ -83,30 +120,61 @@
 			      :name readable-name
 			      :process dap-proc
 			      :gud-buffer gud-buffer)))
-    (process-put dap-proc 'gudap-connection conn)))
+    (process-put dap-proc 'gudap-connection conn)
+    (setq gudap-active-server conn)
+    (gudap-send-request conn 'initialize (gudap--initialize-arguments))))
 
 (cl-defgeneric gudap-send-request (server command arguments))
 
-(cl-defmethod gudap-send-request (server (command (eql initialize)) arguments)
+(cl-defmethod gudap-send-request (server command arguments &optional extra)
-  (puthash (gudap--next-seq server) 'initialize (gudap--sent-requests server))
+  (puthash (gudap--next-seq server)
+	   (append arguments extra)
+	   (gudap-request-args server))
   (gudap--connection-send
    server
    (list :type "request"
-	 :command "initialize"
+	 :command (symbol-name command)
-	 :arguments (gudap--initialize-arguments))))
+	 :arguments arguments)))
 
-(cl-defgeneric gudap-handle-response (server type body))
 
-(cl-defmethod gudap-handle-response (server type body)
+(cl-defgeneric gudap-handle-response (server command req-args success body))
-  (gudap--message "%s" body))
 
-(cl-defmethod gudap-handle-response (server (type (eql initialize)) body)
+(cl-defmethod gudap-handle-response (server (type (eql initialize)) req-args success body)
   (gudap--message "initialized"))
 
+(cl-defmethod gudap-handle-response (server (type (eql setBreakpoints)) req-args (success (eql t)) body)
+  (let ((req-path (gudap--path (plist-get req-args :source)))
+	(req-breakpoints (plist-get req-args :breakpoints))
+	(res-breakpoints (plist-get body :breakpoints)))
+    (if (not (eql (length req-breakpoints) (length res-breakpoints)))
+	(gudap--message "mismatched breakpoints, ignoring")
+      (let ((valid-breakpoints (cl-loop for req-bp across req-breakpoints
+					for res-bp across res-breakpoints
+					for req-line = (plist-get req-bp :line)
+					for res-line = (plist-get res-bp :line)
+					if (plist-get res-bp :verified)
+					collect (list :line (or res-line req-line)))))
+	(puthash req-path valid-breakpoints (gudap-breakpoints server))))))
+
+(cl-defmethod gudap-handle-response (server (type (eql stackTrace)) req-args (success (eql t)) body)
+  (if (plist-get req-args :show)
+      (cl-destructuring-bind (&key stackFrames &allow-other-keys) body
+	(if (length> stackFrames 0)
+	    (let* ((cur-frame (aref stackFrames 0))
+		   (path (gudap--path (plist-get cur-frame :source)))
+		   (line (plist-get cur-frame :line)))
+	      (if (> line 0)
+		  (progn
+		    (setq gud-last-frame (cons path line))
+		    (gud-display-frame))))))))
+	     
+(cl-defmethod gudap-handle-response (server command req-args success body)
+  (gudap--message "unknown response: %s" body))
+
 (cl-defgeneric gudap-handle-event (server event body))
 
 (cl-defmethod gudap-handle-event (server event body)
-  (gudap--message "%s" message))
+  (gudap--message "%s" body))
 
 (cl-defmethod gudap-handle-event (server (event (eql output)) body)
   (let ((gud-process (get-buffer-process (gudap-gud-buffer server))))
@@ -116,8 +184,24 @@
       (pcase category
 	("console" (gud-filter gud-process output))))))
 
+(cl-defmethod gudap-handle-event (server (event (eql initialized)) body)
+  (setf (gudap-initialized server) t))
+
+(cl-defmethod gudap-handle-event (server (event (eql stopped)) body)
+  (cl-destructuring-bind (&key reason threadId &allow-other-keys) body
+    (pcase reason
+      ("breakpoint"
+       (gudap-gud-output server (format "breakpoint hit"))
+       (gudap-send-request server 'stackTrace `(:threadId ,threadId) '(:show t))))))
+
 (cl-defgeneric gudap-handle-request (server command arguments))
 
+(cl-defgeneric gudap-gud-output (server output))
+
+(cl-defmethod gudap-gud-output (server output)
+  (let ((gud-process (get-buffer-process (gudap-gud-buffer server))))
+    (gud-filter gud-process (format "%s\n" output))))
+
 (defun gudap--initialize-arguments ()
   (list :clientId "gudap"
 	:clientName "gudap"
@@ -136,6 +220,9 @@
 	:supportsArgsCanBeInterpretedByShell nil
 	:supportsStartDebuggingRequest nil))
 
+(defun gudap--path (source)
+  (plist-get source :path))
+
 ;; Utils    
 
 (defun gudap--message (format &rest args)
@@ -230,24 +317,24 @@
           (setf (gudap--expected-bytes connection) expected-bytes))))))
 
 (defun gudap--connection-receive (conn message)
-  (cl-destructuring-bind (&key seq type event body arguments &allow-other-keys) message
+  (gudap--message "received message: %s" message)
+  (cl-destructuring-bind (&key seq request_seq type command event body arguments success &allow-other-keys) message
     (cond
      (;; event
       (string-equal type "event")
       (gudap-handle-event conn (intern event) body))
      (;; response
       (string-equal type "response")
-      (let ((request-type (gethash seq (gudap--sent-requests conn))))
+      (let ((request-args (gethash request_seq (gudap-request-args conn))))	
-	(if request-type
+	(gudap-handle-response conn (intern command) request-args success body)
-	    (gudap-handle-response conn request-type body)
+	(remhash request_seq (gudap-request-args conn))))
-	  (gudap--message "received response to a nonexistent request. ignoring")))
-      (remhash seq (gudap--sent-requests conn)))
      (;; reverse request
       (string-equal type "request")
       (gudap-handle-request conn (intern command) arguments)))))
 
 (defun gudap--connection-send (conn message)
   (setq message (plist-put message :seq (gudap--next-seq conn)))
+  (gudap--message "sent message: %s" message)
   (let* ((json-object-type 'plist)
 	 (json (jsonrpc--json-encode message))
 	 (headers `(("Content-Length" . ,(format "%d" (string-bytes json)))))