;;; visual-wrap.el --- Smart line-wrapping with wrap-prefix -*- lexical-binding: t -*-

;; Copyright (C) 2011-2021, 2024 Free Software Foundation, Inc.

;; Author: Stephen Berman <stephen.berman@gmx.net>
;;         Stefan Monnier <monnier@iro.umontreal.ca>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: convenience
;; Package: emacs

;; This file is part of GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This package provides the `visual-wrap-prefix-mode' minor mode
;; which sets the wrap-prefix property on the fly so that
;; single-long-line paragraphs get word-wrapped in a way similar to
;; what you'd get with M-q using adaptive-fill-mode, but without
;; actually changing the buffer's text.

;;; Code:

(defcustom visual-wrap-extra-indent 0
  "Number of extra spaces to indent in `visual-wrap-prefix-mode'.

`visual-wrap-prefix-mode' indents the visual lines to the level
of the actual line plus `visual-wrap-extra-indent'.  A negative
value will do a relative de-indent.

Examples:

actual indent = 2
extra indent = -1

  Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
 do eiusmod tempor incididunt ut labore et dolore magna
 aliqua. Ut enim ad minim veniam, quis nostrud exercitation
 ullamco laboris nisi ut aliquip ex ea commodo consequat.

actual indent = 2
extra indent = 2

  Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed
    do eiusmod tempor incididunt ut labore et dolore magna
    aliqua. Ut enim ad minim veniam, quis nostrud exercitation
    ullamco laboris nisi ut aliquip ex ea commodo consequat."
  :type 'integer
  :safe 'integerp
  :version "30.1"
  :group 'visual-line)

(defun visual-wrap--face-extend-p (face)
  ;; Before Emacs 27, faces always extended beyond EOL, so we check
  ;; for a non-default background instead.
  (cond
   ((listp face)
    (plist-get face (if (fboundp 'face-extend-p) :extend :background)))
   ((symbolp face)
    (if (fboundp 'face-extend-p)
        (face-extend-p face nil t)
      (face-background face nil t)))))

(defun visual-wrap--prefix-face (fcp _beg end)
  ;; If the fill-context-prefix already specifies a face, just use that.
  (cond ((get-text-property 0 'face fcp))
        ;; Else, if the last character is a newline and has a face
        ;; that extends beyond EOL, assume that this face spans the
        ;; whole line and apply it to the prefix to preserve the
        ;; "block" visual effect.
        ;;
        ;; NB: the face might not actually span the whole line: see
        ;; for example removed lines in diff-mode, where the first
        ;; character has the diff-indicator-removed face, while the
        ;; rest of the line has the diff-removed face.
        ((= (char-before end) ?\n)
         (let ((eol-face (get-text-property (1- end) 'face)))
           ;; `eol-face' can be a face, a "face value"
           ;; (plist of face properties) or a list of one of those.
           (if (or (not (consp eol-face)) (keywordp (car eol-face)))
               ;; A single face.
               (if (visual-wrap--face-extend-p eol-face) eol-face)
             ;; A list of faces.  Keep the ones that extend beyond EOL.
             (delq nil (mapcar (lambda (f)
                                 (if (visual-wrap--face-extend-p f) f))
                               eol-face)))))))

(defun visual-wrap--content-prefix (position)
  "Get the content prefix for the line starting at POSITION.
This is like `fill-content-prefix' but doesn't check subsequent lines
and uses display specs to handle variable-pitch faces."
  (save-excursion
    (goto-char position)
    (if (eolp) (forward-line 1))
    ;; Move to the second line unless there is just one.
    (move-to-left-margin)
    (let ((prefix (fill-match-adaptive-prefix)))
      ;; Check whether we should use our first-line content prefix.
      (if (or (and adaptive-fill-first-line-regexp
		   (string-match adaptive-fill-first-line-regexp prefix))
	      (and comment-start-skip
		   (string-match comment-start-skip prefix)))
	  prefix
        ;; We want the prefix to be whitespace of the same width as the
        ;; first-line prefix.
        (let ((spaces (make-string (string-width prefix) ?\s)))
          ;; If the font for our first-line prefix is variable-pitch,
          ;; use a display spec to line the subsequent lines up
          ;; correctly.
          (when-let ((font (font-at position))
                     ((memq (font-get font :spacing) '(nil 0))))
            (put-text-property 0 (length spaces) 'display
                               `(space :width (,(string-pixel-width
                                                 prefix (current-buffer))))
                               spaces))
          spaces)))))

(defun visual-wrap--adjust-display-width (fcp n)
  (when-let ((display (get-text-property 0 'display fcp))
             ;; If we have a display spec here, it should be what we
             ;; specified in `visual-wrap--content-prefix', but
             ;; double-check just to be safe.
             ((eq (car-safe display) 'space))
             (width (car (plist-get (cdr display) :width))))
    (put-text-property 0 (length fcp) 'display
                       `(space :width (,(+ width n))) fcp))
  fcp)

(defun visual-wrap--extra-indent (fcp)
  (let ((fcp-len (string-width fcp)))
    (cond
     ((= 0 visual-wrap-extra-indent)
      fcp)
     ((< 0 visual-wrap-extra-indent)
      (let* ((extra (make-string visual-wrap-extra-indent ?\s))
             (result (concat fcp extra)))
        (visual-wrap--adjust-display-width
         result (string-pixel-width extra (current-buffer)))))
     ((< 0 (+ visual-wrap-extra-indent fcp-len))
      (let* ((idx (+ visual-wrap-extra-indent fcp-len))
             (trim (substring fcp idx))
             (result (substring fcp 0 idx)))
        (remove-text-properties 0 (length trim) '(display) trim)
        (visual-wrap--adjust-display-width
         result (- (string-pixel-width trim (current-buffer))))))
     (t
      ""))))

(defun visual-wrap-fill-context-prefix (beg end)
  "Compute visual wrap prefix from text between BEG and END.
This is like `fill-context-prefix', but supporting variable-width faces
and with the prefix length adjusted by `visual-wrap-extra-indent'."
  (let* ((fcp (visual-wrap--content-prefix beg))
         (prefix (visual-wrap--extra-indent fcp))
         (face (visual-wrap--prefix-face fcp beg end)))
    (if face
        (propertize prefix 'face face)
      prefix)))

(defun visual-wrap-prefix-function (beg end)
  "Indent the region between BEG and END with visual filling."
  ;; Any change at the beginning of a line might change its wrap
  ;; prefix, which affects the whole line.  So we need to "round-up"
  ;; `end' to the nearest end of line.  We do the same with `beg'
  ;; although it's probably not needed.
  (goto-char end)
  (unless (bolp) (forward-line 1))
  (setq end (point))
  (goto-char beg)
  (forward-line 0)
  (setq beg (point))
  (while (< (point) end)
    (let ((lbp (point)))
      (put-text-property
       (point) (progn (search-forward "\n" end 'move) (point))
       'wrap-prefix
       (let ((pfx (visual-wrap-fill-context-prefix
		   lbp (point))))
	 ;; Remove any `wrap-prefix' property that might have been
	 ;; added earlier.  Otherwise, we end up with a string
	 ;; containing a `wrap-prefix' string containing a
	 ;; `wrap-prefix' string ...
	 (remove-text-properties
	  0 (length pfx) '(wrap-prefix) pfx)
         (let ((dp (get-text-property 0 'display pfx)))
           (when (and dp (> lbp (point-min))
                      (eq dp (get-text-property (1- lbp) 'display)))
             ;; There's a `display' property which covers not just the
             ;; prefix but also the previous newline.  So it's not
             ;; just making the prefix more pretty and could interfere
             ;; or even defeat our efforts (e.g. it comes from
             ;; `adaptive-fill-mode').
             (remove-text-properties
	      0 (length pfx) '(display) pfx)))
	 pfx))))
  `(jit-lock-bounds ,beg . ,end))

;;;###autoload
(define-minor-mode visual-wrap-prefix-mode
  "Display continuation lines with prefixes from surrounding context.
To enable this minor mode across all buffers, enable
`global-visual-wrap-prefix-mode'."
  :lighter ""
  :group 'visual-line
  (if visual-wrap-prefix-mode
      (progn
        ;; HACK ATTACK!  We want to run after font-lock (so our
        ;; wrap-prefix includes the faces applied by font-lock), but
        ;; jit-lock-register doesn't accept an `append' argument, so
        ;; we add ourselves beforehand, to make sure we're at the end
        ;; of the hook (bug#15155).
        (add-hook 'jit-lock-functions
                  #'visual-wrap-prefix-function 'append t)
        (jit-lock-register #'visual-wrap-prefix-function)
        ;; FIXME: What should we do about `global-text-scale-adjust' or
        ;; other things that can change the text size?
        (add-hook 'text-scale-mode-hook #'jit-lock-refontify nil t))
    (jit-lock-unregister #'visual-wrap-prefix-function)
    (remove-hook 'text-scale-mode-hook #'jit-lock-refontify)
    (with-silent-modifications
      (save-restriction
        (widen)
        (remove-text-properties (point-min) (point-max) '(wrap-prefix nil))))))

;;;###autoload
(define-globalized-minor-mode global-visual-wrap-prefix-mode
  visual-wrap-prefix-mode visual-wrap-prefix-mode
  :init-value nil
  :group 'visual-line)

(provide 'visual-wrap)
;;; visual-wrap.el ends here