Skip to content

Instantly share code, notes, and snippets.

@rougier
Last active June 11, 2024 18:35
Show Gist options
  • Save rougier/c75dcc1365d15a327260051086d68309 to your computer and use it in GitHub Desktop.
Save rougier/c75dcc1365d15a327260051086d68309 to your computer and use it in GitHub Desktop.
Emacs: add borders around some part of a buffer
;;; make-box.el --- Box around part of a buffer -*- lexical-binding: t -*-
;; Copyright (C) 2024 Nicolas P. Rougier
;; Maintainer: Nicolas P. Rougier <Nicolas.Rougier@inria.fr>
;; Version: 0.1.0
;; Package-Requires: ((emacs "27.1"))
;; Keywords: convenience
;; This file is not part of GNU Emacs.
;; This file 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, or (at your option)
;; any later version.
;; This file 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.
;; For a full copy of the GNU General Public License
;; see <https://www.gnu.org/licenses/>.
(defvar default-box-alist `((foreground-color . ,(face-foreground 'default))
(background-color . ,(face-background 'default))
(header-face . (:height 0.75 :inherit bold))))
(defun make--box (beg end &optional header parameters)
"The make-box function allows to surround some part (from
BEG to END) of a buffer with borders with an optional
HEADER. Style is controlled with the PAREMETERS alist.
The text is left untouched and the method only exploits special
properties: display, wrap-prefix and line-prefix. The drawback is
that the buffer must have a left margin (at least one character)
and a right margin (at least 2 characters). Futhermore, the two
first and two last characters cannot be edited. The resulting box
is dynamic and will adapt automatically to the size of the window."
(let* ((parameters (append parameters default-box-alist))
(fg (alist-get 'foreground-color parameters))
(bg (alist-get 'background-color parameters))
(face (alist-get 'header-face parameters))
(header-face (if (stringp header)
`(:background ,bg :overline ,fg :extend t :inherit ,face)
`(:background ,bg :overline ,fg :extend t :height 0.25)))
(footer-face `(:background ,bg :underline ,fg :extend t :height 0.25))
(header (if (stringp header)
(substring-no-properties header)
""))
(body (concat (propertize " " 'display `((margin left-margin)
,(concat (propertize " " 'face `(:background ,fg :height 10))
(propertize " " 'face `(:background ,bg :height 10)))))
(propertize " " 'display `((margin right-margin)
,(concat (propertize " " 'face `(:background ,bg))
(propertize " " 'face `(:background ,fg :height 10))
(propertize " " 'face `(:background ,(face-background 'default))))))))
(top (concat (propertize " " 'display `((margin left-margin)
,(concat (propertize " " 'face `(:background ,fg :overline ,fg :height 10))
(propertize " " 'face `(:background ,bg :overline ,fg)))))
(propertize " " 'display `((margin right-margin)
,(concat (propertize " " 'face `(:background ,bg :overline ,fg))
(propertize " " 'face `(:background ,fg :overline ,fg :height 10))
(propertize " " 'face `(:background ,(face-background 'default))))))))
(bot (concat (propertize " " 'display `((margin left-margin)
,(concat (propertize " " 'face `(:background ,fg :underline ,fg :height 10))
(propertize " " 'face `(:background ,bg :underline ,fg)))))
(propertize " " 'display `((margin right-margin)
,(concat (propertize " " 'face `(:background ,bg :underline ,fg))
(propertize " " 'face `(:background ,fg :underline ,fg :height 10))
(propertize " " 'face `(:background ,(face-background 'default)))))))))
(add-text-properties (+ beg 1) (+ beg 2) `(display ,(buffer-substring beg (+ beg 2))
cursor-intangible t))
(add-text-properties (- end 2) (- end 1) `(display ,(concat (buffer-substring (- end 2) (- end 0)) "")
cursor-intangible t))
(add-text-properties (+ beg 0) (+ beg 1) `(face ,header-face
font-lock-face ,header-face
display ,(propertize (concat header"\n") 'face header-face
'font-lock-face header-face)
cursor-intangible t
wrap-prefix ,top
line-prefix ,top))
(add-text-properties (+ beg 1) (- end 1) `(wrap-prefix ,body
line-prefix ,body))
;; (add-face-text-property (+ beg 1) (- end 1) `(:background ,bg :extend t))
(add-text-properties (- end 1) (- end 0) `(face ,footer-face
font-lock-face ,footer-face
display ,(propertize "\n" 'face footer-face
'font-lock-face footer-face)
cursor-intangible t
wrap-prefix ,bot
line-prefix ,bot))))
(defun make-box (header)
"This interactive function adds a one pixel border to the
current region (if active) or paragraph, adding an optional
HEADER."
(interactive "sHeader: ")
(setq left-margin-width (max 1 left-margin-width)
right-margin-width (max 2 right-margin-width))
(set-window-margins nil left-margin-width right-margin-width)
(set-window-buffer nil (current-buffer))
(let* ((beg (if (region-active-p)
(region-beginning)
(save-excursion
(start-of-paragraph-text)
(point))))
(beg (save-excursion
(goto-char beg)
(line-beginning-position)))
(end (if (region-active-p)
(region-end)
(save-excursion
(end-of-paragraph-text)
(point))))
(end (save-excursion
(goto-char end)
(1+ (line-end-position))))
(header (when (and (stringp header)
(> (length header) 0))
header)))
(make--box beg end header)))
@rougier
Copy link
Author

rougier commented May 18, 2024

Screenshot 2024-05-18 at 16 31 11

@appetrosyan
Copy link

Awesome! Wen package?

@rougier
Copy link
Author

rougier commented May 19, 2024

Need to find time...

@lodenrogue
Copy link

Looks beautiful in your theme. In mine not so much.

@rougier
Copy link
Author

rougier commented May 21, 2024

Can you post as screenshot?

@lodenrogue
Copy link

@rougier
Copy link
Author

rougier commented May 22, 2024

Oh yes, in org-mode it does not work (yet).

@lodenrogue
Copy link

It looks the same in other modes for me. I've tested in python and lisp mode as well.

@rougier
Copy link
Author

rougier commented May 22, 2024

Can you test in text mode ? Else, you might need to add display to font-lock-extra-managed-props

@lodenrogue
Copy link

In text mode I get this error:

concat: Args out of range: #<buffer test>, 155, 157

Even after adding display to font-lock-extra-managed-props

@rougier
Copy link
Author

rougier commented May 22, 2024

Ouch, more work needed. I'll try to make a box packages and fix this kind of bug.
Also, I did not test througoughly for end of buffer such that best way to test is to have as single pararaphe precedeed and followed by some newlines. Then if you put cursors inside the paragraph, it should work (without region selected)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment