godotengine/emacs-gdscript-mode
1
0
Fork 0
mirror of https://github.com/godotengine/emacs-gdscript-mode.git synced 2025-12-31 21:48:34 +03:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
emacs-gdscript-mode/gdscript-debug.el
Benjamin Kästner 9043e1a6b6 Replace old repository path 
The repository was moved from GDQuest to godotengine on GitHub.
2021-03-28 20:59:54 +02:00

2445 lines
111 KiB
EmacsLisp
Raw Permalink Blame History

;;; gdscript-debug.el --- Debugger for Godot -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2020 GDQuest
;; Author: Josef Vlach <vlach.josef@gmail.com>
;; URL: https://github.com/godotengine/emacs-gdscript-mode/
;; Version: 0.0.1
;; Package-Requires: ((emacs "26.3"))
;; Maintainer: vlach.josef@gmail.com
;; Created: Oct 2020
;; Keywords: languages
;; This file is not part of GNU Emacs
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; For a full copy of the GNU General Public License
;; see <https://www.gnu.org/licenses/>.
;;
;;; Commentary:
;;
;; Inspired by gdb-mi.
;;
;;; Code:
(require 'bindat)
(require 'generator)
(require 'gdscript-customization)
;;(require 'gdscript-hydra) -- this causes cyclic dependency
(require 'gdscript-utils)
(eval-when-compile
(require 'subr-x))
(defcustom gdscript-debug-emacs-executable "Emacs"
"The name of Emacs application. Used for focusing Emacs
when breakpoint is encountered in Godot."
:type 'string
:group 'gdscript)
;; Overlay arrow markers
(defvar gdscript-debug--thread-position nil)
(defvar gdscript-debug--boolean-bindat-spec
'((:boolean-data u32r)))
(defvar gdscript-debug--integer-bindat-spec
`((:data u32r)
(:integer-data eval (- (logand last ,(lognot (lsh 1 31))) (logand last ,(lsh 1 31))))))
(defvar gdscript-debug--integer-64-bindat-spec
`((:data-a u32r)
(:data-b u32r)
(:data eval (let ((a (bindat-get-field struct :data-a))
(b (bindat-get-field struct :data-b)))
(logior (lsh b 32) a)))
(:integer-data eval (let ((a (bindat-get-field struct :data)))
(- (logand a ,(lognot (lsh 1 63))) (logand a ,(lsh 1 63)))))))
;; Credit goes to https://github.com/skeeto/bitpack/blob/master/bitpack.el
(defsubst gdscript-debug--load-f32 (b0 b1 b2 b3)
(let* ((negp (= #x80 (logand b0 #x80)))
(exp (logand (logior (ash b0 1) (ash b1 -7)) #xff))
(mantissa (logior #x800000
(ash (logand #x7f b1) 16)
(ash b2 8)
b3))
(result (cond ((= #xff exp)
(if (= #x800000 mantissa)
1.0e+INF
0.0e+NaN))
((= #x0 exp b1 b2 b3) 0.0)
(t (ldexp (ldexp mantissa -24) (- exp 126))))))
(if negp
(- result)
result)))
(defsubst gdscript-debug--load-f64 (b0 b1 b2 b3 b4 b5 b6 b7)
(let* ((negp (= #x80 (logand b0 #x80)))
(exp (logand (logior (ash b0 4) (ash b1 -4)) #x7ff))
(mantissa (logior #x10000000000000
(ash (logand #xf b1) 48)
(ash b2 40)
(ash b3 32)
(ash b4 24)
(ash b5 16)
(ash b6 8)
b7))
(result (if (= #x7ff exp)
(if (= #x10000000000000 mantissa)
1.0e+INF
0.0e+NaN)
(ldexp (ldexp mantissa -53) (- exp 1022)))))
(if negp
(- result)
result)))
(defsubst gdscript-debug--to-symbol (symbol-name &optional suffix)
(intern (concat (symbol-name symbol-name) suffix)))
(defmacro gdscript-debug--capture-float-spec (symbol-name)
(let ((symbol (gdscript-debug--to-symbol symbol-name)))
`(quote ((:vect vec 4 byte)
(,symbol eval (let ((alist (reverse (append (bindat-get-field struct :vect) nil))))
(apply 'gdscript-debug--load-f32 alist)))))))
(defvar gdscript-debug--float-bindat-spec
'((:vect vec 4 byte)
(:float-value eval (let ((alist (reverse (append (bindat-get-field struct :vect) nil))))
(apply 'gdscript-debug--load-f32 alist)))))
(defvar gdscript-debug--float-64-bindat-spec
'((:vect vec 8 byte)
(:float-value eval (let ((alist (reverse (append (bindat-get-field struct :vect) nil))))
(apply 'gdscript-debug--load-f64 alist)))))
(defvar gdscript-debug--string-bindat-spec
'((:data-length u32r)
(:string-data str (:data-length))
(align 4)))
(defvar gdscript-debug--string-z-bindat-spec
'((:data-length u32r)
(:string-data strz (:data-length))
(align 4)))
(defvar gdscript-debug--vector2-bindat-spec
`(,@(gdscript-debug--capture-float-spec :x)
,@(gdscript-debug--capture-float-spec :y)))
(defvar gdscript-debug--rect2-bindat-spec
`(,@(gdscript-debug--capture-float-spec :x-coordinate)
,@(gdscript-debug--capture-float-spec :y-coordinate)
,@(gdscript-debug--capture-float-spec :x-size)
,@(gdscript-debug--capture-float-spec :y-size)))
(defvar gdscript-debug--vector3-bindat-spec
`(,@(gdscript-debug--capture-float-spec :x)
,@(gdscript-debug--capture-float-spec :y)
,@(gdscript-debug--capture-float-spec :z)))
(defvar gdscript-debug--transform2d-bindat-spec
`(,@(gdscript-debug--capture-float-spec :xx)
,@(gdscript-debug--capture-float-spec :xy)
,@(gdscript-debug--capture-float-spec :yx)
,@(gdscript-debug--capture-float-spec :yy)
,@(gdscript-debug--capture-float-spec :x-origin)
,@(gdscript-debug--capture-float-spec :y-origin)))
(defvar gdscript-debug--dictionary-bindat-spec
'((:data u32r)
(:shared eval (logand (bindat-get-field struct :data) #x80000000))
(:elements eval (logand (bindat-get-field struct :data) #x7fffffff))
(:dictionary-length eval (* 2 last))
(:items repeat (:dictionary-length) (struct gdscript-godot-data-bindat-spec))))
(defvar gdscript-debug--array-bindat-spec
'((:data u32r)
(:shared eval (logand (bindat-get-field struct :data) #x80000000))
(:array-length eval (logand (bindat-get-field struct :data) #x7fffffff))
(:items repeat (:array-length) (struct gdscript-godot-data-bindat-spec))))
(defvar gdscript-debug--pool-byte-array-bindat-spec
'((:array-length u32r)
(:items vec (:array-length) byte)
(align 4)))
(defvar gdscript-debug--pool-int-array-bindat-spec
'((:array-length u32r)
(:items repeat (:array-length) (struct gdscript-debug--integer-bindat-spec))))
(defvar gdscript-debug--pool-real-array-bindat-spec
'((:array-length u32r)
(:items repeat (:array-length) (struct gdscript-debug--float-bindat-spec))))
(defvar gdscript-debug--pool-string-array-bindat-spec
'((:array-length u32r)
(:items repeat (:array-length) (struct gdscript-debug--string-z-bindat-spec))))
(defvar gdscript-debug--pool-vector2-array-bindat-spec
'((:array-length u32r)
(:items repeat (:array-length) (struct gdscript-debug--vector2-bindat-spec))))
(defvar gdscript-debug--pool-vector3-array-bindat-spec
'((:array-length u32r)
(:items repeat (:array-length) (struct gdscript-debug--vector3-bindat-spec))))
(defvar gdscript-debug--pool-color-array-bindat-spec
'((:array-length u32r)
(:items repeat (:array-length) (struct gdscript-debug--color-bindat-spec))))
(defvar gdscript-debug--plane-bindat-spec
`(,@(gdscript-debug--capture-float-spec :normal-x)
,@(gdscript-debug--capture-float-spec :normal-y)
,@(gdscript-debug--capture-float-spec :normal-z)
,@(gdscript-debug--capture-float-spec :distance)))
(defvar gdscript-debug--quat-bindat-spec
`(,@(gdscript-debug--capture-float-spec :x-imaginary)
,@(gdscript-debug--capture-float-spec :y-imaginary)
,@(gdscript-debug--capture-float-spec :z-imaginary)
,@(gdscript-debug--capture-float-spec :real-w)))
(defvar gdscript-debug--aabb-bindat-spec
`(,@(gdscript-debug--capture-float-spec :x-coordinate)
,@(gdscript-debug--capture-float-spec :y-coordinate)
,@(gdscript-debug--capture-float-spec :z-coordinate)
,@(gdscript-debug--capture-float-spec :x-size)
,@(gdscript-debug--capture-float-spec :y-size)
,@(gdscript-debug--capture-float-spec :z-size)))
(defvar gdscript-debug--basis-bindat-spec
`(,@(gdscript-debug--capture-float-spec :xx)
,@(gdscript-debug--capture-float-spec :xy)
,@(gdscript-debug--capture-float-spec :xz)
,@(gdscript-debug--capture-float-spec :yx)
,@(gdscript-debug--capture-float-spec :yy)
,@(gdscript-debug--capture-float-spec :yz)
,@(gdscript-debug--capture-float-spec :zx)
,@(gdscript-debug--capture-float-spec :zy)
,@(gdscript-debug--capture-float-spec :zz)))
(defvar gdscript-debug--transform-bindat-spec
`(,@(gdscript-debug--capture-float-spec :xx)
,@(gdscript-debug--capture-float-spec :xy)
,@(gdscript-debug--capture-float-spec :xz)
,@(gdscript-debug--capture-float-spec :yx)
,@(gdscript-debug--capture-float-spec :yy)
,@(gdscript-debug--capture-float-spec :yz)
,@(gdscript-debug--capture-float-spec :zx)
,@(gdscript-debug--capture-float-spec :zy)
,@(gdscript-debug--capture-float-spec :zz)
,@(gdscript-debug--capture-float-spec :x-origin)
,@(gdscript-debug--capture-float-spec :y-origin)
,@(gdscript-debug--capture-float-spec :z-origin)))
(defvar gdscript-debug--color-bindat-spec
`(,@(gdscript-debug--capture-float-spec :red)
,@(gdscript-debug--capture-float-spec :green)
,@(gdscript-debug--capture-float-spec :blue)
,@(gdscript-debug--capture-float-spec :alpha)))
(defvar gdscript-debug--node-path-bindat-spec
'((:data-length u32r)
(:new-format eval (logand (bindat-get-field struct :data-length) #x80000000))
(:name-count eval (logand (bindat-get-field struct :data-length) #x7FFFFFFF))
(:subname-count u32r)
(:flags u32r)
(:absolute eval (not (eq 0 (logand (bindat-get-field struct :flags) #x1))))
(:names repeat (:name-count) (struct gdscript-debug--string-bindat-spec))
(:subnames repeat (:subname-count) (struct gdscript-debug--string-bindat-spec))))
(defvar gdscript-debug--rid-bindat-spec nil) ;; unsupported
(defvar gdscript-debug--object-as-id-bindat-spec
'((:object-as-id-a u32r)
(:object-as-id-b u32r)
(:long eval (let ((a (bindat-get-field struct :object-as-id-a))
(b (bindat-get-field struct :object-as-id-b)))
(logior (lsh b 32) a)))))
(defconst gdscript-debug--encode-mask #xff)
(defconst gdscript-debug--encode-flag-64 (lsh 1 16))
(defvar gdscript-godot-data-bindat-spec
'((:type-data u32r)
(:type eval (logand last gdscript-debug--encode-mask))
(:flag-64 eval (logand (bindat-get-field struct :type-data) gdscript-debug--encode-flag-64))
(:object-as-id eval (logand (bindat-get-field struct :type-data) gdscript-debug--encode-flag-64))
(union (:type)
(0 nil)
(1 (struct gdscript-debug--boolean-bindat-spec))
((eval (and (eq 2 tag) (equal 0 (bindat-get-field struct :flag-64)))) (struct gdscript-debug--integer-bindat-spec))
(2 (struct gdscript-debug--integer-64-bindat-spec))
((eval (and (eq 3 tag) (equal 0 (bindat-get-field struct :flag-64)))) (struct gdscript-debug--float-bindat-spec))
(3 (struct gdscript-debug--float-64-bindat-spec))
(4 (struct gdscript-debug--string-bindat-spec))
(5 (struct gdscript-debug--vector2-bindat-spec))
(6 (struct gdscript-debug--rect2-bindat-spec))
(7 (struct gdscript-debug--vector3-bindat-spec))
(8 (struct gdscript-debug--transform2d-bindat-spec))
(9 (struct gdscript-debug--plane-bindat-spec))
(10 (struct gdscript-debug--quat-bindat-spec))
(11 (struct gdscript-debug--aabb-bindat-spec))
(12 (struct gdscript-debug--basis-bindat-spec))
(13 (struct gdscript-debug--transform-bindat-spec))
(14 (struct gdscript-debug--color-bindat-spec))
(15 (struct gdscript-debug--node-path-bindat-spec))
(16 (struct gdscript-debug--rid-bindat-spec))
((eval (and (eq 17 tag) (equal 0 (bindat-get-field struct :object-as-id)))) (error "[ObjectId] Not implemented yet"))
(17 (struct gdscript-debug--object-as-id-bindat-spec))
(18 (struct gdscript-debug--dictionary-bindat-spec))
(19 (struct gdscript-debug--array-bindat-spec))
(20 (struct gdscript-debug--pool-byte-array-bindat-spec))
(21 (struct gdscript-debug--pool-int-array-bindat-spec))
(22 (struct gdscript-debug--pool-real-array-bindat-spec))
(23 (struct gdscript-debug--pool-string-array-bindat-spec))
(24 (struct gdscript-debug--pool-vector2-array-bindat-spec))
(25 (struct gdscript-debug--pool-vector3-array-bindat-spec))
(26 (struct gdscript-debug--pool-color-array-bindat-spec))
(t (eval (error "Unknown type: %s" tag))))))
(defvar gdscript-debug--previous-packet-data nil)
(defvar gdscript-debug--data-needed nil)
(defvar gdscript-debug--offset 0)
(defvar gdscript-debug--packet-length-bindat-spec '((:packet-length u32r)))
(defun gdscript-debug--current-packet (content offset)
(bindat-unpack gdscript-debug--packet-length-bindat-spec content offset))
(defun gdscript-debug--process-packet (content offset)
(bindat-unpack gdscript-godot-data-bindat-spec content offset))
(iter-defun gdscript-debug--command-iter ()
(setq gdscript-debug--data-needed
(catch 'not-enough-data-to-process-packed
(while (< gdscript-debug--offset (length gdscript-debug--previous-packet-data))
(let* ((content gdscript-debug--previous-packet-data)
(content-length (length content))
(packet-length-data (gdscript-debug--current-packet content gdscript-debug--offset))
(packet-length (bindat-get-field packet-length-data :packet-length))
(next-packet-offset (+ 4 gdscript-debug--offset packet-length)))
(if (<= next-packet-offset content-length)
(let ((packet-data (gdscript-debug--process-packet content (+ 4 gdscript-debug--offset))))
(setq gdscript-debug--offset next-packet-offset)
(iter-yield packet-data))
(throw 'not-enough-data-to-process-packed next-packet-offset))))))
(setq gdscript-debug--offset 0))
(defsubst gdscript-debug--get-boolean (struct-data)
(bindat-get-field struct-data :boolean-data))
(defsubst gdscript-debug--get-integer (struct-data)
(bindat-get-field struct-data :integer-data))
(defsubst gdscript-debug--get-float (struct-data)
(bindat-get-field struct-data :float-value))
(defsubst gdscript-debug--get-string (struct-data)
(bindat-get-field struct-data :string-data))
(defsubst gdscript-debug--get-array (struct-data)
(bindat-get-field struct-data :items))
(defsubst gdscript-debug--to-plane (struct)
(let ((normal-x (bindat-get-field struct :normal-x))
(normal-y (bindat-get-field struct :normal-y))
(normal-z (bindat-get-field struct :normal-z))
(distance (bindat-get-field struct :distance)))
(gdscript-plane-create
:normal (gdscript-vector3-create
:x normal-x
:y normal-y
:z normal-z)
:distance distance)))
(defsubst gdscript-debug--to-quat (struct)
(let ((x-imaginary (bindat-get-field struct :x-imaginary))
(y-imaginary (bindat-get-field struct :y-imaginary))
(z-imaginary (bindat-get-field struct :z-imaginary))
(real-w (bindat-get-field struct :real-w)))
(gdscript-quat-create
:x-imaginary x-imaginary
:y-imaginary y-imaginary
:z-imaginary z-imaginary
:real-w real-w)))
(defsubst gdscript-debug--to-aabb (struct)
(let ((x-coordinate (bindat-get-field struct :x-coordinate))
(y-coordinate (bindat-get-field struct :y-coordinate))
(z-coordinate (bindat-get-field struct :z-coordinate))
(x-size (bindat-get-field struct :x-size))
(y-size (bindat-get-field struct :y-size))
(z-size (bindat-get-field struct :z-size)))
(gdscript-aabb-create
:position (gdscript-vector3-create
:x x-coordinate
:y y-coordinate
:z z-coordinate)
:size (gdscript-vector3-create
:x x-size
:y y-size
:z z-size))))
(defsubst gdscript-debug--to-basis (struct)
(let ((xx (bindat-get-field struct :xx))
(xy (bindat-get-field struct :xy))
(xz (bindat-get-field struct :xz))
(yx (bindat-get-field struct :yx))
(yy (bindat-get-field struct :yy))
(yz (bindat-get-field struct :yz))
(zx (bindat-get-field struct :zx))
(zy (bindat-get-field struct :zy))
(zz (bindat-get-field struct :zz)))
(gdscript-basis-create
:x (gdscript-vector3-create :x xx :y xy :z xz)
:y (gdscript-vector3-create :x yx :y yy :z yz)
:z (gdscript-vector3-create :x zx :y zy :z zz))))
(defsubst gdscript-debug--to-transform (struct)
(let ((basis (gdscript-debug--to-basis struct))
(x-origin (bindat-get-field struct :x-origin))
(y-origin (bindat-get-field struct :y-origin))
(z-origin (bindat-get-field struct :z-origin)))
(gdscript-transform-create
:basis basis
:origin (gdscript-vector3-create
:x x-origin
:y y-origin
:z z-origin))))
(defsubst gdscript-debug--to-color (struct)
(let ((red (bindat-get-field struct :red))
(green (bindat-get-field struct :green))
(blue (bindat-get-field struct :blue))
(alpha (bindat-get-field struct :alpha)))
(gdscript-color-create :red red :green green :blue blue :alpha alpha)))
(defsubst gdscript-debug--to-node-path (struct)
(let ((names (mapcar 'gdscript-debug--to-string (bindat-get-field struct :names)))
(subnames (mapcar 'gdscript-debug--to-string (bindat-get-field struct :subnames)))
(absolute (bindat-get-field struct :absolute)))
(gdscript-node-path-create :names names :subnames subnames :absolute (gdscript-bool-create :value absolute))))
(defsubst gdscript-debug--to-rid (_struct-data)
(gdscript-rid-create))
(defsubst gdscript-debug--to-vector2 (struct-data)
(let ((x (bindat-get-field struct-data :x))
(y (bindat-get-field struct-data :y)))
(gdscript-vector2-create :x x :y y)))
(defsubst gdscript-debug--to-rect2 (struct)
(let ((x-coordinate (bindat-get-field struct :x-coordinate))
(y-coordinate (bindat-get-field struct :y-coordinate))
(x-size (bindat-get-field struct :x-size))
(y-size (bindat-get-field struct :y-size)))
(gdscript-rect2-create
:coordinate (gdscript-vector2-create :x x-coordinate :y y-coordinate)
:size (gdscript-vector2-create :x x-size :y y-size))))
(defsubst gdscript-debug--to-vector3 (struct-data)
(let ((x (bindat-get-field struct-data :x))
(y (bindat-get-field struct-data :y))
(z (bindat-get-field struct-data :z)))
(gdscript-vector3-create :x x :y y :z z)))
(defsubst gdscript-debug--to-transform2d (struct-data)
(let ((xx (bindat-get-field struct-data :xx))
(xy (bindat-get-field struct-data :xy))
(yx (bindat-get-field struct-data :yx))
(yy (bindat-get-field struct-data :yy))
(x-origin (bindat-get-field struct-data :x-origin))
(y-origin (bindat-get-field struct-data :y-origin)))
(gdscript-transform2d-create
:x (gdscript-vector2-create :x xx :y xy)
:y (gdscript-vector2-create :x yx :y yy)
:origin (gdscript-vector2-create :x x-origin :y y-origin))))
(defsubst gdscript-debug--to-null (_struct-data)
(gdscript-null-create))
(defsubst gdscript-debug--to-boolean (struct-data)
(gdscript-bool-create :value (if (eq 1 (gdscript-debug--get-boolean struct-data))
t
nil)))
(defsubst gdscript-debug--shared-to-boolean (shared)
(gdscript-bool-create :value (if (eq 0 shared) nil t)))
(defsubst gdscript-debug--to-integer (struct-data)
(gdscript-integer-create :value (gdscript-debug--get-integer struct-data)))
(defsubst gdscript-debug--to-float (struct-data)
(gdscript-float-create :value (gdscript-debug--get-float struct-data)))
(defsubst gdscript-debug--to-string (struct-data)
(gdscript-string-create :value (gdscript-debug--get-string struct-data)))
(defsubst gdscript-debug--to-object-id (struct-data)
(gdscript-object-id-create :value (bindat-get-field struct-data :long)))
(defsubst gdscript-debug--to-dictionary (struct-data)
(let* ((shared (bindat-get-field struct-data :shared))
(items (bindat-get-field struct-data :items)))
(gdscript-dictionary-create :shared (gdscript-debug--shared-to-boolean shared) :elements (gdscript-debug--to-dic items))))
(defun gdscript-debug--to-dic (xs)
(cl-loop for (key value) on xs by 'cddr
collect (gdscript-debug--from-key-value key value)))
(defsubst gdscript-debug--to-array (struct-data)
(let ((shared (bindat-get-field struct-data :shared))
(items (bindat-get-field struct-data :items)))
(gdscript-array-create :shared (gdscript-debug--shared-to-boolean shared) :elements (mapcar 'gdscript-debug--from-variant items))))
(defsubst gdscript-debug--to-pool-byte-array (struct-data)
(let ((items (bindat-get-field struct-data :items)))
(gdscript-pool-byte-array-create :elements items)))
(defsubst gdscript-debug--to-pool-int-array (struct-data)
(let ((items (bindat-get-field struct-data :items)))
(gdscript-pool-int-array-create :elements (mapcar 'gdscript-debug--to-integer items))))
(defsubst gdscript-debug--to-pool-real-array (struct-data)
(let ((items (bindat-get-field struct-data :items)))
(gdscript-pool-real-array-create :elements (mapcar 'gdscript-debug--to-float items))))
(defsubst gdscript-debug--to-pool-string-array (struct-data)
(let ((items (bindat-get-field struct-data :items)))
(gdscript-pool-string-array-create :elements (mapcar 'gdscript-debug--to-string items))))
(defsubst gdscript-debug--to-pool-vector2-array (struct-data)
(let ((items (bindat-get-field struct-data :items)))
(gdscript-pool-vector2-array-create :elements (mapcar 'gdscript-debug--to-vector2 items))))
(defsubst gdscript-debug--to-pool-vector3-array (struct-data)
(let ((items (bindat-get-field struct-data :items)))
(gdscript-pool-vector3-array-create :elements (mapcar 'gdscript-debug--to-vector3 items))))
(defsubst gdscript-debug--to-pool-color-array (struct-data)
(let ((items (bindat-get-field struct-data :items)))
(gdscript-pool-color-array-create :elements (mapcar 'gdscript-debug--to-color items))))
(defun gdscript-debug--from-key-value (key value)
(let* ((var-name (gdscript-debug--from-variant key))
(var-val (gdscript-debug--from-variant value)))
`(,var-name . ,var-val)))
(defun gdscript-debug--from-variant (struct)
(let ((type (bindat-get-field struct :type))
(object-as-id (bindat-get-field struct :object-as-id)))
(pcase type
(0 (gdscript-debug--to-null struct))
(1 (gdscript-debug--to-boolean struct))
(2 (gdscript-debug--to-integer struct))
(3 (gdscript-debug--to-float struct))
(4 (gdscript-debug--to-string struct))
(5 (gdscript-debug--to-vector2 struct))
(6 (gdscript-debug--to-rect2 struct))
(7 (gdscript-debug--to-vector3 struct))
(8 (gdscript-debug--to-transform2d struct))
(9 (gdscript-debug--to-plane struct))
(10 (gdscript-debug--to-quat struct))
(11 (gdscript-debug--to-aabb struct))
(12 (gdscript-debug--to-basis struct))
(13 (gdscript-debug--to-transform struct))
(14 (gdscript-debug--to-color struct))
(15 (gdscript-debug--to-node-path struct))
(16 (gdscript-debug--to-rid struct))
(17 (if (eq 0 object-as-id) (error "TODO object as not ID")
(gdscript-debug--to-object-id struct)))
(18 (gdscript-debug--to-dictionary struct))
(19 (gdscript-debug--to-array struct))
(20 (gdscript-debug--to-pool-byte-array struct))
(21 (gdscript-debug--to-pool-int-array struct))
(22 (gdscript-debug--to-pool-real-array struct))
(23 (gdscript-debug--to-pool-string-array struct))
(24 (gdscript-debug--to-pool-vector2-array struct))
(25 (gdscript-debug--to-pool-vector3-array struct))
(26 (gdscript-debug--to-pool-color-array struct))
(_ (error "[gdscript-debug--from-variant] Unknown type %s" type)))))
(defun gdscript-debug--to-stack-dump (stack-data level)
(pcase stack-data
(`(,_file-key, file-value, _line-key, line-value, _function-key, function-value, _id-key, _id-value)
(gdscript-stack-dump-create
:file (gdscript-debug--get-string file-value)
:line (gdscript-debug--get-integer line-value)
:function-name (gdscript-debug--get-string function-value)
:level level))))
(defun gdscript-debug-error-pretty (output-error)
(format "%s:%s %s - %s (%s) - %s"
(gdscript-string->value (gdscript-output-error->source-file output-error))
(gdscript-integer->value (gdscript-output-error->source-line output-error))
(gdscript-string->value (gdscript-output-error->source-func output-error))
(gdscript-string->value (gdscript-output-error->error output-error))
(gdscript-string->value (gdscript-output-error->error-descr output-error))
(gdscript-output-error->callstack output-error)))
(defun gdscript-debug--to-output-error (error-data stack-infos)
(pcase error-data
(`(,hr, min, sec, msec, source-func, source-file, source-line, error-msg, error-descr, warning)
(gdscript-output-error-create
:hr (gdscript-debug--to-integer hr)
:min (gdscript-debug--to-integer min)
:sec (gdscript-debug--to-integer sec)
:msec (gdscript-debug--to-integer msec)
:source-file (gdscript-debug--to-string source-file)
:source-func (gdscript-debug--to-string source-func)
:source-line (gdscript-debug--to-integer source-line)
:error (gdscript-debug--to-string error-msg)
:error-descr (gdscript-debug--to-string error-descr)
:warning (gdscript-debug--to-boolean warning)
:callstack stack-infos))))
(defun gdscript-debug--error-callstack (iter)
(let ((file (bindat-get-field (iter-next iter) :string-data))
(func (bindat-get-field (iter-next iter) :string-data))
(line (bindat-get-field (iter-next iter) :integer-data)))
(sgdscript-tack-info-create :file file :func func :line line)))
(defun gdscript-debug--mk-error (iter)
(let ((_callstack-size (bindat-get-field (iter-next iter) :integer-data))
(error-data (bindat-get-field (iter-next iter) :items))
(error-callstack-size (bindat-get-field (iter-next iter) :integer-data)))
(let ((stack-infos))
(dotimes (_i (/ error-callstack-size 3))
(push (gdscript-debug--error-callstack iter) stack-infos))
(gdscript-debug--to-output-error error-data (reverse stack-infos)))))
(defun gdscript-debug--mk-performance (iter)
(let ((_skip-this (iter-next iter))
(performance-data (bindat-get-field (iter-next iter) :items)))
`(command "performace" performance-data ,performance-data)))
(defun gdscript-debug--read-var-names (iter count)
(let ((variables))
(dotimes (_i count)
(let* ((var-name (bindat-get-field (iter-next iter) :string-data))
(var-value (iter-next iter))
(var-val (gdscript-debug--from-variant var-value)))
(push `(,var-name . ,var-val) variables)))
(reverse variables)))
(defun gdscript-debug--mk-stack-frame-vars (iter)
(let* ((_total-size (gdscript-debug--get-integer (iter-next iter)))
(locals-size (gdscript-debug--get-integer (iter-next iter)))
(locals (gdscript-debug--read-var-names iter locals-size))
(members-size (gdscript-debug--get-integer (iter-next iter)))
(members (gdscript-debug--read-var-names iter members-size))
(globals-size (gdscript-debug--get-integer (iter-next iter)))
(globals (gdscript-debug--read-var-names iter globals-size)))
(gdscript-stack-frame-vars-create :locals locals :members members :globals globals)))
(defun gdscript-debug--to-property-info (properties)
(let ((property-info))
(dolist (property properties)
(cond ((eq 6 (bindat-get-field property :array-length))
(let* ((data (bindat-get-field property :items))
(name (bindat-get-field (car data) :string-data))
(type (bindat-get-field (nth 1 data) :integer-data))
(hint (bindat-get-field (nth 2 data) :integer-data))
(hint-string (bindat-get-field (nth 3 data) :string-data))
(usage (bindat-get-field (nth 4 data) :integer-data))
(variant (gdscript-debug--from-variant (nth 5 data)))
(new-prop (gdscript-property-info-create
:name name
:type type
:hint hint
:hint-string hint-string
:usage usage
:variant variant)))
(push new-prop property-info)))
(t (message "Ignoring property %s" property))))
(reverse property-info)))
(defun gdscript-debug--get-children (iter)
(let ((child-count (gdscript-debug--get-integer (iter-next iter)))
(node-name (gdscript-debug--get-string (iter-next iter)))
(node-class (gdscript-debug--get-string (iter-next iter)))
(instance-id (gdscript-debug--get-integer (iter-next iter))))
(let ((children))
(dotimes (_i child-count)
(push (gdscript-debug--get-children iter) children))
(gdscript-scene-tree-level-edge-create :item (gdscript-scene-tree-node-create
:node-name node-name
:node-class node-class
:instance-id instance-id)
:children children))))
(cl-defstruct (gdscript-scene-tree-level-edge (:constructor gdscript-scene-tree-level-edge-create)
(:copier nil)
(:conc-name gdscript-scene-tree-level-edge->))
item children)
(cl-defstruct (gdscript-scene-tree-node (:constructor gdscript-scene-tree-node-create)
(:copier nil)
(:conc-name gdscript-scene-tree-node->))
node-name node-class instance-id)
(defun gdscript-debug--mk-scene-tree (iter)
(let ((_array-size (gdscript-debug--get-integer (iter-next iter))))
(gdscript-debug--get-children iter)))
(defun gdscript-debug--mk-inspect-object (iter)
(let ((_three (gdscript-debug--get-integer (iter-next iter)))
(object-id (gdscript-debug--get-integer (iter-next iter)))
(class (gdscript-debug--get-string (iter-next iter)))
(properties (gdscript-debug--get-array (iter-next iter))))
(gdscript-inspect-object-create :object-id object-id :class class :properties (gdscript-debug--to-property-info properties))))
(defun gdscript-debug--mk-stack-dump (iter)
(let ((stack-level-count (gdscript-debug--get-integer (iter-next iter)))
(outputs))
(dotimes (level stack-level-count)
(let ((stack-data (bindat-get-field (iter-next iter) :items)))
(push (gdscript-debug--to-stack-dump stack-data level) outputs)))
(reverse outputs)))
(defun gdscript-debug--mk-output (iter)
(let ((output-count (bindat-get-field (iter-next iter) :integer-data))
(outputs))
(dotimes (_i output-count)
(let* ((data (iter-next iter))
(output (bindat-get-field data :items 0 :string-data)))
(setq outputs (cons output outputs))))
`(command "output" outputs, outputs)))
(defun gdscript-debug--mk-debug-enter (iter)
(let ((_skip-this (iter-next iter))
(can-continue (bindat-get-field (iter-next iter) :boolean-data))
(reason (bindat-get-field (iter-next iter) :string-data)))
(gdscript-debug-enter-create :can-continue can-continue :reason reason)))
(defun gdscript-debug--mk-debug-exit (iter)
(let ((_skip-this (iter-next iter)))
'(command "debug_exit")))
(defun gdscript-debug--line-posns (line)
"Return a pair of LINE beginning and end positions."
(let ((offset (1+ (- line (line-number-at-pos)))))
(cons
(line-beginning-position offset)
(line-end-position offset))))
(defsubst gdscript-debug--drop-res (file-path)
(substring file-path (length "res://")))
(defun gdscript-debug--on-stack-dump (stack-dump project-root)
(let* ((file (gdscript-stack-dump->file stack-dump))
(line (gdscript-stack-dump->line stack-dump))
(full-file-path (concat project-root (gdscript-debug--drop-res file))))
(if (not project-root)
(error "Project for file %s not found" file)
(with-current-buffer (find-file-noselect full-file-path)
(let* ((posns (gdscript-debug--line-posns line))
(start-posn (car posns)))
(set-marker gdscript-debug--thread-position start-posn)
(goto-char gdscript-debug--thread-position)
(current-buffer))))))
(defmacro gdscript-debug--command-handler (&rest body)
`(progn
,@body
(setq gdscript-debug--previous-packet-data
(substring gdscript-debug--previous-packet-data gdscript-debug--offset (length gdscript-debug--previous-packet-data)))
(setq gdscript-debug--offset 0)))
(defun gdscript-debug--switch-to-emacs ()
(do-applescript (format "tell application \"%s\" to activate" gdscript-debug-emacs-executable)))
(defun gdscript-debug--handle-server-reply (process content)
"Gets invoked whenever the server sends data to the client."
(setq gdscript-debug--previous-packet-data (concat gdscript-debug--previous-packet-data content))
(when (or (null gdscript-debug--data-needed)
(<= gdscript-debug--data-needed (length gdscript-debug--previous-packet-data)))
(condition-case _x
(let ((iter (gdscript-debug--command-iter)))
(while t
(let* ((next-data (iter-next iter))
(str (bindat-get-field next-data :string-data)))
(pcase str
("debug_enter"
(gdscript-debug--command-handler
;;(message "Received 'debug_enter' command")
(let ((cmd (gdscript-debug--mk-debug-enter iter)))
(setq gdscript-debug--debug-enter cmd)
(gdscript-debug-get-stack-dump))))
("debug_exit"
(gdscript-debug--command-handler
;;(message "Received 'debug_exit' command")
(let ((_cmd (gdscript-debug--mk-debug-exit iter))))))
("output"
(gdscript-debug--command-handler
;;(message "Received 'output' command")
(let ((_cmd (gdscript-debug--mk-output iter))))))
("error"
(gdscript-debug--command-handler
;;(message "Received 'error' command")
(let ((cmd (gdscript-debug--mk-error iter)))
(message "%s" (gdscript-debug-error-pretty cmd)))))
("performance"
(gdscript-debug--command-handler
;;(message "Received 'performance' command")
(let ((_cmd (gdscript-debug--mk-performance iter))))))
("stack_dump"
(gdscript-debug--command-handler
;;(message "Received 'stack_dump' command")
(let ((cmd (gdscript-debug--mk-stack-dump iter))
(project-root (process-get process 'project)))
(pcase (gdscript-debug-enter->reason gdscript-debug--debug-enter)
("Breakpoint"
(gdscript-debug--refresh-stack-dump-buffer cmd project-root)
(setq gdscript-debug--stack-dump (cons cmd project-root))
(let ((top-stack-dump (car cmd)))
(setq gdscript-debug--selected-stack-dump top-stack-dump)
(gdscript-debug--on-stack-dump top-stack-dump project-root)
(gdscript-debug-get-stack-frame-vars (gdscript-stack-dump->level top-stack-dump)))
(gdscript-debug-hydra))
(other
(select-window (display-buffer (gdscript-debug--on-stack-dump (car cmd) project-root)))
(message "%s" other)))
(run-at-time "0.25 sec" nil #'gdscript-debug--switch-to-emacs))))
("stack_frame_vars"
(gdscript-debug--command-handler
;;(message "Received 'stack_frame_vars' command")
(let ((cmd (gdscript-debug--mk-stack-frame-vars iter)))
(setq gdscript-debug--stack-frame-vars cmd
gdscript-debug--inspected-objects (make-hash-table)
gdscript-debug--object-ids-to-fetch nil
gdscript-debug-state nil)
(gdscript-debug--construct-stack-var-buffer cmd)
(let* ((self (cdar (gdscript-stack-frame-vars->members cmd)))
(object-id (gdscript-object-id->value self)))
(setq gdscript-debug--current-self object-id
gdscript-debug--inspector-focused-object-id object-id)
(if (and gdscript-debug--pinned-object-id
(not (eq gdscript-debug--current-self gdscript-debug--pinned-object-id)))
(progn
(gdscript-debug-inspect-object gdscript-debug--pinned-object-id)
(gdscript-debug-inspect-object gdscript-debug--current-self)
(setq gdscript-debug-state :expect-two))
(gdscript-debug-inspect-object gdscript-debug--current-self)
(setq gdscript-debug--inspector-focused-object-id gdscript-debug--current-self
gdscript-debug-state :expect-one)))))
(gdscript-debug-windows))
("message:inspect_object"
(gdscript-debug--command-handler
;;(message "Received 'message:inspect_object' command")
(let* ((cmd (gdscript-debug--mk-inspect-object iter))
(object-id (gdscript-inspect-object->object-id cmd)))
(puthash object-id cmd gdscript-debug--inspected-objects)
(cond ((eq gdscript-debug-state :fetching)
(setq gdscript-debug--object-ids-to-fetch (delete (gdscript-object-id-create :value object-id) gdscript-debug--object-ids-to-fetch))
(when (null gdscript-debug--object-ids-to-fetch)
(setq gdscript-debug-state nil)
(gdscript-debug--construct-stack-var-buffer gdscript-debug--stack-frame-vars)
(gdscript-debug--refresh-inspector-buffer gdscript-debug--inspector-focused-object-id)))
((eq gdscript-debug-state :refresh-inspector)
(setq gdscript-debug-state nil)
(gdscript-debug--refresh-inspector-buffer object-id))
((and
(eq gdscript-debug-state :expect-two)
(eq object-id gdscript-debug--pinned-object-id))
(setq gdscript-debug-state :expect-one))
((and
(eq gdscript-debug-state :expect-two)
(eq object-id gdscript-debug--current-self))
;; Expected `gdscript-debug--pinned-object-id' but got `gdscript-debug--current-self'
;; instead. That means `gdscript-debug--pinned-object-id' doesn't exists anymore.
(setq gdscript-debug--pinned-object-id nil
gdscript-debug--inspector-stack nil
gdscript-debug-state nil)
(gdscript-debug--refresh-inspector-buffer object-id))
((eq gdscript-debug-state :expect-one)
(setq gdscript-debug-state nil
gdscript-debug--inspector-stack nil)
(gdscript-debug--refresh-inspector-buffer (if gdscript-debug--pinned-object-id
gdscript-debug--pinned-object-id
object-id)))))))
("message:scene_tree"
(gdscript-debug--command-handler
(let* ((cmd (gdscript-debug--mk-scene-tree iter)))
(gdscript-debug--refresh-scene-tree-buffer cmd)
(gdscript-debug-display-scene-tree-buffer))))
(_ (error "Unknown command %s" str))))))
;;(iter-end-of-sequence (message "No more packets to process %s" x))
(iter-end-of-sequence nil))))
(defun gdscript-debug-pin-inspected-object-id ()
(interactive)
(setq gdscript-debug--pinned-object-id gdscript-debug--inspector-focused-object-id)
(gdscript-debug--refresh-inspector-buffer gdscript-debug--pinned-object-id))
(defun gdscript-debug-pin-current-self ()
(interactive)
(setq gdscript-debug--pinned-object-id gdscript-debug--current-self
gdscript-debug--inspector-stack nil)
(gdscript-debug--refresh-inspector-buffer gdscript-debug--pinned-object-id))
(defun gdscript-debug-unpin ()
(interactive)
(setq gdscript-debug--pinned-object-id nil
gdscript-debug--inspector-stack nil)
(gdscript-debug--refresh-inspector-buffer gdscript-debug--current-self))
(defun gdscript-debug-fetch-object-ids-detail ()
(interactive)
(setq gdscript-debug-state :fetching)
(mapc #'gdscript-debug-inspect-object (mapcar #'gdscript-object-id->value gdscript-debug--object-ids-to-fetch)))
(defvar gdscript-debug--debug-enter nil
"Stores last received `debug_enter' command data.")
(defvar gdscript-debug--stack-frame-vars nil
"Stores last received `stack_frame_vars' command data.")
(defvar gdscript-debug--inspector-focused-object-id nil
"Stores `object-id' to display in * Inspector * buffer.")
(defvar gdscript-debug--pinned-object-id nil
"Stores pinned `object-id' to display in * Inspector * buffer.
Pinned `object-id' is explicitely controlled by user.")
(defvar gdscript-debug--stack-dump nil
"Stores last received `stack_dump' command data.")
(defvar gdscript-debug--selected-stack-dump nil
"Stores selected `stack-dump' data.")
(defvar gdscript-debug--current-self nil
"Stores selected `stack-dump' data.")
(defvar gdscript-debug--inspected-objects (make-hash-table)
"Mapping from `object-id' to `inspect-object' struct")
(defvar gdscript-debug-state nil)
(defvar gdscript-debug--object-ids-to-fetch nil
"List of all object-id to fetch on demand")
(defvar gdscript-debug--multiline-on (make-hash-table :test #'equal)
"Stores mapping from (`buffer' . `property-name') to bool indicating that `property-name'
in buffer `buffer' should be rendered multiline.")
(defvar gdscript-debug--inspector-stack nil
"A stack of inspected objects for breadcrumb rendering.")
(defun gdscript-debug--construct-stack-var-buffer (stack-frame-vars)
(let ((table (gdscript-debug-table-create)))
(gdscript-debug--table-add-row table (list "Locals:" "" "") nil)
(gdscript-debug--add-stack-var-to-table table (gdscript-stack-frame-vars->locals stack-frame-vars))
(gdscript-debug--table-add-row table (list "Members:" "" "") nil)
(gdscript-debug--add-stack-var-to-table table (gdscript-stack-frame-vars->members stack-frame-vars))
(gdscript-debug--table-add-row table (list "Globals:" "" "") nil)
(gdscript-debug--add-stack-var-to-table table (gdscript-stack-frame-vars->globals stack-frame-vars))
(with-current-buffer (gdscript-debug--get-stack-frame-vars-buffer)
(let ((inhibit-read-only t)
(point (point)))
(setq header-line-format
(format "Stack frame vars - %s:%s %s"
(gdscript-stack-dump->file gdscript-debug--selected-stack-dump)
(gdscript-stack-dump->line gdscript-debug--selected-stack-dump)
(gdscript-stack-dump->function-name gdscript-debug--selected-stack-dump)))
(erase-buffer)
(insert (gdscript-debug--table-string table " "))
;; Keep point in `stack-frame-vars-buffer' as close as possible to previous state
(goto-char point)
(set-window-point (get-buffer-window (current-buffer)) (line-beginning-position))))))
(defun gdscript-debug--add-stack-var-to-table (table items)
(dolist (item items)
(pcase-let* ((`(,variable . ,variant) item)
(print-data (gdscript-debug--pure-stringify variant variable 'stack-frame-vars-buffer)))
(gdscript-debug--table-add-row
table
(list
(gdscript-debug-variable-face variable)
(gdscript-print-data->type-name print-data)
(gdscript-print-data->string-repr print-data))
(append
(list 'property-name variable)
(cond ((gdscript-object-id-p variant)
(list 'object-id (gdscript-object-id->value variant))))))
(when (gdscript-object-id-p variant)
(unless (gethash (gdscript-object-id->value variant) gdscript-debug--inspected-objects)
(push variant gdscript-debug--object-ids-to-fetch))))))
(defun gdscript-debug--refresh-inspector-buffer (object-id)
(when-let* ((inspect-object (gethash object-id gdscript-debug--inspected-objects))
(table (gdscript-debug-table-create)))
(dolist (property (gdscript-inspect-object->properties inspect-object))
(let* ((variant (gdscript-property-info->variant property))
(usage (gdscript-property-info->usage property))
(_hint (gdscript-property-info->hint property))
(name (gdscript-property-info->name property))
(print-data (gdscript-debug--pure-stringify variant name 'inspector-buffer)))
(when-let ((variant (gdscript-property-info->variant property))
(is-object-id (gdscript-object-id-p variant)))
(unless (gethash (gdscript-object-id->value variant) gdscript-debug--inspected-objects)
(push variant gdscript-debug--object-ids-to-fetch)))
(gdscript-debug--table-add-row
table
(cond ((eq 256 (logand 256 usage))
(list
(propertize name 'font-lock-face 'bold)
""
""))
(t (list
;;(concat (format "[%s]" usage) (format "[%s] " hint) name)
name
(gdscript-print-data->type-name print-data)
(gdscript-print-data->string-repr print-data))))
(append
(list 'property-name name)
(cond ((equal name "Node/path")
(list 'node-path (substring-no-properties (gdscript-print-data->string-repr print-data)) 'keymap gdscript-debug--show-in-scene-tree-map))
((gdscript-object-id-p variant)
(list 'object-id (gdscript-object-id->value variant)))
(t nil))))))
(delete-dups gdscript-debug--object-ids-to-fetch)
(with-current-buffer (gdscript-debug--get-inspector-buffer)
(let ((inhibit-read-only t)
(class (gdscript-inspect-object->class inspect-object))
(object-id (gdscript-inspect-object->object-id inspect-object))
(inspector-stack-car (car gdscript-debug--inspector-stack)))
(setq header-line-format
(if gdscript-debug--pinned-object-id
(format "Inspector - Pinned: %s" gdscript-debug--pinned-object-id)
"Inspector"))
(unless (and
inspector-stack-car
(equal class (gdscript-debug-breadcrumb-entry->class inspector-stack-car))
(equal object-id (gdscript-debug-breadcrumb-entry->object-id inspector-stack-car)))
;; Add new entry to the stack only when it differs from the tip (car)
;; to preserve `gdscript-debug-breadcrumb-entry->point' of the tip
(push (gdscript-debug-breadcrumb-entry-create :class class :object-id object-id :point (point)) gdscript-debug--inspector-stack))
(erase-buffer)
(insert (gdscript-debug--inspector-bread-crumb))
(insert "\n")
(insert (gdscript-debug--table-string table " "))
(goto-char (point-min))
(gdscript-debug--display-buffer (current-buffer))))))
(defun gdscript-debug--show-in-scene-tree ()
(interactive)
(if-let* ((node-path (get-text-property (point) 'node-path)))
(gdscript-debug--jump-to-node-path node-path)
(message "Not recognized as node-path line")))
(defun gdscript-debug--jump-to-node-path (node-path)
(with-current-buffer (gdscript-debug--get-scene-tree-buffer)
(if (equal node-path "/root")
(let ((window (display-buffer (current-buffer) '((display-buffer-same-window)))))
(set-window-point window 1))
(let ((change-pos 1))
(while change-pos
(setq change-pos (next-single-property-change change-pos 'node-path))
(if change-pos
(if (equal (get-text-property change-pos 'node-path) node-path)
(let ((window (display-buffer (current-buffer) '((display-buffer-same-window)))))
(set-window-point window change-pos)
(setq change-pos nil))
(setq change-pos (1+ change-pos)))
(setq gdscript-debug--after-refresh-function (lambda () (gdscript-debug--jump-to-node-path node-path)))
(gdscript-debug-request-scene-tree)))))))
(defvar gdscript-debug--show-in-scene-tree-map
(let ((map (make-sparse-keymap)))
(define-key map [remap gdscript-debug-inspect-object-id] 'gdscript-debug--show-in-scene-tree)
map)
"Keymap for `Node/path' in `Inspector' buffer.")
(defun gdscript-debug--inspector-bread-crumb ()
(mapconcat (lambda (breadcrumb-entry)
(propertize (format "%s: %s"
(gdscript-debug-breadcrumb-entry->class breadcrumb-entry)
(gdscript-debug-breadcrumb-entry->object-id breadcrumb-entry))
'font-lock-face 'bold))
(reverse gdscript-debug--inspector-stack)
" > "))
(defun gdscript-debug--table-string (table &optional sep)
"Return TABLE as a string with columns separated with SEP."
(let ((column-sizes (gdscript-debug-table->column-sizes table)))
(mapconcat
'identity
(cl-mapcar
(lambda (row properties)
(apply 'propertize
(mapconcat 'identity
(cl-mapcar (lambda (s x) (gdscript-debug-pad-string s x))
row column-sizes)
sep)
properties))
(gdscript-debug-table->rows table)
(gdscript-debug-table->row-properties table))
"\n")))
(defun gdscript-debug-pad-string (string padding)
(format (concat "%" (number-to-string padding) "s") string))
(defun gdscript-debug--pure-stringify (variant property-name buffer-type &optional inline-only)
(gdscript-debug--to-print-data
(cond ((gdscript-null-p variant)
(list
(gdscript-debug--builtin-face "null")))
((gdscript-bool-p variant)
(list
(gdscript-debug--builtin-face "bool")
(gdscript-debug--gdscript-bool-to-string variant)))
((gdscript-integer-p variant)
(list
(gdscript-debug--builtin-face "int")
(number-to-string (gdscript-integer->value variant))))
((gdscript-float-p variant)
(list
(gdscript-debug--builtin-face "float")
(number-to-string (gdscript-float->value variant))))
((gdscript-string-p variant)
(list
(gdscript-debug-type-face "String")
(gdscript-debug--string-face (gdscript-string->value variant))))
((gdscript-vector2-p variant)
(list
(gdscript-debug-type-face "Vector2")
(gdscript-debug--vector2-to-string variant)))
((gdscript-rect2-p variant)
(list
(gdscript-debug-type-face "Rect2")
(concat (gdscript-debug--vector2-to-string (gdscript-rect2->coordinate variant)) " " (gdscript-debug--vector2-to-string (gdscript-rect2->size variant)))))
((gdscript-vector3-p variant)
(list
(gdscript-debug-type-face "Vector3")
(gdscript-debug--vector3-to-string variant)))
((gdscript-transform2d-p variant)
(list
(gdscript-debug-type-face "Transform2D")
(mapconcat #'gdscript-debug--vector2-to-string (list (gdscript-transform2d->x variant) (gdscript-transform2d->y variant) (gdscript-transform2d->origin variant)) " ")))
((gdscript-plane-p variant)
(list
(gdscript-debug-type-face "Plane")
(concat (gdscript-debug--vector3-to-string (gdscript-plane->normal variant)) " " (number-to-string (gdscript-plane->distance variant)))))
((gdscript-quat-p variant)
(list
(gdscript-debug-type-face "Quat")
(mapconcat #'number-to-string (list (gdscript-quat->x-imaginary variant) (gdscript-quat->y-imaginary variant) (gdscript-quat->z-imaginary variant) (gdscript-quat->real-w variant)) " ")))
((gdscript-aabb-p variant)
(list
(gdscript-debug-type-face "AABB")
(mapconcat #'gdscript-debug--vector3-to-string (list (gdscript-aabb->position variant) (gdscript-aabb->size variant)) " ")))
((gdscript-basis-p variant)
(list
(gdscript-debug-type-face "Basis")
(gdscript-debug--basis-to-string variant)))
((gdscript-transform-p variant)
(list
(gdscript-debug-type-face "Transform")
(concat (gdscript-debug--basis-to-string (gdscript-transform->basis variant)) " " (gdscript-debug--vector3-to-string (gdscript-transform->origin variant)))))
((gdscript-color-p variant)
(list
(gdscript-debug-type-face "Color")
(gdscript-debug--color-to-string variant)))
((gdscript-node-path-p variant)
(list
(gdscript-debug-type-face "NodePath")
(gdscript-debug--constant-face (concat (when (gdscript-bool->value (gdscript-node-path->absolute variant)) "/") (mapconcat #'gdscript-string->value (gdscript-node-path->names variant) "/") (when-let* ((subnames (gdscript-node-path->subnames variant))) (concat ":" (mapconcat #'gdscript-string->value subnames ":")))))))
((gdscript-rid-p variant)
(list
(gdscript-debug-type-face "RID")))
((gdscript-object-id-p variant)
(let* ((object-id (gdscript-object-id->value variant))
(object-id-data (gethash object-id gdscript-debug--inspected-objects)))
(list
(if object-id-data (gdscript-debug-type-face (gdscript-inspect-object->class object-id-data)) "ObjectID")
(concat (gdscript-debug--comment-face (format "ObjectID: %s" (number-to-string object-id)))
(when object-id-data
(let* ((property (car (gdscript-inspect-object->properties object-id-data)))
(name (gdscript-property-info->name property)))
(when (equal name "Node/path")
(concat " " (gdscript-print-data->string-repr (gdscript-debug--pure-stringify (gdscript-property-info->variant property) property-name buffer-type t))))))))))
((gdscript-dictionary-p variant)
(list
(gdscript-debug-type-face "Dictionary")
(gdscript-debug--dictionary-inline-string variant property-name buffer-type)
(gdscript-debug--dictionary-multiline-string variant property-name buffer-type)))
((gdscript-array-p variant)
(list
(gdscript-debug-type-face "Array")
(concat "[" (mapconcat (lambda (element) (gdscript-print-data->string-repr (gdscript-debug--pure-stringify element property-name buffer-type t))) (gdscript-array->elements variant) ", ") "]")
(concat "[" (mapconcat (lambda (element) (gdscript-print-data->string-repr (gdscript-debug--pure-stringify element property-name buffer-type t))) (gdscript-array->elements variant) ", ") "]")))
((gdscript-pool-byte-array-p variant)
(list
(gdscript-debug-type-face "PoolByteArray")
(concat "[" (mapconcat #'number-to-string (gdscript-pool-byte-array->elements variant) " ") "]")
(concat "[" (mapconcat #'number-to-string (gdscript-pool-byte-array->elements variant) " ") "]")))
((gdscript-pool-int-array-p variant)
(list
(gdscript-debug-type-face "PoolIntArray")
(concat "[" (mapconcat (lambda (int) (number-to-string (gdscript-integer->value int))) (gdscript-pool-int-array->elements variant) " ") "]")
(concat "[" (mapconcat (lambda (int) (number-to-string (gdscript-integer->value int))) (gdscript-pool-int-array->elements variant) " ") "]")))
((gdscript-pool-real-array-p variant)
(list
(gdscript-debug-type-face "PoolRealArray")
(gdscript-debug--pool-real-array-inline-string variant)
(gdscript-debug--pool-real-array-multiline-string variant)))
((gdscript-pool-string-array-p variant)
(list
(gdscript-debug-type-face "PoolStringArray")
(gdscript-debug--pool-string-array-inline-string variant)
(gdscript-debug--pool-string-array-multiline-string variant)))
((gdscript-pool-vector2-array-p variant)
(list
(gdscript-debug-type-face "PoolVector2Array")
(gdscript-debug--pool-vector2-array-inline-string variant)
(gdscript-debug--pool-vector2-array-multiline-string variant)))
((gdscript-pool-vector3-array-p variant)
(list
(gdscript-debug-type-face "PoolVector3Array")
(gdscript-debug--pool-vector3-array-inline-string variant)
(gdscript-debug--pool-vector3-array-multiline-string variant)))
((gdscript-pool-color-array-p variant)
(list
(gdscript-debug-type-face "PoolColorArray")
(gdscript-debug--pool-color-array-inline-string variant)
(gdscript-debug--pool-color-array-multiline-string variant)))
(t (error "[gdscript-debug--pure-stringify] Invalid type %s" variant)))
property-name
buffer-type
inline-only))
(defun gdscript-debug--initial-inline-visibility (string init)
(propertize string 'invisible init 'inline t))
(defun gdscript-debug--initial-multiline-visibility (string init)
(propertize string 'invisible init 'multiline t))
(defun gdscript-debug--dictionary-inline-string (is-object-id property-name buffer-type)
(concat "{" (mapconcat (lambda (key-value)
(gdscript-debug--key-value-to-string key-value property-name buffer-type)) (gdscript-dictionary->elements is-object-id) ", ") "}"))
(defun gdscript-debug--dictionary-multiline-string (dictionary property-name buffer-type)
(let ((table (gdscript-debug-table-create)))
(dolist (element (gdscript-dictionary->elements dictionary))
(pcase-let ((`(,key . ,value) element))
(gdscript-debug--table-add-row
table
(list
(concat " "(gdscript-print-data->string-repr (gdscript-debug--pure-stringify key property-name buffer-type t)) ":")
(gdscript-print-data->string-repr (gdscript-debug--pure-stringify value property-name buffer-type t)))
(cond ((gdscript-object-id-p value)
(list 'object-id (gdscript-object-id->value value)))
(t nil)))))
(concat "{\n" (gdscript-debug--table-string table " ") "\n}")))
(defun gdscript-debug--pool-real-array-inline-string (is-object-id)
(concat "[" (mapconcat (lambda (real) (number-to-string (gdscript-float->value real))) (gdscript-pool-real-array->elements is-object-id) " ") "]"))
(defun gdscript-debug--pool-real-array-multiline-string (is-object-id)
(concat "[\n" (mapconcat (lambda (real) (concat " " (number-to-string (gdscript-float->value real)) "\n")) (gdscript-pool-real-array->elements is-object-id) "") "]"))
(defun gdscript-debug--pool-string-array-inline-string (is-object-id)
(concat "[" (mapconcat (lambda (o)
(gdscript-debug--string-face (gdscript-string->value o))) (gdscript-pool-string-array->elements is-object-id) " ") "]"))
(defun gdscript-debug--pool-string-array-multiline-string (is-object-id)
(concat "[\n" (mapconcat (lambda (o)
(concat " " (gdscript-debug--string-face (gdscript-string->value o)) "\n")) (gdscript-pool-string-array->elements is-object-id) "") "]"))
(defun gdscript-debug--pool-vector2-array-inline-string (is-object-id)
(concat "[" (mapconcat #'gdscript-debug--vector2-to-string (gdscript-pool-vector2-array->elements is-object-id) " ") "]"))
(defun gdscript-debug--pool-vector2-array-multiline-string (is-object-id)
(concat "[\n" (mapconcat (lambda (o)
(concat " " (gdscript-debug--vector2-to-string o) "\n")) (gdscript-pool-vector2-array->elements is-object-id) "") "]"))
(defun gdscript-debug--pool-vector3-array-inline-string (is-object-id)
(concat "[" (mapconcat #'gdscript-debug--vector3-to-string (gdscript-pool-vector3-array->elements is-object-id) " ") "]"))
(defun gdscript-debug--pool-vector3-array-multiline-string (is-object-id)
(concat "[\n" (mapconcat (lambda (o)
(concat " " (gdscript-debug--vector3-to-string o) "\n")) (gdscript-pool-vector3-array->elements is-object-id) "") "]"))
(defun gdscript-debug--pool-color-array-inline-string (is-object-id)
(concat "[" (mapconcat #'gdscript-debug--color-to-string (gdscript-pool-color-array->elements is-object-id) " ") "]"))
(defun gdscript-debug--pool-color-array-multiline-string (is-object-id)
(concat "[\n" (mapconcat (lambda (o)
(concat " " (gdscript-debug--color-to-string o) "\n")) (gdscript-pool-color-array->elements is-object-id) "") "]"))
(defun gdscript-debug--to-print-data (args property-name buffer-type &optional inline-only)
(pcase args
(`(,type-name)
(gdscript-print-data-create
:type-name type-name
:string-repr ""))
(`(,type-name ,inline-string-repr)
(gdscript-print-data-create
:type-name type-name
:string-repr (gdscript-debug--initial-inline-visibility inline-string-repr nil)))
(`(,type-name ,inline-string-repr ,multiline-string-repr)
(let ((multiline-invisible (gethash (cons buffer-type property-name) gdscript-debug--multiline-on)))
(gdscript-print-data-create
:type-name type-name
:string-repr (concat
(gdscript-debug--initial-inline-visibility inline-string-repr multiline-invisible)
(unless inline-only
(gdscript-debug--initial-multiline-visibility multiline-string-repr (not multiline-invisible)))))))))
(cl-defstruct (gdscript-print-data (:constructor gdscript-print-data-create)
(:copier nil)
(:conc-name gdscript-print-data->))
type-name string-repr)
(defun gdscript-debug--keyword-face (string)
(propertize string 'font-lock-face font-lock-keyword-face))
(defun gdscript-debug--string-face (string)
(propertize string 'font-lock-face font-lock-string-face))
(defun gdscript-debug--constant-face (string)
(propertize string 'font-lock-face font-lock-constant-face))
(defun gdscript-debug--comment-face (string)
(propertize string 'font-lock-face font-lock-comment-face))
(defun gdscript-debug--builtin-face (string)
(propertize string 'font-lock-face font-lock-builtin-face))
(defun gdscript-debug-type-face (string)
(propertize string 'font-lock-face font-lock-type-face))
(defun gdscript-debug-variable-face (string)
(propertize string 'font-lock-face font-lock-variable-name-face))
(defun gdscript-debug--key-value-to-string (key-value property-name buffer-type)
(let ((key (car key-value))
(value (cdr key-value)))
(concat (gdscript-print-data->string-repr (gdscript-debug--pure-stringify key property-name buffer-type t))
":"
(gdscript-print-data->string-repr (gdscript-debug--pure-stringify value property-name buffer-type t)))))
(defun gdscript-debug--gdscript-bool-to-string (gdscript-bool)
(if (gdscript-bool->value gdscript-bool) (gdscript-debug--keyword-face "true") (gdscript-debug--keyword-face "false")))
(defun gdscript-debug--color-to-string (color)
(format "(%s)" (mapconcat #'number-to-string (list (gdscript-color->red color) (gdscript-color->green color) (gdscript-color->blue color) (gdscript-color->alpha color)) ", ")))
(defun gdscript-debug--basis-to-string (basis)
(mapconcat #'gdscript-debug--vector3-to-string (list (gdscript-basis->x basis) (gdscript-basis->y basis) (gdscript-basis->z basis)) " "))
(defun gdscript-debug--vector2-to-string (vector2)
(concat "(" (number-to-string (gdscript-vector2->x vector2)) ", " (number-to-string (gdscript-vector2->y vector2)) ")"))
(defun gdscript-debug--vector3-to-string (vector3)
(concat "(" (number-to-string (gdscript-vector3->x vector3)) ", " (number-to-string (gdscript-vector3->y vector3)) ", " (number-to-string (gdscript-vector3->z vector3)) ")"))
(defvar gdscript-server-clients '()
"List with client processes")
(defun gdscript-debug--sentinel-function (process event)
"Gets called when the status of the network connection changes."
;; (message "[sentinel] process: %s" process)
;; (message "[sentinel] event : %s" event)
(cond
((string-match "open from .*\n" event)
(push process gdscript-server-clients))
((or
(string= event "connection broken by remote peer\n")
(string= event "deleted\n"))
(set-marker gdscript-debug--thread-position nil)
(setq gdscript-debug--previous-packet-data nil
gdscript-debug--offset 0
gdscript-debug--data-needed nil
gdscript-debug--inspected-objects (make-hash-table)
gdscript-debug--multiline-on (make-hash-table :test #'equal)
gdscript-debug--inspector-stack nil
gdscript-debug--inspector-focused-object-id nil
gdscript-debug--pinned-object-id nil
gdscript-server-clients (seq-remove (lambda (client-process)
(string=
(process-name client-process)
(process-name process)))
gdscript-server-clients))
(message "Resetting server to accept data."))
((eq (process-status process) 'closed)
(message "Process Closed"))))
(defmacro gdscript-debug--send-command (&rest body)
"Todo"
(declare (indent 0) (debug t))
`(pcase gdscript-server-clients
(`() (message "No game process is running."))
(`(,server-process)
(let ((command (progn ,@body)))
(process-send-string server-process command)))
(_ (message "More than one game process running"))))
(defmacro gdscript-debug--if-server-process (&rest body)
"Todo"
(declare (indent 0) (debug t))
`(pcase gdscript-server-clients
(`(,server-process) (progn ,@body))))
(defun gdscript-debug-inspect-object (object-id)
(gdscript-debug--send-command
(gdscript-debug--inspect-object object-id)))
(defun gdscript-debug-request-scene-tree()
(interactive)
(gdscript-debug--send-command (gdscript-debug--command "request_scene_tree")))
(defun gdscript-debug-get-stack-dump()
(interactive)
(gdscript-debug--send-command (gdscript-debug--command "get_stack_dump")))
(defun gdscript-debug-continue()
(interactive)
(gdscript-debug--send-command (gdscript-debug--command "continue")))
(defun gdscript-debug-next()
(interactive)
(gdscript-debug--send-command (gdscript-debug--command "next")))
(defun gdscript-debug-step()
(interactive)
(gdscript-debug--send-command (gdscript-debug--command "step")))
(defun gdscript-debug-process-name (project-root)
(format "*Godot debugger %s*" project-root))
;;;###autoload
(defun gdscript-debug-make-server()
(interactive)
(setq gdscript-debug--thread-position (make-marker))
(add-to-list 'overlay-arrow-variable-list 'gdscript-debug--thread-position)
(if-let* ((project-root (gdscript-util--find-project-configuration-file)))
(let ((server-process
(make-network-process
:name (gdscript-debug-process-name project-root)
:buffer nil
:server t
:host "127.0.0.1"
:service gdscript-debug-port
:coding 'binary
:family 'ipv4
:filter #'gdscript-debug--handle-server-reply
:filter-multibyte nil
:sentinel #'gdscript-debug--sentinel-function)))
(process-put server-process 'project project-root)
(message "Debugger server started - project: %s" project-root))
(error "Not in Godot project!")))
(defun gdscript-debug--inspect-object-definition (command-length)
`((:packet-length u32r)
(:array-type u32r)
(:elements-count u32r)
(:command-type u32r)
(:command-length u32r)
(:command str ,command-length)
(align 4)
(:object-id-type u32r)
(:object-id u32r)))
(defun gdscript-debug--get-stack-frame-vars-definition (command-length)
`((:packet-length u32r)
(:array-type u32r)
(:elements-count u32r)
(:command-type u32r)
(:command-length u32r)
(:command str ,command-length)
(align 4)
(:frame-type u32r)
(:frame u32r)))
(defun gdscript-debug--breakpoint-packet-definition (command-length file-length)
`((:packet-length u32r)
(:array-type u32r)
(:elements-count u32r)
(:command-type u32r)
(:command-length u32r)
(:command str ,command-length)
(align 4)
(:file-type u32r)
(:file-length u32r)
(:file str ,file-length)
(align 4)
(:line-type u32r)
(:line u32r)
(:boolean-type u32r)
(:boolean u32r)))
(defun gdscript-debug--set-skip-breakpoints-packet-definition (command-length)
`((:packet-length u32r)
(:array-type u32r)
(:elements-count u32r)
(:command-type u32r)
(:command-length u32r)
(:command str ,command-length)
(align 4)
(:boolean-type u32r)
(:boolean u32r)))
(defconst gdscript-variant-bool 1 "bool")
(defconst gdscript-variant-integer 2 "integer")
(defconst gdscript-variant-string 4 "string")
(defconst gdscript-variant-array 19 "array")
(defun gdscript-debug--boolean-to-integer (b)
(if (null b) 0 1))
(defun gdscript-debug--inspect-object (object-id)
(let* ((command "inspect_object")
(command-length (length command))
(command-alength (gdscript-debug-align-length command))
(packet-length (+ (* 6 4) command-alength))
(spec (gdscript-debug--inspect-object-definition command-length)))
(bindat-pack spec
`((:packet-length . ,packet-length)
(:array-type . ,gdscript-variant-array)
(:elements-count . 2)
(:command-type . ,gdscript-variant-string)
(:command-length . ,command-length)
(:command . ,command)
(:object-id-type . ,gdscript-variant-integer)
(:object-id . ,object-id)))))
(defun gdscript-debug--get-stack-frame-vars (frame)
(let* ((command "get_stack_frame_vars")
(command-length (length command))
(command-alength (gdscript-debug-align-length command))
(packet-length (+ (* 6 4) command-alength))
(spec (gdscript-debug--get-stack-frame-vars-definition command-length)))
(bindat-pack spec
`((:packet-length . ,packet-length)
(:array-type . ,gdscript-variant-array)
(:elements-count . 2)
(:command-type . ,gdscript-variant-string)
(:command-length . ,command-length)
(:command . ,command)
(:frame-type . ,gdscript-variant-integer)
(:frame . ,frame)))))
(defun gdscript-debug--breakpoint-command (file line add-or-remove)
(let* ((command "breakpoint")
(command-length (length command))
(command-alength (gdscript-debug-align-length command))
(file-length (length file))
(file-alength (gdscript-debug-align-length file))
(packet-length (+ (* 10 4) command-alength file-alength))
(spec (gdscript-debug--breakpoint-packet-definition command-length file-length)))
(bindat-pack spec
`((:packet-length . ,packet-length)
(:array-type . ,gdscript-variant-array)
(:elements-count . 4)
(:command-type . ,gdscript-variant-string)
(:command-length . ,command-length)
(:command . ,command)
(:file-type . ,gdscript-variant-string)
(:file-length . ,file-length)
(:file . ,file)
(:line-type . ,gdscript-variant-integer)
(:line . ,line)
(:boolean-type . ,gdscript-variant-bool)
(:boolean . ,(gdscript-debug--boolean-to-integer add-or-remove))))))
(defun gdscript-debug--set-skip-breakpoints-command (skip)
(let* ((command "set_skip_breakpoints")
(command-length (length command))
(command-alength (gdscript-debug-align-length command))
(packet-length (+ (* 6 4) command-alength))
(spec (gdscript-debug--set-skip-breakpoints-packet-definition command-length)))
(bindat-pack spec
`((:packet-length . ,packet-length)
(:array-type . ,gdscript-variant-array)
(:elements-count . 2)
(:command-type . ,gdscript-variant-string)
(:command-length . ,command-length)
(:command . ,command)
(:boolean-type . ,gdscript-variant-bool)
(:boolean . ,(gdscript-debug--boolean-to-integer skip))))))
(defun gdscript-debug--packet-definition (string-length)
`((:packet-length u32r)
(:array-type u32r)
(:elements-count u32r)
(:type u32r)
(:string-length u32r)
(:string-data str ,string-length)
(align 4)))
(defun gdscript-debug--command (command)
(let* ((command-alength (gdscript-debug-align-length command))
(packet-length (+ (* 4 4) command-alength)))
(bindat-pack
(gdscript-debug--packet-definition (length command))
`((:packet-length . ,packet-length)
(:array-type . ,gdscript-variant-array)
(:elements-count . 1)
(:type . ,gdscript-variant-string)
(:string-length . ,(length command))
(:string-data . ,command)))))
(defun gdscript-debug-align-length (string)
(let ((len (length string)))
(while (/= (% len 4) 0)
(setq len (1+ len)))
len))
(defun gdscript-debug--add-fringe(pos enabled &rest sprops)
(interactive)
(let* ((string (make-string 1 ?x))
(buffer (current-buffer))
(prop `(left-fringe breakpoint ,(if enabled 'breakpoint-enabled 'breakpoint-disabled)))
(overlay (make-overlay pos pos buffer)))
(put-text-property 0 1 'display prop string)
(if sprops
(add-text-properties 0 1 sprops string))
(overlay-put overlay 'put-break t)
(overlay-put overlay 'before-string string)))
(defun gdscript-debug--remove-strings (start end &optional buffer)
"Remove strings between START and END in BUFFER.
Remove only strings that were put in BUFFER with calls to `gdscript-debug--add-fringe'.
BUFFER nil or omitted means use the current buffer."
(unless buffer
(setq buffer (current-buffer)))
(dolist (overlay (overlays-in start end))
(when (overlay-get overlay 'put-break)
(delete-overlay overlay))))
(defun gdscript-debug--absolute-path ()
"Return the absolute path of current gdscript file."
(when (and buffer-file-name
(file-exists-p buffer-file-name)
(string= (file-name-extension buffer-file-name) "gd"))
buffer-file-name))
(defun gdscript-debug--current-file ()
(let ((current-file (gdscript-util--get-godot-project-file-path-relative buffer-file-name)))
(when current-file
(let ((extension (file-name-extension buffer-file-name)))
(when (string= extension "gd")
(concat "res://" current-file ".gd"))))))
(defmacro gdscript-debug--with-gdscript-file (file-info body)
(declare (indent 1) (debug t))
`(let ((,file-info (cons (gdscript-debug--current-file) (gdscript-debug--absolute-path))))
(if (not (car ,file-info))
(message "No GDScript file.")
,body)))
(defun gdscript-debug-get-stack-frame-vars (level)
(gdscript-debug--send-command
(gdscript-debug--get-stack-frame-vars level)))
(cl-defstruct (gdscript-null (:constructor gdscript-null-create)
(:copier nil)))
(cl-defstruct (gdscript-bool (:constructor gdscript-bool-create)
(:copier nil)
(:conc-name gdscript-bool->))
value)
(cl-defstruct (gdscript-integer (:constructor gdscript-integer-create)
(:copier nil)
(:conc-name gdscript-integer->))
value)
(cl-defstruct (gdscript-float (:constructor gdscript-float-create)
(:copier nil)
(:conc-name gdscript-float->))
value)
(cl-defstruct (gdscript-string (:constructor gdscript-string-create)
(:copier nil)
(:conc-name gdscript-string->))
value)
(cl-defstruct (gdscript-plane (:constructor gdscript-plane-create)
(:copier nil)
(:conc-name gdscript-plane->))
normal distance)
(cl-defstruct (gdscript-quat (:constructor gdscript-quat-create)
(:copier nil)
(:conc-name gdscript-quat->))
x-imaginary y-imaginary z-imaginary real-w)
(cl-defstruct (gdscript-aabb (:constructor gdscript-aabb-create)
(:copier nil)
(:conc-name gdscript-aabb->))
position size)
(cl-defstruct (gdscript-basis (:constructor gdscript-basis-create)
(:copier nil)
(:conc-name gdscript-basis->))
x y z)
(cl-defstruct (gdscript-transform (:constructor gdscript-transform-create)
(:copier nil)
(:conc-name gdscript-transform->))
basis origin)
(cl-defstruct (gdscript-color (:constructor gdscript-color-create)
(:copier nil)
(:conc-name gdscript-color->))
red green blue alpha)
(cl-defstruct (gdscript-node-path (:constructor gdscript-node-path-create)
(:copier nil)
(:conc-name gdscript-node-path->))
names subnames absolute)
(cl-defstruct (gdscript-rid (:constructor gdscript-rid-create)
(:copier nil)))
(cl-defstruct (gdscript-object-id (:constructor gdscript-object-id-create)
(:copier nil)
(:conc-name gdscript-object-id->))
value)
(cl-defstruct (gdscript-dictionary (:constructor gdscript-dictionary-create)
(:copier nil)
(:conc-name gdscript-dictionary->))
shared elements)
(cl-defstruct (gdscript-vector2 (:constructor gdscript-vector2-create)
(:copier nil)
(:conc-name gdscript-vector2->))
x y)
(cl-defstruct (gdscript-rect2 (:constructor gdscript-rect2-create)
(:copier nil)
(:conc-name gdscript-rect2->))
coordinate size)
(cl-defstruct (gdscript-vector3 (:constructor gdscript-vector3-create)
(:copier nil)
(:conc-name gdscript-vector3->))
x y z)
(cl-defstruct (gdscript-transform2d (:constructor gdscript-transform2d-create)
(:copier nil)
(:conc-name gdscript-transform2d->))
x y origin)
(cl-defstruct (gdscript-array (:constructor gdscript-array-create)
(:copier nil)
(:conc-name gdscript-array->))
shared elements)
(cl-defstruct (gdscript-pool-byte-array (:constructor gdscript-pool-byte-array-create)
(:copier nil)
(:conc-name gdscript-pool-byte-array->))
elements)
(cl-defstruct (gdscript-pool-int-array (:constructor gdscript-pool-int-array-create)
(:copier nil)
(:conc-name gdscript-pool-int-array->))
elements)
(cl-defstruct (gdscript-pool-real-array (:constructor gdscript-pool-real-array-create)
(:copier nil)
(:conc-name gdscript-pool-real-array->))
elements)
(cl-defstruct (gdscript-pool-string-array (:constructor gdscript-pool-string-array-create)
(:copier nil)
(:conc-name gdscript-pool-string-array->))
elements)
(cl-defstruct (gdscript-pool-vector2-array (:constructor gdscript-pool-vector2-array-create)
(:copier nil)
(:conc-name gdscript-pool-vector2-array->))
elements)
(cl-defstruct (gdscript-pool-vector3-array (:constructor gdscript-pool-vector3-array-create)
(:copier nil)
(:conc-name gdscript-pool-vector3-array->))
elements)
(cl-defstruct (gdscript-pool-color-array (:constructor gdscript-pool-color-array-create)
(:copier nil)
(:conc-name gdscript-pool-color-array->))
elements)
(cl-defstruct (gdscript-stack-frame-vars (:constructor gdscript-stack-frame-vars-create)
(:copier nil)
(:conc-name gdscript-stack-frame-vars->))
locals members globals)
(cl-defstruct (gdscript-stack-dump (:constructor gdscript-stack-dump-create)
(:copier nil)
(:conc-name gdscript-stack-dump->))
file line function-name level)
(cl-defstruct (gdscript-output-error (:constructor gdscript-output-error-create)
(:copier nil)
(:conc-name gdscript-output-error->))
;; See struct OutputError in script_debugger_remote.h
hr ;; int
min ;; int
sec ;; int
msec ;; int
source-file ;; String
source-func ;; String
source-line ;; int
error ;; String
error-descr ;; String
warning ;; bool
callstack) ;; Array
(cl-defstruct (gdscript-stack-info (:constructor sgdscript-tack-info-create)
(:copier nil)
(:conc-name gdscript-stack-info->))
file func line)
(cl-defstruct (gdscript-inspect-object (:constructor gdscript-inspect-object-create)
(:copier nil)
(:conc-name gdscript-inspect-object->))
object-id class properties)
(cl-defstruct (gdscript-property-info (:constructor gdscript-property-info-create)
(:copier nil)
(:conc-name gdscript-property-info->))
name
type
hint ;; see enum PropertyHint in object.h
hint-string
usage ;; see enum PropertyUsageFlags in object.h
variant)
(cl-defstruct (gdscript-breakpoint (:constructor gdscript-breakpoint-create)
(:copier nil)
(:conc-name gdscript-breakpoint->))
file file-absolute line)
(cl-defstruct (gdscript-debug-enter (:constructor gdscript-debug-enter-create)
(:copier nil)
(:conc-name gdscript-debug-enter->))
can-continue reason)
(cl-defstruct (gdscript-debug-table (:constructor gdscript-debug-table-create)
(:copier nil)
(:conc-name gdscript-debug-table->))
column-sizes
rows
row-properties
right-align)
(cl-defstruct (gdscript-debug-breadcrumb-entry (:constructor gdscript-debug-breadcrumb-entry-create)
(:copier nil)
(:conc-name gdscript-debug-breadcrumb-entry->))
class object-id point)
(defun gdscript-debug--table-add-row (table row &optional properties)
"Add ROW of string to TABLE and recalculate column sizes.
When non-nil, PROPERTIES will be added to the whole row when
calling `gdscript-debug--table-string'."
(let ((rows (gdscript-debug-table->rows table))
(row-properties (gdscript-debug-table->row-properties table))
(column-sizes (gdscript-debug-table->column-sizes table))
(right-align (gdscript-debug-table->right-align table)))
(when (not column-sizes)
(setf (gdscript-debug-table->column-sizes table)
(make-list (length row) 0)))
(setf (gdscript-debug-table->rows table)
(append rows (list row)))
(setf (gdscript-debug-table->row-properties table)
(append row-properties (list properties)))
(setf (gdscript-debug-table->column-sizes table)
(cl-mapcar (lambda (x s)
(let ((new-x
(max (abs x) (string-width (or s "")))))
(if right-align new-x (- new-x))))
(gdscript-debug-table->column-sizes table)
row))
;; Avoid trailing whitespace at eol
(if (not (gdscript-debug-table->right-align table))
(setcar (last (gdscript-debug-table->column-sizes table)) 0))))
(defun gdscript-debug--parent-mode ()
"Generic mode to derive all other buffer modes from."
(kill-all-local-variables)
(setq buffer-read-only t)
(buffer-disable-undo))
(defun gdscript-debug-toggle-breakpoint ()
"Add or remove a breakpoint on the line at POINT."
(interactive)
(let* ((breakpoint (gdscript-debug--construct-breakpoint-at-point)))
(if (gdscript-debug--is-existing-breakpoint-p breakpoint)
(gdscript-debug--remove-breakpoint breakpoint)
(gdscript-debug--add-breakpoint-to-line breakpoint))))
(defun gdscript-debug--construct-breakpoint-at-point ()
"Construct a breakpoint object for the line at POINT and return it.
May match an existing breakpoint."
(gdscript-debug--with-gdscript-file file-info
(let* ((start (line-beginning-position))
(end (line-end-position))
(line (line-number-at-pos))
(file (car file-info))
(file-absolute (cdr file-info))
(breakpoint (gdscript-breakpoint-create :file file :file-absolute file-absolute :line line)))
breakpoint)))
(defun gdscript-debug--is-existing-breakpoint-p (breakpoint)
"Return t if `BREAKPOINT' is an existing breakpoint in the project."
(member breakpoint gdscript-debug--breakpoints))
(defun gdscript-debug--add-breakpoint-to-line (breakpoint)
"Register `BREAKPOINT' to the current line in a GDScript buffer."
(gdscript-debug--with-gdscript-file file-info
(let* ((line (line-number-at-pos))
(file (car file-info)))
(if (member breakpoint gdscript-debug--breakpoints)
(message "Breakpoint already present at %s:%s" file line)
(gdscript-debug--add-fringe (line-beginning-position) (not gdscript-debug--skip-breakpoints) 'gdb-bptno 1)
(gdscript-debug--add-breakpoint-to-buffer breakpoint)
(gdscript-debug-refresh-breakpoints-buffer)
(gdscript-debug--if-server-process
(gdscript-debug--send-command
(gdscript-debug--breakpoint-command file line t)))))))
(defun gdscript-debug--remove-breakpoint (breakpoint)
"Remove `BREAKPOINT' to the current line in a GDScript buffer."
(gdscript-debug--with-gdscript-file file-info
(let* ((start (line-beginning-position))
(end (line-end-position))
(line (line-number-at-pos))
(file (car file-info)))
(if (not (member breakpoint gdscript-debug--breakpoints))
(message "No breakpoint at %s:%s" file line)
(gdscript-debug--remove-strings start end)
(gdscript-debug--remove-breakpoint-from-buffer breakpoint)
(gdscript-debug--if-server-process
(gdscript-debug--send-command
(gdscript-debug--breakpoint-command file line nil)))))))
(defun gdscript-debug--set-left-fringe-breakpoints (enabled)
(gdscript-debug-refresh-breakpoints-buffer)
(dolist (breakpoint gdscript-debug--breakpoints)
(let ((file (gdscript-breakpoint->file-absolute breakpoint))
(line (gdscript-breakpoint->line breakpoint)))
(save-selected-window
(let ((buffer (find-file-noselect file)))
(save-excursion
(with-current-buffer buffer
(goto-char (point-min))
(forward-line (1- line))
(let ((start (line-beginning-position))
(end (line-end-position)))
(dolist (overlay (overlays-in start end))
(when (overlay-get overlay 'put-break)
(let* ((string (overlay-get overlay 'before-string))
(prop `(left-fringe breakpoint ,(if (not enabled) 'breakpoint-enabled 'breakpoint-disabled))))
(put-text-property 0 1 'display prop string))))))))))))
(defun gdscript-debug-toggle-skip-breakpoints ()
"Toggle the execution of all breakpoints without removing them.
Like Godot's Skip Breakpoints button."
(interactive)
(setq gdscript-debug--skip-breakpoints (not gdscript-debug--skip-breakpoints))
(gdscript-debug--set-left-fringe-breakpoints gdscript-debug--skip-breakpoints)
(gdscript-debug--send-command
(gdscript-debug--set-skip-breakpoints-command gdscript-debug--skip-breakpoints)))
(defun gdscript-debug-delete-breakpoint ()
(interactive)
(if-let* ((breakpoint (get-text-property (point) 'gdscript-debug--breakpoint)))
(let ((file (gdscript-breakpoint->file-absolute breakpoint))
(line (gdscript-breakpoint->line breakpoint)))
(save-selected-window
(let ((buffer (find-file-noselect file)))
(with-current-buffer buffer
(goto-char (point-min))
(forward-line (1- line))
(gdscript-debug--remove-breakpoint breakpoint)))))
(message "Not recognized as breakpoint line")))
(defun gdscript-debug-goto-breakpoint ()
(interactive)
(if-let* ((breakpoint (get-text-property (point) 'gdscript-debug--breakpoint)))
(let ((file (gdscript-breakpoint->file-absolute breakpoint))
(line (gdscript-breakpoint->line breakpoint)))
(save-selected-window
(let* ((buffer (find-file-noselect file))
(window (gdscript-debug--display-buffer buffer)))
(with-current-buffer buffer
(goto-char (point-min))
(forward-line (1- line))
(set-window-point window (point))))))
(message "Not recognized as breakpoint line")))
(defun gdscript-debug-inspect-object-id ()
(interactive)
(save-excursion
(when (or (derived-mode-p 'gdscript-debug--scene-tree-mode)
(derived-mode-p 'gdscript-debug--stack-frame-vars-mode))
(setq gdscript-debug--inspector-stack nil))
(if-let* ((object-id (get-text-property (point) 'object-id)))
(progn
(setq gdscript-debug--inspector-focused-object-id object-id)
(gdscript-debug--show-object-id object-id))
(message "Not recognized as object-id line"))))
(defun gdscript-debug--show-object-id (object-id)
(if (gethash object-id gdscript-debug--inspected-objects)
(gdscript-debug--refresh-inspector-buffer object-id)
(if gdscript-debug-state
(message "Cannot inspect object-id now")
(setq gdscript-debug-state :refresh-inspector)
(gdscript-debug-inspect-object object-id))))
(defun gdscript-debug-show-stack-frame-vars ()
(interactive)
(save-excursion
(beginning-of-line)
(if-let* ((stack (get-text-property (point) 'gdscript-debug--stack-dump)))
(progn (setq gdscript-debug--selected-stack-dump stack)
(gdscript-debug-get-stack-frame-vars (gdscript-stack-dump->level stack)))
(message "Not recognized as stack-frame line"))))
(defun gdscript-debug-jump-to-stack-point ()
(interactive)
(save-excursion
(beginning-of-line)
(if-let* ((stack-dump (get-text-property (point) 'gdscript-debug--stack-dump))
(project-root (get-text-property (point) 'gdscript-debug--project-root)))
(let* ((file (gdscript-stack-dump->file stack-dump))
(line (gdscript-stack-dump->line stack-dump))
(full-file-path (concat project-root (gdscript-debug--drop-res file))))
(with-current-buffer (find-file full-file-path)
(let* ((posns (gdscript-debug--line-posns line))
(start-posn (car posns)))
(goto-char start-posn))))
(message "Not recognized as stack-frame line"))))
(defun gdscript-debug-go-back ()
(interactive)
(cond
((>= 1 (length gdscript-debug--inspector-stack))
(switch-to-buffer (gdscript-debug--get-stack-frame-vars-buffer)))
(t
(let* ((last-breadcrumb (pop gdscript-debug--inspector-stack))
(show-breadcrumb (car gdscript-debug--inspector-stack))
(object-id (gdscript-debug-breadcrumb-entry->object-id show-breadcrumb)))
(setq gdscript-debug--inspector-focused-object-id object-id)
(gdscript-debug--show-object-id object-id)
(goto-char (gdscript-debug-breadcrumb-entry->point last-breadcrumb))))))
(defun gdscript-debug-toggle-visibility ()
(interactive)
(when-let ((is-on-multiline (get-pos-property (point) 'multiline)))
(goto-char (previous-single-property-change (point) 'multiline)))
(when (get-text-property (line-end-position) 'multiline)
(let* ((inhibit-read-only t)
(start (line-beginning-position))
(end (line-end-position))
(property-name (get-text-property start 'property-name))
(inline-start (next-single-property-change start 'inline (current-buffer) end))
(inline-end (next-single-property-change inline-start 'inline))
(multiline-start inline-end)
(multiline-end (next-single-property-change multiline-start 'multiline))
(inline-invisible (get-pos-property inline-end 'invisible))
(multiline-invisible (get-pos-property multiline-end 'invisible)))
(put-text-property inline-start inline-end 'invisible (not inline-invisible))
(put-text-property multiline-start multiline-end 'invisible (not multiline-invisible))
(puthash (cons gdscript-debug--buffer-type property-name) multiline-invisible gdscript-debug--multiline-on)
(when inline-invisible (goto-char start)))))
(defvar gdscript-debug--stack-dump-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "q" 'kill-current-buffer)
(define-key map " " 'gdscript-debug-jump-to-stack-point)
(define-key map "p" 'previous-line)
(define-key map "n" 'next-line)
(define-key map "l" 'gdscript-debug-display-stack-frame-vars-buffer)
(define-key map "\r" 'gdscript-debug-show-stack-frame-vars)
(define-key map "?" 'describe-mode)
(define-key map (kbd "C-c n") 'gdscript-debug-hydra)
(define-key map (kbd "C-c r") 'gdscript-hydra-show)
map))
(defvar gdscript-debug--breakpoints-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map " " 'gdscript-debug-toggle-skip-breakpoints)
(define-key map "q" 'kill-current-buffer)
(define-key map "D" 'gdscript-debug-delete-breakpoint)
(define-key map "\r" 'gdscript-debug-goto-breakpoint)
(define-key map "\t" 'gdscript-debug-display-stack-dump-buffer)
(define-key map "?" 'describe-mode)
(define-key map (kbd "C-c n") 'gdscript-debug-hydra)
(define-key map (kbd "C-c r") 'gdscript-hydra-show)
map))
(defvar gdscript-debug--stack-frame-vars-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "d" 'gdscript-debug-fetch-object-ids-detail)
(define-key map "l" 'gdscript-debug-display-stack-dump-buffer)
(define-key map "n" 'next-line)
(define-key map "o" 'gdscript-debug-pin-inspected-object-id)
(define-key map "p" 'previous-line)
(define-key map "q" 'kill-current-buffer)
(define-key map "u" 'gdscript-debug-unpin)
(define-key map "\r" 'gdscript-debug-inspect-object-id)
(define-key map "\t" 'gdscript-debug-toggle-visibility)
(define-key map "?" 'describe-mode)
(define-key map (kbd "C-c n") 'gdscript-debug-hydra)
(define-key map (kbd "C-c r") 'gdscript-hydra-show)
map))
(defvar gdscript-debug--inspector-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "d" 'gdscript-debug-fetch-object-ids-detail)
(define-key map "l" 'gdscript-debug-go-back)
(define-key map "n" 'next-line)
(define-key map "u" 'gdscript-debug-unpin)
(define-key map "o" 'gdscript-debug-pin-inspected-object-id)
(define-key map "p" 'previous-line)
(define-key map "q" 'kill-current-buffer)
(define-key map "\t" 'gdscript-debug-toggle-visibility)
(define-key map "\r" 'gdscript-debug-inspect-object-id)
(define-key map "?" 'describe-mode)
(define-key map (kbd "C-c n") 'gdscript-debug-hydra)
(define-key map (kbd "C-c r") 'gdscript-hydra-show)
map))
(defvar gdscript-debug--scene-tree-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "q" 'kill-current-buffer)
(define-key map "p" 'previous-line)
(define-key map "n" 'next-line)
(define-key map "g" 'gdscript-debug-request-scene-tree)
(define-key map "\r" 'gdscript-debug-inspect-object-id)
(define-key map "?" 'describe-mode)
(define-key map (kbd "C-c n") 'gdscript-debug-hydra)
(define-key map (kbd "C-c r") 'gdscript-hydra-show)
map))
(defvar-local gdscript-debug--buffer-type nil
"One of the symbols bound in `gdscript-debug--get-buffer-create'.")
(defvar-local gdscript-debug--after-refresh-function nil
"Function to call after command to popular buffer is received.")
(defun gdscript-debug--get-buffer (buffer-type)
"Get a specific buffer.
In that buffer, `gdscript-debug--buffer-type' must be equal to BUFFER-TYPE."
(catch 'found
(dolist (buffer (buffer-list) nil)
(with-current-buffer buffer
(when (eq gdscript-debug--buffer-type buffer-type)
(throw 'found buffer))))))
(defun gdscript-debug--get-breakpoint-buffer()
(gdscript-debug--get-buffer-create 'breakpoints-buffer))
(defun gdscript-debug--get-stack-dump-buffer ()
(gdscript-debug--get-buffer-create 'stack-dump-buffer))
(defun gdscript-debug--get-stack-frame-vars-buffer ()
(gdscript-debug--get-buffer-create 'stack-frame-vars-buffer))
(defun gdscript-debug--get-inspector-buffer ()
(gdscript-debug--get-buffer-create 'inspector-buffer))
(defun gdscript-debug--get-scene-tree-buffer ()
(gdscript-debug--get-buffer-create 'scene-tree-buffer))
(defun gdscript-debug--many-windows (buffer-to-display _action-alist)
(let ((mode-to-display (with-current-buffer buffer-to-display major-mode))
(window-to-switch))
(when
(or (eq mode-to-display 'gdscript-debug--breakpoints-mode)
(eq mode-to-display 'gdscript-debug--stack-dump-mode)
(eq mode-to-display 'gdscript-debug--stack-frame-vars-mode)
(eq mode-to-display 'gdscript-debug--inspector-mode)
(eq mode-to-display 'gdscript-debug--scene-tree-mode))
(mapc (lambda (window)
(with-current-buffer (window-buffer window)
(when (not
(or (eq major-mode 'gdscript-mode)
(eq window lv-wnd)))
(setq window-to-switch window)
(set-window-buffer window buffer-to-display))))
(window-list)))
window-to-switch))
(defun gdscript-debug--stack-dump-file-path (stack-dump)
(concat (cdr gdscript-debug--stack-dump) (gdscript-debug--drop-res (gdscript-stack-dump->file stack-dump))))
(defun gdscript-debug--set-window-buffer (window stack-dump)
(let ((buffer (find-file-noselect (gdscript-debug--stack-dump-file-path stack-dump))))
(set-window-buffer window buffer)
(with-current-buffer buffer
(goto-char (point-min))
(forward-line (1- (gdscript-stack-dump->line stack-dump)))
(point))))
(defun gdscript-debug-windows ()
(delete-other-windows)
(gdscript-debug-hydra)
(pcase (car gdscript-debug--stack-dump)
(`() nil)
(`(,stack-dump)
(let* ((top-left (selected-window))
(bottom-left (split-window))
(bottom-right (split-window bottom-left nil t)))
(set-window-buffer top-left (find-file-noselect (gdscript-debug--stack-dump-file-path stack-dump)))
(set-window-buffer bottom-left (gdscript-debug--get-inspector-buffer))
(set-window-buffer bottom-right (gdscript-debug--get-stack-frame-vars-buffer))))
(_
(let* ((stack-dump-a (caar gdscript-debug--stack-dump))
(stack-dump-b (cadr (car gdscript-debug--stack-dump)))
(top-left (selected-window))
(bottom-left (split-window))
(top-right (split-window nil nil t))
(bottom-right (split-window bottom-left nil t))
(top-left-point (gdscript-debug--set-window-buffer top-left stack-dump-b))
(top-right-point (gdscript-debug--set-window-buffer top-right stack-dump-a)))
(set-window-point top-left top-left-point)
(set-window-point top-right top-right-point)
(set-window-buffer bottom-left (gdscript-debug--get-inspector-buffer))
(set-window-buffer bottom-right (gdscript-debug--get-stack-frame-vars-buffer))
(select-window top-right)))))
(defun gdscript-debug--display-buffer (buffer)
(display-buffer buffer
'((display-buffer-reuse-window
gdscript-debug--many-windows))))
(defun gdscript-debug-display-stack-dump-buffer ()
"Display stack dump."
(interactive)
(display-buffer (gdscript-debug--get-stack-dump-buffer) '((display-buffer-same-window))))
(defun gdscript-debug-display-stack-frame-vars-buffer ()
"Display the variables of current stack."
(interactive)
(display-buffer (gdscript-debug--get-stack-frame-vars-buffer) '((display-buffer-same-window))))
(defun gdscript-debug-display-breakpoint-buffer ()
"Display the breakpoints."
(interactive)
(display-buffer (gdscript-debug--get-breakpoint-buffer) '((display-buffer-same-window)))
(gdscript-debug-refresh-breakpoints-buffer))
(defun gdscript-debug-display-inspector-buffer ()
"Display the inspector."
(interactive)
(gdscript-debug--display-buffer (gdscript-debug--get-inspector-buffer)))
(defun gdscript-debug-display-scene-tree-buffer ()
"Display the Scene tree."
(interactive)
(display-buffer (gdscript-debug--get-scene-tree-buffer) '((display-buffer-same-window))))
(defun gdscript-debug-display-source-buffer ()
"Using stack dump jump to the source"
(interactive)
(with-current-buffer (gdscript-debug--get-stack-dump-buffer)
(goto-char (point-min))
(gdscript-debug-jump-to-stack-point)))
(defun gdscript-debug--remove-breakpoint-from-buffer (breakpoint)
(setq gdscript-debug--breakpoints (remove breakpoint gdscript-debug--breakpoints))
(gdscript-debug-refresh-breakpoints-buffer))
(defun gdscript-debug--add-breakpoint-to-buffer (breakpoint)
(unless (member breakpoint gdscript-debug--breakpoints)
(push breakpoint gdscript-debug--breakpoints)))
(defun gdscript-debug--refresh-scene-tree-buffer (scene-tree-data)
(with-current-buffer (gdscript-debug--get-scene-tree-buffer)
(let ((inhibit-read-only t)
(point (point)))
(erase-buffer)
(gdscript-debug--scene-tree-row scene-tree-data 0 "")
(goto-char point)
(when gdscript-debug--after-refresh-function
(funcall gdscript-debug--after-refresh-function)
(setq gdscript-debug--after-refresh-function nil)))))
(defun gdscript-debug--scene-tree-row (scene-tree-level-edge level node-path)
(let* ((node (gdscript-scene-tree-level-edge->item scene-tree-level-edge))
(children (gdscript-scene-tree-level-edge->children scene-tree-level-edge))
(node-name (gdscript-scene-tree-node->node-name node))
(node-class (gdscript-scene-tree-node->node-class node))
(path (concat node-path "/" node-name)))
(insert (propertize (format "%s %s %s %s\n"
(gdscript-debug-pad-string (if children "+" " ") (* 4 level))
(gdscript-debug-variable-face node-name)
(gdscript-debug-type-face node-class)
(gdscript-scene-tree-node->instance-id node))
'object-id (gdscript-scene-tree-node->instance-id node)
'node-path path))
(dolist (child children)
(gdscript-debug--scene-tree-row child (1+ level) path))))
(defun gdscript-debug--refresh-stack-dump-buffer (stack-dump project-root)
(with-current-buffer (gdscript-debug--get-stack-dump-buffer)
(let ((inhibit-read-only t)
(longest-file-name 0))
(dolist (stack stack-dump)
(let* ((file (gdscript-stack-dump->file stack))
(line (gdscript-stack-dump->line stack))
(len (+ (length file) (length (number-to-string line)))))
(when (< longest-file-name len)
(setq longest-file-name len))))
(erase-buffer)
(dolist (stack stack-dump)
(let ((ident (format "%s:%s" (gdscript-stack-dump->file stack) (gdscript-stack-dump->line stack))))
(insert (propertize
(concat
(format (concat "%s - %-" (number-to-string (1+ longest-file-name)) "s - ") (gdscript-stack-dump->level stack) ident)
(propertize
(format "%s\n" (gdscript-stack-dump->function-name stack)) 'font-lock-face font-lock-function-name-face))
'gdscript-debug--stack-dump stack
'gdscript-debug--project-root project-root)))))))
(defun gdscript-debug-refresh-breakpoints-buffer ()
(with-current-buffer (gdscript-debug--get-breakpoint-buffer)
(let* ((inhibit-read-only t)
(window (get-buffer-window (current-buffer) 0))
(start (window-start window))
(p (window-point window)))
(erase-buffer)
(insert "Enb Location\n")
(dolist (breakpoint gdscript-debug--breakpoints)
(let ((indicator (if (not gdscript-debug--skip-breakpoints)
(propertize (format "%-4s" "y") 'font-lock-face
font-lock-warning-face)
(propertize (format "%-4s" "n") 'font-lock-face
font-lock-comment-face))))
(insert (propertize (format "%s%s:%s\n"
indicator
(gdscript-breakpoint->file breakpoint)
(gdscript-breakpoint->line breakpoint))
'gdscript-debug--breakpoint breakpoint))))
(set-window-start window start) ;; Forces fringe icons to refresh
(set-window-point window p))))
(defun gdscript-debug--get-buffer-create (buffer-type)
(or (gdscript-debug--get-buffer buffer-type)
(let ((rules (assoc buffer-type gdscript-debug--buffer-rules))
(new (generate-new-buffer "limbo")))
(with-current-buffer new
(let ((mode (gdscript-debug--rules-buffer-mode rules)))
(when mode (funcall mode))
(setq gdscript-debug--buffer-type buffer-type)
(rename-buffer (funcall (gdscript-debug--rules-name-maker rules)))
(current-buffer))))))
(define-derived-mode gdscript-debug--stack-dump-mode gdscript-debug--parent-mode "Stack Dump"
"Major mode for stack dump."
(setq header-line-format "Stack dump"))
(define-derived-mode gdscript-debug--stack-frame-vars-mode gdscript-debug--parent-mode "Stack Frame Vars"
"Major mode for stack frame variables."
(setq header-line-format "Stack frame vars"))
(define-derived-mode gdscript-debug--breakpoints-mode gdscript-debug--parent-mode "Breakpoints"
"Major mode for breakpoints management."
(setq header-line-format "Breakpoints"))
(define-derived-mode gdscript-debug--inspector-mode gdscript-debug--parent-mode "Inspector"
"Major mode for inspector management."
(setq header-line-format "Inspector"))
(define-derived-mode gdscript-debug--scene-tree-mode gdscript-debug--parent-mode "Scene Tree"
"Major mode for scene tree."
(setq header-line-format "Scene Tree"))
(defun gdscript-debug--stack-dump-buffer-name ()
(concat "* Stack dump *"))
(defun gdscript-debug--stack-frame-vars-buffer-name ()
(concat "* Stack frame vars *"))
(defun gdscript-debug--breakpoints-buffer-name ()
(concat "* Breakpoints *"))
(defun gdscript-debug--inspector-buffer-name ()
(concat "* Inspector *"))
(defun gdscript-debug--scene-tree-buffer-name ()
(concat "* Scene tree *"))
(defvar gdscript-debug--buffer-rules '())
(defvar gdscript-debug--breakpoints '())
(defvar gdscript-debug--skip-breakpoints nil)
(defun gdscript-debug--rules-name-maker (rules-entry)
(cadr rules-entry))
(defun gdscript-debug--rules-buffer-mode (rules-entry)
(nth 2 rules-entry))
(defun gdscript-debug--set-buffer-rules (buffer-type &rest rules)
(if-let* ((binding (assoc buffer-type gdscript-debug--buffer-rules)))
(setcdr binding rules)
(push (cons buffer-type rules)
gdscript-debug--buffer-rules)))
(gdscript-debug--set-buffer-rules
'stack-frame-vars-buffer
'gdscript-debug--stack-frame-vars-buffer-name
'gdscript-debug--stack-frame-vars-mode)
(gdscript-debug--set-buffer-rules
'stack-dump-buffer
'gdscript-debug--stack-dump-buffer-name
'gdscript-debug--stack-dump-mode)
(gdscript-debug--set-buffer-rules
'breakpoints-buffer
'gdscript-debug--breakpoints-buffer-name
'gdscript-debug--breakpoints-mode)
(gdscript-debug--set-buffer-rules
'inspector-buffer
'gdscript-debug--inspector-buffer-name
'gdscript-debug--inspector-mode)
(gdscript-debug--set-buffer-rules
'scene-tree-buffer
'gdscript-debug--scene-tree-buffer-name
'gdscript-debug--scene-tree-mode)
(ignore-errors
;; Don't signal an error when hydra.el is not present
(defhydra gdscript-debug--hydra (:hint none)
"
_n_ next _c_ continue _m_ step _b_ breakpoints _s_ stack _v_ vars _i_ inspector _t_ scene-tree _d_ details _o_ pin _u_ unpin _q_ quit
"
("n" (gdscript-debug-next))
("c" (gdscript-debug-continue))
("m" (gdscript-debug-step))
("s" (gdscript-debug-display-stack-dump-buffer))
("b" (gdscript-debug-display-breakpoint-buffer))
("v" (gdscript-debug-display-stack-frame-vars-buffer))
("i" (gdscript-debug-display-inspector-buffer))
("t" (gdscript-debug-request-scene-tree))
("d" (gdscript-debug-fetch-object-ids-detail))
("o" (gdscript-debug-pin-current-self))
("u" (gdscript-debug-unpin))
("q" nil)))
(defun gdscript-debug-hydra ()
"Show debug hydra."
(interactive)
(gdscript-util--with-available-hydra (gdscript-debug--hydra/body)))
(provide 'gdscript-debug)
Reference in New Issue View Git Blame Copy Permalink