writeroom-mode.el

;;; writeroom-mode.el --- Minor mode for distraction-free writing  -*- lexical-binding: t -*-

;; Copyright (c) 2012-2023 Joost Kremers

;; Author: Joost Kremers <joostkremers@fastmail.fm>
;; Maintainer: Joost Kremers <joostkremers@fastmail.fm>
;; Created: 11 July 2012
;; Package-Requires: ((emacs "25.1") (visual-fill-column "2.2"))
;; Version: 3.12
;; Keywords: text
;; URL: https://github.com/joostkremers/writeroom-mode

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. The name of the author may not be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; LOSS OF USE,
;; DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; Commentary:

;; writeroom-mode is a minor mode for Emacs that implements a
;; distraction-free writing mode similar to the famous Writeroom editor for
;; OS X. writeroom-mode is meant for GNU Emacs 25 and isn't tested on older
;; versions.
;;
;; See the README or info manual for usage instructions.
;;
;;; Code:

(require 'visual-fill-column)

(defvar writeroom--frame nil
  "The frame in which `writeroom-mode' is activated.
The global effects only apply to this frame.")

(defvar writeroom--buffers nil
  "List of buffers in which `writeroom-mode' is activated.")

(defvar writeroom--local-variables '(mode-line-format
                                     header-line-format
                                     line-spacing)
  "Local variables whose values are saved when `writeroom-mode' is activated.")

(defvar writeroom--saved-data nil
  "Buffer-local data to be stored when `writeroom-mode' is activated.
These settings are restored when `writeroom-mode' is
deactivated.")
(make-variable-buffer-local 'writeroom--saved-data)

(defvar writeroom--saved-visual-fill-column nil
  "Status of `visual-fill-column-mode' before activating `writeroom-mode'.")
(make-variable-buffer-local 'writeroom--saved-visual-fill-column)

(defvar writeroom--saved-window-config nil
  "Window configuration active before `writeroom-mode' is activated.")

(defgroup writeroom nil "Minor mode for distraction-free writing."
  :group 'text
  :prefix "writeroom-")

(defcustom writeroom-width 80
  "Width of the writeroom writing area.
This can be specified as an absolute width (the number of
characters in a line), or as a fraction of the total window
width, in the latter it should be a number between 0 and 1."
  :group 'writeroom
  :type '(choice (integer :tag "Absolute width:")
                 (float :tag "Relative width:" :value 0.5)))

(defun writeroom-full-line-number-width ()
  "Return the line number width including padding.
`line-number-display-width' does not include the two spaces used
for padding the line number display."
  (if display-line-numbers
      (+ 2 (line-number-display-width))
    0))

(defcustom writeroom-added-width-left (if (>= emacs-major-version 26)
                                          #'writeroom-full-line-number-width
                                        0)
  "Number of columns to add to the text area on the left.
This can be a number or a function which should return a number."
  :group 'writeroom
  :type '(choice (const :tag "Do not add extra width" 0)
                 (integer :tag "Fixed extra width")
                 (function :tag "Function to calculate extra width")))

(defcustom writeroom-mode-line nil
  "The mode line format to use with `writeroom-mode'.
By default, this option is set to nil, which disables the mode
line when `writeroom-mode' is activated.  By setting this option
to t, the standard mode line is retained.  Alternatively, it is
possible to specify a special mode line for `writeroom-mode'
buffers.  If this option is chosen, the default is to only show
the buffer's modification status and the buffer name, but the
format can be customized.  See the documentation for the variable
`mode-line-format' for further information.  Note that if you set
this option, it may be more visually pleasing to set
`writeroom-bottom-divider-width' to 0."
  :group 'writeroom
  :type '(choice (const :tag "Disable the mode line" nil)
                 (const :tag "Use standard mode line" t)
                 (sexp :tag "Customize mode line"
                       :value ("   " mode-line-modified "   " mode-line-buffer-identification))))

(defcustom writeroom-header-line nil
  "The header line used with `writeroom-mode'.
Possible values are nil (the default), which disables the header
line; t, which retains the standard header line; the symbol
`mode-line', which means to display the standard mode line in the
header line (this value makes most sense when
`writeroom-mode-line' is set to nil); or a sexp, which should be
a valid mode line construct."
  :group 'writeroom
  :type '(choice (const :tag "Do not show the header line" nil)
                 (const :tag "Use standard header line" t)
                 (const :tag "Show standard mode line in header line" mode-line)
                 (sexp :tag "Customize header line"
                       :value nil)))

(defcustom writeroom-mode-line-toggle-position 'header-line-format
  "Position to temporarily show the mode line.
When the mode line is disabled, the function
`writeroom-toggle-mode-line' makes the mode line visible.  This
option determines whether it is shown as the mode line or as the
header line."
  :group 'writeroom
  :type '(choice (const :tag "Use the mode line" mode-line-format)
                 (const :tag "Use the header line" header-line-format)))

(defcustom writeroom-bottom-divider-width 1
  "Width of the bottom window divider in pixels."
  :group 'writeroom
  :type '(integer :tag "Width"))

(make-obsolete-variable 'writeroom-disable-fringe
                        "The variable `writeroom-disable-fringe' is no longer used."
                        "`writeroom-mode' version 2.9")

(defcustom writeroom-maximize-window t
  "Whether to maximize the current window in its frame.
When set to t, `writeroom-mode' deletes all other windows in
the current frame."
  :group 'writeroom
  :type '(choice (const :tag "Maximize window" t)
                 (const :tag "Do not maximize window" nil)))

(defcustom writeroom-fullscreen-effect 'fullboth
  "Effect applied when enabling fullscreen.
The value can be `fullboth', in which case fullscreen is
activated, or `maximized', in which case the relevant frame is
maximized but window decorations are still available."
  :group 'writeroom
  :type '(choice (const :tag "Fullscreen" fullboth)
                 (const :tag "Maximized" maximized)))

(defcustom writeroom-border-width 30
  "Width in pixels of the border.
To use this option, select the option \"Add border\" in `Global
Effects'. This adds a border around the text area."
  :group 'writeroom
  :type '(integer :tag "Border width"))

(defcustom writeroom-fringes-outside-margins t
  "If set, place the fringes outside the margins."
  :group 'writeroom
  :type '(choice (const :tag "Place fringes outside margins" t)
                 (const :tag "Place fringes inside margins" nil)))

(defcustom writeroom-major-modes '(text-mode)
  "List of major modes in which writeroom-mode is activated.
The command `global-writeroom-mode' activates `writeroom-mode' in
every buffer that has one of the major modes listed in this
option.  Modes can be specified as symbols or as regular
expressions.  If a buffer has one of the specified major modes or
if its major mode name matches one of the regular expressions,
`writeroom-mode' is activated."
  :group 'writeroom
  :type '(repeat (choice (symbol :tag "Major mode")
                         (string :tag "Regular expression"))))

(defcustom writeroom-use-derived-modes t
  "Activate `writeroom-mode' in derived modes as well.'.
If this option is set, the command `global-writeroom-mode'
activates `writeroom-mode' in modes that are derived from those
listed in `writeroom-major-modes'.  Note that this option applies
only to symbols in `writeroom-major-modes'.  Regular expressions
are ignored."
  :group 'writeroom
  :type '(choice (const :tag "Use derived modes" t)
                 (const :tag "Do not use derived modes" nil)))

(defcustom writeroom-major-modes-exceptions nil
  "List of major modes in which `writeroom-mode' should not be activated.
This option lists exceptions to `writeroom-major-modes'.  Modes
can be specified as symbols or as regular expressions."
  :group 'writeroom
  :type '(repeat (choice (symbol :tag "Major mode exception")
                         (string :tag "Regular expression"))))

(defcustom writeroom-restore-window-config nil
  "If set, restore window configuration after disabling `writeroom-mode'.
Setting this option makes sense primarily if `writeroom-mode' is
used in one buffer only.  The window configuration that is stored
is the one that exists when `writeroom-mode' is first called, and
it is restored when `writeroom-mode' is deactivated in the last
buffer."
  :group 'writeroom
  :type '(choice (const :tag "Do not restore window configuration" nil)
                 (const :tag "Restore window configuration" t)))

(defcustom writeroom-extra-line-spacing nil
  "Additional line spacing for `writeroom-mode`."
  :group 'writeroom
  :type '(choice (const :tag "Do not add extra line spacing" :value nil)
                 (integer :tag "Absolute height" :value 5)
                 (float :tag "Relative height" :value 0.8)))

(defcustom writeroom-mode-enable-hook nil
  "Hook run when `writeroom-mode' is enabled.
This hook is run after all `writeroom-mode'-specific effects have
been enabled, but before `writeroom-mode-hook' itself is run.  It
can be used for enabling effects that cannot be enabled in
`writeroom-mode-hook'."
  :group 'writeroom
  :type '(repeat function))

(defcustom writeroom-mode-disable-hook nil
  "Hook run when `writeroom-mode' is disabled.
This hook is run after all `writeroom-mode'-specific effects have
been disabled and the buffer state before enabling
`writeroom-mode' has been restored.  It can be used for disabling
effects that were enabled in `writeroom-mode-enable-hook'."
  :group 'writeroom
  :type '(repeat function))

(define-obsolete-variable-alias 'writeroom-global-functions 'writeroom-global-effects "`writeroom-mode' version 2.0")

(defcustom writeroom-global-effects '(writeroom-set-fullscreen
                                      writeroom-set-alpha
                                      writeroom-set-menu-bar-lines
                                      writeroom-set-tool-bar-lines
                                      writeroom-set-vertical-scroll-bars
                                      writeroom-set-bottom-divider-width)
  "List of global effects for `writeroom-mode'.
These effects are enabled when `writeroom-mode' is activated in
the first buffer and disabled when it is deactivated in the last
buffer."
  :group 'writeroom
  :type '(set (const :tag "Fullscreen" writeroom-set-fullscreen)
              (const :tag "Disable transparency" writeroom-set-alpha)
              (const :tag "Disable menu bar" writeroom-set-menu-bar-lines)
              (const :tag "Disable tool bar" writeroom-set-tool-bar-lines)
              (const :tag "Disable scroll bar" writeroom-set-vertical-scroll-bars)
              (const :tag "Enable bottom window divider" writeroom-set-bottom-divider-width)
              (const :tag "Add border" writeroom-set-internal-border-width)
              (const :tag "Display frame on all workspaces" writeroom-set-sticky)
              (repeat :inline t :tag "Custom effects" function)))

(defmacro define-writeroom-global-effect (fp value)
  "Define a global effect for `writeroom-mode'.
The effect is activated by setting frame parameter FP to VALUE.
FP should be an unquoted symbol, the name of a frame parameter;
VALUE must be quoted (unless it is a string or a number, of
course).  It can also be an unquoted symbol, in which case it
should be the name of a global variable whose value is then
assigned to FP.

This macro defines a function `writeroom-set-<FP>' that takes one
argument and activates the effect if this argument is 1 and
deactivates it if it is -1.  When the effect is activated, the
original value of frame parameter FP is stored in a frame
parameter `writeroom-<FP>', so that it can be restored when the
effect is deactivated."
  (declare (indent defun))
  (let ((wfp (intern (format "writeroom-%s" fp))))
    `(fset (quote ,(intern (format "writeroom-set-%s" fp)))
           (lambda (&optional arg)
             (when (frame-live-p writeroom--frame)
               (cond
                ((= arg 1)         ; activate
                 (set-frame-parameter writeroom--frame (quote ,wfp) (frame-parameter writeroom--frame (quote ,fp)))
                 (set-frame-parameter writeroom--frame (quote ,fp) ,value))
                ((= arg -1)        ; deactivate
                 (set-frame-parameter writeroom--frame (quote ,fp) (frame-parameter writeroom--frame (quote ,wfp)))
                 (set-frame-parameter writeroom--frame (quote ,wfp) nil))))))))

(define-writeroom-global-effect fullscreen writeroom-fullscreen-effect)
(define-writeroom-global-effect alpha '(100 100))
(define-writeroom-global-effect vertical-scroll-bars nil)
(define-writeroom-global-effect menu-bar-lines 0)
(define-writeroom-global-effect tool-bar-lines 0)
(define-writeroom-global-effect internal-border-width writeroom-border-width)
(define-writeroom-global-effect sticky t)
(define-writeroom-global-effect bottom-divider-width writeroom-bottom-divider-width)

(defcustom writeroom-local-effects nil
  "List of buffer-local effects for `writeroom-mode'.
This should be a list of functions that activate or deactive some
local effect.  These functions are called with the argument \"1\"
when `writeroom-mode' is enabled and with the argument \"-1\"
when it is disabled.  This means that you can add minor-mode
symbols to this list and have them activated and deactivated
together with `writeroom-mode'."
  :group 'writeroom
  :type '(repeat function))

(defun turn-on-writeroom-mode ()
  "Turn on `writeroom-mode'.
This function activates `writeroom-mode' in a buffer if that
buffer's major mode matchs against one of `writeroom-major-modes'."
  (unless (writeroom--match-major-mode writeroom-major-modes-exceptions)
    (if (writeroom--match-major-mode writeroom-major-modes writeroom-use-derived-modes)
        (writeroom-mode 1))))

(defun writeroom--match-major-mode (modes &optional derived)
  "Match the current buffer's major mode against MODES.
MODES a list of mode names (symbols) or regular expressions.
Return t if the current major mode matches one of the elements of
MODES, nil otherwise.  Comparison is done with `eq` (for symbols
in MODES) or with `string-match-p' (for strings in MODES).  That
is, if the major mode is e.g., `emacs-lisp-mode', it will not
match the symbol `lisp-mode', but it will match the string
\"lisp-mode\".

If DERIVED is non-nil, also return t if the current buffer's
major mode is a derived mode of one of the major mode symbols in
MODES."
  (catch 'match
    (dolist (elem modes)
      (if (cond ((symbolp elem)
                 (or (eq elem major-mode)
                     (and derived (derived-mode-p elem))))
                ((string-match-p elem (symbol-name major-mode))))
          (throw 'match t)))))

(defvar writeroom-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "s-?") #'writeroom-toggle-mode-line)
    map)
  "Keymap for writeroom-mode.")

;;;###autoload
(define-minor-mode writeroom-mode
  "Minor mode for distraction-free writing."
  :init-value nil :lighter nil :global nil
  (if writeroom-mode
      (writeroom--enable)
    (writeroom--disable)))

;;;###autoload
(define-globalized-minor-mode global-writeroom-mode writeroom-mode turn-on-writeroom-mode
  :require 'writeroom-mode
  :group 'writeroom)

(defun writeroom--kill-buffer-function ()
  "Disable `writeroom-mode' before killing a buffer, if necessary.
This function is for use in `kill-buffer-hook'.  It checks whether
`writeroom-mode' is enabled in the buffer to be killed and
adjusts `writeroom--buffers' and the global effects accordingly."
  (when writeroom-mode
    (setq writeroom--buffers (delq (current-buffer) writeroom--buffers))
    (when (not writeroom--buffers)
      (writeroom--set-global-effects -1)
      (setq writeroom--frame nil))))

(add-hook 'kill-buffer-hook #'writeroom--kill-buffer-function)

(defun writeroom--set-global-effects (arg)
  "Activate or deactivate global effects.
The effects are activated if ARG is 1, deactivated if it is -1."
  (mapc (lambda (fn)
          (funcall fn arg))
        writeroom-global-effects))

(defun writeroom--calculate-width ()
  "Calculate the width of the writing area."
  (if (floatp writeroom-width)
      (truncate (* (window-total-width) writeroom-width))
    writeroom-width))

(defvar writeroom--mode-line-showing nil
  "Flag indicating whether the original mode line is displayed.")
(make-variable-buffer-local 'writeroom--mode-line-showing)

(defvar writeroom--orig-header-line nil
  "Original format of the header line.
When the header line is used to temporarily display the mode
line, its original format is saved here.")
(make-variable-buffer-local 'writeroom--orig-header-line)

(defun writeroom-toggle-mode-line ()
  "Toggle display of the original mode."
  (interactive)
  (unless (or (eq writeroom-mode-line t)
              (eq writeroom-header-line 'mode-line)) ; This means the original mode-line is displayed already.
    (cond
     ((not writeroom--mode-line-showing)
      (setq writeroom--orig-header-line header-line-format)
      (set writeroom-mode-line-toggle-position (or (cdr (assq 'mode-line-format writeroom--saved-data))
                                                   (default-value 'mode-line-format)))
      (setq writeroom--mode-line-showing t))
     (writeroom--mode-line-showing
      (if (eq writeroom-mode-line-toggle-position 'header-line-format)
          (setq header-line-format writeroom--orig-header-line)
        (setq mode-line-format writeroom-mode-line))
      (setq writeroom--mode-line-showing nil)))
    (force-mode-line-update)))

(defun writeroom-adjust-width (amount)
  "Adjust the width of the writing area on the fly by AMOUNT.
A numeric prefix argument can be used to specify the adjustment.
When called without a prefix, this will reset the width to the default value."
  (interactive "P")
  (if amount
      (setq visual-fill-column-width (max 1 (+ visual-fill-column-width amount)))
    (setq visual-fill-column-width (writeroom--calculate-width)))
  (visual-fill-column--adjust-window)
  (message "Writing area is now %d characters wide" visual-fill-column-width))

(defun writeroom-increase-width ()
  "Increase the width of the writing area by 2 characters."
  (interactive)
  (writeroom-adjust-width 2))

(defun writeroom-decrease-width ()
  "Decrease the width of the writing area by 2 characters."
  (interactive)
  (writeroom-adjust-width -2))

(defun writeroom--enable ()
  "Set up writeroom-mode for the current buffer.
Also run the functions in `writeroom-global-effects' if the
current buffer is the first buffer in which `writeroom-mode' is
activated."
  ;; Save buffer-local variables, if they have a buffer-local binding.
  (setq writeroom--saved-data (mapcar (lambda (sym)
                                        (if (local-variable-p sym)
                                            (cons sym (buffer-local-value sym (current-buffer)))
                                          sym))
                                      writeroom--local-variables))
  (setq writeroom--saved-visual-fill-column visual-fill-column-mode)

  ;; Activate global effects.
  (when (not writeroom--buffers)
    (setq writeroom--frame (selected-frame))
    (writeroom--set-global-effects 1)
    (if writeroom-restore-window-config
        (setq writeroom--saved-window-config (current-window-configuration))))

  (push (current-buffer) writeroom--buffers)

  (when writeroom-maximize-window
    (delete-other-windows))

  (when writeroom-extra-line-spacing
    (setq line-spacing writeroom-extra-line-spacing))

  (unless (eq writeroom-header-line t) ; If t, use standard header line.
    (if (eq writeroom-header-line 'mode-line)
        (setq header-line-format mode-line-format)
      (setq header-line-format writeroom-header-line)))

  (unless (eq writeroom-mode-line t) ; If t, use standard mode line.
    (setq mode-line-format writeroom-mode-line))

  (setq visual-fill-column-width (writeroom--calculate-width)
        visual-fill-column-center-text t
        visual-fill-column-fringes-outside-margins writeroom-fringes-outside-margins
        visual-fill-column-extra-text-width (cons (cond
                                                   ((numberp writeroom-added-width-left)
                                                    writeroom-added-width-left)
                                                   ((functionp writeroom-added-width-left)
                                                    (funcall writeroom-added-width-left))
                                                   (t 0))
                                                  0))
  (visual-fill-column-mode 1)

  ;; Run hooks on enabling `writeroom-mode'.
  (run-hook-with-args 'writeroom-local-effects 1)
  (run-hooks 'writeroom-mode-enable-hook)

  ;; If the current buffer is displayed in some window, the windows'
  ;; margins and fringes must be adjusted.
  (mapc (lambda (w)
          (with-selected-window w
            (visual-fill-column--adjust-window)))
        (get-buffer-window-list (current-buffer) nil)))

(defun writeroom--disable ()
  "Reset the current buffer to its normal appearance.
Also run the functions in `writeroom-global-effects' to undo
their effects if `writeroom-mode' is deactivated in the last
buffer in which it was active."
  ;; Disable visual-fill-column-mode.
  (visual-fill-column-mode -1)
  (kill-local-variable 'visual-fill-column-width)
  (kill-local-variable 'visual-fill-column-center-text)
  (kill-local-variable 'visual-fill-column-fringes-outside-margins)
  (kill-local-variable 'visual-fill-column-extra-text-width)

  ;; Restore global effects if necessary.
  (setq writeroom--buffers (delq (current-buffer) writeroom--buffers))
  (when (not writeroom--buffers)
    (writeroom--set-global-effects -1)
    (setq writeroom--frame nil)
    (if writeroom-restore-window-config
        (set-window-configuration writeroom--saved-window-config)))

  ;; Restore local variables.
  (mapc (lambda (val)
          (if (symbolp val)
              (kill-local-variable val)
            (set (car val) (cdr val))))
        writeroom--saved-data)

  ;; If the current buffer is displayed in some window, the windows'
  ;; margins and fringes must be adjusted.
  (mapc (lambda (w)
          (with-selected-window w
            (set-window-margins (selected-window) 0 0)
            (set-window-fringes (selected-window) nil)))
        (get-buffer-window-list (current-buffer) nil))

  ;; Reenable `visual-fill-colummn-mode' with original settings if it was
  ;; active before activating `writeroom-mode'.
  (if writeroom--saved-visual-fill-column
      (visual-fill-column-mode 1))

  ;; Run hook on disabling `writeroom-mode'.
  (run-hook-with-args 'writeroom-local-effects -1)
  (run-hooks 'writeroom-mode-disable-hook))

(provide 'writeroom-mode)

;;; writeroom-mode.el ends here