Merge 707eee02d6 into 704db49988

focus.el

@@ -31,6 +31,7 @@
 ;;; Code:
 
 (require 'cl-lib)
+(require 'org-element)
 (require 'thingatpt)
 
 (defgroup focus ()
@@ -38,7 +39,9 @@
   :group 'font-lock
   :prefix "focus-")
 
-(defcustom focus-mode-to-thing '((prog-mode . defun) (text-mode . sentence))
+(defcustom focus-mode-to-thing '((prog-mode . defun)
+                                 (text-mode . paragraph)
+                                 (org-mode . org-element))
   "An associated list between mode and thing.
 
 A thing is defined in thingatpt.el; the thing determines the
@@ -59,8 +62,12 @@ Things that are defined include `symbol', `list', `sexp',
   :type 'number
   :group 'focus)
 
-(defface focus-unfocused
+(defcustom focus-fraction 0.5
-  '((t :inherit font-lock-comment-face))
+  "Determines the amount of dimness in out of focus sections (0.0 – 1.0)."
+  :type '(float)
+  :group 'focus)
+
+(defface focus-unfocused nil
   "The face that overlays the unfocused area."
   :group 'focus)
 
@@ -69,7 +76,7 @@ Things that are defined include `symbol', `list', `sexp',
   :group 'focus)
 
 (defvar focus-cursor-type cursor-type
-  "Used to restore the users `cursor-type'")
+  "Used to restore the users `cursor-type'.")
 
 (defvar-local focus-current-thing nil
   "Overrides the choice of thing dictated by `focus-mode-to-thing' if set.")
@@ -77,20 +84,30 @@ Things that are defined include `symbol', `list', `sexp',
 (defvar-local focus-buffer nil
   "Local reference to the buffer focus functions operate on.")
 
-(defvar-local focus-pre-overlay nil
+(defvar-local focus-unfocused-overlays nil
-  "The overlay that dims the text prior to the current-point.")
+  "The overlays that dims the unfocused area.")
 
-(defvar-local focus-mid-overlay nil
+(defvar-local focus-focused-overlay nil
-  "The overlay that surrounds the text of the current-point.")
+  "The overlay that is added to the focused area.")
 
-(defvar-local focus-post-overlay nil
+(defvar-local focus-pin-bounds nil
-  "The overlay that dims the text past the current-point.")
+  "Bounds set by `focus-pin'.")
+
+(defvar-local focus-last-bounds nil
+  "Used to identify changes in `focus-bounds'.")
+
+(defvar-local focus-last-window-bounds nil
+  "Used to identify changes in `window-start' and `window-end'.")
+
+(defvar-local focus-last-background nil
+  "Used to identify changes in the background.")
 
 (defvar-local focus-read-only-blink-timer nil
   "Timer started from `focus-read-only-cursor-blink'.
 The timer calls `focus-read-only-hide-cursor' after
 `focus-read-only-blink-seconds' seconds.")
 
+
 (defun focus-get-thing ()
   "Return the current thing, based on `focus-mode-to-thing'."
   (or focus-current-thing
@@ -99,57 +116,126 @@ The timer calls `focus-read-only-hide-cursor' after
                         (apply #'derived-mode-p modes))))
         (if mode (cdr (assoc mode focus-mode-to-thing)) 'sentence))))
 
+(defun focus-org-element-bounds ()
+  "Extract bounds from `org-element-at-point'"
+  (let* ((elem (org-element-at-point))
+         (beg (org-element-property :begin elem))
+         (end (org-element-property :end elem)))
+    (and beg end (cons beg end))))
+
+(put 'org-element 'bounds-of-thing-at-point
+     #'focus-org-element-bounds)
+
 (defun focus-bounds ()
   "Return the current bounds, based on `focus-get-thing'."
-  (bounds-of-thing-at-point (focus-get-thing)))
+  (or focus-pin-bounds
+      (bounds-of-thing-at-point (focus-get-thing))))
 
-(defun focus-move-focus ()
+(defun focus-window-bounds ()
+  (cons (window-start) (window-end nil t)))
+
+(defun focus-lerp (c1 c2 d)
+  "Interpolate C1 with C2, where D controls the amount."
+  (apply 'color-rgb-to-hex
+         (cl-mapcar (lambda (x y) (+ (* x (- 1 d)) (* y d))) c1 c2)))
+
+(defun focus-make-unfocused-face (fg)
+  "Add dimmed foreground color FG to the `focus-unfocused` face."
+  (let ((bg (face-background 'default)))
+    (if (and fg bg (color-defined-p fg) (color-defined-p bg)
+             (not (color-defined-p (face-attribute 'focus-unfocused :foreground))))
+        (plist-put (face-attr-construct 'focus-unfocused)
+                   :foreground (focus-lerp (color-name-to-rgb fg)
+                                           (color-name-to-rgb bg)
+                                           focus-fraction))
+      'focus-unfocused)))
+
+(defun focus-foreground-from-face (face)
+  "Return foreground color for FACE, or 'default if nil."
+  (if (facep face)
+      (face-attribute face :foreground)
+    (face-attribute 'default :foreground)))
+
+(defun focus-dim-area (low high)
+  "Restore original colors between LOW and HIGH.
+
+Returns the list of added overlays."
+  (while (< low high)
+    (let ((next (next-single-property-change low 'face nil high)))
+      (if (invisible-p low)
+          (setq low (next-single-char-property-change low 'invisible nil high))
+        (let* ((face (get-text-property low 'face))
+               (fg (focus-foreground-from-face face))
+               (unfocused-face (focus-make-unfocused-face fg))
+               (o (make-overlay low next)))
+          (overlay-put o 'face unfocused-face)
+          (push o focus-unfocused-overlays)
+          (setq low next))))))
+
+(defun focus-remove-unfocused-overlays ()
+  (while focus-unfocused-overlays
+    (delete-overlay (pop focus-unfocused-overlays))))
+
+(defun focus-move-focus (&rest _args)
   "Move the focused section according to `focus-bounds'.
 
-If `focus-mode' is enabled, this command fires after each
+If `focus-mode' is enabled, this function is added to
-command."
+`post-command-hook' and `window-scroll-functions'. The function
-  (with-current-buffer focus-buffer
+can be called with an arbitrary number of _ARGS to support being
-    (let* ((bounds (focus-bounds)))
+called from `window-scroll-functions'."
-      (when bounds
+  (while-no-input
-        (focus-move-overlays (car bounds) (cdr bounds))))))
+    (with-current-buffer focus-buffer
+      (let* ((bg (face-background 'default))
+             (window-bounds (focus-window-bounds))
+             (bounds (focus-bounds)))
+        (when (and bounds (or (not (equal bg focus-last-background))
+                              (not (equal window-bounds focus-last-window-bounds))
+                              (not (equal bounds focus-last-bounds))))
+          (let ((start (car window-bounds))
+                (end (cdr window-bounds))
+                (low (car bounds))
+                (high (cdr bounds)))
+            (focus-remove-unfocused-overlays)
+            (focus-dim-area start low)
+            (focus-dim-area high end)
+            (move-overlay focus-focused-overlay low high)))
+        (setq focus-last-background bg)
+        (setq focus-last-window-bounds window-bounds)
+        (setq focus-last-bounds bounds)))))
 
-(defun focus-move-overlays (low high)
+(defun focus-make-focused-overlay ()
-  "Move `focus-pre-overlay', `focus-mid-overlay' and `focus-post-overlay'."
+  (let ((o (make-overlay (point-min) (point-max))))
-  (move-overlay focus-pre-overlay (point-min) low)
+    (overlay-put o 'face 'focus-focused)
-  (move-overlay focus-mid-overlay low high)
+    o))
-  (move-overlay focus-post-overlay high (point-max)))
 
 (defun focus-init ()
-  "This function is run when command `focus-mode' is enabled.
+  "This function run when command `focus-mode' is enabled.
 
 It sets the `focus-pre-overlay', `focus-min-overlay', and
 `focus-post-overlay' to overlays; these are invisible until
-`focus-move-focus' is run. It adds `focus-move-focus' to
+`focus-move-focus' runs. It adds `focus-move-focus' to
 `post-command-hook'."
-  (unless (or focus-pre-overlay focus-post-overlay)
+  (focus-cleanup)
-    (setq focus-pre-overlay  (make-overlay (point-min) (point-min))
+  (setq focus-buffer (current-buffer))
-          focus-mid-overlay  (make-overlay (point-min) (point-max))
+  (setq focus-focused-overlay (focus-make-focused-overlay))
-          focus-post-overlay (make-overlay (point-max) (point-max))
+  (add-hook 'post-command-hook 'focus-move-focus t t)
-          focus-buffer (current-buffer))
+  (add-hook 'window-scroll-functions 'focus-move-focus t t)
-    (overlay-put focus-mid-overlay 'face 'focus-focused)
+  (add-hook 'change-major-mode-hook 'focus-cleanup t t)
-    (mapc (lambda (o) (overlay-put o 'face 'focus-unfocused))
+  (focus-move-focus))
-          (list focus-pre-overlay focus-post-overlay))
-    (add-hook 'post-command-hook 'focus-move-focus nil t)
-    (add-hook 'change-major-mode-hook 'focus-terminate nil t)))
 
-(defun focus-terminate ()
+(defun focus-cleanup ()
   "This function is run when command `focus-mode' is disabled.
 
-The overlays pointed to by `focus-pre-overlay',
+Overlays are deleted. `focus-move-focus' is removed from
-`focus-mid-overlay' and `focus-post-overlay' are deleted, and
+`post-command-hook'."
-`focus-move-focus' is removed from `post-command-hook'."
+  (let ((overlays (cons focus-focused-overlay focus-unfocused-overlays)))
-  (when (and focus-pre-overlay focus-post-overlay)
+    (mapc (lambda (o) (and (overlayp o) (delete-overlay o))) overlays)
-    (mapc 'delete-overlay
-          (list focus-pre-overlay focus-mid-overlay focus-post-overlay))
     (remove-hook 'post-command-hook 'focus-move-focus t)
-    (setq focus-pre-overlay nil
+    (remove-hook 'window-scroll-functions 'focus-move-focus t)
-          focus-mid-overlay nil
+    (setq focus-unfocused-overlays nil
-          focus-post-overlay nil)))
+          focus-focused-overlay nil
+          focus-last-bounds nil
+          focus-last-background nil)))
 
 (defun focus-goto-thing (bounds)
   "Move point to the middle of BOUNDS."
@@ -165,23 +251,22 @@ according to major-mode. If `focus-current-thing' is set, this
 default is overwritten. This function simply helps set the
 `focus-current-thing'."
   (interactive)
-  (let* ((candidates '(defun line list paragraph sentence sexp symbol word))
+  (let* ((candidates '(defun line list org-element paragraph sentence sexp symbol word))
          (thing (completing-read "Thing: " candidates)))
     (setq focus-current-thing (intern thing))))
 
 (defun focus-pin ()
   "Pin the focused section to its current location or the region, if active."
   (interactive)
-  (when (bound-and-true-p focus-mode)
+  (when (and (bound-and-true-p focus-mode)
-    (when (region-active-p)
+             (region-active-p))
-      (focus-move-overlays (region-beginning) (region-end)))
+    (setq focus-pin-bounds (cons (region-beginning) (region-end)))))
-    (remove-hook 'post-command-hook 'focus-move-focus t)))
 
 (defun focus-unpin ()
   "Unpin the focused section."
   (interactive)
   (when (bound-and-true-p focus-mode)
-    (add-hook 'post-command-hook 'focus-move-focus nil t)))
+    (setq focus-pin-bounds nil)))
 
 (defun focus-next-thing (&optional n)
   "Move the point to the middle of the Nth next thing."
@@ -256,7 +341,7 @@ It cleans up the `focus-read-only-blink-timer' and hooks."
   :keymap (let ((map (make-sparse-keymap)))
             (define-key map (kbd "C-c C-q") 'focus-read-only-mode)
             map)
-  (if focus-mode (focus-init) (focus-terminate)))
+  (if focus-mode (focus-init) (focus-cleanup)))
 
 ;;;###autoload
 (define-minor-mode focus-read-only-mode