I'm looking for some assistance, please to debug my test function so that the yellow vertical line looks exactly the same as the red line. I have decided to exclude highlighting tabs because they are two (2) characters wide and it makes the vertical line like distorted. In my attempt to exclude tabs, however, I lose highlighting of any text to the immediate right. My attempts at fixing this breaks the functionality of the blue and/or red lines.
In a nutshell, the blue and red lines are working as desired, but the yellow line is broken (to the immediate right of a tab) -- the yellow line should look just like the red line.
The problem with my test function lies in the following code snippet:
(not (save-excursion (move-to-column my-col-b)
(< 0 (skip-chars-forward "\t"))))
(not (save-excursion (move-to-column my-col-b)
(> 0 (skip-chars-backward "\t")))))
The following functions were used to create the image of buffer depicted in the screenshot below:
(defun test ()
(interactive)
(let* (my-last-column
my-o-beg-a my-o-end-a (my-col-a 3)
my-o-beg-b my-o-end-b (my-col-b 28)
my-o-beg-c my-o-end-c (my-col-c 29) )
(generate-test-buffer)
(goto-char (point-max))
(while (re-search-backward "\n" (point-min) t)
(setq my-last-column (current-column))
(setq my-o-beg-a (progn (move-to-column my-col-a) (point)))
(setq my-o-end-a (+ 1 my-o-beg-a))
(setq my-o-beg-b (progn (move-to-column my-col-b) (point)))
(setq my-o-end-b (+ 1 my-o-beg-b))
(setq my-o-beg-c (progn (move-to-column my-col-c) (point)))
(setq my-o-end-c (+ 1 my-o-beg-c))
(when (and
(< my-col-a my-last-column)
(not (save-excursion (move-to-column my-col-a)
(< 0 (skip-chars-forward "\t"))))
(not (save-excursion (move-to-column my-col-a)
(> 0 (skip-chars-backward "\t")))))
(overlay-put (make-overlay my-o-beg-a my-o-end-a) 'face '(
(background-color . "cyan")
(foreground-color . "black") )))
(when (and
(< my-col-b my-last-column)
(not (save-excursion (move-to-column my-col-b)
(< 0 (skip-chars-forward "\t"))))
(not (save-excursion (move-to-column my-col-b)
(> 0 (skip-chars-backward "\t")))))
(overlay-put (make-overlay my-o-beg-b my-o-end-b) 'face '(
(background-color . "yellow")
(foreground-color . "black") )))
(when (and
(< my-col-b my-last-column)
(not (save-excursion (move-to-column my-col-c)
(< 0 (skip-chars-forward "\t"))))
(not (save-excursion (move-to-column my-col-c)
(> 0 (skip-chars-backward "\t")))))
(overlay-put (make-overlay my-o-beg-c my-o-end-c) 'face '(
(background-color . "red")
(foreground-color . "black") ))) )))
(defun generate-test-buffer ()
(if (get-buffer "foo.el")
(with-current-buffer "foo.el"
(erase-buffer))
(get-buffer-create "foo.el"))
(switch-to-buffer (get-buffer "foo.el"))
(setq whitespace-style '(face space-mark tab-mark newline-mark) )
(setq indent-tabs-mode t)
(setq tab-stop-list (number-sequence 4 200 4))
(setq tab-width 4)
(setq indent-line-function 'insert-tab)
(whitespace-mode t)
(insert ";;;;")
(insert-tabs 1)
(insert "(defun test ()\n;;;;")
(insert-tabs 1)
(insert "(interactive)\n;;;;")
(insert-tabs 2)
(insert "(let* (my-last-column\n;;;;")
(insert-tabs 4)
(insert "my-o-beg-a my-o-end-a (my-col-a 1)\n;;;;")
(insert-tabs 4)
(insert "my-o-beg-b my-o-end-b (my-col-b 11)\n;;;;")
(insert-tabs 4)
(insert "my-o-beg-c my-o-end-c (my-col-c 16) )\n;;;;")
(insert-tabs 3)
(insert "(generate-test-buffer)\n;;;;")
(insert-tabs 3)
(insert "(goto-char (point-max))\n;;;;")
(insert-tabs 3)
(insert "(while (re-search-backward \"\\n\" (point-min) t)\n;;;;")
(insert-tabs 4)
(insert "(setq my-last-column (current-column))\n;;;;")
(insert-tabs 4)
(insert "(setq my-o-beg-a (progn (move-to-column my-col-a) (point)))\n;;;;")
(insert-tabs 4)
(insert "(setq my-o-end-a (+ 1 my-o-beg-a))\n;;;;")
(insert-tabs 4)
(insert "(setq my-o-beg-b (progn (move-to-column my-col-b) (point)))\n;;;;")
(insert-tabs 4)
(insert "(setq my-o-end-b (+ 1 my-o-beg-b))\n;;;;")
(insert-tabs 4)
(insert "(setq my-o-beg-c (progn (move-to-column my-col-c) (point)))\n;;;;")
(insert-tabs 4)
(insert "(setq my-o-end-c (+ 1 my-o-beg-c))\n;;;;")
(insert-tabs 4)
(insert "(when (and\n;;;;")
(insert-tabs 6)
(insert "(< my-col-a my-last-column)\n;;;;")
(insert-tabs 6)
(insert "(not (save-excursion (move-to-column my-col-a)\n;;;;")
(insert-tabs 7)
(insert "(< 0 (skip-chars-forward \"\t\"))))\n;;;;")
(insert-tabs 6)
(insert "(not (save-excursion (move-to-column my-col-a)\n;;;;")
(insert-tabs 7)
(insert "(> 0 (skip-chars-backward \"\t\")))))\n;;;;")
(insert-tabs 5)
(insert "(overlay-put (make-overlay my-o-beg-a my-o-end-a) 'face '(\n;;;;")
(insert-tabs 6)
(insert "(background-color . \"cyan\")\n;;;;")
(insert-tabs 6)
(insert "(foreground-color . \"black\") )))\n;;;;")
(insert-tabs 4)
(insert "(when (and\n;;;;")
(insert-tabs 6)
(insert "(< my-col-b my-last-column)\n;;;;")
(insert-tabs 7)
(insert "(not (save-excursion (move-to-column my-col-b)\n;;;;")
(insert-tabs 7)
(insert "(< 0 (skip-chars-forward \"\t\"))))\n;;;;")
(insert-tabs 6)
(insert "(not (save-excursion (move-to-column my-col-b)\n;;;;")
(insert-tabs 7)
(insert "(> 0 (skip-chars-backward \"\t\")))))\n;;;;")
(insert-tabs 5)
(insert "(overlay-put (make-overlay my-o-beg-b my-o-end-b) 'face '(\n;;;;")
(insert-tabs 6)
(insert "(background-color . \"yellow\")\n;;;;")
(insert-tabs 6)
(insert "(foreground-color . \"black\") )))\n;;;;")
(insert-tabs 4)
(insert "(when (and\n;;;;")
(insert-tabs 6)
(insert "(< my-col-b my-last-column)\n;;;;")
(insert-tabs 6)
(insert "(not (save-excursion (move-to-column my-col-c)\n;;;;")
(insert-tabs 7)
(insert "(< 0 (skip-chars-forward \"\t\"))))\n;;;;")
(insert-tabs 6)
(insert "(not (save-excursion (move-to-column my-col-c)\n;;;;")
(insert-tabs 7)
(insert "(> 0 (skip-chars-backward \"\t\")))))\n;;;;")
(insert-tabs 5)
(insert "(overlay-put (make-overlay my-o-beg-c my-o-end-c) 'face '(\n;;;;")
(insert-tabs 6)
(insert "(background-color . \"red\")\n;;;;")
(insert-tabs 6)
(insert "(foreground-color . \"black\") ))) )))\n" ))
(defun insert-tabs (n)
;; http://stackoverflow.com/a/11830118/2112489
"Inserts N number of tabs"
(interactive "nNumber of tabs: ")
(dotimes (i n)
(indent-for-tab-command)))
(source: lawlist.com)
May 3, 2014: Initial answer -- apparent working solution.
A tab has a character code of 9.
The width of a tab is equal to only one (1) point.
A tab can be equal to one or more columns wide, depending upon the tab-width.
When dealing with tabs, determining the type of character that follows a particular column is problematic because . . . [to be filled in when I understand more].
When dealing with tabs, moving forward one (1) point and looking back is also problematic because . . . [to be filled in when I understand more].
The working solution is to move one (1) column ahead and check the preceding character code -- if it is still a character code of 9, then do not place an overlay (at that preceding column). If the target column was already on a non-tab character, then moving forward one (1) column and looking back should logically yield the proper result.
(defun test ()
(interactive)
(let* (my-last-column
my-o-beg-a my-o-end-a (my-col-a 3)
my-o-beg-b my-o-end-b (my-col-b 28)
my-o-beg-c my-o-end-c (my-col-c 29) )
(generate-test-buffer)
(goto-char (point-max))
(while (re-search-backward "\n" (point-min) t)
(setq my-last-column (current-column))
(setq my-o-beg-a (progn (move-to-column my-col-a) (point)))
(setq my-o-end-a (+ 1 my-o-beg-a))
(setq my-o-beg-b (progn (move-to-column my-col-b) (point)))
(setq my-o-end-b (+ 1 my-o-beg-b))
(setq my-o-beg-c (progn (move-to-column my-col-c) (point)))
(setq my-o-end-c (+ 1 my-o-beg-c))
(when (and
(< my-col-a my-last-column)
(not (progn (move-to-column (+ 1 my-col-a)) (eq (preceding-char) 9))))
(overlay-put (make-overlay my-o-beg-a my-o-end-a) 'face '(
(background-color . "cyan")
(foreground-color . "black") )))
(when (and
(< my-col-b my-last-column)
(not (progn (move-to-column (+ 1 my-col-b)) (eq (preceding-char) 9))))
(overlay-put (make-overlay my-o-beg-b my-o-end-b) 'face '(
(background-color . "yellow")
(foreground-color . "black") )))
(when (and
(< my-col-b my-last-column)
(not (progn (move-to-column (+ 1 my-col-c)) (eq (preceding-char) 9))))
(overlay-put (make-overlay my-o-beg-c my-o-end-c) 'face '(
(background-color . "red")
(foreground-color . "black") ))) )))
Related
I'm trying to add source blocks to the visibility cycling tree. Essentially I want a source block to be treated as a child of its heading. Consider the following org-mode document:
* Heading 1
** Heading 2
#+BEGIN_SRC R
print("hello world")
#+END_SRC
** Heading 3
I would like to be able to press TAB on heading one to cycle through the folding of the various parts including the source block. Currently org-mode does seem to have the facilities for folding the source block, because I can fold that if I go to #+BEGIN_SRC R and hit tab, but it doesnt seem to be being treated in the global cycling. Any suggestions to add it?
Thanks!
This is a slight modification of the code contained in the link mentioned in my first comment above: https://stackoverflow.com/a/21594242/2112489
All I did was replace the begin / end html regexp for the SRC regexp. Go ahead and give it a whirl and see if it is what you're looking for. I left my prior footnote modification in there.
(require 'org)
(defalias 'org-cycle-hide-drawers 'lawlist-block-org-cycle-hide-drawers)
(defun lawlist-block-org-cycle-hide-drawers (state)
"Re-hide all drawers, footnotes or html blocks after a visibility state change."
(when
(and
(derived-mode-p 'org-mode)
(not (memq state '(overview folded contents))))
(save-excursion
(let* (
(globalp (memq state '(contents all)))
(beg (if globalp (point-min) (point)))
(end
(cond
(globalp
(point-max))
((eq state 'children)
(save-excursion (outline-next-heading) (point)))
(t (org-end-of-subtree t)) )))
(goto-char beg)
(while
(re-search-forward
".*\\[fn\\|^\\#\\+BEGIN_SRC.*$\\|^[ \t]*:PROPERTIES:[ \t]*$" end t)
(lawlist-org-flag t))))))
(defalias 'org-cycle-internal-local 'lawlist-block-org-cycle-internal-local)
(defun lawlist-block-org-cycle-internal-local ()
"Do the local cycling action."
(let ((goal-column 0) eoh eol eos has-children children-skipped struct)
(save-excursion
(if (org-at-item-p)
(progn
(beginning-of-line)
(setq struct (org-list-struct))
(setq eoh (point-at-eol))
(setq eos (org-list-get-item-end-before-blank (point) struct))
(setq has-children (org-list-has-child-p (point) struct)))
(org-back-to-heading)
(setq eoh (save-excursion (outline-end-of-heading) (point)))
(setq eos (save-excursion (1- (org-end-of-subtree t t))))
(setq has-children
(or
(save-excursion
(let ((level (funcall outline-level)))
(outline-next-heading)
(and
(org-at-heading-p t)
(> (funcall outline-level) level))))
(save-excursion
(org-list-search-forward (org-item-beginning-re) eos t)))))
(beginning-of-line 2)
(if (featurep 'xemacs)
(while
(and
(not (eobp))
(get-char-property (1- (point)) 'invisible))
(beginning-of-line 2))
(while
(and
(not (eobp))
(get-char-property (1- (point)) 'invisible))
(goto-char (next-single-char-property-change (point) 'invisible))
(and
(eolp)
(beginning-of-line 2))))
(setq eol (point)))
(cond
((= eos eoh)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-pre-cycle-hook 'empty))
(org-unlogged-message "EMPTY ENTRY")
(setq org-cycle-subtree-status nil)
(save-excursion
(goto-char eos)
(outline-next-heading)
(if (outline-invisible-p)
(org-flag-heading nil))))
((and
(or
(>= eol eos)
(not (string-match "\\S-" (buffer-substring eol eos))))
(or
has-children
(not (setq children-skipped
org-cycle-skip-children-state-if-no-children))))
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-pre-cycle-hook 'children))
(if (org-at-item-p)
;; then
(org-list-set-item-visibility (point-at-bol) struct 'children)
;; else
(org-show-entry)
(org-with-limited-levels (show-children))
(when (eq org-cycle-include-plain-lists 'integrate)
(save-excursion
(org-back-to-heading)
(while (org-list-search-forward (org-item-beginning-re) eos t)
(beginning-of-line 1)
(let* (
(struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(end (org-list-get-bottom-point struct)))
(mapc (lambda (e) (org-list-set-item-visibility e struct 'folded))
(org-list-get-all-items (point) struct prevs))
(goto-char (if (< end eos) end eos)))))))
(org-unlogged-message "CHILDREN")
(save-excursion
(goto-char eos)
(outline-next-heading)
(if (outline-invisible-p)
(org-flag-heading nil)))
(setq org-cycle-subtree-status 'children)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'children)))
((or
children-skipped
(and
(eq last-command this-command)
(eq org-cycle-subtree-status 'children)))
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-pre-cycle-hook 'subtree))
(outline-flag-region eoh eos nil)
(org-unlogged-message
(if children-skipped
"SUBTREE (NO CHILDREN)"
"SUBTREE"))
(setq org-cycle-subtree-status 'subtree)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'subtree)))
((eq org-cycle-subtree-status 'subtree)
(org-show-subtree)
(message "ALL")
(setq org-cycle-subtree-status 'all))
(t
(run-hook-with-args 'org-pre-cycle-hook 'folded)
(outline-flag-region eoh eos t)
(org-unlogged-message "FOLDED")
(setq org-cycle-subtree-status 'folded)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'folded))))))
(defun lawlist-org-flag (flag)
"When FLAG is non-nil, hide any of the following: html code block;
footnote; or, the properties drawer. Otherwise make it visible."
(save-excursion
(beginning-of-line 1)
(cond
((looking-at ".*\\[fn")
(let* (
(begin (match-end 0))
end-footnote)
(if (re-search-forward "\\]"
(save-excursion (outline-next-heading) (point)) t)
(progn
(setq end-footnote (point))
(outline-flag-region begin end-footnote flag))
(user-error "Error beginning at point %s." begin))))
((looking-at "^\\#\\+BEGIN_SRC.*$\\|^[ \t]*:PROPERTIES:[ \t]*$")
(let* ((begin (match-end 0)))
(if (re-search-forward "^\\#\\+END_SRC.*$\\|^[ \t]*:END:"
(save-excursion (outline-next-heading) (point)) t)
(outline-flag-region begin (point-at-eol) flag)
(user-error "Error beginning at point %s." begin)))))))
(defun lawlist-toggle-block-visibility ()
"For this function to work, the cursor must be on the same line as the regexp."
(interactive)
(if
(save-excursion
(beginning-of-line 1)
(looking-at
".*\\[fn\\|^\\#\\+BEGIN_SRC.*$\\|^[ \t]*:PROPERTIES:[ \t]*$"))
(lawlist-org-flag (not (get-char-property (match-end 0) 'invisible)))
(message "Sorry, you are not on a line containing the beginning regexp.")))
I'm writing a minor mode for emacs which, at the very least, will calculate a numeric value for each line in a buffer. I want to display this visually, preferable neatly before each line.
I know some minor modes draw to the fringe, and I know overlays are an option too (are these related?), but I can't find a good example of what I want anywhere.
Basically, I want to have something like the line numbers from linum-mode, but they will need to change every time the buffer is modified (actually, only whenever the line they're on changes). Something like a character counter for each line would be a good example. And I'd like it to not break linum-mode, but not depend on it, etc, if possible.
Here is a quick example of one way to put an overlay after linum-mode numbers and before the line of text. I will need to give some thought about right-alignment of the character count.
NOTE: This method contemplates that the linum-mode numbers are generated before the code that follows in this example. If the post-command-hook or the widow-scroll-functions hook is used to implement this proposed method, then those additions to the hooks would need to follow in time subsequently to the linum-mode functions attached to those same hooks.
The following example could be implemented with the post-command-hook and the window-scroll-functions hook. See the following link for an example of how to determine window-start and window-end before a redisplay occurs: https://stackoverflow.com/a/24216247/2112489
EDIT: Added right-alignment of character count -- contemplates a maximum of three digits (i.e., up to 999 characters per line). The text after the character count overlays are now left-aligned.
(save-excursion
(let* (
(window-start (window-start))
(window-end (window-end)))
(goto-char window-end)
(while (re-search-backward "\n" window-start t)
(let* (
(pbol (point-at-bol))
(peol (point-at-eol))
(raw-char-count (abs (- peol pbol)))
(starting-column
(propertize (char-to-string ?\uE001)
'display
`((space :align-to 1)
(space :width 0))))
(colored-char-count
(propertize (number-to-string raw-char-count)
'face '(:background "gray50" :foreground "black")
'cursor t))
(one-spacer
(propertize (char-to-string ?\uE001)
'display
`((space :width 1))))
(two-spacers
(propertize (char-to-string ?\uE001)
'display
`((space :width 2))))
(final-char-count
(cond
((and
(< raw-char-count 100)
(> raw-char-count 9))
(concat one-spacer colored-char-count))
((< raw-char-count 10)
(concat two-spacers colored-char-count))
(t colored-char-count))) )
(overlay-put (make-overlay pbol pbol)
'before-string
(concat starting-column final-char-count two-spacers) )))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; M-x char-count-mode
(defvar char-count-p nil
"When `char-count-p` is non-`nil`, the overlays are present.")
(make-variable-buffer-local 'char-count-p)
(defvar char-count-this-command nil
"This local variable is set within the `post-command-hook`; and,
is also used by the `window-scroll-functions` hook.")
(make-variable-buffer-local 'char-count-this-command)
(defvar char-count-overlay-list nil
"List used to store overlays until they are removed.")
(make-variable-buffer-local 'char-count-overlay-list)
(defun char-count-post-command-hook ()
"Doc-string."
(setq char-count-this-command this-command)
(character-count-function))
(defun character-count-window-scroll-functions (win _start)
"Doc-string."
(character-count-function))
(defun equal-including-properties--remove-overlays (beg end name val)
"Remove the overlays using `equal`, instead of `eq`."
(when (and beg end name val)
(overlay-recenter end)
(dolist (o (overlays-in beg end))
(when (equal-including-properties (overlay-get o name) val)
(delete-overlay o)))))
(defun character-count-function ()
"Doc-string for the character-count-function."
(when
(and
char-count-mode
char-count-this-command
(window-live-p (get-buffer-window (current-buffer)))
(not (minibufferp))
(pos-visible-in-window-p (point)
(get-buffer-window (current-buffer) (selected-frame)) t) )
(remove-char-count-overlays)
(save-excursion
(let* (
counter
(selected-window (selected-window))
(window-start (window-start selected-window))
(window-end (window-end selected-window t)) )
(goto-char window-end)
(catch 'done
(while t
(when counter
(re-search-backward "\n" window-start t))
(when (not counter)
(setq counter t))
(let* (
(pbol (point-at-bol))
(peol (point-at-eol))
(raw-char-count (abs (- peol pbol)))
(starting-column
(propertize (char-to-string ?\uE001)
'display
`((space :align-to 1) (space :width 0))))
(colored-char-count
(propertize (number-to-string raw-char-count)
'face '(:background "gray50" :foreground "black")))
(one-spacer
(propertize (char-to-string ?\uE001)
'display
`((space :width 1))))
(two-spacers
(propertize (char-to-string ?\uE001)
'display
`((space :width 2))))
(final-char-count
(cond
((and
(< raw-char-count 100)
(> raw-char-count 9))
(concat one-spacer colored-char-count))
((< raw-char-count 10)
(concat two-spacers colored-char-count))
(t colored-char-count)))
(ov-string (concat starting-column final-char-count two-spacers)) )
(push ov-string char-count-overlay-list)
(overlay-put (make-overlay pbol pbol) 'before-string ov-string)
(when (<= pbol window-start)
(throw 'done nil)) )))
(setq char-count-p t)))
(setq char-count-this-command nil) ))
(defun remove-char-count-overlays ()
(when char-count-p
(require 'cl)
(setq char-count-overlay-list
(remove-duplicates char-count-overlay-list
:test (lambda (x y) (or (null y) (equal-including-properties x y)))
:from-end t))
(dolist (description char-count-overlay-list)
(equal-including-properties--remove-overlays (point-min) (point-max) 'before-string description))
(setq char-count-p nil) ))
(defun turn-off-char-count-mode ()
(char-count-mode -1))
(define-minor-mode char-count-mode
"A minor-mode that places the character count at the beginning of the line."
:init-value nil
:lighter " Char-Count"
:keymap nil
:global nil
:group nil
(cond
(char-count-mode
(setq scroll-conservatively 101)
(add-hook 'post-command-hook 'char-count-post-command-hook t t)
(add-hook 'window-scroll-functions
'character-count-window-scroll-functions t t)
(add-hook 'change-major-mode-hook 'turn-off-char-count-mode nil t)
(message "Turned ON `char-count-mode`."))
(t
(remove-char-count-overlays)
(remove-hook 'post-command-hook 'char-count-post-command-hook t)
(remove-hook 'window-scroll-functions
'character-count-window-scroll-functions t)
(remove-hook 'change-major-mode-hook 'turn-off-char-count-mode t)
(kill-local-variable 'scroll-conservatively)
(message "Turned OFF `char-count-mode`.") )))
(provide 'char-count)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
I am looking for some assistance, please, to track down why the runtime of following overlay function increases with each successive run.
From what I can tell, the runtime should be the same if the text in the buffer remains the same -- i.e., just moving the cursor left / right should not increase the runtime (but it does).
I tried the following, but to no avail: (setq buffer-undo-list t); killing all local variables; (setq-default cache-long-scans nil).
This function is a scaled down version for purposes of creating a minimal working example. The full version starts of with a .1 second runtime and increases .1 seconds each successive run until the function becomes unusable.
(add-hook 'post-command-hook (lambda ()
(draw-vertical-line (window-start) (window-end))))
(defun draw-vertical-line (start end)
"Erase and redraw the vertical-line between START and END."
(measure-time
(setq my-cursor-point (point))
(setq my-current-col (current-column))
(save-excursion
(if (not (eq start (progn (goto-char start) (point-at-bol))))
(setq start (progn (goto-char start) (beginning-of-line) (point)))))
(save-excursion
(let* (my-last-column my-overlay beg-ov end-ov)
(goto-char end)
(mapc #'(lambda (o) (when (overlay-get o 'my-overlay-properties)
(delete-overlay o))) (overlays-in start end))
(goto-char end)
(while (re-search-backward "\n" start t)
(setq my-last-column (current-column))
(my-not-wrapped-line-function) )))))
(defun my-not-wrapped-line-function ()
(unless (eq (buffer-size) 0)
(setq beg-ov (save-excursion (move-to-column my-current-col) (point)))
(setq end-ov (+ 1 beg-ov))
(setq my-overlay (make-overlay beg-ov end-ov ))
(cond
;; text, excluding tabs
((and
(or
(< my-current-col my-last-column)
(and (eobp) (= my-current-col my-last-column)))
(not-tab-looking-back-p)
(not (eq my-cursor-point beg-ov)))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'text-exclude-tabs t)
(overlay-put my-overlay 'face '(:background "yellow" :foreground "black") ) )
;; tab with text to the right
((and
(tab-left-p)
(tab-looking-forward-p)
(tab-p)
(not (eq my-cursor-point beg-ov))
(< my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'tab-text-right t)
(overlay-put my-overlay 'face '(:foreground "purple" :weight bold) ) )
;; tab with text to the left
((and
(not-tab-left-p)
(tab-p)
(not (eq my-cursor-point beg-ov))
(< my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'tab-text-left t)
(overlay-put my-overlay 'face '(:foreground "green" :weight bold) ) )
;; tab sandwiched between a tab on each side
((and
(tab-p)
(tab-sandwiched-p)
(not (eq my-cursor-point beg-ov))
(< my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'tab-sandwiched t)
(overlay-put my-overlay 'face '(:foreground "orange" :weight bold) ) )
;; end of line, but not wrapped
((and
(= my-current-col my-last-column)
(eolp)
(not (eq my-cursor-point beg-ov)))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'eol t)
(overlay-put my-overlay 'face '(:foreground "brown" :weight bold) ) )
;; cursor -- not wrapped -- not end of line
((and
(not
(catch 'found
(dolist (ol (overlays-at beg-ov))
(and (overlay-get ol 'hl-p)
(throw 'found t)))))
(not (region-active-p))
(eq my-cursor-point beg-ov)
(not (eq (preceding-char) 9))
(< my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'my-cursor-not-wrapped-not-eol t)
(overlay-put my-overlay 'face '(:background "black" :weight bold) ) )
;; cursor -- end of line, but not a wrapped line
((and
(not (region-active-p))
(eq my-cursor-point beg-ov)
;; (not (eq (preceding-char) 9))
(= my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'my-cursor-eol-not-wrapped t)
(overlay-put my-overlay 'face '(:foreground "SteelBlue" :weight bold) ) ) )))
(defvar my-cursor-point nil
"Point used to prevent the formation of a cursor overlay.
It must be set within the function `draw-vertical-line`.")
(make-variable-buffer-local 'my-cursor-point)
(defsubst tab-left-p ()
(not (not (save-excursion
(if my-current-col
(move-to-column my-current-col)
(current-column))
(unless (bobp) (backward-char 1)) (eq (char-after (point)) 9)))))
(defsubst not-tab-left-p ()
(not (save-excursion
(if my-current-col
(move-to-column my-current-col)
(current-column))
(unless (bobp) (backward-char 1)) (eq (char-after (point)) 9))))
(defsubst tab-p ()
(save-excursion
(if my-current-col
(move-to-column my-current-col)
(current-column))
(eq (char-after (point)) 9)))
(defsubst not-tab-looking-back-p ()
(not (save-excursion
(if my-current-col
(move-to-column (+ 1 my-current-col))
(move-to-column (+ 1 (current-column))))
(eq (preceding-char) 9))))
(defsubst tab-looking-forward-p ()
(not (save-excursion
(if my-current-col
(move-to-column (+ 1 my-current-col))
(move-to-column (+ 1 current-column)))
(eq (char-after (point)) 9))))
(defsubst tab-sandwiched-p ()
(let ((my-current-col
(if my-current-col
my-current-col
(current-column))))
(not (eq
(save-excursion (move-to-column my-current-col)
(re-search-backward "\t" (point-at-bol) t) (point))
(save-excursion (move-to-column (+ my-current-col 1))
(re-search-backward "\t" (point-at-bol) t) (point))))))
(defmacro measure-time (&rest body)
"Measure the time it takes to evaluate BODY."
`(let ((time (current-time)))
,#body
(message "%.06f" (float-time (time-since time)))))
The current implementation of overlays is algorithnically very poor. Many basic operations (such as move-overlay, inserting/deleting text, or even sometimes just moving point) have time O(N), where N is the number of overlays. Sometimes you can tremendously speed things up by jusdicious use of overlay-recenter.
We know how to fix those algorithmic problems, and I'd be very happy to help someone work on the implementation.
Since my guess in the comments was correct, posting an actual answer for more visibility in case someone has a similar problem:
delete-overlay may not be doing what you expect. From the manual:
— Function: delete-overlay overlay
This function deletes overlay. The overlay continues to exist as a Lisp object, and its property list is unchanged, but it ceases to be attached to the buffer it belonged to, and ceases to have any effect on display.
A deleted overlay is not permanently disconnected. You can give it a position in a buffer again by calling move-overlay.
Maybe you have a giant pile of disconnected overlays eating up memory or causing a lot of processing.
Error message: let: Wrong type argument: overlayp, (#<overlay from 478 to 480 in *Calendar*>)
mouse-1 successfully marks a date in the calendar. The built-in functions only provide for deleting all of the overlays, instead of just one particular date. Could anyone please give me a hand to delete the overlay for just one marked date -- I was thinking this could be either mouse-2 or U. I thought of using skip-syntax-forwards/backwards because some of the dates have just one digit, and some have two digits -- the cursor may be between two digits or on either side of the date. I assume we need a beginning and ending point.
(define-key calendar-mode-map [mouse-1] (lambda () (interactive)
(calendar-mark-visible-date (calendar-cursor-to-date t))))
(define-key calendar-mode-map "U" (lambda () (interactive)
(cond
((save-excursion (> 0 (skip-syntax-backward "w")))
(skip-syntax-backward "w")
(let ((beg (point)))
(skip-syntax-forward "w")
(let ((end (point)))
(delete-overlay (overlays-in beg end)))))
((save-excursion (< 0 (skip-syntax-forward "w")))
(skip-syntax-forward "w")
(let ((end (point)))
(skip-syntax-backward "w")
(let ((beg (point)))
(delete-overlay (overlays-in beg end))))))))
EDIT (December 12, 2013): First working draft based upon the helpful answer from #Drew. Added mouse-set-point and interactive code to support said function. Consolidated keyboard shortcuts so that mouse-1 activates / deactivates the overlay at point -- now uses overlays-at.
EDIT (January 1, 2014): To distinguish between one or more overlays at point, see the following thread: How to distinguish between different overlays at point With the examples in that thread, different actions can occur depending upon whether a particular overlay exists at point.
(defvar lawlist-calendar-face (make-face 'lawlist-calendar-face))
(set-face-attribute 'lawlist-calendar-face nil
:background "LightCoral" :foreground "black")
(define-key calendar-mode-map [mouse-1] (lambda (event) (interactive "e")
(mouse-set-point event)
(if (not (overlays-at (point)))
(calendar-mark-visible-date (calendar-cursor-to-date t) lawlist-calendar-face)
(cond
;; cursor is one whitespace to the left of 1 to 9
((and
(save-excursion (< 0 (skip-chars-forward " \t")))
(not (save-excursion (< 0 (skip-syntax-forward "w")))))
(save-excursion
(let ((beg (point)))
(skip-chars-forward " \t")
(skip-syntax-forward "w")
(let ((end (point)))
(mapc 'delete-overlay (overlays-in beg end))))))
;; cursor is sandwiched between a digit on each side.
((and
(save-excursion (> 0 (skip-syntax-backward "w")))
(save-excursion (< 0 (skip-syntax-forward "w"))))
(save-excursion
(skip-syntax-backward "w")
(let ((beg (point)))
(skip-syntax-forward "w")
(let ((end (point)))
(mapc 'delete-overlay (overlays-in beg end))))))
;; cursor is to the far right of one or two digit dates
((and
(save-excursion (> 0 (skip-syntax-backward "w")))
(not (save-excursion (< 0 (skip-syntax-forward "w")))))
(save-excursion
(skip-syntax-backward "w")
(let ((beg (point)))
(skip-syntax-forward "w")
(let ((end (point)))
(mapc 'delete-overlay (overlays-in beg end))))))
;; cursor to the far left of one or two digits dates
((and
(save-excursion (< 0 (skip-syntax-forward "w")))
(not (save-excursion (> 0 (skip-syntax-backward "w")))))
(save-excursion
(skip-syntax-forward "w")
(let ((end (point)))
(skip-syntax-backward "w")
(let ((beg (point)))
(mapc 'delete-overlay (overlays-in beg end))))))))))
Wrt the error:
delete-overlay expects a single overlay as its argument. You are passing it a list (empty or nonempty) of overlays instead. You should iterate over the list, e.g., with while or dolist or mapc.
I have been unable to come up with a method to test for a syntax condition without moving the cursor -- e.g., skip-syntax-forward and skip-chars-forward both move the cursor in order to return t or a positive value. How can I return t or nil without moving the cursor?
(defun lawlist-kill-word ()
"Mark word / symbol + whitespace to the right of the cursor, and kill same."
(interactive)
(let* (
(symbol-regexp "\\s.\\|\\s_")
(word-regexp "\\sw"))
(modify-syntax-entry ?' "_") ;; apostrophe = symbol constituent
(cond
((< 0 (skip-syntax-forward "_."))
(let ((end (point)))
(set-mark end)
(while (looking-back symbol-regexp)
(backward-char))
(let ((beg (point)))
(delete-region beg end)
(setq beg (point))
(cond
((skip-chars-forward " \t")
(setq end (point))
(set-mark end)
(delete-region beg end))))))
((< 0 (skip-syntax-forward "w"))
(let ((end (point)))
(set-mark end)
(while (looking-back word-regexp)
(backward-char))
(let ((beg (point)))
(delete-region beg end)
(setq beg (point))
(cond
((skip-chars-forward " \t")
(setq end (point))
(set-mark end)
(delete-region beg end))))))
(t
(let ((beg (point)))
(set-mark beg)
(skip-chars-forward " \t")
(let ((end (point)))
(delete-region beg end)))
(deactivate-mark)))
(modify-syntax-entry ?' "w") )) ;; apostrophe = word constituent
EDIT: lawlist-kill-word is a work in progress -- any updates to this function will be posted to a thread related to that issue -- i.e.,: Emacs: delete whitespaces or a word
As #Tobias said: wrap cursor movements in save-excursion. Save any values you want (e.g., of (point)) in variables and return them as needed.
E.g., if you want the position four lines ahead, do something like this:
(let ((posn (save-excursion (forward-line 4) (point))))
posn)