[elpa] master 87d1ada 137/215: Refactor and improve breakpoint UI

[Rocky Bernstein]

branch: master
commit 87d1ada22563349d86b0b7be90d09814375a1963
Author: Clément Pit--Claudel <address@hidden>
Commit: Clément Pit--Claudel <address@hidden>

    Refactor and improve breakpoint UI
    
    Improvements:
    
    * Support non-graphical displays
    * Properly handle multiple breakpoints on the same line
    * Use fringes instead of margins to display breakpoint icons on
      graphical displays (customizable with realgud-bp-use-fringe)
    * Let users set or disable breakpoints by clicking on the fringe or
      in the margin
    * Make breakpoint fringe icons customizable, and default to a hollow
      circle for disabled breakpoints
---
 realgud/common/bp.el           |  314 +++++++++++++++++++++-------------------
 realgud/common/cmds.el         |   19 +++
 realgud/common/fringe-utils.py |   36 +++++
 realgud/common/shortkey.el     |    2 +
 4 files changed, 219 insertions(+), 152 deletions(-)

diff --git a/realgud/common/bp.el b/realgud/common/bp.el
index 7b9365f..4de307a 100644
--- a/realgud/common/bp.el
+++ b/realgud/common/bp.el
@@ -5,176 +5,186 @@
 (require 'load-relative)
 (require-relative-list '("loc" "bp-image-data") "realgud-")
 
+(defun realgud-bp-remove-icons (&optional begin-pos end-pos bpnum)
+  "Remove breakpoint icons (overlays) in BEGIN-POS .. END-POS.
+The default value for BEGIN-POS is `point'.  The default value
+for END-POS is BEGIN-POS.  When BPNUM is non-nil, only remove
+overlays with that breakpoint number.
+
+The way we determine if an overlay is ours is by inspecting the
+overlay for a realgud property."
+  (interactive "r")
+  (setq begin-pos (or begin-pos (point))
+        end-pos (or end-pos begin-pos))
+  (dolist (overlay (overlays-in begin-pos end-pos))
+    (when (overlay-get overlay 'realgud)
+      (when (or (null bpnum) (equal bpnum (overlay-get overlay 
'realgud-bp-num)))
+        (delete-overlay overlay)))))
+
 (defvar realgud-bp-enabled-icon nil
   "Icon for an enabled breakpoint in display margin.")
 
 (defvar realgud-bp-disabled-icon nil
   "Icon for a disabled breakpoint in display margin.")
 
-(defun realgud-bp-remove-icons (&optional opt-begin-pos opt-end-pos)
-  "Remove dbgr breakpoint icons (overlays) in the region
-OPT-BEGIN-POS to OPT-END-POS. The default value for OPT-BEGIN-POS
-is `point'.  The default value for OPT-END-POS is OPT-BEGIN-POS.
-
-The way we determine if an overlay is ours is by inspecting the
-overlay for a before-string property containing one we normally set.
-"
-  (interactive "r")
-  (let* ((begin-pos (or opt-begin-pos (point)))
-         (end-pos (or opt-end-pos begin-pos))
-        )
-    (dolist (overlay (overlays-in begin-pos end-pos))
-      ;; We determine if this overlay is one we set by seeing if the
-      ;; string in its 'before-string property has a 'realgud-bptno property
-      (let ((before-string (overlay-get overlay 'before-string)))
-        (when (and before-string (get-text-property 0 'realgud-bptno 
before-string))
-          (delete-overlay overlay)
-          )
-        )
-      )
-    )
-  )
-
 (defun realgud-set-bp-icons()
-  (if (display-images-p)
-    ;; NOTE: if you don't see the icon, check the that the window margin
-    ;; is not nil.
-      (progn
-       (setq realgud-bp-enabled-icon
-             (find-image `((:type xpm :data
-                                  ,realgud-bp-xpm-data
-                                  :ascent 100 :pointer hand)
-                           (:type svg :data
-                                  ,realgud-bp-enabled-svg-data
-                                  :ascent 100 :pointer hand)
-                           (:type tiff :data
-                                  ,realgud-bp-enabled-tiff-data
-                                  :ascent 100 :pointer hand)
-                           (:type pbm :data
-                                  ,realgud-bp-enabled-pbm-data
-                                  :ascent 100 :pointer hand)
-                           )))
-
-       ;; For seeing what realgud-bp-enabled-icon looks like:
-       ;; (insert-image realgud-bp-enabled-icon)
-
-       (setq realgud-bp-disabled-icon
-             (find-image `((:type xpm :data
-                                  ,realgud-bp-xpm-data
-                                  :conversion disabled ;; different than 
'enabled'
-                                  :ascent 100 :pointer hand)
-                           (:type svg :data
-                                  ,realgud-bp-disabled-svg-data
-                                  :ascent 100 :pointer hand)
-                           (:type tiff :data
-                                  ,realgud-bp-disabled-tiff-data
-                                  :ascent 100 :pointer hand)
-                           (:type pbm :data
-                                  ,realgud-bp-disabled-pbm-data
-                                  :ascent 100 :pointer hand)
-                           (:type svg :data
-                                  ,realgud-bp-disabled-svg-data
-                                  :ascent 100 :pointer hand)
-                           )))
-       ;; For seeing what realgud-bp-enabled-icon looks like:
-       ;; (insert-image realgud-bp-disabled-icon)
-       )
-    (message "Display doesn't support breakpoint images in fringe")
-    )
-  )
-
-
-(defun realgud-bp-put-icon (pos enabled bp-num &optional opt-buf)
-  "Add a breakpoint icon in the left margin at POS via a `put-image' overlay.
-The alternate string name for the image is created from the value
-of ENABLED and BP-NUM.  In particular, if ENABLED is 't and
-BP-NUM is 5 the overlay string is be 'B5:' If ENABLED is false
-then the overlay string is 'b5:'. Breakpoint text properties are
-also attached to the icon via its display string."
-  (let ((enabled-str)
-        (buf (or opt-buf (current-buffer)))
-        (bp-num-str
-         (cond
-          ((or (not bp-num) (not (numberp bp-num))) ":")
-          ('t (format "%d:" bp-num))))
-        (brkpt-icon)
-        (bp-str)
-        (help-string "mouse-1: enable/disable bkpt")
-        )
-    (with-current-buffer buf
-      (unless realgud-bp-enabled-icon (realgud-set-bp-icons))
-      (if enabled
-          (progn
-            (setq enabled-str "B")
-            (setq brkpt-icon realgud-bp-enabled-icon)
-            )
-        (progn
-          (setq enabled-str "b")
-          (setq brkpt-icon realgud-bp-disabled-icon)
-          ))
-      ;; Create alternate display string and attach
-      ;; properties it.
-      (setq bp-str (concat enabled-str bp-num-str))
-      (add-text-properties
-       0 1 `(realgud-bptno ,bp-num enabled ,enabled) bp-str)
-      (add-text-properties
-       0 1 (list 'help-echo (format "%s %s" bp-str help-string))
-       bp-str)
-
-      ;; Display breakpoint icon or display string.  If the window is
-      ;; nil, the image doesn't get displayed, so make sure it is large
-      ;; enough.
+  "Load breakpoint icons, if needed."
+  (when (display-images-p)
+    (unless realgud-bp-enabled-icon
+      (setq realgud-bp-enabled-icon
+            (find-image `((:type xpm :data
+                                 ,realgud-bp-xpm-data
+                                 :ascent 100 :pointer hand)
+                          (:type svg :data
+                                 ,realgud-bp-enabled-svg-data
+                                 :ascent 100 :pointer hand)
+                          (:type tiff :data
+                                 ,realgud-bp-enabled-tiff-data
+                                 :ascent 100 :pointer hand)
+                          (:type pbm :data
+                                 ,realgud-bp-enabled-pbm-data
+                                 :ascent 100 :pointer hand)))))
+    (unless realgud-bp-disabled-icon
+      (setq realgud-bp-disabled-icon
+            (find-image `((:type xpm :data
+                                 ,realgud-bp-xpm-data
+                                 :conversion disabled ; different than 
'enabled'
+                                 :ascent 100 :pointer hand)
+                          (:type svg :data
+                                 ,realgud-bp-disabled-svg-data
+                                 :ascent 100 :pointer hand)
+                          (:type tiff :data
+                                 ,realgud-bp-disabled-tiff-data
+                                 :ascent 100 :pointer hand)
+                          (:type pbm :data
+                                 ,realgud-bp-disabled-pbm-data
+                                 :ascent 100 :pointer hand)
+                          (:type svg :data
+                                 ,realgud-bp-disabled-svg-data
+                                 :ascent 100 :pointer hand)))))))
+
+(declare-function define-fringe-bitmap "fringe.c"
+                  (bitmap bits &optional height width align))
+
+(when (display-images-p)
+  ;; Taken from gdb-mi
+  (define-fringe-bitmap 'realgud-bp-filled
+    "\x3c\x7e\xff\xff\xff\xff\x7e\x3c")
+  (define-fringe-bitmap 'realgud-bp-hollow
+    "\x3c\x42\x81\x81\x81\x81\x42\x3c"))
+
+(defgroup realgud-bp nil
+  "RealGUD breakpoints UI"
+  :group 'realgud
+  :prefix 'realgud-bp-)
+
+(defface realgud-bp-enabled-face
+  '((t :foreground "red" :weight bold))
+  "Face for enabled breakpoints."
+  :group 'realgud-bp)
+
+(defface realgud-bp-disabled-face
+  '((t :foreground "grey" :weight bold))
+  "Face for disabled breakpoints."
+  :group 'realgud-bp)
+
+(defcustom realgud-bp-fringe-indicator-style '(realgud-bp-filled . 
realgud-bp-hollow)
+  "Which fringe icon to use for breakpoints."
+  :type '(choice (const :tag "Disc" (realgud-bp-filled . realgud-bp-hollow))
+                 (const :tag "Square" (filled-square . hollow-square))
+                 (const :tag "Rectangle" (filled-rectangle . 
hollow-rectangle)))
+  :group 'realgud-bp)
+
+(defcustom realgud-bp-use-fringe t
+  "Whether to use the fringe to display breakpoints.
+If nil, use margins instead."
+  :type '(boolean)
+  :group 'realgud-bp)
+
+(defun realgud-bp--fringe-width ()
+  "Compute width of left fringe."
+  (let ((window (get-buffer-window (current-buffer))))
+    (or left-fringe-width
+        (and window (car (window-fringes window)))
+        0)))
+
+(defun realgud-bp-add-fringe-icon (overlay icon face)
+  "Add a fringe icon to OVERLAY.
+ICON is a fringe icon symbol; the corresponding icon gets
+highlighted with FACE."
+  ;; Ensure that the fringe is wide enough
+  (unless (>= (realgud-bp--fringe-width) 8)
+    (set-fringe-mode `(8 . ,right-fringe-width)))
+  ;; Add the fringe icon
+  (let* ((fringe-spec `(left-fringe ,icon ,face)))
+    (overlay-put overlay 'before-string (propertize "x" 'display 
fringe-spec))))
+
+(defun realgud-bp-add-margin-indicator (overlay text image face)
+  "Add a margin breakpoint indicator to OVERLAY.
+TEXT is a string, IMAGE an IMAGE spec or nil; TEXT gets
+highlighted with FACE."
+  ;; Ensure that the margin is large enough (Taken from gdb-mi)
+  (when (< left-margin-width 2)
+    (save-current-buffer
+      (setq left-margin-width 2)
       (let ((window (get-buffer-window (current-buffer) 0)))
         (if window
-            (set-window-margins window 2)
-          ;; FIXME: This is all crap, but I don't know how to fix.
-          (let ((buffer-save (window-buffer (selected-window))))
-            (set-window-buffer (selected-window) (current-buffer))
-            (set-window-margins (selected-window) 2)
-            (set-window-buffer (selected-window) buffer-save))
-          ))
-      (realgud-bp-remove-icons pos)
-      (if brkpt-icon
-          (put-image brkpt-icon pos bp-str 'left-margin))
-      )
-    )
-  )
-
-(defun realgud-bp-del-icon (pos &optional opt-buf)
-  "Delete breakpoint icon in the left margin at POS via a `put-image' overlay.
-The alternate string name for the image is created from the value
-of ENABLED and BP-NUM.  In particular, if ENABLED is 't and
-BP-NUM is 5 the overlay string is be 'B5:' If ENABLED is false
-then the overlay string is 'b5:'. Breakpoint text properties are
-also attached to the icon via its display string."
-  (let ((buf (or opt-buf (current-buffer))))
-    (with-current-buffer buf
-      (realgud-bp-remove-icons pos)
-    )
-  )
-)
+            (set-window-margins
+             window left-margin-width right-margin-width)))))
+  ;; Add the margin string
+  (let* ((indicator (or image (propertize text 'face face)))
+         (spec `((margin left-margin) ,indicator)))
+    (overlay-put overlay 'before-string (propertize text 'display spec))))
+
+(defun realgud-bp-put-icon (pos enabled bp-num &optional buf)
+  "Add a breakpoint icon at POS according to breakpoint-display-style.
+Use the fringe if available, and the margin otherwise.  Record
+breakpoint status ENABLED and breakpoint number BP-NUM in
+overlay.  BUF is the buffer that POS refers to; it detaults to
+the current buffer."
+  (let* ((margin-text) (face) (margin-icon) (fringe-icon))
+    (realgud-set-bp-icons)
+    (if enabled
+        (setq margin-text "B"
+              face 'realgud-bp-enabled-face
+              margin-icon realgud-bp-enabled-icon
+              fringe-icon (car realgud-bp-fringe-indicator-style))
+      (setq margin-text "b"
+            face 'realgud-bp-disabled-face
+            margin-icon realgud-bp-disabled-icon
+            fringe-icon (cdr realgud-bp-fringe-indicator-style)))
+    (let ((help-echo (format "%s%s: mouse-1 to clear" margin-text bp-num)))
+      (setq margin-text (propertize margin-text 'help-echo help-echo)))
+    (with-current-buffer (or buf (current-buffer))
+      (realgud-bp-remove-icons pos pos bp-num)
+      (let ((ov (make-overlay pos pos (current-buffer) t nil)))
+        (if (and realgud-bp-use-fringe (display-images-p))
+            (realgud-bp-add-fringe-icon ov fringe-icon face)
+          (realgud-bp-add-margin-indicator ov margin-text margin-icon face))
+        (overlay-put ov 'realgud t)
+        (overlay-put ov 'realgud-bp-num bp-num)
+        (overlay-put ov 'realgud-bp-enabled enabled)))))
+
+(defun realgud-bp-del-icon (pos &optional buf bpnum)
+  "Delete breakpoint icon at POS.
+BUF is the buffer which pos refers to (default: current buffer).
+If BPNUM is non-nil, only remove overlays maching that breakpoint
+number."
+  (with-current-buffer (or buf (current-buffer))
+    (realgud-bp-remove-icons pos pos bpnum)))
 
 (defun realgud-bp-add-info (loc)
   "Record bp information for location LOC."
   (if (realgud-loc? loc)
       (let* ((marker (realgud-loc-marker loc))
-             (bp-num (realgud-loc-num loc))
-             )
-        (realgud-bp-put-icon marker 't bp-num)
-        )
-    )
-)
+             (bp-num (realgud-loc-num loc)))
+        (realgud-bp-put-icon marker t bp-num))))
 
 (defun realgud-bp-del-info (loc)
   "Remove bp information for location LOC."
   (if (realgud-loc? loc)
       (let* ((marker (realgud-loc-marker loc))
-             (bp-num (realgud-loc-num loc))
-             )
-        (realgud-bp-del-icon marker)
-        )
-    )
-)
-
+             (bp-num (realgud-loc-num loc)))
+        (realgud-bp-del-icon marker (current-buffer) bp-num))))
 
 (provide-me "realgud-")
diff --git a/realgud/common/cmds.el b/realgud/common/cmds.el
index c854cd1..03990f5 100644
--- a/realgud/common/cmds.el
+++ b/realgud/common/cmds.el
@@ -173,6 +173,25 @@ be found on the current line, prompt for a breakpoint 
number."
     (interactive (realgud:bpnum-from-prefix-arg))
     (realgud:cmd-run-command bpnum "enable" "enable %p"))
 
+(defun realgud-cmds--add-remove-bp (pos)
+  "Add or delete breakpoint at POS."
+  (save-excursion
+    (goto-char pos)
+    (let ((existing-bp-num (realgud:bpnum-on-current-line)))
+      (if existing-bp-num
+          (realgud:cmd-delete existing-bp-num)
+        (realgud:cmd-break pos)))))
+
+(defun realgud-cmds--mouse-add-remove-bp (event)
+  "Add or delete breakpoint on line pointed to by EVENT.
+EVENT should be a mouse click on the left fringe or margin."
+  (interactive "e")
+  (let* ((posn (event-end event))
+         (pos (posn-point posn)))
+    (when (numberp pos)
+      (with-current-buffer (window-buffer (posn-window posn))
+        (realgud-cmds--add-remove-bp pos)))))
+
 (defun realgud:cmd-eval(arg)
     "Evaluate an expression."
     (interactive "MEval expesssion: ")
diff --git a/realgud/common/fringe-utils.py b/realgud/common/fringe-utils.py
new file mode 100644
index 0000000..c344e50
--- /dev/null
+++ b/realgud/common/fringe-utils.py
@@ -0,0 +1,36 @@
+def bit2char(byte, offset):
+    return "X" if byte & (1 << offset) else " "
+
+def char2bit(char, offset):
+    return (0 if char == " " else 1) << offset
+
+def decompile_bitmap(bmp_bytes):
+    lines = []
+    for b in bmp_bytes:
+        lines.append("".join(bit2char(b, offset) for offset in range(8)))
+    return lines
+
+def compile_bitmap(bmp_lines):
+    bmp_bytes = []
+    for line in bmp_lines:
+        s = sum(char2bit(c, offset) for (offset, c) in enumerate(line))
+        print(s)
+        bmp_bytes.append(s.to_bytes(1, byteorder="big"))
+    return b"".join(bmp_bytes)
+
+hollow_circle = ["  XXXX  ",
+                 " X    X ",
+                 "X      X",
+                 "X      X",
+                 "X      X",
+                 "X      X",
+                 " X    X ",
+                 "  XXXX  "]
+
+def print_compiled(bmp):
+    print("".join(r'\x{:02x}'.format(b) for b in bmp))
+
+print("\n".join(decompile_bitmap(b"\x3c\x7e\xff\xff\xff\xff\x7e\x3c")))
+print_compiled(compile_bitmap(decompile_bitmap(b"\x3c\x7e\xff\xff\xff\xff\x7e\x3c")))
+print_compiled(compile_bitmap(hollow_circle))
+
diff --git a/realgud/common/shortkey.el b/realgud/common/shortkey.el
index c236237..6c03a4f 100644
--- a/realgud/common/shortkey.el
+++ b/realgud/common/shortkey.el
@@ -46,6 +46,8 @@
     (define-key map "e"        'realgud:cmd-eval-dwim)
     (define-key map "U"        'realgud:cmd-until)
     (define-key map [mouse-2]  'realgud:tooltip-eval)
+    (define-key map [left-fringe mouse-1] #'realgud-cmds--mouse-add-remove-bp)
+    (define-key map [left-margin mouse-1] #'realgud-cmds--mouse-add-remove-bp)
 
     ;; FIXME: these can go to a common routine
     (define-key map "<"        'realgud:cmd-newer-frame)