Book a Demo!
CoCalc Logo Icon
StoreFeaturesDocsShareSupportNewsAboutPoliciesSign UpSign In
marvel
GitHub Repository: marvel/qnf
 Path: blob/master/elisp/slime/contrib/slime-highlight-edits.el
990 views
1


2
(define-slime-contrib slime-highlight-edits

3
  "Highlight edited, i.e. not yet compiled, code."

4
  (:authors "William Bland <[email protected]>")

5
  (:license "GPL")

6
  (:on-load   (add-hook 'slime-mode-hook 'slime-activate-highlight-edits))

7
  (:on-unload (remove-hook 'slime-mode-hook 'slime-activate-highlight-edits)))

8


9
(defun slime-activate-highlight-edits ()

10
 (slime-highlight-edits-mode 1))

11


12
(defface slime-highlight-edits-face

13
    `((((class color) (background light))

14
       (:background "lightgray"))

15
      (((class color) (background dark))

16
       (:background "dimgray"))

17
      (t (:background "yellow")))

18
  "Face for displaying edit but not compiled code."

19
  :group 'slime-mode-faces)

20


21
(define-minor-mode slime-highlight-edits-mode 

22
  "Minor mode to highlight not-yet-compiled code." nil)

23


24
(add-hook 'slime-highlight-edits-mode-on-hook

25
          'slime-highlight-edits-init-buffer)

26


27
(add-hook 'slime-highlight-edits-mode-off-hook

28
          'slime-highlight-edits-reset-buffer)

29


30
(defun slime-highlight-edits-init-buffer ()

31
  (make-local-variable 'after-change-functions)

32
  (add-to-list 'after-change-functions 

33
               'slime-highlight-edits)

34
  (add-to-list 'slime-before-compile-functions

35
               'slime-highlight-edits-compile-hook))

36


37
(defun slime-highlight-edits-reset-buffer ()

38
  (setq after-change-functions  

39
        (remove 'slime-highlight-edits after-change-functions))

40
  (slime-remove-edits (point-min) (point-max)))

41


42
;; FIXME: what's the LEN arg for?

43
(defun slime-highlight-edits (beg end &optional len) 

44
  (save-match-data

45
    (when (and (slime-connected-p)

46
               (not (slime-inside-comment-p))

47
               (not (slime-only-whitespace-p beg end)))

48
      (let ((overlay (make-overlay beg end)))

49
        (overlay-put overlay 'face 'slime-highlight-edits-face)

50
        (overlay-put overlay 'slime-edit t)))))

51


52
(defun slime-remove-edits (start end)

53
  "Delete the existing Slime edit hilights in the current buffer."

54
  (save-excursion

55
    (goto-char start)

56
    (while (< (point) end)

57
      (dolist (o (overlays-at (point)))

58
        (when (overlay-get o 'slime-edit)

59
          (delete-overlay o)))

60
      (goto-char (next-overlay-change (point))))))

61


62
(defun slime-highlight-edits-compile-hook (start end)

63
  (when slime-highlight-edits-mode

64
    (let ((start (save-excursion (goto-char start) 

65
				 (skip-chars-backward " \t\n\r")

66
				 (point)))

67
	  (end (save-excursion (goto-char end) 

68
			       (skip-chars-forward " \t\n\r")

69
			       (point))))

70
      (slime-remove-edits start end))))

71


72
(defun slime-only-whitespace-p (beg end)

73
  "Contains the region from BEG to END only whitespace?"

74
  (save-excursion

75
    (goto-char beg)

76
    (skip-chars-forward " \n\t\r" end)

77
    (<= end (point))))

78


79
(provide 'slime-highlight-edits)

80


81