c-boxes.el

;;; Boxed comments for C mode.
;;; Copyright (C) 1991-1994, 2008-2014, 2016-2017, 2020-2021 Free
;;; Software Foundation, Inc.
;;; François Pinard <pinard@iro.umontreal.ca>, April 1991.
;;;
;;; This file is part of GNU M4.
;;;
;;; GNU M4 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.
;;;
;;; GNU M4 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 <https://www.gnu.org/licenses/>.

;;; I often refill paragraphs inside C comments, while stretching or
;;; shrinking the surrounding box as needed.  This is a real pain to
;;; do by hand.  Here is the code I made to ease my life on this,
;;; usable from within GNU Emacs.  It would not be fair giving all
;;; sources for a product without also giving the means for nicely
;;; modifying them.
;;;
;;; The function rebox-c-comment adjust comment boxes without
;;; refilling comment paragraphs, while reindent-c-comment adjust
;;; comment boxes after refilling.  Numeric prefixes are used to add,
;;; remove, or change the style of the box surrounding the comment.
;;; Since refilling paragraphs in C mode does make sense only for
;;; comments, this code redefines the M-q command in C mode.  I use
;;; this hack by putting, in my .emacs file:
;;;
;;;	(setq c-mode-hook
;;;	      '(lambda ()
;;;		 (define-key c-mode-map "\M-q" 'reindent-c-comment)))
;;;	(autoload 'rebox-c-comment "c-boxes" nil t)
;;;	(autoload 'reindent-c-comment "c-boxes" nil t)
;;;
;;; The cursor should be within a comment before any of these
;;; commands, or else it should be between two comments, in which case
;;; the command applies to the next comment.  When the command is
;;; given without prefix, the current comment box type is recognized
;;; and preserved.  Given 0 as a prefix, the comment box disappears
;;; and the comment stays between a single opening `/*' and a single
;;; closing `*/'.  Given 1 or 2 as a prefix, a single or doubled lined
;;; comment box is forced.  Given 3 as a prefix, a Taarna style box is
;;; forced, but you do not even want to hear about those.  When a
;;; negative prefix is given, the absolute value is used, but the
;;; default style is changed.  Any other value (like C-u alone) forces
;;; the default box style.
;;;
;;; I observed rounded corners first in some code from Warren Tucker
;;; <wht@n4hgf.mt-park.ga.us>.

(defvar c-box-default-style 'single "*Preferred style for box comments.")
(defvar c-mode-taarna-style nil "*Non-nil for Taarna team C-style.")

;;; Set or reset the Taarna team's own way for a C style.

(defun taarna-mode ()
  (interactive)
  (if c-mode-taarna-style
      (progn

        (setq c-mode-taarna-style nil)
        (setq c-indent-level 2)
        (setq c-continued-statement-offset 2)
        (setq c-brace-offset 0)
        (setq c-argdecl-indent 5)
        (setq c-label-offset -2)
        (setq c-tab-always-indent t)
        (setq c-box-default-style 'single)
        (message "C mode: GNU style"))

    (setq c-mode-taarna-style t)
    (setq c-indent-level 4)
    (setq c-continued-statement-offset 4)
    (setq c-brace-offset -4)
    (setq c-argdecl-indent 4)
    (setq c-label-offset -4)
    (setq c-tab-always-indent t)
    (setq c-box-default-style 'taarna)
    (message "C mode: Taarna style")))

;;; Return the minimum value of the left margin of all lines, or -1 if
;;; all lines are empty.

(defun buffer-left-margin ()
  (let ((margin -1))
    (goto-char (point-min))
    (while (not (eobp))
      (skip-chars-forward " \t")
      (if (not (looking-at "\n"))
          (setq margin
                (if (< margin 0)
                    (current-column)
                  (min margin (current-column)))))
      (forward-line 1))
    margin))

;;; Return the maximum value of the right margin of all lines.  Any
;;; sentence ending a line has a space guaranteed before the margin.

(defun buffer-right-margin ()
  (let ((margin 0) period)
    (goto-char (point-min))
    (while (not (eobp))
      (end-of-line)
      (if (bobp)
          (setq period 0)
        (backward-char 1)
        (setq period (if (looking-at "[.?!]") 1 0))
        (forward-char 1))
      (setq margin (max margin (+ (current-column) period)))
      (forward-char 1))
    margin))

;;; Add, delete or adjust a C comment box.  If FLAG is nil, the
;;; current boxing style is recognized and preserved.  When 0, the box
;;; is removed; when 1, a single lined box is forced; when 2, a double
;;; lined box is forced; when 3, a Taarna style box is forced.  If
;;; negative, the absolute value is used, but the default style is
;;; changed.  For any other value (like C-u), the default style is
;;; forced.  If REFILL is not nil, refill the comment paragraphs prior
;;; to reboxing.

(defun rebox-c-comment-engine (flag refill)
  (save-restriction
    (let ((undo-list buffer-undo-list)
          (marked-point (point-marker))
          (saved-point (point))
          box-style left-margin right-margin)

      ;; First, find the limits of the block of comments following or
      ;; enclosing the cursor, or return an error if the cursor is not
      ;; within such a block of comments, narrow the buffer, and
      ;; untabify it.

      ;; - insure the point is into the following comment, if any

      (skip-chars-forward " \t\n")
      (if (looking-at "/\\*")
          (forward-char 2))

      (let ((here (point)) start end temp)

        ;; - identify a minimal comment block

        (search-backward "/*")
        (setq temp (point))
        (beginning-of-line)
        (setq start (point))
        (skip-chars-forward " \t")
        (if (< (point) temp)
            (progn
              (goto-char saved-point)
              (error "text before comment's start")))
        (search-forward "*/")
        (setq temp (point))
        (end-of-line)
        (if (looking-at "\n")
            (forward-char 1))
        (setq end (point))
        (skip-chars-backward " \t\n")
        (if (> (point) temp)
            (progn
              (goto-char saved-point)
              (error "text after comment's end")))
        (if (< end here)
            (progn
              (goto-char saved-point)
              (error "outside any comment block")))

        ;; - try to extend the comment block backwards

        (goto-char start)
        (while (and (not (bobp))
                    (progn (previous-line 1)
                           (beginning-of-line)
                           (looking-at "[ \t]*/\\*.*\\*/[ \t]*$")))
          (setq start (point)))

        ;; - try to extend the comment block forward

        (goto-char end)
        (while (looking-at "[ \t]*/\\*.*\\*/[ \t]*$")
          (forward-line 1)
          (beginning-of-line)
          (setq end (point)))

        ;; - narrow to the whole block of comments

        (narrow-to-region start end))

      ;; Second, remove all the comment marks, and move all the text
      ;; rigidly to the left to insure the left margin stays at the
      ;; same place.  At the same time, recognize and save the box
      ;; style in BOX-STYLE.

      (let ((previous-margin (buffer-left-margin))
            actual-margin)

        ;; - remove all comment marks

        (goto-char (point-min))
        (replace-regexp "^\\([ \t]*\\)/\\*" "\\1  ")
        (goto-char (point-min))
        (replace-regexp "^\\([ \t]*\\)|" "\\1 ")
        (goto-char (point-min))
        (replace-regexp "\\(\\*/\\||\\)[ \t]*" "")
        (goto-char (point-min))
        (replace-regexp "\\*/[ \t]*/\\*" " ")

        ;; - remove the first and last dashed lines

        (setq box-style 'plain)
        (goto-char (point-min))
        (if (looking-at "^[ \t]*-*[.\+\\]?[ \t]*\n")
            (progn
              (setq box-style 'single)
              (replace-match ""))
          (if (looking-at "^[ \t]*=*[.\+\\]?[ \t]*\n")
              (progn
                (setq box-style 'double)
                (replace-match ""))))
        (goto-char (point-max))
        (previous-line 1)
        (beginning-of-line)
        (if (looking-at "^[ \t]*[`\+\\]?*[-=]+[ \t]*\n")
            (progn
              (if (eq box-style 'plain)
                  (setq box-style 'taarna))
              (replace-match "")))

        ;; - remove all spurious whitespace

        (goto-char (point-min))
        (replace-regexp "[ \t]+$" "")
        (goto-char (point-min))
        (if (looking-at "\n+")
            (replace-match ""))
        (goto-char (point-max))
        (skip-chars-backward "\n")
        (if (looking-at "\n\n+")
            (replace-match "\n"))
        (goto-char (point-min))
        (replace-regexp "\n\n\n+" "\n\n")

        ;; - move the text left is adequate

        (setq actual-margin (buffer-left-margin))
        (if (not (= previous-margin actual-margin))
            (indent-rigidly (point-min) (point-max)
                            (- previous-margin actual-margin))))

      ;; Third, select the new box style from the old box style and
      ;; the argument, choose the margins for this style and refill
      ;; each paragraph.

      ;; - modify box-style only if flag is defined

      (if flag
          (setq box-style
                (cond ((eq flag 0) 'plain)
                      ((eq flag 1) 'single)
                      ((eq flag 2) 'double)
                      ((eq flag 3) 'taarna)
                      ((eq flag '-) (setq c-box-default-style 'plain) 'plain)
                      ((eq flag -1) (setq c-box-default-style 'single) 'single)
                      ((eq flag -2) (setq c-box-default-style 'double) 'double)
                      ((eq flag -3) (setq c-box-default-style 'taarna) 'taarna)
                      (t c-box-default-style))))

      ;; - compute the left margin

      (setq left-margin (buffer-left-margin))

      ;; - temporarily set the fill prefix and column, then refill

      (untabify (point-min) (point-max))

      (if refill
          (let ((fill-prefix (make-string left-margin ? ))
                (fill-column (- fill-column
                                (if (memq box-style '(single double)) 4 6))))
            (fill-region (point-min) (point-max))))

      ;; - compute the right margin after refill

      (setq right-margin (buffer-right-margin))

      ;; Fourth, put the narrowed buffer back into a comment box,
      ;; according to the value of box-style.  Values may be:
      ;;    plain: insert between a single pair of comment delimiters
      ;;    single: complete box, overline and underline with dashes
      ;;    double: complete box, overline and underline with equal signs
      ;;    taarna: comment delimiters on each line, underline with dashes

      ;; - move the right margin to account for left inserts

      (setq right-margin (+ right-margin
                            (if (memq box-style '(single double))
                                2
                              3)))

      ;; - construct the box comment, from top to bottom

      (goto-char (point-min))
      (cond ((eq box-style 'plain)

             ;; - construct a plain style comment

             (skip-chars-forward " " (+ (point) left-margin))
             (insert (make-string (- left-margin (current-column)) ? )
                     "/* ")
             (end-of-line)
             (forward-char 1)
             (while (not (eobp))
               (skip-chars-forward " " (+ (point) left-margin))
               (insert (make-string (- left-margin (current-column)) ? )
                       "   ")
               (end-of-line)
               (forward-char 1))
             (backward-char 1)
             (insert "  */"))
            ((eq box-style 'single)

             ;; - construct a single line style comment

             (indent-to left-margin)
             (insert "/*")
             (insert (make-string (- right-margin (current-column)) ?-)
                     "-.\n")
             (while (not (eobp))
               (skip-chars-forward " " (+ (point) left-margin))
               (insert (make-string (- left-margin (current-column)) ? )
                       "| ")
               (end-of-line)
               (indent-to right-margin)
               (insert " |")
               (forward-char 1))
             (indent-to left-margin)
             (insert "`")
             (insert (make-string (- right-margin (current-column)) ?-)
                     "*/\n"))
            ((eq box-style 'double)

             ;; - construct a double line style comment

             (indent-to left-margin)
             (insert "/*")
             (insert (make-string (- right-margin (current-column)) ?=)
                     "=\\\n")
             (while (not (eobp))
               (skip-chars-forward " " (+ (point) left-margin))
               (insert (make-string (- left-margin (current-column)) ? )
                       "| ")
               (end-of-line)
               (indent-to right-margin)
               (insert " |")
               (forward-char 1))
             (indent-to left-margin)
             (insert "\\")
             (insert (make-string (- right-margin (current-column)) ?=)
                     "*/\n"))
            ((eq box-style 'taarna)

             ;; - construct a Taarna style comment

             (while (not (eobp))
               (skip-chars-forward " " (+ (point) left-margin))
               (insert (make-string (- left-margin (current-column)) ? )
                       "/* ")
               (end-of-line)
               (indent-to right-margin)
               (insert " */")
               (forward-char 1))
             (indent-to left-margin)
             (insert "/* ")
             (insert (make-string (- right-margin (current-column)) ?-)
                     " */\n"))
            (t (error "unknown box style")))

      ;; Fifth, retabify, restore the point position, then cleanup the
      ;; undo list of any boundary since we started.

      ;; - retabify before left margin only (adapted from tabify.el)

      (goto-char (point-min))
      (while (re-search-forward "^[ \t][ \t][ \t]*" nil t)
        (let ((column (current-column))
              (indent-tabs-mode t))
          (delete-region (match-beginning 0) (point))
          (indent-to column)))

      ;; - restore the point position

      (goto-char (marker-position marked-point))

      ;; - remove all intermediate boundaries from the undo list

      (if (not (eq buffer-undo-list undo-list))
          (let ((cursor buffer-undo-list))
            (while (not (eq (cdr cursor) undo-list))
              (if (car (cdr cursor))
                  (setq cursor (cdr cursor))
                (rplacd cursor (cdr (cdr cursor))))))))))

;;; Rebox a C comment without refilling it.

(defun rebox-c-comment (flag)
  (interactive "P")
  (rebox-c-comment-engine flag nil))

;;; Rebox a C comment after refilling.

(defun reindent-c-comment (flag)
  (interactive "P")
  (rebox-c-comment-engine flag t))