path: root/siege-mode.el

;;; Package --- Surround region with smart delimiters interactively
;; Time-stamp: <2018-07-08 14:37:21 (tslil)>

;; Copyright (c) 2018 tslil clingman

;; Author: tslil clingman <tslil@posteo.de>
;; Version: 2.0
;; Package-Requires: ((emacs "24.4"))
;; Keywords: region wrap

;;; License:

;; siege-mode 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.
;;
;; siege-mode 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
;; siege-mode. If not, see http://www.gnu.org/licenses.

;;; Commentary:

;; Lay siege to the region from both sides!
;; 
;; When the region is active, all input is redirected to the minibuffer and
;; treated as a delimiter for the region. The input is used as the left
;; delimiter from which the right one is derived using `siege-transform-regexs'
;; applied to tokens generated by `siege-boundary-list' and `siege-block-*'. If
;; such derivations are not desired they may be disabled via "C-c a" in the
;; minibuffer or by default (`siege-default-derive').
;;
;; All changes are dynamically displayed in the buffer (see
;; `siege-preview-face') and may be committed by "Ret" in the minibuffer. It is
;; also possible to commit the input on "space" as set by
;; `siege-default-end-on-space' and toggled by "C-c s" in the minibuffer.
;;
;; By default siege-mode understands the usual delimeter pairs, as well as latex
;; LaTeX begin/end pairs and left/right pairs. Moreover, for ease of use it will
;; pair both _{ and ^{ with } by default.

;;; Code:
(require 'subr-x)
(require 'cl-lib)

(defcustom siege-transform-regexs '(("({" . "})")
                                    ("(" . ")")
                                    ("\\[" . "]")
                                    ("[_^]?{" . "}")
                                    ("<" . ">")
                                    ("`" . "'")
                                    ("``" . "''")
                                    ("\\\\left" . "\\\\right")
                                    ("\\\\langle" . "\\\\rangle")
                                    ("\\\\begin" . "\\\\end"))
  "List of pairs (REGEX . REPLACE) used to generate the right delimiter from \
the left one. The list is traversed in order and every substitution is applied."
  :group 'siege-mode
  :type '(repeat (cons string string)))

(defcustom siege-boundary-list '("\\\\left\\\\{"
                                 "\\\\left[({<\\[]"
                                 "[_^]?{"
                                 "\\Sw" )
  "List of regexes giving tokens at which the input delimiter should be split \
so that the resulting substrings may be transformed. Note that these are used \
as regex alternative in order and so it is recommended that the last element \
is a catch-all for generic tokenization. By default it is \\Sw to break on any \
non-word tokens. See `siege--tokenize-non-block' for details on tokenisation."
  :group 'siege-mode
  :type '(list string))

(defcustom siege-block-open ?{
  "Character signifying the start of an atomic block in delimiter input. \
Such blocks will appear verbatim in the derived delimiter."
  :group 'siege-mode
  :type 'char)

(defcustom siege-block-close ?}
  "Character signifying the end of an atomic block in delimiter input. \
Such blocks will appear verbatim in the derived delimiter."
  :group 'siege-mode
  :type 'char)

(defcustom siege-block-prefix "\\\\begin{\\|{"
  "Regex matching the start of an atomic block in the delimiter input, \
`siege-block-open', or an optional prefix as well as that character.

Such prefixes will have their relative orientation to the block preserved in \
the derived delimiter, but will still be subject to the transformations given \
in `siege-transform-regexs'."
  :group 'siege-mode
  :type 'string)

(defcustom siege-default-derive t
  "Whether siege-mode should default to deriving the matching delimiter \
from the input or reproduce it on both sides verbatim."
  :group 'siege-mode
  :type 'bool)

(defcustom siege-default-end-on-space nil
  "Whether siege-mode should, by default, interpret a space entered in the \
delimiter as marking the end of input (like return)."
  :group 'siege-mode
  :type 'bool)

(defface siege-preview-face '((t :inherit (warning)))
  "Face in which to render delimiter previews for Siege mode."
  :group 'siege-mode)

(defvar siege--overlay nil)
(defvar siege--selected-window nil)
(defvar siege--derive t)
(defvar siege--boundary "")
(defvar siege--end-on-space nil)
(defvar siege--hist '())

(defun siege--toggle-derive ()
  "Toggle the automatic derivation of a matching delimiter for \
the currently running instance. See also `siege-default-derive'."
  (interactive)
  (setq siege--derive (not siege--derive))
  (minibuffer-message "%s right delimeter."
                      (if siege--derive "DERIVING" "NOT deriving")))

(defun siege--toggle-space ()
  "Toggle whether pressing space in the minibuffer confirms marks the end of \
the input stream. See `siege-default-end-on-space'."
  (interactive)
  (setq siege--end-on-space (not siege--end-on-space))
  (minibuffer-message "Space entry %s input"
                      (if siege--end-on-space "part of" "ends")))

(defun siege--handle-space ()
  (interactive)
  "Handle spc input in the minibuffer according to session toggle. See also \
`siege-default-end-on-space'."
  (if siege--end-on-space (exit-minibuffer) (insert " ")))

(defvar siege-minibuffer-map
  (let ((map minibuffer-local-map))
    (define-key map (kbd "SPC") 'siege--handle-space)
    (define-key map (kbd "C-c a") 'siege--toggle-derive)
    (define-key map (kbd "C-c s") 'siege--toggle-space)
    map))

(defun siege--extract-next-block (string start open-chr close-chr
                                         prefix-match)
  "Given a STRING and a START index, find the next block \
delimeted by balanced pairs of OPEN-CHR CLOSE-CHR, optionally \
prefixed by anything matching PREFIX-MATCH.

PREFIX-MATCH is assumed to match against OPEN-CHR. Returns the list\
 (prefix-start block-start block-end)"
  (let ((pos start) pre beg end (count 1) curr )
    (save-match-data
      (when (setq pre (string-match prefix-match string start))
        (setq beg (1- (match-end 0))
              pos (match-end 0))
        (while (and (not end) (< pos (length string)))
          (setq curr (aref string pos))
          (when (char-equal curr open-chr) (incf count))
          (when (char-equal curr close-chr) (decf count))
          (incf pos)
          (when (= count 0) (setq end pos)))))
    (when end (list pre beg end))))

(defun siege--tokenize-blocks (string open-char close-char
                                      prefix-match)
  "Given a STRING, produce a list of pairs (type . substring). Type is one of \
'block or 'text. Blocks are substrings delimeted by balanced pairs of \
OPEN-CHAR and CLOSE-CHAR, text is everything else. The list is in reverse \
order of occurence, with the exception of block prefixes (see \
`siege--extract-next-block' and PREFIX-MATCH) whose relative positioning \
to the blocks the blocks they abut is preserved."
  (let (result (start 0) block)
    (while start
      (if (setq block (siege--extract-next-block
                       string start open-char close-char prefix-match))
          (progn
            (when (/= start (nth 0 block))
              (push (cons 'text
                          (substring-no-properties
                           string start (nth 0 block)))
                    result))
            (push (cons 'block (substring-no-properties
                                string (nth 1 block) (nth 2 block)))
                  result)
            (when (/= (nth 0 block) (nth 1 block))
              (push (cons 'text (substring-no-properties
                                 string (nth 0 block) (nth 1 block)))
                    result))
            (setq start (nth 2 block)))
        (if (/= start (length string))
            (push (cons 'text (substring string start)) result))
        (setq start nil)))
    result))

(defun siege--tokenize-non-block (string boundary-regex)
  "Given a STRING, split the string on anything matching \
BOUNDARY-REGEX and collate the results in reverse order. \
Splitting tokens appear in output."
  (let (result (start 0))
    (save-match-data
      (while start
        (if (string-match boundary-regex string start)
            (progn
              (when (/= start (match-beginning 0))
                (push (substring-no-properties
                       string start (match-beginning 0))
                      result))
              (push (substring-no-properties
                     string (match-beginning 0) (match-end 0))
                    result)
              (setq start (match-end 0)))
          (when (/= start (length string))
            (push (substring-no-properties string start) result))
          (setq start nil))))
    result))

(defun siege--derive-delimiter (string
                                block-open block-close
                                block-prefix-match
                                boundary-regex transforms)
  "Given a STRING, BLOCK-OPEN and BLOCK-CLOSE characters, and a \
BLOCK-PREFIX-MATCH regex matching against BLOCK-OPEN, this function first \
tokenizes the string into blocks and text (see `siege--tokenize-blocks'). The \
text is then further tokenized on boundaries given by BOUNDARY-REGEX (see \
`siege--tokenize-non-block') and finally all text tokens (not blocks) are \
transformed as follows and collated to generate the output.

TRANSFORMS is a list of pairs of strings (regex . subst) whics is applied \
sequentially to every text token."
  (apply
   #'concat
   (mapcar
    #'(lambda (pair)
        (if (eq 'block (car pair)) (cdr pair)
          (apply
           #'concat
           (mapcar
            #'(lambda (str)
                (let ((res str))
                  (dolist (tr transforms res)
                    (setq
                     res
                     (replace-regexp-in-string (car tr) (cdr tr) res)))))
            (siege--tokenize-non-block (cdr pair) boundary-regex)))))
    (siege--tokenize-blocks string block-open block-close
                            block-prefix-match))))

(defun siege--make-boundary-regex-from-list (list)
  "LIST is a list of strings which are concatenated, separated in the output \
by regex optional match strings (\\|)"
  (let ((res "")) (dolist (r list (substring res 0 (- (length res) 2)))
                    (setq res (concat res r "\\|")))))

(defun siege--matching-pair (input)
  "Generate a matching delimiter from INPUT according to all siege-* variables."
  (if siege--derive
      (let ((output (siege--derive-delimiter
                     input siege-block-open siege-block-close
                     siege-block-prefix siege--boundary
                     siege-transform-regexs)))
        (cons input output))
    (cons input input)))

(defun siege--preview-input ()
  "Render the siege delimiters in the buffer using overlays."
  (let ((inp (minibuffer-contents)))
    (if (string-blank-p inp)
        (siege--preview-end)
      (with-selected-window siege--selected-window
        (let ((beg (region-beginning))
              (end (region-end)))
          (if (overlayp siege--overlay)
              (move-overlay siege--overlay beg end)
            (setq siege--overlay (make-overlay beg end))
            (overlay-put siege--overlay 'sieging t))
          (let ((pair (siege--matching-pair inp)))
            (overlay-put siege--overlay 'before-string
                         (propertize (car pair)
                                     'face 'siege-preview-face))
            (overlay-put siege--overlay 'after-string
                         (propertize (cdr pair)
                                     'face 'siege-preview-face))))))))

(defun siege--preview-end ()
  "Gracefully remove the siege preview overlay."
  (with-selected-window siege--selected-window
    (remove-overlays (buffer-end -1) (buffer-end 1) 'sieging t)))

(defun siege--interactive (initial)
  "Use to enter the interactive delimiter building for region.

INITIAL is the string present in the minibuffer, which is not necessarily\
the default value."
  (barf-if-buffer-read-only)
  (setq siege--selected-window (selected-window)
        siege--derive siege-default-derive
        siege--end-on-space siege-default-end-on-space
        siege--boundary (siege--make-boundary-regex-from-list
                         siege-boundary-list))
  (let* ((start (region-beginning))
         (end (region-end))
         (result (minibuffer-with-setup-hook
                     (lambda ()
                       (add-hook 'post-command-hook #'siege--preview-input nil t)
                       (add-hook 'minibuffer-exit-hook #'siege--preview-end nil t)
                       (siege--preview-input))
                   (read-from-minibuffer
                    "Enter left delimiter: "
                    initial siege-minibuffer-map
                    nil 'siege--hist)))
         (pair (siege--matching-pair result)))
    (siege--preview-end)
    (goto-char start)
    (insert (car pair))
    (goto-char (+ end (string-width (car pair))))
    (insert (cdr pair))))

(defun siege--self-insert (arg)
  "This function replaces `self-insert-command'.

When the region is active, all input is redirected to the \
minibuffer and treated as a delimiter for the region. By default \
the input is used as the left delimiter from which the right one \
is derived according to all siege-* variables. See also \
`siege--derive-delimiter'. ARG is ignored.

If the region is not active then ARG is passed on to `self-insert-command'."
  (interactive "p")
  (if (and (region-active-p) (characterp last-command-event))
      (siege--interactive (char-to-string last-command-event))
    (self-insert-command arg)))

(defvar siege-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [remap self-insert-command] 'siege--self-insert)
    map))

(define-minor-mode siege-mode
  "Siege minor mode."
  nil
  " siege" siege-mode-map
  :global true)

(provide 'siege-mode)
;;; siege-mode.el ends here