diff --git a/lisp/ace-window.el b/lisp/ace-window.el new file mode 100644 index 00000000..b5dba2d4 --- /dev/null +++ b/lisp/ace-window.el @@ -0,0 +1,958 @@ +;;; ace-window.el --- Quickly switch windows. -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; Maintainer: Oleh Krehel +;; URL: https://github.com/abo-abo/ace-window +;; Package-Version: 20200606.1259 +;; Package-Commit: c7cb315c14e36fded5ac4096e158497ae974bec9 +;; Version: 0.10.0 +;; Package-Requires: ((avy "0.5.0")) +;; Keywords: window, location + +;; This file is 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 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. + +;; For a full copy of the GNU General Public License +;; see . + +;;; Commentary: +;; +;; The main function, `ace-window' is meant to replace `other-window' +;; by assigning each window a short, unique label. When there are only +;; two windows present, `other-window' is called (unless +;; aw-dispatch-always is set non-nil). If there are more, each +;; window will have its first label character highlighted. Once a +;; unique label is typed, ace-window will switch to that window. +;; +;; To setup this package, just add to your .emacs: +;; +;; (global-set-key (kbd "M-o") 'ace-window) +;; +;; replacing "M-o" with an appropriate shortcut. +;; +;; By default, ace-window uses numbers for window labels so the window +;; labeling is intuitively ordered. But if you prefer to type keys on +;; your home row for quicker access, use this setting: +;; +;; (setq aw-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l)) +;; +;; Whenever ace-window prompts for a window selection, it grays out +;; all the window characters, highlighting window labels in red. To +;; disable this behavior, set this: +;; +;; (setq aw-background nil) +;; +;; If you want to know the selection characters ahead of time, turn on +;; `ace-window-display-mode'. +;; +;; When prefixed with one `universal-argument', instead of switching +;; to the selected window, the selected window is swapped with the +;; current one. +;; +;; When prefixed with two `universal-argument', the selected window is +;; deleted instead. + +;;; Code: +(require 'avy) +(require 'ring) +(require 'subr-x) + +;;* Customization +(defgroup ace-window nil + "Quickly switch current window." + :group 'convenience + :prefix "aw-") + +(defcustom aw-keys '(?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9) + "Keys for selecting window." + :type '(repeat character)) + +(defcustom aw-scope 'global + "The scope used by `ace-window'." + :type '(choice + (const :tag "visible frames" visible) + (const :tag "global" global) + (const :tag "frame" frame))) + +(defcustom aw-translate-char-function #'identity + "Function to translate user input key into another key. +For example, to make SPC do the same as ?a, use +\(lambda (c) (if (= c 32) ?a c))." + :type '(choice + (const :tag "Off" #'identity) + (const :tag "Ignore Case" #'downcase) + (function :tag "Custom"))) + +(defcustom aw-minibuffer-flag nil + "When non-nil, also display `ace-window-mode' string in the minibuffer when ace-window is active." + :type 'boolean) + +(defcustom aw-ignored-buffers '("*Calc Trail*" " *LV*") + "List of buffers and major-modes to ignore when choosing a window from the window list. +Active only when `aw-ignore-on' is non-nil." + :type '(repeat string)) + +(defcustom aw-ignore-on t + "When t, `ace-window' will ignore buffers and major-modes in `aw-ignored-buffers'. +Use M-0 `ace-window' to toggle this value." + :type 'boolean) + +(defcustom aw-ignore-current nil + "When t, `ace-window' will ignore `selected-window'." + :type 'boolean) + +(defcustom aw-background t + "When t, `ace-window' will dim out all buffers temporarily when used." + :type 'boolean) + +(defcustom aw-leading-char-style 'char + "Style of the leading char overlay." + :type '(choice + (const :tag "single char" 'char) + (const :tag "full path" 'path))) + +(defcustom aw-dispatch-always nil + "When non-nil, `ace-window' will issue a `read-char' even for one window. +This will make `ace-window' act different from `other-window' for + one or two windows." + :type 'boolean) + +(defcustom aw-dispatch-when-more-than 2 + "If the number of windows is more than this, activate ace-window-ness." + :type 'integer) + +(defcustom aw-reverse-frame-list nil + "When non-nil `ace-window' will order frames for selection in +the reverse of `frame-list'" + :type 'boolean) + +(defcustom aw-frame-offset '(13 . 23) + "Increase in pixel offset for new ace-window frames relative to the selected frame. +Its value is an (x-offset . y-offset) pair in pixels." + :type '(cons integer integer)) + +(defcustom aw-frame-size nil + "Frame size to make new ace-window frames. +Its value is a (width . height) pair in pixels or nil for the default frame size. +(0 . 0) is special and means make the frame size the same as the last selected frame size." + :type '(cons integer integer)) + +(defcustom aw-char-position 'top-left + "Window positions of the character overlay. +Consider changing this if the overlay tends to overlap with other things." + :type '(choice + (const :tag "top left corner only" 'top-left) + (const :tag "both left corners" 'left))) + +;; Must be defined before `aw-make-frame-char' since its :set function references this. +(defvar aw-dispatch-alist + '((?x aw-delete-window "Delete Window") + (?m aw-swap-window "Swap Windows") + (?M aw-move-window "Move Window") + (?c aw-copy-window "Copy Window") + (?j aw-switch-buffer-in-window "Select Buffer") + (?n aw-flip-window) + (?u aw-switch-buffer-other-window "Switch Buffer Other Window") + (?e aw-execute-command-other-window "Execute Command Other Window") + (?F aw-split-window-fair "Split Fair Window") + (?v aw-split-window-vert "Split Vert Window") + (?b aw-split-window-horz "Split Horz Window") + (?o delete-other-windows "Delete Other Windows") + (?T aw-transpose-frame "Transpose Frame") + ;; ?i ?r ?t are used by hyperbole.el + (?? aw-show-dispatch-help)) + "List of actions for `aw-dispatch-default'. +Each action is a list of either: + (char function description) where function takes a single window argument +or + (char function) where function takes no argument and the description is omitted.") + +(defun aw-set-make-frame-char (option value) + ;; Signal an error if `aw-make-frame-char' is ever set to an invalid + ;; or conflicting value. + (when value + (cond ((not (characterp value)) + (user-error "`aw-make-frame-char' must be a character, not `%s'" value)) + ((memq value aw-keys) + (user-error "`aw-make-frame-char' is `%c'; this conflicts with the same character in `aw-keys'" value)) + ((assq value aw-dispatch-alist) + (user-error "`aw-make-frame-char' is `%c'; this conflicts with the same character in `aw-dispatch-alist'" value)))) + (set option value)) + +(defcustom aw-make-frame-char ?z + "Non-existing ace window label character that triggers creation of a new single-window frame for display." + :set 'aw-set-make-frame-char + :type 'character) + +(defface aw-leading-char-face + '((((class color)) (:foreground "red")) + (((background dark)) (:foreground "gray100")) + (((background light)) (:foreground "gray0")) + (t (:foreground "gray100" :underline nil))) + "Face for each window's leading char.") + +(defface aw-minibuffer-leading-char-face + '((t :inherit aw-leading-char-face)) + "Face for minibuffer leading char.") + +(defface aw-background-face + '((t (:foreground "gray40"))) + "Face for whole window background during selection.") + +(defface aw-mode-line-face + '((t (:inherit mode-line-buffer-id))) + "Face used for displaying the ace window key in the mode-line.") + +(defface aw-key-face + '((t :inherit font-lock-builtin-face)) + "Face used by `aw-show-dispatch-help'.") + +;;* Implementation +(defun aw-ignored-p (window) + "Return t if WINDOW should be ignored when choosing from the window list." + (or (and aw-ignore-on + ;; Ignore major-modes and buffer-names in `aw-ignored-buffers'. + (or (memq (buffer-local-value 'major-mode (window-buffer window)) + aw-ignored-buffers) + (member (buffer-name (window-buffer window)) aw-ignored-buffers))) + ;; ignore child frames + (and (fboundp 'frame-parent) (frame-parent (window-frame window))) + ;; Ignore selected window if `aw-ignore-current' is non-nil. + (and aw-ignore-current + (equal window (selected-window))) + ;; When `ignore-window-parameters' is nil, ignore windows whose + ;; `no-other-window’ or `no-delete-other-windows' parameter is non-nil. + (unless ignore-window-parameters + (cl-case this-command + (ace-select-window (window-parameter window 'no-other-window)) + (ace-delete-window (window-parameter window 'no-delete-other-windows)) + (ace-delete-other-windows (window-parameter + window 'no-delete-other-windows)))))) + +(defun aw-window-list () + "Return the list of interesting windows." + (sort + (cl-remove-if + (lambda (w) + (let ((f (window-frame w))) + (or (not (and (frame-live-p f) + (frame-visible-p f))) + (string= "initial_terminal" (terminal-name f)) + (aw-ignored-p w)))) + (cl-case aw-scope + (visible + (cl-mapcan #'window-list (visible-frame-list))) + (global + (cl-mapcan #'window-list (frame-list))) + (frame + (window-list)) + (t + (error "Invalid `aw-scope': %S" aw-scope)))) + 'aw-window<)) + +(defvar aw-overlays-back nil + "Hold overlays for when `aw-background' is t.") + +(defvar ace-window-mode nil + "Minor mode during the selection process.") + +;; register minor mode +(or (assq 'ace-window-mode minor-mode-alist) + (nconc minor-mode-alist + (list '(ace-window-mode ace-window-mode)))) + +(defvar aw-empty-buffers-list nil + "Store the read-only empty buffers which had to be modified. +Modify them back eventually.") + +(defvar aw--windows-hscroll nil + "List of (window . hscroll-columns) items, each listing a window whose + horizontal scroll will be restored upon ace-window action completion.") + +(defvar aw--windows-points nil + "List of (window . point) items. The point position had to be + moved in order to display the overlay.") + +(defun aw--done () + "Clean up mode line and overlays." + ;; mode line + (aw-set-mode-line nil) + ;; background + (mapc #'delete-overlay aw-overlays-back) + (setq aw-overlays-back nil) + (avy--remove-leading-chars) + (dolist (b aw-empty-buffers-list) + (with-current-buffer b + (when (string= (buffer-string) " ") + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max)))))) + (setq aw-empty-buffers-list nil) + (aw--restore-windows-hscroll) + (let (c) + (while (setq c (pop aw--windows-points)) + (with-selected-window (car c) + (goto-char (cdr c)))))) + +(defun aw--restore-windows-hscroll () + "Restore horizontal scroll of windows from `aw--windows-hscroll' list." + (let (wnd hscroll) + (mapc (lambda (wnd-and-hscroll) + (setq wnd (car wnd-and-hscroll) + hscroll (cdr wnd-and-hscroll)) + (when (window-live-p wnd) + (set-window-hscroll wnd hscroll))) + aw--windows-hscroll)) + (setq aw--windows-hscroll nil)) + +(defun aw--overlay-str (wnd pos path) + "Return the replacement text for an overlay in WND at POS, +accessible by typing PATH." + (let ((old-str (or + (ignore-errors + (with-selected-window wnd + (buffer-substring pos (1+ pos)))) + ""))) + (concat + (cl-case aw-leading-char-style + (char + (string (avy--key-to-char (car (last path))))) + (path + (mapconcat + (lambda (x) (string (avy--key-to-char x))) + (reverse path) + "")) + (t + (error "Bad `aw-leading-char-style': %S" + aw-leading-char-style))) + (cond ((string-equal old-str "\t") + (make-string (1- tab-width) ?\ )) + ((string-equal old-str "\n") + "\n") + (t + (make-string + (max 0 (1- (string-width old-str))) + ?\ )))))) + +(defun aw--point-visible-p () + "Return non-nil if point is visible in the selected window. +Return nil when horizontal scrolling has moved it off screen." + (and (>= (- (current-column) (window-hscroll)) 0) + (< (- (current-column) (window-hscroll)) + (window-width)))) + +(defun aw--lead-overlay (path leaf) + "Create an overlay using PATH at LEAF. +LEAF is (PT . WND)." + ;; Properly adds overlay in visible region of most windows except for any one + ;; receiving output while this function is executing, since that moves point, + ;; potentially shifting the added overlay outside the window's visible region. + (let ((wnd (cdr leaf)) + ;; Prevent temporary movement of point from scrolling any window. + (scroll-margin 0)) + (with-selected-window wnd + (when (= 0 (buffer-size)) + (push (current-buffer) aw-empty-buffers-list) + (let ((inhibit-read-only t)) + (insert " "))) + ;; If point is not visible due to horizontal scrolling of the + ;; window, this next expression temporarily scrolls the window + ;; right until point is visible, so that the leading-char can be + ;; seen when it is inserted. When ace-window's action finishes, + ;; the horizontal scroll is restored by (aw--done). + (while (and (not (aw--point-visible-p)) + (not (zerop (window-hscroll))) + (progn (push (cons (selected-window) (window-hscroll)) aw--windows-hscroll) t) + (not (zerop (scroll-right))))) + (let* ((ws (window-start)) + (prev nil) + (vertical-pos (if (eq aw-char-position 'left) -1 0)) + (horizontal-pos (if (zerop (window-hscroll)) 0 (1+ (window-hscroll)))) + (old-pt (point)) + (pt + (progn + ;; If leading-char is to be displayed at the top-left, move + ;; to the first visible line in the window, otherwise, move + ;; to the last visible line. + (move-to-window-line vertical-pos) + (move-to-column horizontal-pos) + ;; Find a nearby point that is not at the end-of-line but + ;; is visible so have space for the overlay. + (setq prev (1- (point))) + (while (and (>= prev ws) (/= prev (point)) (eolp)) + (setq prev (point)) + (unless (bobp) + (line-move -1 t) + (move-to-column horizontal-pos))) + (recenter vertical-pos) + (point))) + (ol (make-overlay pt (1+ pt) (window-buffer wnd)))) + (if (= (aw--face-rel-height) 1) + (goto-char old-pt) + (when (/= pt old-pt) + (goto-char (+ pt 1)) + (push (cons wnd old-pt) aw--windows-points))) + (overlay-put ol 'display (aw--overlay-str wnd pt path)) + (if (window-minibuffer-p wnd) + (overlay-put ol 'face 'aw-minibuffer-leading-char-face) + (overlay-put ol 'face 'aw-leading-char-face)) + (overlay-put ol 'window wnd) + (push ol avy--overlays-lead))))) + +(defun aw--make-backgrounds (wnd-list) + "Create a dim background overlay for each window on WND-LIST." + (when aw-background + (setq aw-overlays-back + (mapcar (lambda (w) + (let ((ol (make-overlay + (window-start w) + (window-end w) + (window-buffer w)))) + (overlay-put ol 'face 'aw-background-face) + ol)) + wnd-list)))) + +(defvar aw-dispatch-function 'aw-dispatch-default + "Function to call when a character not in `aw-keys' is pressed.") + +(defvar aw-action nil + "Function to call at the end of `aw-select'.") + +(defun aw-set-mode-line (str) + "Set mode line indicator to STR." + (setq ace-window-mode str) + (when (and aw-minibuffer-flag ace-window-mode) + (message "%s" (string-trim-left str))) + (force-mode-line-update)) + +(defun aw--dispatch-action (char) + "Return item from `aw-dispatch-alist' matching CHAR." + (assoc char aw-dispatch-alist)) + +(defun aw-make-frame () + "Make a new Emacs frame using the values of `aw-frame-size' and `aw-frame-offset'." + (make-frame + (delq nil + (list + ;; This first parameter is important because an + ;; aw-dispatch-alist command may not want to leave this + ;; frame with input focus. If it is given focus, the + ;; command may not be able to return focus to a different + ;; frame since this is done asynchronously by the window + ;; manager. + '(no-focus-on-map . t) + (when aw-frame-size + (cons 'width + (if (zerop (car aw-frame-size)) + (frame-width) + (car aw-frame-size)))) + (when aw-frame-size + (cons 'height + (if (zerop (cdr aw-frame-size)) + (frame-height) + (car aw-frame-size)))) + (cons 'left (+ (car aw-frame-offset) + (car (frame-position)))) + (cons 'top (+ (cdr aw-frame-offset) + (cdr (frame-position)))))))) + +(defun aw-use-frame (window) + "Create a new frame using the contents of WINDOW. + +The new frame is set to the same size as the previous frame, offset by +`aw-frame-offset' (x . y) pixels." + (aw-switch-to-window window) + (aw-make-frame)) + +(defun aw-clean-up-avy-current-path () + "Edit `avy-current-path' so only window label characters remain." + ;; Remove any possible ace-window command char that may + ;; precede the last specified window label, so + ;; functions can use `avy-current-path' as the chosen + ;; window label. + (when (and (> (length avy-current-path) 0) + (assq (aref avy-current-path 0) aw-dispatch-alist)) + (setq avy-current-path (substring avy-current-path 1)))) + +(defun aw-dispatch-default (char) + "Perform an action depending on CHAR." + (cond ((and (fboundp 'avy-mouse-event-window) + (avy-mouse-event-window char))) + ((= char (aref (kbd "C-g") 0)) + (throw 'done 'exit)) + ((and aw-make-frame-char (= char aw-make-frame-char)) + ;; Make a new frame and perform any action on its window. + (let ((start-win (selected-window)) + (end-win (frame-selected-window (aw-make-frame)))) + (if aw-action + ;; Action must be called from the start-win. The action + ;; determines which window to leave selected. + (progn (select-frame-set-input-focus (window-frame start-win)) + (funcall aw-action end-win)) + ;; Select end-win when no action + (aw-switch-to-window end-win))) + (throw 'done 'exit)) + (t + (let ((action (aw--dispatch-action char))) + (if action + (cl-destructuring-bind (_key fn &optional description) action + (if (and fn description) + (prog1 (setq aw-action fn) + (aw-set-mode-line (format " Ace - %s" description))) + (if (commandp fn) + (call-interactively fn) + (funcall fn)) + (throw 'done 'exit))) + (aw-clean-up-avy-current-path) + ;; Prevent any char from triggering an avy dispatch command. + (let ((avy-dispatch-alist)) + (avy-handler-default char))))))) + +(defcustom aw-display-mode-overlay t + "When nil, don't display overlays. Rely on the mode line instead." + :type 'boolean) + +(defvar ace-window-display-mode) + +(defun aw-select (mode-line &optional action) + "Return a selected other window. +Amend MODE-LINE to the mode line for the duration of the selection." + (setq aw-action action) + (let ((start-window (selected-window)) + (next-window-scope (cl-case aw-scope + ('visible 'visible) + ('global 'visible) + ('frame 'frame))) + (wnd-list (aw-window-list)) + window) + (setq window + (cond ((<= (length wnd-list) 1) + (when aw-dispatch-always + (setq aw-action + (unwind-protect + (catch 'done + (funcall aw-dispatch-function (read-char))) + (aw--done))) + (when (eq aw-action 'exit) + (setq aw-action nil))) + (or (car wnd-list) start-window)) + ((and (<= (+ (length wnd-list) (if (aw-ignored-p start-window) 1 0)) + aw-dispatch-when-more-than) + (not aw-dispatch-always) + (not aw-ignore-current)) + (let ((wnd (next-window nil nil next-window-scope))) + (while (and (or (not (memq wnd wnd-list)) + (aw-ignored-p wnd)) + (not (equal wnd start-window))) + (setq wnd (next-window wnd nil next-window-scope))) + wnd)) + (t + (let ((candidate-list + (mapcar (lambda (wnd) + (cons (aw-offset wnd) wnd)) + wnd-list))) + (aw--make-backgrounds wnd-list) + (aw-set-mode-line mode-line) + ;; turn off helm transient map + (remove-hook 'post-command-hook 'helm--maybe-update-keymap) + (unwind-protect + (let* ((avy-handler-function aw-dispatch-function) + (avy-translate-char-function aw-translate-char-function) + (transient-mark-mode nil) + (res (avy-read (avy-tree candidate-list aw-keys) + (if (and ace-window-display-mode + (null aw-display-mode-overlay)) + (lambda (_path _leaf)) + #'aw--lead-overlay) + #'avy--remove-leading-chars))) + (if (eq res 'exit) + (setq aw-action nil) + (or (cdr res) + start-window))) + (aw--done)))))) + (if aw-action + (funcall aw-action window) + window))) + +;;* Interactive +;;;###autoload +(defun ace-select-window () + "Ace select window." + (interactive) + (aw-select " Ace - Window" + #'aw-switch-to-window)) + +;;;###autoload +(defun ace-delete-window () + "Ace delete window." + (interactive) + (aw-select " Ace - Delete Window" + #'aw-delete-window)) + +;;;###autoload +(defun ace-swap-window () + "Ace swap window." + (interactive) + (aw-select " Ace - Swap Window" + #'aw-swap-window)) + +;;;###autoload +(defun ace-delete-other-windows () + "Ace delete other windows." + (interactive) + (aw-select " Ace - Delete Other Windows" + #'delete-other-windows)) + +;;;###autoload +(defun ace-display-buffer (buffer alist) + "Make `display-buffer' and `pop-to-buffer' select using `ace-window'. +See sample config for `display-buffer-base-action' and `display-buffer-alist': +https://github.com/abo-abo/ace-window/wiki/display-buffer." + (let* ((aw-ignore-current (cdr (assq 'inhibit-same-window alist))) + (rf (cdr (assq 'reusable-frames alist))) + (aw-scope (cl-case rf + ((nil) 'frame) + (visible 'visible) + ((0 t) 'global)))) + (unless (or (<= (length (aw-window-list)) 1) + (not aw-scope)) + (window--display-buffer + buffer (aw-select "Ace - Display Buffer") 'reuse)))) + +(declare-function transpose-frame "ext:transpose-frame") +(defun aw-transpose-frame (w) + "Select any window on frame and `tranpose-frame'." + (transpose-frame (window-frame w))) + +;;;###autoload +(defun ace-window (arg) + "Select a window. +Perform an action based on ARG described below. + +By default, behaves like extended `other-window'. +See `aw-scope' which extends it to work with frames. + +Prefixed with one \\[universal-argument], does a swap between the +selected window and the current window, so that the selected +buffer moves to current window (and current buffer moves to +selected window). + +Prefixed with two \\[universal-argument]'s, deletes the selected +window." + (interactive "p") + (setq avy-current-path "") + (cl-case arg + (0 + (let ((aw-ignore-on (not aw-ignore-on))) + (ace-select-window))) + (4 (ace-swap-window)) + (16 (ace-delete-window)) + (t (ace-select-window)))) + +;;* Utility +(unless (fboundp 'frame-position) + (defun frame-position (&optional frame) + (let ((pl (frame-parameter frame 'left)) + (pt (frame-parameter frame 'top))) + (when (consp pl) + (setq pl (eval pl))) + (when (consp pt) + (setq pt (eval pt))) + (cons pl pt)))) + +(defun aw-window< (wnd1 wnd2) + "Return true if WND1 is less than WND2. +This is determined by their respective window coordinates. +Windows are numbered top down, left to right." + (let* ((f1 (window-frame wnd1)) + (f2 (window-frame wnd2)) + (e1 (window-edges wnd1)) + (e2 (window-edges wnd2)) + (p1 (frame-position f1)) + (p2 (frame-position f2)) + (nl (or (null (car p1)) (null (car p2))))) + (cond ((and (not nl) (< (car p1) (car p2))) + (not aw-reverse-frame-list)) + ((and (not nl) (> (car p1) (car p2))) + aw-reverse-frame-list) + ((< (car e1) (car e2)) + t) + ((> (car e1) (car e2)) + nil) + ((< (cadr e1) (cadr e2)) + t)))) + +(defvar aw--window-ring (make-ring 10) + "Hold the window switching history.") + +(defun aw--push-window (window) + "Store WINDOW to `aw--window-ring'." + (when (or (zerop (ring-length aw--window-ring)) + (not (equal + (ring-ref aw--window-ring 0) + window))) + (ring-insert aw--window-ring (selected-window)))) + +(defun aw--pop-window () + "Return the removed top of `aw--window-ring'." + (let (res) + (condition-case nil + (while (or (not (window-live-p + (setq res (ring-remove aw--window-ring 0)))) + (equal res (selected-window)))) + (error + (if (= (length (aw-window-list)) 2) + (progn + (other-window 1) + (setq res (selected-window))) + (error "No previous windows stored")))) + res)) + +(defun aw-switch-to-window (window) + "Switch to the window WINDOW." + (let ((frame (window-frame window))) + (aw--push-window (selected-window)) + (when (and (frame-live-p frame) + (not (eq frame (selected-frame)))) + (select-frame-set-input-focus frame)) + (if (window-live-p window) + (select-window window) + (error "Got a dead window %S" window)))) + +(defun aw-flip-window () + "Switch to the window you were previously in." + (interactive) + (aw-switch-to-window (aw--pop-window))) + +(defun aw-show-dispatch-help () + "Display action shortucts in echo area." + (interactive) + (message "%s" (mapconcat + (lambda (action) + (cl-destructuring-bind (key fn &optional description) action + (format "%s: %s" + (propertize + (char-to-string key) + 'face 'aw-key-face) + (or description fn)))) + aw-dispatch-alist + "\n")) + ;; Prevent this from replacing any help display + ;; in the minibuffer. + (let (aw-minibuffer-flag) + (mapc #'delete-overlay aw-overlays-back) + (call-interactively 'ace-window))) + +(defun aw-delete-window (window &optional kill-buffer) + "Delete window WINDOW. +When KILL-BUFFER is non-nil, also kill the buffer." + (let ((frame (window-frame window))) + (when (and (frame-live-p frame) + (not (eq frame (selected-frame)))) + (select-frame-set-input-focus (window-frame window))) + (if (= 1 (length (window-list))) + (delete-frame frame) + (if (window-live-p window) + (let ((buffer (window-buffer window))) + (delete-window window) + (when kill-buffer + (kill-buffer buffer))) + (error "Got a dead window %S" window))))) + +(defun aw-switch-buffer-in-window (window) + "Select buffer in WINDOW." + (aw-switch-to-window window) + (aw--switch-buffer)) + +(declare-function ivy-switch-buffer "ext:ivy") + +(defun aw--switch-buffer () + (cond ((bound-and-true-p ivy-mode) + (ivy-switch-buffer)) + ((bound-and-true-p ido-mode) + (ido-switch-buffer)) + (t + (call-interactively 'switch-to-buffer)))) + +(defcustom aw-swap-invert nil + "When non-nil, the other of the two swapped windows gets the point." + :type 'boolean) + +(defun aw-swap-window (window) + "Swap buffers of current window and WINDOW." + (cl-labels ((swap-windows (window1 window2) + "Swap the buffers of WINDOW1 and WINDOW2." + (let ((buffer1 (window-buffer window1)) + (buffer2 (window-buffer window2))) + (set-window-buffer window1 buffer2) + (set-window-buffer window2 buffer1) + (select-window window2)))) + (let ((frame (window-frame window)) + (this-window (selected-window))) + (when (and (frame-live-p frame) + (not (eq frame (selected-frame)))) + (select-frame-set-input-focus (window-frame window))) + (when (and (window-live-p window) + (not (eq window this-window))) + (aw--push-window this-window) + (if aw-swap-invert + (swap-windows window this-window) + (swap-windows this-window window)))))) + +(defun aw-move-window (window) + "Move the current buffer to WINDOW. +Switch the current window to the previous buffer." + (let ((buffer (current-buffer))) + (switch-to-buffer (other-buffer)) + (aw-switch-to-window window) + (switch-to-buffer buffer))) + +(defun aw-copy-window (window) + "Copy the current buffer to WINDOW - including window-start and point." + (let ((buffer (current-buffer)) + (window-start (window-start)) + (point (point))) + (aw-switch-to-window window) + (switch-to-buffer buffer) + (set-window-start (frame-selected-window) window-start) + (goto-char point))) + +(defun aw-split-window-vert (window) + "Split WINDOW vertically." + (select-window window) + (split-window-vertically)) + +(defun aw-split-window-horz (window) + "Split WINDOW horizontally." + (select-window window) + (split-window-horizontally)) + +(defcustom aw-fair-aspect-ratio 2 + "The aspect ratio to aim for when splitting windows. +Sizes are based on the number of characters, not pixels. +Increase to prefer wider windows, or decrease for taller windows." + :type 'number) + +(defun aw-split-window-fair (window) + "Split WINDOW vertically or horizontally, based on its current dimensions. +Modify `aw-fair-aspect-ratio' to tweak behavior." + (let ((w (window-body-width window)) + (h (window-body-height window))) + (if (< (* h aw-fair-aspect-ratio) w) + (aw-split-window-horz window) + (aw-split-window-vert window)))) + +(defun aw-switch-buffer-other-window (window) + "Switch buffer in WINDOW." + (aw-switch-to-window window) + (unwind-protect + (aw--switch-buffer) + (aw-flip-window))) + +(defun aw-execute-command-other-window (window) + "Execute a command in WINDOW." + (aw-switch-to-window window) + (unwind-protect + (funcall + (key-binding + (read-key-sequence + "Enter key sequence: "))) + (aw-flip-window))) + +(defun aw--face-rel-height () + (let ((h (face-attribute 'aw-leading-char-face :height))) + (cond + ((eq h 'unspecified) + 1) + ((floatp h) + (max (floor h) 1)) + ((integerp h) + 1) + (t + (error "unexpected: %s" h))))) + +(defun aw-offset (window) + "Return point in WINDOW that's closest to top left corner. +The point is writable, i.e. it's not part of space after newline." + (let ((h (window-hscroll window)) + (beg (window-start window)) + (end (window-end window)) + (inhibit-field-text-motion t)) + (with-current-buffer (window-buffer window) + (save-excursion + (goto-char beg) + (forward-line (1- + (min + (count-lines + (point) + (point-max)) + (aw--face-rel-height)))) + (while (and (< (point) end) + (< (- (line-end-position) + (line-beginning-position)) + h)) + (forward-line)) + (+ (point) h))))) + +(defun aw--after-make-frame (f) + (aw-update) + (make-frame-visible f)) + +;;* Mode line +;;;###autoload +(define-minor-mode ace-window-display-mode + "Minor mode for showing the ace window key in the mode line." + :global t + (if ace-window-display-mode + (progn + (aw-update) + (set-default + 'mode-line-format + `((ace-window-display-mode + (:eval (window-parameter (selected-window) 'ace-window-path))) + ,@(assq-delete-all + 'ace-window-display-mode + (default-value 'mode-line-format)))) + (force-mode-line-update t) + (add-hook 'window-configuration-change-hook 'aw-update) + ;; Add at the end so does not precede select-frame call. + (add-hook 'after-make-frame-functions #'aw--after-make-frame t)) + (set-default + 'mode-line-format + (assq-delete-all + 'ace-window-display-mode + (default-value 'mode-line-format))) + (remove-hook 'window-configuration-change-hook 'aw-update) + (remove-hook 'after-make-frame-functions 'aw--after-make-frame))) + +(defun aw-update () + "Update ace-window-path window parameter for all windows. + +Ensure all windows are labeled so the user can select a specific +one, even from the set of windows typically ignored when making a +window list." + (let ((aw-ignore-on) + (aw-ignore-current) + (ignore-window-parameters t)) + (avy-traverse + (avy-tree (aw-window-list) aw-keys) + (lambda (path leaf) + (set-window-parameter + leaf 'ace-window-path + (propertize + (apply #'string (reverse path)) + 'face 'aw-mode-line-face)))))) + +(provide 'ace-window) + +;;; ace-window.el ends here diff --git a/lisp/adaptive-wrap.el b/lisp/adaptive-wrap.el new file mode 100644 index 00000000..91f81f9f --- /dev/null +++ b/lisp/adaptive-wrap.el @@ -0,0 +1,240 @@ +;;; adaptive-wrap.el --- Smart line-wrapping with wrap-prefix + +;; Copyright (C) 2011-2018 Free Software Foundation, Inc. + +;; Author: Stephen Berman +;; Stefan Monnier +;; Version: 0.7 + +;; 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 . + +;;; Commentary: + +;; This package provides the `adaptive-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: + +(require 'easymenu) + +(defcustom adaptive-wrap-extra-indent 0 + "Number of extra spaces to indent in `adaptive-wrap-prefix-mode'. + +`adaptive-wrap-prefix-mode' indents the visual lines to +the level of the actual line plus `adaptive-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 + :group 'visual-line) +(make-variable-buffer-local 'adaptive-wrap-extra-indent) + +(defun adaptive-wrap-fill-context-prefix (beg end) + "Like `fill-context-prefix', but with length adjusted by `adaptive-wrap-extra-indent'." + (let* ((fcp + ;; `fill-context-prefix' ignores prefixes that look like paragraph + ;; starts, in order to avoid inadvertently creating a new paragraph + ;; while filling, but here we're only dealing with single-line + ;; "paragraphs" and we don't actually modify the buffer, so this + ;; restriction doesn't make much sense (and is positively harmful in + ;; taskpaper-mode where paragraph-start matches everything). + (or (let ((paragraph-start "\\`\\'a")) + (fill-context-prefix beg end)) + ;; Note: fill-context-prefix may return nil; See: + ;; http://article.gmane.org/gmane.emacs.devel/156285 + "")) + (fcp-len (string-width fcp)) + (fill-char (if (< 0 fcp-len) + (string-to-char (substring fcp -1)) + ?\ ))) + (cond + ((= 0 adaptive-wrap-extra-indent) + fcp) + ((< 0 adaptive-wrap-extra-indent) + (concat fcp + (make-string adaptive-wrap-extra-indent fill-char))) + ((< 0 (+ adaptive-wrap-extra-indent fcp-len)) + (substring fcp + 0 + (+ adaptive-wrap-extra-indent fcp-len))) + (t + "")))) + +(defun adaptive-wrap-prefix-function (beg end) + "Indent the region between BEG and END with adaptive 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 (adaptive-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 (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 `visual-fill-mode'). + (remove-text-properties + 0 (length pfx) '(display) pfx))) + pfx)))) + `(jit-lock-bounds ,beg . ,end)) + +;;;###autoload +(define-minor-mode adaptive-wrap-prefix-mode + "Wrap the buffer text with adaptive filling." + :lighter "" + :group 'visual-line + (if adaptive-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 + #'adaptive-wrap-prefix-function 'append t) + (jit-lock-register #'adaptive-wrap-prefix-function)) + (jit-lock-unregister #'adaptive-wrap-prefix-function) + (with-silent-modifications + (save-restriction + (widen) + (remove-text-properties (point-min) (point-max) '(wrap-prefix nil)))))) + +(define-key-after (lookup-key menu-bar-options-menu [line-wrapping]) + [adaptive-wrap] + '(menu-item "Adaptive Wrap" adaptive-wrap-prefix-mode + :visible (menu-bar-menu-frame-live-and-visible-p) + :help "Show wrapped long lines with an adjustable prefix" + :button (:toggle . (bound-and-true-p adaptive-wrap-prefix-mode))) + word-wrap) + +;;;; ChangeLog: + +;; 2018-10-16 Stefan Monnier +;; +;; * adaptive-wrap.el (adaptive-wrap-fill-context-prefix): Ignore +;; paragraph-start +;; +;; (and rename 'en' to 'end'). Reported by Dmitry Safronov +;; +;; +;; 2018-10-15 Stefan Monnier +;; +;; * adaptive-wrap/adaptive-wrap.el: Fix interaction with visual-fill +;; +;; (adaptive-wrap-prefix-function): Remove problematic 'display' properties +;; as well. +;; +;; 2018-03-12 Stefan Monnier +;; +;; * adaptive-wrap/adaptive-wrap.el: Fix use without font-lock +;; +;; (adaptive-wrap-prefix-function): Work on whole lines. Fix a kind of +;; memory leak. +;; +;; 2017-05-04 Noam Postavsky +;; +;; Mark adaptive-wrap-extra-indent as safe if integerp (Bug#23816) +;; +;; * packages/adaptive-wrap/adaptive-wrap.el: Bump version, copyright. +;; (adaptive-wrap-extra-indent): Mark as safe if integerp. +;; +;; 2013-08-24 Stefan Monnier +;; +;; * adaptive-wrap.el (adaptive-wrap-mode): Move after font-lock +;; (bug#15155). +;; +;; 2013-07-31 Stephen Berman +;; +;; * adaptive-wrap.el: Fix bug#14974 by using define-key-after instead of +;; easy-menu-add-item. +;; (adaptive-wrap-unload-function): Remove. +;; +;; 2013-07-29 Stephen Berman +;; +;; * adaptive-wrap.el: Require easymenu (bug#14974). +;; +;; 2013-07-19 Rüdiger Sonderfeld +;; +;; * adaptive-wrap.el (menu-bar-options-menu): Add checkbox for Adaptive +;; Wrap to the Line Wrapping submenu. +;; (adaptive-wrap-unload-function): New function. +;; +;; 2013-02-01 Stephen Berman +;; +;; Fix error during redisplay: (wrong-type-argument stringp nil) +;; +;; 2012-12-05 Stefan Monnier +;; +;; * adaptive-wrap.el (adaptive-wrap-extra-indent): Fix buffer-localness. +;; Reported by Jonathan Kotta . +;; +;; 2012-10-30 Stefan Monnier +;; +;; Clean up copyright notices. +;; +;; 2012-05-21 Jonathan Kotta +;; +;; Add adaptive-wrap-extra-indent. +;; * adaptive-wrap/adaptive-wrap.el (adaptive-wrap-extra-indent): New var. +;; (adaptive-wrap-fill-context-prefix): New function. +;; (adaptive-wrap-prefix-function): Use it. +;; (adaptive-wrap-prefix-mode): Add to visual-line custom group. +;; +;; 2012-01-05 Chong Yidong +;; +;; Rename adaptive-wrap-prefix to adaptive-wrap. +;; +;; The old name overflowed the column in list-packages. +;; + + +(provide 'adaptive-wrap) +;;; adaptive-wrap.el ends here diff --git a/lisp/amx.el b/lisp/amx.el new file mode 100644 index 00000000..5fb087be --- /dev/null +++ b/lisp/amx.el @@ -0,0 +1,1353 @@ +;;; amx.el --- Alternative M-x with extra features. -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 Ryan C. Thompson +;; +;; Some Portions Copyright (C) 2009-2014 Cornelius Mika and other contributors +;; +;; Author: Ryan C. Thompson +;; Cornelius Mika +;; Maintainer: Ryan C. Thompson +;; URL: http://github.com/DarwinAwardWinner/amx/ +;; Package-Version: 20200701.2108 +;; Package-Commit: ccfc92c600df681df5e8b5fecec328c462ceb71e +;; Package-Requires: ((emacs "24.4") (s "0")) +;; Version: 3.3 +;; Keywords: convenience, usability + +;; This file is not 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; Quick start: Run `M-x amx-mode'. Enable ido-mode or ivy-mode if you +;; like. Use M-x as normal. +;; +;; For a more details see: +;; http://github.com/DarwinAwardWinner/amx/blob/master/README.mkdn + +;;; Code: + +(require 'cl-lib) +(require 's) + +(defvar amx-initialized nil + "If non-nil amx is initialized.") + +(defvar amx-cache) +(defvar amx-data) +(defvar amx-history) +(defvar amx-backend) + +;; Variables used from other packages +(defvar smex-save-file) +(defvar ivy-mode) +(defvar ivy-text) +(defvar ido-mode) +(defvar ido-ubiquitous-mode) +(defvar ido-completion-map) +(defvar ido-setup-hook) +(defvar ido-text) +(defvar helm-comp-read-map) + +(defvar amx-command-count 0 + "Number of commands known to amx.") + +(defvar amx-custom-action nil + "If non-nil, amx will call this in place of `execute-extended-command'. + +This should be set to a function that accepts a symbol +representing the name of a command.") + +(defvar amx-minibuffer-depth -1 + "Used to determine if amx \"owns\" the current active minibuffer.") + +(defvar amx-command-keybind-hash (make-hash-table :size 0) + "Hash table for translating between commands and key bindings. + +See `amx-make-keybind-hash'.") + +(defvar amx-origin-buffer nil + "The buffer amx was called from. + +This is used to determine which buffer's key bindings to use when +`amx-show-key-bindings' is non-nil.") + +(defvar amx-known-backends nil + "Plist of known amx completion backends.") + +(defvar amx-temp-prompt-string nil + "If non-nil, overrides `amx-prompt-string' once. + +Each time `amx-prompt-with-prefix-arg' is called, this is reset +to nil.") + +;; This timer will run every time Emacs is idle for 1 second, but most +;; of the time it will do nothing. +(defvar amx-short-idle-update-timer nil) +;; This timer forces a periodic updates to happen if you walk away for +;; a few hours, so that amx won't wait until you come back to do a +;; periodic update +(defvar amx-long-idle-update-timer nil) + +(defvar amx-last-update-time nil + "Time when `amx-update' was last run. + +If nil, a `amx-update' is needed ASAP.") + +(cl-defstruct amx-backend + name + required-feature + comp-fun + get-text-fun + exit-fun + auto-activate) + +(defgroup amx nil + "M-x interface with Ido-style fuzzy matching and ranking heuristics." + :group 'extensions + :group 'convenience + :link '(emacs-library-link :tag "Lisp File" "amx.el")) + +;;;###autoload +(define-minor-mode amx-mode + ;; TODO Update all references to ido + "Use ido completion for M-x" + :global t + :group 'amx + (if amx-mode + (progn + (amx-initialize) + (add-hook 'auto-save-hook 'amx-save-to-file) + (global-set-key [remap execute-extended-command] 'amx)) + (remove-hook 'auto-save-hook 'amx-save-to-file) + (when (eq (global-key-binding [remap execute-extended-command]) 'amx) + (global-unset-key [remap execute-extended-command])))) + +(define-minor-mode amx-debug-mode + "If non-nil, amx will print debug info. + +Debug info is printed to the *Messages* buffer." + :global t + :group 'amx) + +(defsubst amx--debug-message (format-string &rest args) + "Send a message prefixed with \"amx\" and the current time. + +This has no effect unless `amx-debug-mode' is enabled. + +Arguments have the same meaning as in `message'." + (when amx-debug-mode + (apply #'message (concat "amx (%s): " format-string) + (format-time-string "%FT%T.%6N%z") args))) + +(defun amx-set-auto-update-interval (symbol value) + "Custom setter for `amx-auto-update-interval'. + +Arguments have the same meaning as in `set-default'. + +In addition to setting the variable, this will also set up an +idle timer to ensure that updates happen when idle." + (cl-assert (eq symbol 'amx-auto-update-interval)) + (set-default symbol value) + ;; Cancel any previous timer + (when amx-long-idle-update-timer + (cancel-timer amx-long-idle-update-timer) + (setq amx-long-idle-update-timer nil)) + (when value + ;; Enable idle updating + (setq amx-long-idle-update-timer + (run-with-idle-timer (1+ (* 60 value)) t + 'amx-idle-update)))) + +(defcustom amx-auto-update-interval nil + "Time in minutes between periodic updates of the command list. + +Amx already updates the command list after functions like `load' +and `eval-expression' that could possibly define new commands. +Generally this should be enough to catch all newly-loaded +commands, but just in case any slip through, you can enable +periodic updates to catch them. If this variable is nil, no +periodic updates will be performed." + :type '(choice (const :tag "Disabled" nil) + (number :tag "Minutes")) + :set #'amx-set-auto-update-interval) + +(defun amx-set-save-file (symbol value) + "Custom setter for `amx-save-file'. + +Arguments are the same as in `set-default'. + +This function will refuse to set the backend unless it can load +the associated feature, if any." + (cl-assert (eq symbol 'amx-save-file)) + (let ((old-value (when (boundp symbol) (symbol-value symbol)))) + (set-default symbol value) + (if (file-exists-p value) + ;; If the new save file already exists, reinitialize from it + ;; (but only if amx is already initialized). + (when (bound-and-true-p amx-initialized) + (amx-initialize t)) + ;; If the new save file doesn't exist but the old one does, copy + ;; the old file to the new location. + (when (and old-value (file-exists-p old-value)) + (copy-file old-value value))))) + +(defcustom amx-save-file (locate-user-emacs-file "amx-items" ".amx-items") + "File in which the amx state is saved between Emacs sessions. + +Variables stored are: `amx-data', `amx-history'." + :type '(choice (string :tag "File name") + (const :tag "Don't save" nil)) + :set #'amx-set-save-file) + +(defcustom amx-history-length 7 + "Number of recently executed commands to record." + ;; TODO allow this to be set any time + :type 'integer) + +(defcustom amx-show-key-bindings t + "If non-nil, show key binding while completing commands. + +Enabling this feature can cause a noticeable delay when running +`amx', so you may wish to disable it (by setting this variable to +nil) if you don't find it useful." + :type 'boolean) + +(defcustom amx-prompt-string "M-x " + "String to display in the Amx prompt." + :type 'string) + +(defcustom amx-ignored-command-matchers + '("\\`self-insert-command\\'" + "\\`self-insert-and-exit\\'" + "\\`ad-Orig-" + "\\`menu-bar" + amx-command-marked-ignored-p + amx-command-obsolete-p + amx-command-mouse-interactive-p) + "List of regexps and/or functions. + +Each element is either a regular expression or a function of one +argument. Commands that match any of the regexps or return +non-nil for any of these functions will be hidden from the amx +completion list (but will still be accessible by typing in their +exact name). + +Note that if you want an exact match, the Elisp regular +expression anchors for start and end of string are \"\\`\" and +\"\\'\", respectively. + +Enabling this feature can cause a noticeable delay when running +`amx', so you may wish to disable it (by setting this variable to +nil) if you don't find it useful." + :type '(repeat + (choice + (regexp :tag "Regular expression") + (function :tag "Function")))) + +;;-------------------------------------------------------------------------------- +;; Amx Internals + +(defun amx-get-command-name (cmd) + "Return CMD as a string. + +CMD can be a string, symbol, or cons cell whose `car' is a string +or symbol." + (cond + ((symbolp cmd) + (symbol-name cmd)) + ((consp cmd) + (amx-get-command-name (car cmd))) + ((stringp cmd) + cmd) + (t + (error "Unrecognized command: %S" cmd)))) + +(defun amx-get-command-symbol (cmd &optional force) + "Return CMD as a symbol, or nil if it is not a command. + +CMD can be a symbol or a string, and will always be returned as a +symbol (although the returned symbol may be nil). + +If optional argument FORCE is non-nil, return the symbol even if it +does not correspond to a defined command." + (cond + ((consp cmd) + (amx-get-command-symbol (car cmd))) + ((symbolp cmd) + (when (or force (commandp cmd)) + cmd)) + ((stringp cmd) + (amx-get-command-symbol + (funcall (if force #'intern #'intern-soft) cmd) + force)) + ((null cmd) + nil) + (t + (error "Unrecognized command: %S" cmd)))) + +(defun amx-get-default (choices &optional bind-hash) + "Get the first non-ignored entry from CHOICES as a string." + (cl-loop + with bind-hash = (or bind-hash amx-command-keybind-hash) + for choice in + (if (listp choices) + choices + (amx--debug-message "Getting default from non-list collection might be slow") + (all-completions "" choices)) + for cmd = (amx-get-command-name choice) + if (not (amx-command-ignored-p cmd)) + return (amx-augment-command-with-keybind (format "%s" cmd) bind-hash) + finally return nil)) + +;;-------------------------------------------------------------------------------- +;; Amx Interface + +(defsubst amx-active () + "Return non-nil if amx is currently using the minibuffer." + (>= amx-minibuffer-depth (minibuffer-depth))) + +;;;###autoload +(defun amx () + "Read a command name and execute the command. + +This is the main entry point for the Amx package, an alternative +to the normal \\[execute-extended-command] built into Emacs that +provides several extra features." + (interactive) + (amx-initialize) + (if (amx-active) + (amx-update-and-rerun) + (amx-update-if-needed) + (amx-read-and-run amx-cache))) + +(defun amx-update-and-rerun () + "Check for newly defined commands and re-run `amx'. + +This function should only be called if amx completion is already +running." + (unless (amx-active) + (error "Cannot rerun amx because it is not currently running")) + (select-window (active-minibuffer-window)) + (message "Re-running amx") + (let ((new-initial-input + (funcall (amx-backend-get-text-fun (amx-get-backend))))) + (amx-do-with-selected-item + (lambda (_) (amx-update) (amx-read-and-run amx-cache new-initial-input))))) + +(defun amx-read-and-run (commands &optional initial-input) + "Prompt the user using Amx to choose one of COMMANDS and run it. + +INITIAL-INPUT has the same meaning as in +`completing-read'." + (amx--debug-message "Starting amx-read-and-run") + (let* ((amx-origin-buffer + (or amx-origin-buffer (current-buffer))) + (amx-command-keybind-hash + (if amx-show-key-bindings + (amx-make-keybind-hash) + (make-hash-table :size 0))) + (def (amx-get-default commands)) + (_ignore (amx--debug-message "Got default: %s" def)) + (commands + ;; Add key bindings to completions + (if amx-show-key-bindings + (completion-table-in-turn + (amx-augment-commands-with-keybinds commands) + commands) + commands)) + (collection + (if amx-ignored-command-matchers + ;; Initially complete with only non-ignored commands, + ;; but if all of those are ruled out, allow completing + ;; with ignored commands. + (apply-partially #'completion-table-with-predicate + commands + (lambda (cmd) (not (amx-command-ignored-p cmd))) + nil) + commands)) + (_ignore (amx--debug-message "Ready to call amx-completing-read")) + ;; Symbol + (chosen-item + (amx-clean-command-name + (amx-completing-read collection + :initial-input initial-input + :def def))) + ;; String + (chosen-item-name (symbol-name chosen-item))) + (cl-assert (commandp chosen-item)) + (if amx-custom-action + (let ((action amx-custom-action)) + (setq amx-custom-action nil) + (funcall action chosen-item)) + (unwind-protect + ;; Don't warn about non-interactive use of + ;; `execute-extended-command' + (with-no-warnings + (execute-extended-command current-prefix-arg chosen-item-name)) + (amx-rank chosen-item))))) + +;;;###autoload +(defun amx-major-mode-commands () + "Like `amx', but limited to commands that are relevant to the active major mode." + (interactive) + (amx-initialize) + (let ((commands (delete-dups (append (amx-extract-commands-from-keymap (current-local-map)) + (amx-extract-commands-from-features major-mode))))) + (setq commands (amx-sort-according-to-cache commands)) + (setq commands + (apply-partially #'completion-table-with-predicate + commands + (lambda (cmd) (not (amx-command-ignored-p cmd))) + nil)) + (amx-read-and-run commands))) + +(defvar amx-map + (let ((keymap (make-sparse-keymap))) + (define-key keymap (kbd "C-h f") 'amx-describe-function) + (define-key keymap (kbd "C-h w") 'amx-where-is) + (define-key keymap (kbd "M-.") 'amx-find-function) + keymap) + "Additional key bindings for amx completion.") + +(defvar amx-ido-map + (let ((keymap (make-sparse-keymap))) + (define-key keymap (kbd "C-a") 'move-beginning-of-line) + (set-keymap-parent keymap amx-map) + keymap)) + +(defun amx-prepare-ido-bindings () + "Add Amx bindings to the ido completion map. + +This must be run from `ido-setup-hook'." + (setq ido-completion-map + (make-composed-keymap (list amx-ido-map ido-completion-map)))) + +(defun amx-default-exit-minibuffer () + "Run the key binding for RET. + +This should work for most completion backends, without having to +know exactly which functions each one uses to exit the +minibuffer." + (execute-kbd-macro (kbd "RET"))) + +(cl-defun amx-completing-read (choices &key initial-input predicate def backend) + (when backend + (amx-load-backend backend)) + (let ((amx-backend (or backend amx-backend))) + (amx--debug-message "Doing completion using backend `%s'" amx-backend) + ;; Need to do this to ensure that the specified backend is + ;; available + (let ((amx-minibuffer-depth (1+ (minibuffer-depth))) + (comp-fun (amx-backend-comp-fun (amx-get-backend)))) + (funcall comp-fun choices + :initial-input initial-input + ;; Work around a bug + :predicate (or predicate #'identity) + :def def)))) + +(defun amx-prompt-with-prefix-arg () + "Return `amx-prompt-string' with the prefix arg prepended." + (let ((amx-prompt-string + (or amx-temp-prompt-string amx-prompt-string))) + (setq amx-temp-prompt-string nil) + (if (not current-prefix-arg) + amx-prompt-string + (concat + (if (eq current-prefix-arg '-) + "- " + (if (integerp current-prefix-arg) + (format "%d " current-prefix-arg) + (if (= (car current-prefix-arg) 4) + "C-u " + (format "%d " (car current-prefix-arg))))) + amx-prompt-string)))) + +;;-------------------------------------------------------------------------------- +;; Pluggable Backends + +(cl-defun amx-define-backend (&key name comp-fun + (get-text-fun 'amx-default-get-text) + (exit-fun 'amx-default-exit-minibuffer) + required-feature + auto-activate) + "Define a new backend for `amx'. + +A backend must be defined with at least a `:name' and a +`:comp-fun', which is the function to call to do completion. The +`:comp-fun' must accept the same arguments as +`amx-completing-read-default'. + +Additionally, a backend muse declare a `:get-text-fun', unless +`amx-default-get-text' is sufficient to get the user's currently +entered text for the backend. Similarly, if pressing RET is not +the correct way to exit the minibuffer with the currently +selected text or item when using the backend, it must declare an +`:exit-fun' that does so. + +If the backend needs to load a feature in order to be used, it +must declare that feature using `:required-feature'. If there is +a condition under which the backend should automatically be +activated, that should be declared as `:auto-activate'. If the +condition evaluates to non-nil, the auto backend will automatically +choose the backend." + (cl-assert + (and (symbolp name) name + ;; Unfortunately we can't rely on these to be defined as + ;; functions since their respective packages may not be + ;; loaded. + (or (functionp comp-fun) (symbolp comp-fun)) + (or (functionp get-text-fun) (symbolp get-text-fun)) + (or (functionp exit-fun) (symbolp exit-fun)) + (symbolp required-feature)) + nil + "Invalid amx backend spec: (:name %S :comp-fun %S :get-text-fun %S :exit-fun %S :required-feature %S :auto-activate %S)" + (list name comp-fun get-text-fun exit-fun required-feature auto-activate)) + (let ((backend + (make-amx-backend :name name + :comp-fun comp-fun + :get-text-fun get-text-fun + :exit-fun exit-fun + :required-feature required-feature + :auto-activate auto-activate))) + (setq amx-known-backends + (plist-put amx-known-backends name backend)))) + +(cl-defun amx-get-backend (&optional (backend amx-backend)) + (cond + ((amx-backend-p backend) + backend) + ((plist-get amx-known-backends backend)) + (t (error "Unknown amx backed %S" backend)))) + +(cl-defun amx-completing-read-default (choices &key initial-input predicate def) + "Amx backend for default Emacs completion" + (amx--debug-message "Preparing default-style completion") + (require 'minibuf-eldef) + (let ((minibuffer-completion-table choices) + (prompt (concat (amx-prompt-with-prefix-arg) + (when def + (format "[%s]: " def)))) + (prev-eldef-mode minibuffer-electric-default-mode)) + (unwind-protect + (progn + (minibuffer-electric-default-mode 1) + (minibuffer-with-setup-hook + (lambda () + (use-local-map (make-composed-keymap + (list amx-map (current-local-map))))) + (amx--debug-message "Starting default-style completion") + (completing-read-default + prompt choices predicate t initial-input + 'extended-command-history def))) + (minibuffer-electric-default-mode + (if prev-eldef-mode 1 0))))) + +(defun amx-default-get-text () + "Default function for getting the user's current text input. + +May not work for things like ido and ivy." + (buffer-substring-no-properties (minibuffer-prompt-end) (point-max))) + +(amx-define-backend + :name 'standard + :comp-fun 'amx-completing-read-default + :get-text-fun 'amx-default-get-text) + +(declare-function ido-completing-read+ "ext:ido-completing-read+") + +(cl-defun amx-completing-read-ido (choices &key initial-input predicate def) + "Amx backend for ido completion" + (require 'ido-completing-read+) + (let ((ido-completion-map ido-completion-map) + (ido-setup-hook (cons 'amx-prepare-ido-bindings ido-setup-hook)) + (minibuffer-completion-table choices)) + (ido-completing-read+ (amx-prompt-with-prefix-arg) choices predicate t + initial-input 'extended-command-history def))) + +(defun amx-ido-get-text () + "Function to return the user's entered text for ido." + ido-text) + +(amx-define-backend + :name 'ido + :comp-fun 'amx-completing-read-ido + :get-text-fun 'amx-ido-get-text + :required-feature 'ido-completing-read+ + :auto-activate '(or (bound-and-true-p ido-mode) + (bound-and-true-p ido-ubiquitous-mode))) + +(declare-function ivy-read "ext:ivy") + +(cl-defun amx-completing-read-ivy (choices &key initial-input predicate def) + "Amx backend for ivy completion" + (require 'ivy) + (ivy-read (amx-prompt-with-prefix-arg) choices + :predicate predicate + :keymap amx-map + :history 'extended-command-history + :initial-input initial-input + :preselect def + :require-match t + :caller 'amx-completing-read-ivy)) + +(defun amx-ivy-get-text () + "Function to return the user's entered text for ivy." + ivy-text) + +(amx-define-backend + :name 'ivy + :comp-fun 'amx-completing-read-ivy + :get-text-fun 'amx-ivy-get-text + :required-feature 'ivy + :auto-activate '(bound-and-true-p ivy-mode)) + +(declare-function helm-comp-read "ext:helm-mode") + +(cl-defun amx-completing-read-helm (choices &key initial-input predicate def) + "Amx backend for helm completion" + (require 'helm-config) + (require 'helm-mode) ; Provides `helm-comp-read-map' + (helm-comp-read (amx-prompt-with-prefix-arg) choices + :initial-input initial-input + :test predicate + :default def + :name "Helm M-x Completions" + :buffer "Helm M-x Completions" + :history extended-command-history + :reverse-history t + :must-match t + :keymap (make-composed-keymap amx-map helm-comp-read-map))) + +(amx-define-backend + :name 'helm + :comp-fun 'amx-completing-read-helm + :get-text-fun 'amx-default-get-text + :exit-fun 'helm-confirm-and-exit-minibuffer + :required-feature 'helm + :auto-activate '(bound-and-true-p helm-mode)) + +(declare-function selectrum-read "ext:selectrum") +(declare-function selectrum--normalize-collection "ext:selectrum") +(defvar selectrum-should-sort-p) +(defvar selectrum--previous-input-string) + +(cl-defun amx-completing-read-selectrum (choices &key initial-input predicate def) + "Amx backend for selectrum completion." + (let ((choices (cl-remove-if-not (or predicate #'identity) + choices)) + (selectrum-should-sort-p nil)) + (minibuffer-with-setup-hook + (lambda () + (use-local-map (make-composed-keymap + (list amx-map (current-local-map))))) + (selectrum-read (amx-prompt-with-prefix-arg) + (selectrum--normalize-collection choices) + :history 'extended-command-history + :require-match t + :default-candidate def + :initial-input initial-input)))) + +(defun amx-selectrum-get-text () + selectrum--previous-input-string) + +(amx-define-backend + :name 'selectrum + :comp-fun 'amx-completing-read-selectrum + :get-text-fun 'amx-selectrum-get-text + :required-feature 'selectrum + :auto-activate '(bound-and-true-p selectrum-mode)) + +(defsubst amx-auto-select-backend () + (cl-loop for (bname b) on amx-known-backends by 'cddr + ;; Don't auto-select the auto backend, or the + ;; default backend. + unless (memq bname '(auto standard)) + ;; Auto-select a backend if its auto-activate + ;; condition evaluates to non-nil. + if (ignore-errors (eval (amx-backend-auto-activate b))) + return b + ;; If no backend's auto-activate condition is + ;; fulfilled, auto-select the standard backend. + finally return 'standard)) + +(cl-defun amx-completing-read-auto (choices &key initial-input predicate def) + "Automatically select the appropriate completion system for M-x. + +This iterates through the `:auto-activate' declarations of each +backend until it finds one that evaluates to non-nil, and uses that +backend." + (let ((backend (amx-auto-select-backend))) + (amx--debug-message "Auto-selected backend `%s'" + (if (symbolp backend) backend + (amx-backend-name backend))) + (condition-case err + (amx-load-backend backend) + (error + (if (eq backend 'standard) + (error "Failed to use standard backend") + (display-warning + 'amx + (format "Falling back to standard amx backend due to error loading %s backend: %S" + backend (cadr err))) + (setq backend 'standard)))) + (amx-completing-read choices + :initial-input initial-input + :predicate predicate + :def def + :backend backend))) + +(amx-define-backend + :name 'auto + :comp-fun 'amx-completing-read-auto + :get-text-fun (lambda () (error "This exit function should never be called")) + :exit-fun (lambda () (error "This get-text function should never be called"))) + +(defun amx-load-backend (backend) + "Load all required features for BACKEND." + (let* ((backend (amx-get-backend backend)) + (feature (amx-backend-required-feature backend))) + (unless (listp feature) + (setq feature (list feature))) + (cl-loop for f in feature + unless (require f nil 'noerror) + do (error "Feature `%s' is required for backend `%s'" + f (amx-backend-name backend))))) + +(defun amx-set-backend (symbol value) + "Custom setter for `amx-backend'. + +Arguments are the same as in `set-default'. + +This function will refuse to set the backend unless it can load +the associated feature, if any." + (cl-assert (eq symbol 'amx-backend)) + (let* ((backend (or (plist-get amx-known-backends value) + (error "Unknown amx backend: %s" value)))) + (amx-load-backend backend)) + ;; If we got through that, then actually set the variable + (set-default symbol value)) + +(defcustom amx-backend 'auto + "Completion function to select a candidate from a list of strings. + +This function should take the same arguments as +`amx-completing-read': CHOICES and INITIAL-INPUT. + +By default, an appropriate method is selected based on whether +`ivy-mode' or `ido-mode' is enabled." + :type '(choice + (const :tag "Auto-select" auto) + (const :tag "Ido" ido) + (const :tag "Ivy" ivy) + (const :tag "Helm" helm) + (const :tag "Standard" standard) + (symbol :tag "Custom backend")) + :set #'amx-set-backend) + +;;-------------------------------------------------------------------------------- +;; Cache and Maintenance + +(defun amx-rebuild-cache () + "Add newly defined commands to `amx-cache'." + (setq amx-cache nil) + + ;; Build up list 'new-commands' and later put it at the end of 'amx-cache'. + ;; This speeds up sorting. + (let (new-commands) + (mapatoms (lambda (symbol) + (when (commandp symbol) + (let ((known-command (assq symbol amx-data))) + (if known-command + (setq amx-cache (cons known-command amx-cache)) + (setq new-commands (cons (list symbol) new-commands))))))) + (if (eq (length amx-cache) 0) + (setq amx-cache new-commands) + (setcdr (last amx-cache) new-commands))) + + (setq amx-cache (sort amx-cache 'amx-sorting-rules)) + (amx-restore-history)) + +(defun amx-restore-history () + "Rearrange `amx-cache' according to `amx-history'." + (if (> (length amx-history) amx-history-length) + (setcdr (nthcdr (- amx-history-length 1) amx-history) nil)) + (mapc (lambda (command) + (unless (eq command (caar amx-cache)) + (let ((command-cell-position (amx-detect-position + amx-cache + (lambda (cell) + (eq command (caar cell)))))) + (when command-cell-position + (let ((command-cell (amx-remove-nth-cell + command-cell-position amx-cache))) + (setcdr command-cell amx-cache) + (setq amx-cache command-cell)))))) + (reverse amx-history))) + +(defun amx-sort-according-to-cache (list) + "Sort LIST of commands by their order in `amx-cache'." + (let (sorted) + (dolist (command-item amx-cache) + (let ((command (car command-item))) + (when (memq command list) + (setq sorted (cons command sorted)) + (setq list (delq command list))))) + (nreverse (append list sorted)))) + +(defun amx-update () + "Update the Amx cache with any newly-defined commands." + (interactive) + (amx--debug-message "Doing full update") + (amx-save-history) + (amx-rebuild-cache) + (setq amx-last-update-time (current-time)) + (amx--debug-message "Finished full update")) + +(defun amx-detect-new-commands () + "Return non-nil if the number of defined commands has changed. + +The return value is actually the new count of commands." + (let ((i 0)) + (mapatoms (lambda (symbol) (if (commandp symbol) (setq i (1+ i))))) + (unless (= i amx-command-count) + (setq amx-command-count i)))) + +(defun amx-update-if-needed (&optional count-commands) + "Run `amx-update' if necessary. + +If `amx-last-update-time' is nil, do an update unconditionally. +Otherwise, if optional arg COUNT-COMMANDS is non-nil, count the +total number of defined commands in `obarray' and update if it +has changed." + (if (or (null amx-last-update-time) + (and count-commands + (amx-detect-new-commands))) + (amx-update) + (amx--debug-message "No update needed at this time."))) + +;;;###autoload +(defun amx-initialize (&optional reinit) + "Ensure that amx is properly initialized. + +This function is normally idempotent, only having an effect the +first time it is called, so it is safe to call it at the +beginning of any function that expects amx to be initialized. +However, optional arg REINIT forces the initialization needs to +be re-run. Interactively, reinitialize when a prefix arg is +provided." + (interactive "P") + (when (or reinit (not amx-initialized)) + (amx-load-save-file) + (amx-detect-new-commands) + (amx-rebuild-cache) + (add-hook 'kill-emacs-hook 'amx-save-to-file) + (setq amx-initialized t))) + +(defsubst amx-buffer-not-empty-p () + "Return non-nil if current buffer contains a non-space character." + (string-match-p "\[^[:space:]\]" (buffer-string))) + +(defun amx-load-save-file () + "Load `amx-history' and `amx-data' from `amx-save-file'. + +In order to facilitate migrating from smex, if `amx-save-file' +does not exist, but smex is loaded and `smex-save-file' exists, +copy `smex-save-file' to `amx-save-file' and load it." + (setq amx-history nil amx-data nil) + (when amx-save-file + (let ((amx-save-file + (if (and (not (file-exists-p amx-save-file)) + (bound-and-true-p smex-save-file) + (file-exists-p smex-save-file)) + (prog1 smex-save-file + (message "Amx is loading your saved data from smex.")) + amx-save-file))) + (let ((save-file (expand-file-name amx-save-file))) + (when (file-readable-p save-file) + (with-temp-buffer + (insert-file-contents save-file) + (condition-case nil + (setq amx-history (read (current-buffer)) + amx-data (read (current-buffer))) + (error (if (amx-buffer-not-empty-p) + (error "Invalid data in amx-save-file (%s). Can't restore history" + amx-save-file) + (unless (boundp 'amx-history) (setq amx-history nil)) + (unless (boundp 'amx-data) (setq amx-data nil))))))))))) + +(defun amx-save-history () + "Update `amx-history'." + (setq amx-history + (cl-loop + for i from 1 upto amx-history-length + for (command-name . count) in amx-cache + collect command-name))) + +(defun amx-pp* (list list-name) + "Helper function for `amx-pp'." + (let ((print-level nil) (eval-expression-print-level nil) + (print-length nil) (eval-expression-print-length nil)) + (insert "\n;; ----- " list-name " -----\n(\n ") + (while list + (let* ((elt (car list)) + (s (if (consp elt) (car elt) elt))) + (if (and (stringp s) (= (length s) 0)) + (setq s nil)) + (if s + (prin1 elt (current-buffer))) + (if (and (setq list (cdr list)) s) + (insert "\n ")))) + (insert "\n)\n"))) + +(defmacro amx-pp (list-var) + "A copy of `ido-pp' that's compatible with lexical bindings." + `(amx-pp* ,list-var ,(symbol-name list-var))) + +(defun amx-save-to-file () + "Save Amx history and cache to `amx-save-file' for future sessions." + (interactive) + (when amx-save-file + ;; If `init-file-user' is nil, we are running under "emacs -Q", so + ;; don't save anything to disk + (if init-file-user + (progn + (amx-save-history) + (with-temp-file (expand-file-name amx-save-file) + (amx-pp amx-history) + (amx-pp amx-data))) + (display-warning 'amx "Not saving amx state from \"emacs -Q\".")))) + +;;-------------------------------------------------------------------------------- +;; Ranking + +(defun amx-sorting-rules (command-item other-command-item) + "Return non-nil if COMMAND-ITEM should sort before OTHER-COMMAND-ITEM." + (let* ((count (or (cdr command-item ) 0)) + (other-count (or (cdr other-command-item) 0)) + (name (car command-item)) + (other-name (car other-command-item)) + (length (length (symbol-name name))) + (other-length (length (symbol-name other-name)))) + (or (> count other-count) ; 1. Frequency of use + (and (= count other-count) + (or (< length other-length) ; 2. Command length + (and (= length other-length) + (string< name other-name))))))) ; 3. Alphabetical order + +(defun amx-rank (command) + "Update the recently-used ranking for COMMAND." + (let ((command-item (or (assq command amx-cache) + ;; Update caches and try again if not found. + (progn (amx-update) + (assq command amx-cache))))) + (when command-item + (amx-update-counter command-item) + + ;; Don't touch the cache order if the chosen command + ;; has just been execucted previously. + (unless (eq command-item (car amx-cache)) + (let (command-cell + (pos (amx-detect-position amx-cache (lambda (cell) + (eq command-item (car cell)))))) + ;; Remove the just executed command. + (setq command-cell (amx-remove-nth-cell pos amx-cache)) + ;; And put it on top of the cache. + (setcdr command-cell amx-cache) + (setq amx-cache command-cell) + + ;; Now put the last history item back to its normal place. + (amx-sort-item-at amx-history-length)))))) + +(defun amx-update-counter (command-item) + "Update the run counter for COMMAND-ITEM. + +If COMMAND-ITEM already has a counter, it is incremented by 1. +Otherwise, its counter is initilized to 1." + (let ((count (cdr command-item))) + (setcdr command-item + (if count + (1+ count) + ;; Else: Command has just been executed for the first time. + ;; Add it to `amx-data'. + (if amx-data + (setcdr (last amx-data) (list command-item)) + (setq amx-data (list command-item))) + 1)))) + +(defun amx-sort-item-at (n) + "Sort item at position N in `amx-cache'." + (let* ((command-cell (nthcdr n amx-cache)) + (command-item (car command-cell))) + (let ((insert-at (amx-detect-position + command-cell + (lambda (cell) + (amx-sorting-rules command-item (car cell)))))) + ;; TODO: Should we handle the case of 'insert-at' being nil? + ;; This will never happen in practice. + (when (> insert-at 1) + (setq command-cell (amx-remove-nth-cell n amx-cache)) + ;; amx-cache just got shorter by one element, so subtract '1' from insert-at. + (setq insert-at (+ n (- insert-at 1))) + (amx-insert-cell command-cell insert-at amx-cache))))) + +(defun amx-detect-position (cell pred) + "Find the position of the first element in `(cdr CELL)' matching PRED. + +Only checks cells after CELL, starting with the cell right after +CELL. Returns nil if no element after CELL matches PRED." + (let ((pos 1)) + (catch 'break + (while t + (setq cell (cdr cell)) + (if (not cell) + (throw 'break nil) + (if (funcall pred cell) (throw 'break pos)) + (setq pos (1+ pos))))))) + +(defun amx-remove-nth-cell (n list) + "Remove and return the Nth cell in LIST." + (let* ((previous-cell (nthcdr (- n 1) list)) + (result (cdr previous-cell))) + (setcdr previous-cell (cdr result)) + result)) + +(defun amx-insert-cell (new-cell n list) + "Insert NEW-CELL at position N in LIST." + (let* ((cell (nthcdr (- n 1) list)) + (next-cell (cdr cell))) + (setcdr (setcdr cell new-cell) next-cell))) + +;;-------------------------------------------------------------------------------- +;; Display key bindings in completions + +(defun amx-make-keybind-hash (&optional keymap) + "Return a hash table of all commands that might be bound in KEYMAP. + +The KEYMAP argument is interpreted as in `where-is-internal'. + +The hash will actually contain two kinds of mappings. Symbol keys +are mappings of command symbols to key bindings, while string +keys are mappings of string representations of the command and +its binding together, e.g. \"forward-char (C-f)\", to the command +symbol by itself." + (amx--debug-message "Building new keybind hash table.") + (let* ((keymap-list + (cond + ((keymapp keymap) + (list keymap global-map)) + ((null keymap) + ;; Run `current-active-maps' in `amx-origin-buffer' if + ;; any + (with-current-buffer (or amx-origin-buffer (current-buffer)) + (current-active-maps))) + ((listp keymap) + keymap))) + (composed-keymap + (make-composed-keymap keymap-list))) + (cl-loop + with bindhash = (make-hash-table :test 'equal) + for kseq being the key-seqs of composed-keymap using (key-bindings cmd) + for curbind = (gethash cmd bindhash) + ;; Only take the first binding for each command + if (and (not curbind) (commandp cmd)) + ;; Let's abuse this hash by storing two different + ;; kinds of key/values pairs in it + do (progn + ;; cmd => key + (puthash cmd (key-description kseq) bindhash) + ;; "cmd (key)" => cmd, for looking up the original command + (puthash (format "%s (%s)" cmd (key-description kseq)) cmd bindhash)) + finally do (amx--debug-message "Finished building new keybind hash table.") + finally return bindhash))) + +(defun amx-augment-command-with-keybind (command &optional bind-hash) + "Append COMMAND's key binding to COMMAND. + +The key binding is looked up in BIND-HASH. If a binding is not +found for COMMAND, the command's name is returned alone." + (let* ((cmdname (amx-get-command-name command)) + (cmdsym (intern cmdname)) + (keybind (and bind-hash (gethash cmdsym bind-hash)))) + (if (and keybind (not (amx-command-ignored-p cmdsym))) + (format "%s (%s)" cmdname keybind) + cmdname))) + +(defun amx-augment-commands-with-keybinds + (commands &optional bind-hash) + "Append key bindings from BIND-HASH to COMMANDS. + +Given a list of commands (either as symbols or cons cells in the +form of `amx-cache'), returns an equivalent list, except that +every command is converted to a string, and any command with a +key binding recorded in `BIND-HASH will have that binding +appended. By default, key bindings are looked up in +`amx-command-keybind-hash', which is updated using +`amx-make-keybind-hash' if necessary. + +In the returned list, each element will be a string." + (cl-loop + ;; Default to `amx-command-keybind-hash', updating it if + ;; necessary. + with bind-hash = (or bind-hash amx-command-keybind-hash) + for cmd in commands + collect (amx-augment-command-with-keybind cmd bind-hash))) + +(defun amx-clean-command-name (command-name) + "Return the symbol for COMMAND-NAME, stripping any keybinds. + +For example, given \"forward-char (C-f)\", this would return +`forward-char'. + +This is roughly the inverse of +`amx-augment-command-with-keybind'." + (amx-get-command-symbol + (or + ;; First try getting it from the hash table as a shortcut + (and amx-command-keybind-hash + (gethash command-name amx-command-keybind-hash)) + ;; If that doesn't work, we do it the hard way: chop chars off the + ;; end until the result is a command + (cl-loop + for s = (cl-copy-seq command-name) then (substring s 0 -1) + for sym = (intern-soft s) + if (and sym (commandp sym)) + return sym + if (= 0 (length s)) + return nil) + ;; Finally, just take all non-space chars up to the first space + (car (s-match "\\`[^[:space:]]+" command-name)) + ;; If none of the above works, fail + (error "Could not find command: %S" command-name)) + t)) + +;;-------------------------------------------------------------------------------- +;; Ignored commands + +(defun amx-command-ignored-p (command) + "Return non-nil if COMMAND is ignored by amx completion. + +See `amx-ignored-command-matchers'." + ;; Allow passing entries from `amx-cache', whose `car' is the + ;; command symbol. + (when (consp command) + (setq command (car command))) + ;; Command might be a string like "CMD (KEY)", requiring a lookup of + ;; the real command name + (when (stringp command) + (setq command (amx-clean-command-name command))) + (setq command (amx-get-command-symbol command)) + (cl-loop + with matched = nil + for matcher in amx-ignored-command-matchers + ;; regexp + if (stringp matcher) + do (setq matched (string-match-p matcher (symbol-name command))) + ;; function + else + do (setq matched (funcall matcher command)) + if matched return t + finally return nil)) + +(defun amx-command-marked-ignored-p (command) + "Return non-nil if COMMAND's `amx-ignored' property is non-nil. + +See `amx-ignore-command'." + ;; Allow passing entries from `amx-cache', whose `car' is the + ;; command symbol. + (get (amx-get-command-symbol command) 'amx-ignored)) + +(defun amx-command-obsolete-p (command) + "Return non-nil if COMMAND is marked obsolete." + (get (amx-get-command-symbol command) 'byte-obsolete-info)) + +(defun amx-command-mouse-interactive-p (command) + "Return non-nil if COMMAND uses mouse events. + +This is not guaranteed to detect all mouse-interacting commands, +but it should find most of them." + (setq command (amx-get-command-symbol command)) + (and (listp (help-function-arglist command)) + (not (eq ?\& (aref (symbol-name (car (help-function-arglist command))) 0))) + (stringp (cadr (interactive-form command))) + (string-match-p "\\`[*@^]*e" (cadr (interactive-form command))))) + +(cl-defun amx-ignore-command (command &optional (do-ignore t)) + "Tell amx to ignore COMMAND. + +Ignored commands are still usable, but are hidden from completion +in amx. + +COMMAND can also be a list of commands to ignore. + +A hidden second arg defaults to t, but if nil is explicitly +passed for this arg, it tells amx *not* to ignore COMMAND, +reversing the effect of a previous `amx-ignore'. " + (interactive + (list + (let ((amx-temp-prompt-string "Ignore command: ")) + (amx-completing-read + amx-cache + :predicate (lambda (cmd) (not (amx-command-ignored-p cmd))))))) + (declare (advertised-calling-convention (command) nil)) + (unless (listp command) + (setq command (list command))) + (cl-loop + for cmd in command + if (stringp cmd) + do (setq cmd (intern cmd)) + do (put cmd 'amx-ignored do-ignore))) + +(defun amx-unignore-command (command) + "Undo a previous `amx-ignore' on COMMAND." + (interactive + (list + (let ((amx-temp-prompt-string "Un-ignore command: ")) + (amx-completing-read + amx-cache + :predicate #'amx-command-marked-ignored-p)))) + (amx-ignore-command command nil)) + + +;;-------------------------------------------------------------------------------- +;; Help and Reference + +(defun amx-exit-minibuffer () + "Call the backend-specific minibuffer exit function." + (interactive) + (funcall (amx-backend-exit-fun (amx-get-backend)))) + +(defun amx-do-with-selected-item (fn) + "Exit minibuffer and call FN on the selected item." + (setq amx-custom-action fn) + (amx-exit-minibuffer)) + +(defun amx-describe-function () + "Exit the minibuffer and call `describe-function' on selected item." + (interactive) + (amx-do-with-selected-item (lambda (chosen) + (describe-function chosen) + (pop-to-buffer "*Help*")))) + +(defun amx-where-is () + "Exit the minibuffer and call `where-is' on selected item." + (interactive) + (amx-do-with-selected-item 'where-is)) + +(defun amx-find-function () + "Exit the minibuffer and call `find-function' on selected item." + (interactive) + (amx-do-with-selected-item 'find-function)) + +;; TODO: These are redundant with the keymap functions I wrote. DRY it +;; out. +(defun amx-extract-commands-from-keymap (keymap) + (let (commands) + (amx-parse-keymap keymap commands) + commands)) + +(defun amx-parse-keymap (keymap commands) + (map-keymap (lambda (_binding element) + (if (and (listp element) (eq 'keymap (car element))) + (amx-parse-keymap element commands) + ;; Strings are commands, too. Reject them. + (if (and (symbolp element) (commandp element)) + (push element commands)))) + keymap)) + +(defun amx-extract-commands-from-features (mode) + (let ((library-path (symbol-file mode)) + (mode-name (symbol-name mode)) + commands) + + (string-match "\\(.+?\\)\\(-mode\\)?$" mode-name) + ;; 'lisp-mode' -> 'lisp' + (setq mode-name (match-string 1 mode-name)) + (if (string= mode-name "c") (setq mode-name "cc")) + (setq mode-name (regexp-quote mode-name)) + + (dolist (feature load-history) + (let ((feature-path (car feature))) + (when (and feature-path (or (equal feature-path library-path) + (string-match mode-name (file-name-nondirectory + feature-path)))) + (dolist (item (cdr feature)) + (if (and (listp item) (eq 'defun (car item))) + (let ((function (cdr item))) + (when (commandp function) + (setq commands (append commands (list function)))))))))) + commands)) + +(defun amx-show-unbound-commands () + "Show unbound commands in a new buffer sorted by frequency of use." + (interactive) + (setq amx-data (sort amx-data 'amx-sorting-rules)) + (let ((unbound-commands (delq nil + (mapcar (lambda (command-item) + (unless (where-is-internal (car command-item)) + command-item)) + amx-data)))) + (view-buffer-other-window "*Amx: Unbound Commands*") + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + (amx-pp unbound-commands)) + (set-buffer-modified-p nil) + (goto-char (point-min)))) + +;;-------------------------------------------------------------------------------- +;; Auto Update + +(defun amx-post-eval-force-update (&rest _args) + "Schedule an amx update the next time Emacs is idle." + (setq amx-last-update-time nil)) + +;; It's pretty much impossible to define a new command without going +;; through one of these functions, so updating after any of them is +;; called should catch all new command definitions. +(cl-loop for fun in '(load eval-last-sexp eval-buffer eval-region eval-expression autoload-do-load) + do (advice-add fun :after #'amx-post-eval-force-update)) + +(defun amx-idle-update (&optional force) + "Function meant to be run in idle timers to update amx caches. + +Optional argument FORCE tells amx to completely rebuild all of +its cached data, even if it believes that data is already +current." + (unless (and (amx-active) + (minibufferp)) + (amx-initialize) + (let ((do-recount + (or force + ;; If periodic updates are enabled, force a full search + ;; for new commands after the auto-update interval has + ;; elapsed. + (and amx-auto-update-interval + amx-last-update-time + (> (float-time (time-since amx-last-update-time)) + (* 60 amx-auto-update-interval)))))) + (amx-update-if-needed do-recount)))) + +;; This does a quick update every time emacs is idle +(progn + ;; Make sure we don't run multiple instances of the timer when + ;; re-evaluating this file multiple times + (when amx-short-idle-update-timer + (cancel-timer amx-short-idle-update-timer)) + (setq amx-short-idle-update-timer + (run-with-idle-timer 1 t 'amx-idle-update))) + +(provide 'amx) +;;; amx.el ends here diff --git a/lisp/anaconda-mode.el b/lisp/anaconda-mode.el new file mode 100644 index 00000000..5534b34c --- /dev/null +++ b/lisp/anaconda-mode.el @@ -0,0 +1,852 @@ +;;; anaconda-mode.el --- Code navigation, documentation lookup and completion for Python -*- lexical-binding: t; -*- + +;; Copyright (C) 2013-2018 by Artem Malyshev + +;; Author: Artem Malyshev +;; URL: https://github.com/proofit404/anaconda-mode +;; Package-Version: 20200129.1718 +;; Package-Commit: 10299bd9ff38c4f0da1d892905d02ef828e7fdce +;; Version: 0.1.13 +;; Package-Requires: ((emacs "25.1") (pythonic "0.1.0") (dash "2.6.0") (s "1.9") (f "0.16.2")) + +;; 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 . + +;;; Commentary: + +;; See the README for more details. + +;;; Code: + +(require 'ansi-color) +(require 'pythonic) +(require 'tramp) +(require 'xref) +(require 'json) +(require 'dash) +(require 'url) +(require 's) +(require 'f) + +(defgroup anaconda nil + "Code navigation, documentation lookup and completion for Python." + :group 'programming) + +(defcustom anaconda-mode-installation-directory + (locate-user-emacs-file "anaconda-mode") + "Installation directory for `anaconda-mode' server." + :type 'directory) + +(defcustom anaconda-mode-eldoc-as-single-line nil + "If not nil, trim eldoc string to frame width." + :type 'boolean) + +(defcustom anaconda-mode-lighter " Anaconda" + "Text displayed in the mode line when `anaconda-mode’ is active." + :type 'sexp) + +(defcustom anaconda-mode-localhost-address "127.0.0.1" + "Address used by `anaconda-mode' to resolve localhost." + :type 'string) + +(defcustom anaconda-mode-doc-frame-background (face-attribute 'default :background) + "Doc frame background color, default color is current theme's background." + :type 'string) + +(defcustom anaconda-mode-doc-frame-foreground (face-attribute 'default :foreground) + "Doc frame foreground color, default color is current theme's foreground." + :type 'string) + +(defcustom anaconda-mode-use-posframe-show-doc nil + "If the value is not nil, use posframe to show eldoc." + :type 'boolean) + +(defcustom anaconda-mode-tunnel-setup-sleep 2 + "Time in seconds `anaconda-mode' waits after tunnel creation before first RPC call." + :group 'anaconda-mode + :type 'integer) + +;;; Compatibility + +;; Functions from posframe which is an optional dependency +(declare-function posframe-workable-p "posframe") +(declare-function posframe-hide "posframe") +(declare-function posframe-show "posframe") + +;;; Server. +(defvar anaconda-mode-server-version "0.1.13" + "Server version needed to run `anaconda-mode'.") + +(defvar anaconda-mode-server-command " +from __future__ import print_function + +# CLI arguments. + +import sys + +assert len(sys.argv) > 3, 'CLI arguments: %s' % sys.argv + +server_directory = sys.argv[-3] +server_address = sys.argv[-2] +virtual_environment = sys.argv[-1] + +# Ensure directory. + +import os + +server_directory = os.path.expanduser(server_directory) +virtual_environment = os.path.expanduser(virtual_environment) + +if not os.path.exists(server_directory): + os.makedirs(server_directory) + +# Installation check. + +jedi_dep = ('jedi', '0.13.0') +service_factory_dep = ('service_factory', '0.1.5') + +missing_dependencies = [] + +def instrument_installation(): + for package in (jedi_dep, service_factory_dep): + package_is_installed = False + for path in os.listdir(server_directory): + path = os.path.join(server_directory, path) + if path.endswith('.egg') and os.path.isdir(path): + if path not in sys.path: + sys.path.insert(0, path) + if package[0] in path: + package_is_installed = True + if not package_is_installed: + missing_dependencies.append('>='.join(package)) + +instrument_installation() + +# Installation. + +def install_deps(): + import site + import setuptools.command.easy_install + site.addsitedir(server_directory) + cmd = ['--install-dir', server_directory, + '--site-dirs', server_directory, + '--always-copy','--always-unzip'] + cmd.extend(missing_dependencies) + setuptools.command.easy_install.main(cmd) + instrument_installation() + +if missing_dependencies: + install_deps() + +del missing_dependencies[:] + +try: + import jedi +except ImportError: + missing_dependencies.append('>='.join(jedi_dep)) + +try: + import service_factory +except ImportError: + missing_dependencies.append('>='.join(service_factory_dep)) + +# Try one more time in case if anaconda installation gets broken somehow +if missing_dependencies: + install_deps() + import jedi + import service_factory + +# Setup server. + +assert jedi.__version__ >= jedi_dep[1], 'Jedi version should be >= %s, current version: %s' % (jedi_dep[1], jedi.__version__,) + +if virtual_environment: + virtual_environment = jedi.create_environment(virtual_environment, safe=False) +else: + virtual_environment = None + +# Define JSON-RPC application. + +import functools +import threading + +def script_method(f): + @functools.wraps(f) + def wrapper(source, line, column, path): + timer = threading.Timer(30.0, sys.exit) + timer.start() + result = f(jedi.Script(source, line, column, path, environment=virtual_environment)) + timer.cancel() + return result + return wrapper + +def process_definitions(f): + @functools.wraps(f) + def wrapper(script): + definitions = f(script) + if len(definitions) == 1 and not definitions[0].module_path: + return '%s is defined in %s compiled module' % ( + definitions[0].name, definitions[0].module_name) + return [[definition.module_path, + definition.line, + definition.column, + definition.get_line_code().strip()] + for definition in definitions + if definition.module_path] or None + return wrapper + +@script_method +def complete(script): + return [[definition.name, definition.type] + for definition in script.completions()] + +@script_method +def company_complete(script): + return [[definition.name, + definition.type, + definition.docstring(), + definition.module_path, + definition.line] + for definition in script.completions()] + +@script_method +def show_doc(script): + return [[definition.module_name, definition.docstring()] + for definition in script.goto_definitions()] + +@script_method +@process_definitions +def goto_definitions(script): + return script.goto_definitions() + +@script_method +@process_definitions +def goto_assignments(script): + return script.goto_assignments() + +@script_method +@process_definitions +def usages(script): + return script.usages() + +@script_method +def eldoc(script): + signatures = script.call_signatures() + if len(signatures) == 1: + signature = signatures[0] + return [signature.name, + signature.index, + [param.description[6:] for param in signature.params]] + +# Run. + +app = [complete, company_complete, show_doc, goto_definitions, goto_assignments, usages, eldoc] + +service_factory.service_factory(app, server_address, 0, 'anaconda_mode port {port}') +" "Run `anaconda-mode' server.") + +(defvar anaconda-mode-process-name "anaconda-mode" + "Process name for `anaconda-mode' processes.") + +(defvar anaconda-mode-process-buffer "*anaconda-mode*" + "Buffer name for `anaconda-mode' process.") + +(defvar anaconda-mode-process nil + "Currently running `anaconda-mode' process.") + +(defvar anaconda-mode-response-buffer "*anaconda-response*" + "Buffer name for error report when `anaconda-mode' fail to read server response.") + +(defvar anaconda-mode-socat-process-name "anaconda-socat" + "Process name for `anaconda-mode' socat companion process.") + +(defvar anaconda-mode-socat-process-buffer "*anaconda-socat*" + "Buffer name for `anaconda-mode' socat companion process.") + +(defvar anaconda-mode-socat-process nil + "Currently running `anaconda-mode' socat companion process.") + +(defvar anaconda-mode-ssh-process-name "anaconda-ssh" + "Process name for `anaconda-mode' ssh port forward companion process.") + +(defvar anaconda-mode-ssh-process-buffer "*anaconda-ssh*" + "Buffer name for `anaconda-mode' ssh port forward companion process.") + +(defvar anaconda-mode-ssh-process nil + "Currently running `anaconda-mode' ssh port forward companion process.") + +(defvar anaconda-mode-doc-frame-name "*Anaconda Posframe*" + "The posframe to show anaconda documentation.") + +(defvar anaconda-mode-frame-last-point 0 + "The last point of anaconda doc view frame, use for hide frame after move point.") + +(defvar anaconda-mode-frame-last-scroll-offset 0 + "The last scroll offset when show doc view frame, use for hide frame after window scroll.") + +(defun anaconda-mode-server-directory () + "Anaconda mode installation directory." + (f-short (f-join anaconda-mode-installation-directory + anaconda-mode-server-version))) + +(defun anaconda-mode-host () + "Target host with `anaconda-mode' server." + (cond + ((pythonic-remote-docker-p) + anaconda-mode-localhost-address) + ((pythonic-remote-p) + (pythonic-remote-host)) + (t + anaconda-mode-localhost-address))) + +(defun anaconda-mode-port () + "Port for `anaconda-mode' connection." + (process-get anaconda-mode-process 'port)) + +(defun anaconda-mode-start (&optional callback) + "Start `anaconda-mode' server. +CALLBACK function will be called when `anaconda-mode-port' will +be bound." + (when (anaconda-mode-need-restart) + (anaconda-mode-stop)) + (if (anaconda-mode-running-p) + (and callback + (anaconda-mode-bound-p) + (funcall callback)) + (anaconda-mode-bootstrap callback))) + +(defun anaconda-mode-stop () + "Stop `anaconda-mode' server." + (when (anaconda-mode-running-p) + (set-process-filter anaconda-mode-process nil) + (set-process-sentinel anaconda-mode-process nil) + (kill-process anaconda-mode-process) + (setq anaconda-mode-process nil)) + (when (anaconda-mode-socat-running-p) + (kill-process anaconda-mode-socat-process) + (setq anaconda-mode-socat-process nil)) + (when (anaconda-mode-ssh-running-p) + (kill-process anaconda-mode-ssh-process) + (setq anaconda-mode-ssh-process nil))) + +(defun anaconda-mode-running-p () + "Is `anaconda-mode' server running." + (and anaconda-mode-process + (process-live-p anaconda-mode-process))) + +(defun anaconda-mode-socat-running-p () + "Is `anaconda-mode' socat companion process running." + (and anaconda-mode-socat-process + (process-live-p anaconda-mode-socat-process))) + +(defun anaconda-mode-ssh-running-p () + "Is `anaconda-mode' ssh port forward companion process running." + (and anaconda-mode-ssh-process + (process-live-p anaconda-mode-ssh-process))) + +(defun anaconda-mode-bound-p () + "Is `anaconda-mode' port bound." + (numberp (anaconda-mode-port))) + +(defun anaconda-mode-need-restart () + "Check if we need to restart `anaconda-mode-server'." + (when (and (anaconda-mode-running-p) + (anaconda-mode-bound-p)) + (not (and (equal (process-get anaconda-mode-process 'interpreter) + python-shell-interpreter) + (equal (process-get anaconda-mode-process 'virtualenv) + python-shell-virtualenv-root) + (equal (process-get anaconda-mode-process 'remote-p) + (pythonic-remote-p)) + (if (pythonic-local-p) + t + (equal (process-get anaconda-mode-process 'remote-method) + (pythonic-remote-method)) + (equal (process-get anaconda-mode-process 'remote-user) + (pythonic-remote-user)) + (equal (process-get anaconda-mode-process 'remote-host) + (pythonic-remote-host)) + (equal (process-get anaconda-mode-process 'remote-port) + (pythonic-remote-port))))))) + +(defun anaconda-mode-bootstrap (&optional callback) + "Run `anaconda-mode' server. +CALLBACK function will be called when `anaconda-mode-port' will +be bound." + (setq anaconda-mode-process + (pythonic-start-process :process anaconda-mode-process-name + :buffer (get-buffer-create anaconda-mode-process-buffer) + :query-on-exit nil + :filter (lambda (process output) + (anaconda-mode-bootstrap-filter process output callback)) + :sentinel (lambda (_process _event)) + :args `("-c" + ,anaconda-mode-server-command + ,(anaconda-mode-server-directory) + ,(if (pythonic-remote-p) + "0.0.0.0" + anaconda-mode-localhost-address) + ,(or python-shell-virtualenv-root "")))) + (process-put anaconda-mode-process 'interpreter python-shell-interpreter) + (process-put anaconda-mode-process 'virtualenv python-shell-virtualenv-root) + (process-put anaconda-mode-process 'port nil) + (when (pythonic-remote-p) + (process-put anaconda-mode-process 'remote-p t) + (process-put anaconda-mode-process 'remote-method (pythonic-remote-method)) + (process-put anaconda-mode-process 'remote-user (pythonic-remote-user)) + (process-put anaconda-mode-process 'remote-host (pythonic-remote-host)) + (process-put anaconda-mode-process 'remote-port (pythonic-remote-port)))) + +(defun anaconda-jump-proxy-string () + "Create -J option string for SSH tunnel." + (let ((dfn + (tramp-dissect-file-name (pythonic-aliased-path default-directory)))) + (when (tramp-file-name-hop dfn) + (let ((hop-list (split-string (tramp-file-name-hop dfn) "|")) + (result "-J ")) + (delete "" hop-list) ;; remove empty string after final pipe + (dolist (elt hop-list result) + ;; tramp-dissect-file-name expects a filename so give it dummy.file + (let ((ts (tramp-dissect-file-name (concat "/" elt ":/dummy.file")))) + (setq result (concat result + (format "%s@%s:%s," + (tramp-file-name-user ts) + (tramp-file-name-host ts) + (or (tramp-file-name-port-or-default ts) 22)))))) + ;; Remove final comma + (substring result 0 -1))))) + +(defun anaconda-mode-bootstrap-filter (process output &optional callback) + "Set `anaconda-mode-port' from PROCESS OUTPUT. +Connect to the `anaconda-mode' server. CALLBACK function will be +called when `anaconda-mode-port' will be bound." + ;; Mimic default filter. + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (save-excursion + (goto-char (process-mark process)) + (insert (ansi-color-apply output)) + (set-marker (process-mark process) (point))))) + (unless (anaconda-mode-bound-p) + (--when-let (s-match "anaconda_mode port \\([0-9]+\\)" output) + (process-put anaconda-mode-process 'port (string-to-number (cadr it))) + (cond ((pythonic-remote-docker-p) + (let* ((container-raw-description (with-output-to-string + (with-current-buffer + standard-output + (call-process "docker" nil t nil "inspect" (pythonic-remote-host))))) + (container-description (let ((json-array-type 'list)) + (json-read-from-string container-raw-description))) + (container-ip (cdr (assoc 'IPAddress + (cdadr (assoc 'Networks + (cdr (assoc 'NetworkSettings + (car container-description))))))))) + (setq anaconda-mode-socat-process + (start-process anaconda-mode-socat-process-name + anaconda-mode-socat-process-buffer + "socat" + (format "TCP4-LISTEN:%d" (anaconda-mode-port)) + (format "TCP4:%s:%d" container-ip (anaconda-mode-port)))) + (set-process-query-on-exit-flag anaconda-mode-socat-process nil))) + ((pythonic-remote-ssh-p) + (let ((jump (anaconda-jump-proxy-string))) + (message (format "Anaconda Jump Proxy: %s" jump)) + (setq anaconda-mode-ssh-process + (if jump + (start-process anaconda-mode-ssh-process-name + anaconda-mode-ssh-process-buffer + "ssh" jump "-nNT" + "-L" (format "%s:localhost:%s" (anaconda-mode-port) (anaconda-mode-port)) + (format "%s@%s" (pythonic-remote-user) (pythonic-remote-host)) + "-p" (number-to-string (or (pythonic-remote-port) 22))) + (start-process anaconda-mode-ssh-process-name + anaconda-mode-ssh-process-buffer + "ssh" "-nNT" + "-L" (format "%s:localhost:%s" (anaconda-mode-port) (anaconda-mode-port)) + (format "%s@%s" (pythonic-remote-user) (pythonic-remote-host)) + "-p" (number-to-string (or (pythonic-remote-port) 22))))) + ;; prevent race condition between tunnel setup and first use + (sleep-for anaconda-mode-tunnel-setup-sleep) + (set-process-query-on-exit-flag anaconda-mode-ssh-process nil)))) + (when callback + (funcall callback))))) + + +;;; Interaction. + +(defun anaconda-mode-call (command callback) + "Make remote procedure call for COMMAND. +Apply CALLBACK to it result." + (anaconda-mode-start + (lambda () (anaconda-mode-jsonrpc command callback)))) + +(defun anaconda-mode-jsonrpc (command callback) + "Perform JSONRPC call for COMMAND. +Apply CALLBACK to the call result when retrieve it. Remote +COMMAND must expect four arguments: python buffer content, line +number position, column number position and file path." + (let ((url-request-method "POST") + (url-request-data (anaconda-mode-jsonrpc-request command))) + (url-retrieve + (format "http://%s:%s" anaconda-mode-localhost-address (anaconda-mode-port)) + (anaconda-mode-create-response-handler callback) + nil + t))) + +(defun anaconda-mode-jsonrpc-request (command) + "Prepare JSON encoded buffer data for COMMAND call." + (encode-coding-string (json-encode (anaconda-mode-jsonrpc-request-data command)) 'utf-8)) + +(defun anaconda-mode-jsonrpc-request-data (command) + "Prepare buffer data for COMMAND call." + `((jsonrpc . "2.0") + (id . 1) + (method . ,command) + (params . ((source . ,(buffer-substring-no-properties (point-min) (point-max))) + (line . ,(line-number-at-pos (point))) + (column . ,(- (point) (line-beginning-position))) + (path . ,(when (buffer-file-name) + (pythonic-python-readable-file-name (buffer-file-name)))))))) + +(defun anaconda-mode-create-response-handler (callback) + "Create server response handler based on CALLBACK function." + (let ((anaconda-mode-request-point (point)) + (anaconda-mode-request-buffer (current-buffer)) + (anaconda-mode-request-window (selected-window)) + (anaconda-mode-request-tick (buffer-chars-modified-tick))) + (lambda (status) + (let ((http-buffer (current-buffer))) + (unwind-protect + (if (or (not (equal anaconda-mode-request-window (selected-window))) + (with-current-buffer (window-buffer anaconda-mode-request-window) + (or (not (equal anaconda-mode-request-buffer (current-buffer))) + (not (equal anaconda-mode-request-point (point))) + (not (equal anaconda-mode-request-tick (buffer-chars-modified-tick)))))) + nil + (search-forward-regexp "\r?\n\r?\n" nil t) + (let ((response (condition-case nil + (json-read) + ((json-readtable-error json-end-of-file end-of-file) + (let ((response (concat (format "# status: %s\n# point: %s\n" status (point)) + (buffer-string)))) + (with-current-buffer (get-buffer-create anaconda-mode-response-buffer) + (erase-buffer) + (insert response) + (goto-char (point-min))) + nil))))) + (if (null response) + (message "Cannot read anaconda-mode server response") + (if (assoc 'error response) + (let* ((error-structure (cdr (assoc 'error response))) + (error-message (cdr (assoc 'message error-structure))) + (error-data (cdr (assoc 'data error-structure))) + (error-template (concat (if error-data "%s: %s" "%s") + " - see " anaconda-mode-process-buffer + " for more information."))) + (apply 'message error-template (delq nil (list error-message error-data)))) + (with-current-buffer anaconda-mode-request-buffer + (let ((result (cdr (assoc 'result response)))) + ;; Terminate `apply' call with empty list so response + ;; will be treated as single argument. + (apply callback result nil))))))) + (kill-buffer http-buffer)))))) + + +;;; Code completion. + +(defun anaconda-mode-complete () + "Request completion candidates." + (interactive) + (unless (python-syntax-comment-or-string-p) + (anaconda-mode-call "complete" 'anaconda-mode-complete-callback))) + +(defun anaconda-mode-complete-callback (result) + "Start interactive completion on RESULT receiving." + (let* ((bounds (bounds-of-thing-at-point 'symbol)) + (start (or (car bounds) (point))) + (stop (or (cdr bounds) (point))) + (collection (anaconda-mode-complete-extract-names result)) + (completion-extra-properties '(:annotation-function anaconda-mode-complete-annotation))) + (completion-in-region start stop collection))) + +(defun anaconda-mode-complete-extract-names (result) + "Extract completion names from `anaconda-mode' RESULT." + (--map (let ((name (aref it 0)) + (type (aref it 1))) + (put-text-property 0 1 'type type name) + name) + result)) + +(defun anaconda-mode-complete-annotation (candidate) + "Get annotation for CANDIDATE." + (--when-let (get-text-property 0 'type candidate) + (concat " <" it ">"))) + + +;;; View documentation. + +(defun anaconda-mode-show-doc () + "Show documentation for context at point." + (interactive) + (anaconda-mode-call "show_doc" 'anaconda-mode-show-doc-callback)) + +(defun anaconda-mode-show-doc-callback (result) + "Process view doc RESULT." + (if (> (length result) 0) + (if (and anaconda-mode-use-posframe-show-doc + (require 'posframe nil 'noerror) + (posframe-workable-p)) + (anaconda-mode-documentation-posframe-view result) + (pop-to-buffer (anaconda-mode-documentation-view result) t)) + (message "No documentation available"))) + +(defun anaconda-mode-documentation-view (result) + "Show documentation view for rpc RESULT, and return buffer." + (let ((buf (get-buffer-create "*Anaconda*"))) + (with-current-buffer buf + (view-mode -1) + (erase-buffer) + (mapc + (lambda (it) + (insert (propertize (aref it 0) 'face 'bold)) + (insert "\n") + (insert (s-trim-right (aref it 1))) + (insert "\n\n")) + result) + (view-mode 1) + (goto-char (point-min)) + buf))) + +(defun anaconda-mode-documentation-posframe-view (result) + "Show documentation view in posframe for rpc RESULT." + (with-current-buffer (get-buffer-create anaconda-mode-doc-frame-name) + (erase-buffer) + (mapc + (lambda (it) + (insert (propertize (aref it 0) 'face 'bold)) + (insert "\n") + (insert (s-trim-left (aref it 1))) + (insert "\n\n")) + result)) + (posframe-show anaconda-mode-doc-frame-name + :position (point) + :internal-border-width 10 + :background-color anaconda-mode-doc-frame-background + :foreground-color anaconda-mode-doc-frame-foreground) + (add-hook 'post-command-hook 'anaconda-mode-hide-frame) + (setq anaconda-mode-frame-last-point (point)) + (setq anaconda-mode-frame-last-scroll-offset (window-start))) + +(defun anaconda-mode-hide-frame () + "Hide posframe when window scroll or move point." + (ignore-errors + (when (get-buffer anaconda-mode-doc-frame-name) + (unless (and (equal (point) anaconda-mode-frame-last-point) + (equal (window-start) anaconda-mode-frame-last-scroll-offset)) + (posframe-hide anaconda-mode-doc-frame-name) + (remove-hook 'post-command-hook 'anaconda-mode-hide-frame))))) + + +;;; Find definitions. + +(defun anaconda-mode-find-definitions () + "Find definitions for thing at point." + (interactive) + (anaconda-mode-call + "goto_definitions" + (lambda (result) + (anaconda-mode-show-xrefs result nil "No definitions found")))) + +(defun anaconda-mode-find-definitions-other-window () + "Find definitions for thing at point." + (interactive) + (anaconda-mode-call + "goto_definitions" + (lambda (result) + (anaconda-mode-show-xrefs result 'window "No definitions found")))) + +(defun anaconda-mode-find-definitions-other-frame () + "Find definitions for thing at point." + (interactive) + (anaconda-mode-call + "goto_definitions" + (lambda (result) + (anaconda-mode-show-xrefs result 'frame "No definitions found")))) + + +;;; Find assignments. + +(defun anaconda-mode-find-assignments () + "Find assignments for thing at point." + (interactive) + (anaconda-mode-call + "goto_assignments" + (lambda (result) + (anaconda-mode-show-xrefs result nil "No assignments found")))) + +(defun anaconda-mode-find-assignments-other-window () + "Find assignments for thing at point." + (interactive) + (anaconda-mode-call + "goto_assignments" + (lambda (result) + (anaconda-mode-show-xrefs result 'window "No assignments found")))) + +(defun anaconda-mode-find-assignments-other-frame () + "Find assignments for thing at point." + (interactive) + (anaconda-mode-call + "goto_assignments" + (lambda (result) + (anaconda-mode-show-xrefs result 'frame "No assignments found")))) + + +;;; Find references. + +(defun anaconda-mode-find-references () + "Find references for thing at point." + (interactive) + (anaconda-mode-call + "usages" + (lambda (result) + (anaconda-mode-show-xrefs result nil "No references found")))) + +(defun anaconda-mode-find-references-other-window () + "Find references for thing at point." + (interactive) + (anaconda-mode-call + "usages" + (lambda (result) + (anaconda-mode-show-xrefs result 'window "No references found")))) + +(defun anaconda-mode-find-references-other-frame () + "Find references for thing at point." + (interactive) + (anaconda-mode-call + "usages" + (lambda (result) + (anaconda-mode-show-xrefs result 'frame "No references found")))) + + +;;; Xref. + +(defun anaconda-mode-show-xrefs (result display-action error-message) + "Show xref from RESULT using DISPLAY-ACTION. +Show ERROR-MESSAGE if result is empty." + (if result + (if (stringp result) + (message result) + (let ((xrefs (anaconda-mode-make-xrefs result))) + (if (not (cdr xrefs)) + (progn + (xref-push-marker-stack) + (funcall (if (fboundp 'xref-pop-to-location) + 'xref-pop-to-location + 'xref--pop-to-location) + (cl-first xrefs) + display-action)) + (xref--show-xrefs (if (functionp 'xref--create-fetcher) + (lambda (&rest _) xrefs) + xrefs) + display-action)))) + (message error-message))) + +(defun anaconda-mode-make-xrefs (result) + "Return a list of x-reference candidates created from RESULT." + (--map + (xref-make + (aref it 3) + (xref-make-file-location (pythonic-emacs-readable-file-name (aref it 0)) (aref it 1) (aref it 2))) + result)) + + +;;; Eldoc. + +(defun anaconda-mode-eldoc-function () + "Show eldoc for context at point." + (anaconda-mode-call "eldoc" 'anaconda-mode-eldoc-callback) + ;; Don't show response buffer name as ElDoc message. + nil) + +(defun anaconda-mode-eldoc-callback (result) + "Display eldoc from server RESULT." + (eldoc-message (anaconda-mode-eldoc-format result))) + +(defun anaconda-mode-eldoc-format (result) + "Format eldoc string from RESULT." + (when result + (let ((doc (anaconda-mode-eldoc-format-definition + (aref result 0) + (aref result 1) + (aref result 2)))) + (if anaconda-mode-eldoc-as-single-line + (substring doc 0 (min (frame-width) (length doc))) + doc)))) + +(defun anaconda-mode-eldoc-format-definition (name index params) + "Format function definition from NAME, INDEX and PARAMS." + (when index + (aset params index (propertize (aref params index) 'face 'eldoc-highlight-function-argument))) + (concat (propertize name 'face 'font-lock-function-name-face) "(" (mapconcat 'identity params ", ") ")")) + + +;;; Anaconda minor mode. + +(defvar anaconda-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-M-i") 'anaconda-mode-complete) + (define-key map (kbd "M-.") 'anaconda-mode-find-definitions) + (define-key map (kbd "C-x 4 .") 'anaconda-mode-find-definitions-other-window) + (define-key map (kbd "C-x 5 .") 'anaconda-mode-find-definitions-other-frame) + (define-key map (kbd "M-=") 'anaconda-mode-find-assignments) + (define-key map (kbd "C-x 4 =") 'anaconda-mode-find-assignments-other-window) + (define-key map (kbd "C-x 5 =") 'anaconda-mode-find-assignments-other-frame) + (define-key map (kbd "M-r") 'anaconda-mode-find-references) + (define-key map (kbd "C-x 4 r") 'anaconda-mode-find-references-other-window) + (define-key map (kbd "C-x 5 r") 'anaconda-mode-find-references-other-frame) + (define-key map (kbd "M-,") 'xref-pop-marker-stack) + (define-key map (kbd "M-?") 'anaconda-mode-show-doc) + map) + "Keymap for `anaconda-mode'.") + +;;;###autoload +(define-minor-mode anaconda-mode + "Code navigation, documentation lookup and completion for Python. + +\\{anaconda-mode-map}" + :lighter anaconda-mode-lighter + :keymap anaconda-mode-map + (setq-local url-http-attempt-keepalives nil)) + +;;;###autoload +(define-minor-mode anaconda-eldoc-mode + "Toggle echo area display of Python objects at point." + :lighter "" + (if anaconda-eldoc-mode + (turn-on-anaconda-eldoc-mode) + (turn-off-anaconda-eldoc-mode))) + +(defun turn-on-anaconda-eldoc-mode () + "Turn on `anaconda-eldoc-mode'." + (make-local-variable 'eldoc-documentation-function) + (setq-local eldoc-documentation-function 'anaconda-mode-eldoc-function) + (eldoc-mode +1)) + +(defun turn-off-anaconda-eldoc-mode () + "Turn off `anaconda-eldoc-mode'." + (kill-local-variable 'eldoc-documentation-function) + (eldoc-mode -1)) + +(provide 'anaconda-mode) + +;;; anaconda-mode.el ends here diff --git a/lisp/avy.el b/lisp/avy.el new file mode 100644 index 00000000..02d026ff --- /dev/null +++ b/lisp/avy.el @@ -0,0 +1,2226 @@ +;;; avy.el --- Jump to arbitrary positions in visible text and select text quickly. -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; URL: https://github.com/abo-abo/avy +;; Package-Version: 20200624.1148 +;; Package-Commit: bbf1e7339eba06784dfe86643bb0fbddf5bb0342 +;; Version: 0.5.0 +;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) +;; Keywords: point, location + +;; This file is 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 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. + +;; For a full copy of the GNU General Public License +;; see . + +;;; Commentary: +;; +;; With Avy, you can move point to any position in Emacs – even in a +;; different window – using very few keystrokes. For this, you look at +;; the position where you want point to be, invoke Avy, and then enter +;; the sequence of characters displayed at that position. +;; +;; If the position you want to jump to can be determined after only +;; issuing a single keystroke, point is moved to the desired position +;; immediately after that keystroke. In case this isn't possible, the +;; sequence of keystrokes you need to enter is comprised of more than +;; one character. Avy uses a decision tree where each candidate position +;; is a leaf and each edge is described by a character which is distinct +;; per level of the tree. By entering those characters, you navigate the +;; tree, quickly arriving at the desired candidate position, such that +;; Avy can move point to it. +;; +;; Note that this only makes sense for positions you are able to see +;; when invoking Avy. These kinds of positions are supported: +;; +;; * character positions +;; * word or subword start positions +;; * line beginning positions +;; * link positions +;; * window positions +;; +;; If you're familiar with the popular `ace-jump-mode' package, this +;; package does all that and more, without the implementation +;; headache. + +;;; Code: +(require 'cl-lib) +(require 'ring) + +;;* Customization +(defgroup avy nil + "Jump to things tree-style." + :group 'convenience + :prefix "avy-") + +(defcustom avy-keys '(?a ?s ?d ?f ?g ?h ?j ?k ?l) + "Default keys for jumping. +Any key is either a character representing a self-inserting +key (letters, digits, punctuation, etc.) or a symbol denoting a +non-printing key like an arrow key (left, right, up, down). For +non-printing keys, a corresponding entry in +`avy-key-to-char-alist' must exist in order to visualize the key +in the avy overlays. + +If `avy-style' is set to words, make sure there are at least three +keys different than the following: a, e, i, o, u, y" + :type '(repeat :tag "Keys" (choice + (character :tag "char") + (symbol :tag "non-printing key")))) + +(defconst avy--key-type + '(choice :tag "Command" + (const avy-goto-char) + (const avy-goto-char-2) + (const avy-isearch) + (const avy-goto-line) + (const avy-goto-subword-0) + (const avy-goto-subword-1) + (const avy-goto-word-0) + (const avy-goto-word-1) + (const avy-copy-line) + (const avy-copy-region) + (const avy-move-line) + (const avy-move-region) + (const avy-kill-whole-line) + (const avy-kill-region) + (const avy-kill-ring-save-whole-line) + (const avy-kill-ring-save-region) + (function :tag "Other command"))) + +(defcustom avy-keys-alist nil + "Alist of avy-jump commands to `avy-keys' overriding the default `avy-keys'." + :type `(alist + :key-type ,avy--key-type + :value-type (repeat :tag "Keys" character))) + +(defcustom avy-orders-alist '((avy-goto-char . avy-order-closest)) + "Alist of candidate ordering functions. +Usually, candidates appear in their point position order." + :type `(alist + :key-type ,avy--key-type + :value-type function)) + +(defcustom avy-words + '("am" "by" "if" "is" "it" "my" "ox" "up" + "ace" "act" "add" "age" "ago" "aim" "air" "ale" "all" "and" "ant" "any" + "ape" "apt" "arc" "are" "arm" "art" "ash" "ate" "awe" "axe" "bad" "bag" + "ban" "bar" "bat" "bay" "bed" "bee" "beg" "bet" "bid" "big" "bit" "bob" + "bot" "bow" "box" "boy" "but" "cab" "can" "cap" "car" "cat" "cog" "cop" + "cow" "cry" "cup" "cut" "day" "dew" "did" "die" "dig" "dim" "dip" "dog" + "dot" "dry" "dub" "dug" "dye" "ear" "eat" "eel" "egg" "ego" "elf" "eve" + "eye" "fan" "far" "fat" "fax" "fee" "few" "fin" "fit" "fix" "flu" "fly" + "foe" "fog" "for" "fox" "fry" "fun" "fur" "gag" "gap" "gas" "gel" "gem" + "get" "gig" "gin" "gnu" "god" "got" "gum" "gun" "gut" "guy" "gym" "had" + "hag" "ham" "has" "hat" "her" "hid" "him" "hip" "his" "hit" "hop" "hot" + "how" "hub" "hue" "hug" "hut" "ice" "icy" "imp" "ink" "inn" "ion" "ire" + "ivy" "jab" "jam" "jar" "jaw" "jet" "job" "jog" "joy" "key" "kid" "kit" + "lag" "lap" "lay" "let" "lid" "lie" "lip" "lit" "lob" "log" "lot" "low" + "mad" "man" "map" "mat" "may" "men" "met" "mix" "mob" "mop" "mud" "mug" + "nag" "nap" "new" "nil" "nod" "nor" "not" "now" "nun" "oak" "odd" "off" + "oil" "old" "one" "orb" "ore" "ork" "our" "out" "owl" "own" "pad" "pan" + "par" "pat" "paw" "pay" "pea" "pen" "pet" "pig" "pin" "pit" "pod" "pot" + "pry" "pub" "pun" "put" "rag" "ram" "ran" "rat" "raw" "ray" "red" "rib" + "rim" "rip" "rob" "rod" "rot" "row" "rub" "rug" "rum" "run" "sad" "sat" + "saw" "say" "sea" "see" "sew" "she" "shy" "sin" "sip" "sit" "six" "ski" + "sky" "sly" "sob" "son" "soy" "spy" "sum" "sun" "tab" "tad" "tag" "tan" + "tap" "tar" "tax" "tea" "the" "tie" "tin" "tip" "toe" "ton" "too" "top" + "toy" "try" "tub" "two" "urn" "use" "van" "war" "was" "wax" "way" "web" + "wed" "wet" "who" "why" "wig" "win" "wit" "woe" "won" "wry" "you" "zap" + "zip" "zoo") + "Words to use in case `avy-style' is set to `words'. +Every word should contain at least one vowel i.e. one of the following +characters: a, e, i, o, u, y +They do not have to be sorted but no word should be a prefix of another one." + :type '(repeat string)) + +(defcustom avy-style 'at-full + "The default method of displaying the overlays. +Use `avy-styles-alist' to customize this per-command." + :type '(choice + (const :tag "Pre" pre) + (const :tag "At" at) + (const :tag "At Full" at-full) + (const :tag "Post" post) + (const :tag "De Bruijn" de-bruijn) + (const :tag "Words" words))) + +(defcustom avy-styles-alist nil + "Alist of avy-jump commands to the style for each command. +If the commands isn't on the list, `avy-style' is used." + :type '(alist + :key-type (choice :tag "Command" + (const avy-goto-char) + (const avy-goto-char-2) + (const avy-isearch) + (const avy-goto-line) + (const avy-goto-subword-0) + (const avy-goto-subword-1) + (const avy-goto-word-0) + (const avy-goto-word-1) + (const avy-copy-line) + (const avy-copy-region) + (const avy-move-line) + (const avy-move-region) + (const avy-kill-whole-line) + (const avy-kill-region) + (const avy-kill-ring-save-whole-line) + (const avy-kill-ring-save-region) + (function :tag "Other command")) + :value-type (choice + (const :tag "Pre" pre) + (const :tag "At" at) + (const :tag "At Full" at-full) + (const :tag "Post" post) + (const :tag "De Bruijn" de-bruijn) + (const :tag "Words" words)))) + +(defcustom avy-dispatch-alist + '((?x . avy-action-kill-move) + (?X . avy-action-kill-stay) + (?t . avy-action-teleport) + (?m . avy-action-mark) + (?n . avy-action-copy) + (?y . avy-action-yank) + (?Y . avy-action-yank-line) + (?i . avy-action-ispell) + (?z . avy-action-zap-to-char)) + "List of actions for `avy-handler-default'. + +Each item is (KEY . ACTION). When KEY not on `avy-keys' is +pressed during the dispatch, ACTION is set to replace the default +`avy-action-goto' once a candidate is finally selected." + :type + '(alist + :key-type (choice (character :tag "Char")) + :value-type (choice + (const :tag "Mark" avy-action-mark) + (const :tag "Copy" avy-action-copy) + (const :tag "Kill and move point" avy-action-kill-move) + (const :tag "Kill" avy-action-kill-stay)))) + +(defcustom avy-background nil + "When non-nil, a gray background will be added during the selection." + :type 'boolean) + +(defcustom avy-all-windows t + "Determine the list of windows to consider in search of candidates." + :type + '(choice + (const :tag "All Frames" all-frames) + (const :tag "This Frame" t) + (const :tag "This Window" nil))) + +(defcustom avy-case-fold-search t + "Non-nil if searches should ignore case." + :type 'boolean) + +(defcustom avy-word-punc-regexp "[!-/:-@[-`{-~]" + "Regexp of punctuation chars that count as word starts for `avy-goto-word-1. +When nil, punctuation chars will not be matched. + +\"[!-/:-@[-`{-~]\" will match all printable punctuation chars." + :type 'regexp) + +(defcustom avy-goto-word-0-regexp "\\b\\sw" + "Regexp that determines positions for `avy-goto-word-0'." + :type '(choice + (const :tag "Default" "\\b\\sw") + (const :tag "Symbol" "\\_<\\(\\sw\\|\\s_\\)") + (const :tag "Not whitespace" "[^ \r\n\t]+") + (regexp :tag "Regex"))) + +(defcustom avy-ignored-modes '(image-mode doc-view-mode pdf-view-mode) + "List of modes to ignore when searching for candidates. +Typically, these modes don't use the text representation." + :type 'list) + +(defcustom avy-single-candidate-jump t + "In case there is only one candidate jumps directly to it." + :type 'boolean) + +(defcustom avy-del-last-char-by '(?\b ?\d) + "List of event types, i.e. key presses, that delete the last +character read. The default represents `C-h' and `DEL'. See +`event-convert-list'." + :type 'list) + +(defcustom avy-escape-chars '(?\e ?\C-g) + "List of characters that quit avy during `read-char'." + :type 'list) + +(defvar avy-ring (make-ring 20) + "Hold the window and point history.") + +(defvar avy-translate-char-function #'identity + "Function to translate user input key into another key. +For example, to make SPC do the same as ?a, use +\(lambda (c) (if (= c 32) ?a c)).") + +(defface avy-lead-face-0 + '((t (:foreground "white" :background "#4f57f9"))) + "Face used for first non-terminating leading chars.") + +(defface avy-lead-face-1 + '((t (:foreground "white" :background "gray"))) + "Face used for matched leading chars.") + +(defface avy-lead-face-2 + '((t (:foreground "white" :background "#f86bf3"))) + "Face used for leading chars.") + +(defface avy-lead-face + '((t (:foreground "white" :background "#e52b50"))) + "Face used for the leading chars.") + +(defface avy-background-face + '((t (:foreground "gray40"))) + "Face for whole window background during selection.") + +(defface avy-goto-char-timer-face + '((t (:inherit highlight))) + "Face for matches during reading chars using `avy-goto-char-timer'.") + +(defconst avy-lead-faces '(avy-lead-face + avy-lead-face-0 + avy-lead-face-2 + avy-lead-face + avy-lead-face-0 + avy-lead-face-2) + "Face sequence for `avy--overlay-at-full'.") + +(defvar avy-key-to-char-alist '((left . ?◀) + (right . ?▶) + (up . ?▲) + (down . ?▼) + (prior . ?△) + (next . ?▽)) + "An alist from non-character keys to printable chars used in avy overlays. +This alist must contain all keys used in `avy-keys' which are not +self-inserting keys and thus aren't read as characters.") + +;;* Internals +;;** Tree +(defmacro avy-multipop (lst n) + "Remove LST's first N elements and return them." + `(if (<= (length ,lst) ,n) + (prog1 ,lst + (setq ,lst nil)) + (prog1 ,lst + (setcdr + (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst)))) + nil)))) + +(defun avy--de-bruijn (keys n) + "De Bruijn sequence for alphabet KEYS and subsequences of length N." + (let* ((k (length keys)) + (a (make-list (* n k) 0)) + sequence) + (cl-labels ((db (T p) + (if (> T n) + (if (eq (% n p) 0) + (setq sequence + (append sequence + (cl-subseq a 1 (1+ p))))) + (setf (nth T a) (nth (- T p) a)) + (db (1+ T) p) + (cl-loop for j from (1+ (nth (- T p) a)) to (1- k) do + (setf (nth T a) j) + (db (1+ T) T))))) + (db 1 1) + (mapcar (lambda (n) + (nth n keys)) + sequence)))) + +(defun avy--path-alist-1 (lst seq-len keys) + "Build a De Bruin sequence from LST. +SEQ-LEN is how many elements of KEYS it takes to identify a match." + (let ((db-seq (avy--de-bruijn keys seq-len)) + prev-pos prev-seq prev-win path-alist) + ;; The De Bruijn seq is cyclic, so append the seq-len - 1 first chars to + ;; the end. + (setq db-seq (nconc db-seq (cl-subseq db-seq 0 (1- seq-len)))) + (cl-labels ((subseq-and-pop () + (when (nth (1- seq-len) db-seq) + (prog1 (cl-subseq db-seq 0 seq-len) + (pop db-seq))))) + (while lst + (let* ((cur (car lst)) + (pos (cond + ;; ace-window has matches of the form (pos . wnd) + ((integerp (car cur)) (car cur)) + ;; avy-jump have form ((start . end) . wnd) + ((consp (car cur)) (caar cur)) + (t (error "Unexpected match representation: %s" cur)))) + (win (cdr cur)) + (path (if prev-pos + (let ((diff (if (eq win prev-win) + (- pos prev-pos) + 0))) + (when (and (> diff 0) (< diff seq-len)) + (while (and (nth (1- seq-len) db-seq) + (not + (eq 0 + (cl-search + (cl-subseq prev-seq diff) + (cl-subseq db-seq 0 seq-len))))) + (pop db-seq))) + (subseq-and-pop)) + (subseq-and-pop)))) + (if (not path) + (setq lst nil + path-alist nil) + (push (cons path (car lst)) path-alist) + (setq prev-pos pos + prev-seq path + prev-win win + lst (cdr lst)))))) + (nreverse path-alist))) + +(defun avy-order-closest (x) + (abs (- (if (numberp (car x)) + (car x) + (caar x)) + (point)))) + +(defvar avy-command nil + "Store the current command symbol. +E.g. 'avy-goto-line or 'avy-goto-char.") + +(defun avy-tree (lst keys) + "Coerce LST into a balanced tree. +The degree of the tree is the length of KEYS. +KEYS are placed appropriately on internal nodes." + (let* ((len (length keys)) + (order-fn (cdr (assq avy-command avy-orders-alist))) + (lst (if order-fn + (cl-sort lst #'< :key order-fn) + lst))) + (cl-labels + ((rd (ls) + (let ((ln (length ls))) + (if (< ln len) + (cl-pairlis keys + (mapcar (lambda (x) (cons 'leaf x)) ls)) + (let ((ks (copy-sequence keys)) + res) + (dolist (s (avy-subdiv ln len)) + (push (cons (pop ks) + (if (eq s 1) + (cons 'leaf (pop ls)) + (rd (avy-multipop ls s)))) + res)) + (nreverse res)))))) + (rd lst)))) + +(defun avy-subdiv (n b) + "Distribute N in B terms in a balanced way." + (let* ((p (1- (floor (+ (log n b) 1e-6)))) + (x1 (expt b p)) + (x2 (* b x1)) + (delta (- n x2)) + (n2 (/ delta (- x2 x1))) + (n1 (- b n2 1))) + (append + (make-list n1 x1) + (list + (- n (* n1 x1) (* n2 x2))) + (make-list n2 x2)))) + +(defun avy-traverse (tree walker &optional recur-key) + "Traverse TREE generated by `avy-tree'. +WALKER is a function that takes KEYS and LEAF. + +RECUR-KEY is used in recursion. + +LEAF is a member of LST argument of `avy-tree'. + +KEYS is the path from the root of `avy-tree' to LEAF." + (dolist (br tree) + (let ((key (cons (car br) recur-key))) + (if (eq (cadr br) 'leaf) + (funcall walker key (cddr br)) + (avy-traverse (cdr br) walker key))))) + +(defvar avy-action nil + "Function to call at the end of select.") + +(defun avy-handler-default (char) + "The default handler for a bad CHAR." + (let (dispatch) + (cond ((setq dispatch (assoc char avy-dispatch-alist)) + (unless (eq avy-style 'words) + (setq avy-action (cdr dispatch))) + (throw 'done 'restart)) + ((memq char avy-escape-chars) + ;; exit silently + (throw 'done 'abort)) + ((eq char ??) + (avy-show-dispatch-help) + (throw 'done 'restart)) + ((mouse-event-p char) + (signal 'user-error (list "Mouse event not handled" char))) + (t + (message "No such candidate: %s, hit `C-g' to quit." + (if (characterp char) (string char) char)))))) + +(defun avy-show-dispatch-help () + "Display action shortucts in echo area." + (let ((len (length "avy-action-"))) + (message "%s" (mapconcat + (lambda (x) + (format "%s: %s" + (propertize + (char-to-string (car x)) + 'face 'aw-key-face) + (substring (symbol-name (cdr x)) len))) + avy-dispatch-alist + " ")))) + +(defvar avy-handler-function 'avy-handler-default + "A function to call for a bad `read-key' in `avy-read'.") + +(defvar avy-current-path "" + "Store the current incomplete path during `avy-read'.") + +(defun avy-mouse-event-window (char) + "If CHAR is a mouse event, return the window of the event if any or the selected window. +Return nil if not a mouse event." + (when (mouse-event-p char) + (cond ((windowp (posn-window (event-start char))) + (posn-window (event-start char))) + ((framep (posn-window (event-start char))) + (frame-selected-window (posn-window (event-start char)))) + (t (selected-window))))) + +(defun avy-read (tree display-fn cleanup-fn) + "Select a leaf from TREE using consecutive `read-key'. + +DISPLAY-FN should take CHAR and LEAF and signify that LEAFs +associated with CHAR will be selected if CHAR is pressed. This is +commonly done by adding a CHAR overlay at LEAF position. + +CLEANUP-FN should take no arguments and remove the effects of +multiple DISPLAY-FN invocations." + (catch 'done + (setq avy-current-path "") + (while tree + (let ((avy--leafs nil)) + (avy-traverse tree + (lambda (path leaf) + (push (cons path leaf) avy--leafs))) + (dolist (x avy--leafs) + (funcall display-fn (car x) (cdr x)))) + (let ((char (funcall avy-translate-char-function (read-key))) + window + branch) + (funcall cleanup-fn) + (if (setq window (avy-mouse-event-window char)) + (throw 'done (cons char window)) + (if (setq branch (assoc char tree)) + (progn + ;; Ensure avy-current-path stores the full path prior to + ;; exit so other packages can utilize its value. + (setq avy-current-path + (concat avy-current-path (string (avy--key-to-char char)))) + (if (eq (car (setq tree (cdr branch))) 'leaf) + (throw 'done (cdr tree)))) + (funcall avy-handler-function char))))))) + +(defun avy-read-de-bruijn (lst keys) + "Select from LST dispatching on KEYS." + ;; In theory, the De Bruijn sequence B(k,n) has k^n subsequences of length n + ;; (the path length) usable as paths, thus that's the lower bound. Due to + ;; partially overlapping matches, not all subsequences may be usable, so it's + ;; possible that the path-len must be incremented, e.g., if we're matching + ;; for x and a buffer contains xaxbxcx only every second subsequence is + ;; usable for the four matches. + (catch 'done + (let* ((path-len (ceiling (log (length lst) (length keys)))) + (alist (avy--path-alist-1 lst path-len keys))) + (while (not alist) + (cl-incf path-len) + (setq alist (avy--path-alist-1 lst path-len keys))) + (let* ((len (length (caar alist))) + (i 0)) + (setq avy-current-path "") + (while (< i len) + (dolist (x (reverse alist)) + (avy--overlay-at-full (reverse (car x)) (cdr x))) + (let ((char (funcall avy-translate-char-function (read-key)))) + (avy--remove-leading-chars) + (setq alist + (delq nil + (mapcar (lambda (x) + (when (eq (caar x) char) + (cons (cdr (car x)) (cdr x)))) + alist))) + (setq avy-current-path + (concat avy-current-path (string (avy--key-to-char char)))) + (cl-incf i) + (unless alist + (funcall avy-handler-function char)))) + (cdar alist))))) + +(defun avy-read-words (lst words) + "Select from LST using WORDS." + (catch 'done + (let ((num-words (length words)) + (num-entries (length lst)) + alist) + ;; If there are not enough words to cover all the candidates, + ;; we use a De Bruijn sequence to generate the remaining ones. + (when (< num-words num-entries) + (let ((keys avy-keys) + (bad-keys '(?a ?e ?i ?o ?u ?y)) + (path-len 1) + (num-remaining (- num-entries num-words)) + tmp-alist) + ;; Delete all keys which could lead to duplicates. + ;; We want at least three keys left to work with. + (dolist (x bad-keys) + (when (memq x keys) + (setq keys (delq ?a keys)))) + (when (< (length keys) 3) + (signal 'user-error + '("Please add more keys to the variable `avy-keys'."))) + ;; Generate the sequence and add the keys to the existing words. + (while (not tmp-alist) + (cl-incf path-len) + (setq tmp-alist (avy--path-alist-1 lst path-len keys))) + (while (>= (cl-decf num-remaining) 0) + (push (mapconcat 'string (caar tmp-alist) nil) (cdr (last words))) + (setq tmp-alist (cdr tmp-alist))))) + (dolist (x lst) + (push (cons (string-to-list (pop words)) x) alist)) + (setq avy-current-path "") + (while (or (> (length alist) 1) + (caar alist)) + (dolist (x (reverse alist)) + (avy--overlay-at-full (reverse (car x)) (cdr x))) + (let ((char (funcall avy-translate-char-function (read-key)))) + (avy--remove-leading-chars) + (setq alist + (delq nil + (mapcar (lambda (x) + (when (eq (caar x) char) + (cons (cdr (car x)) (cdr x)))) + alist))) + (setq avy-current-path + (concat avy-current-path (string (avy--key-to-char char)))) + (unless alist + (funcall avy-handler-function char)))) + (cdar alist)))) + +;;** Rest +(defun avy-window-list () + "Return a list of windows depending on `avy-all-windows'." + (cond ((eq avy-all-windows 'all-frames) + (cl-mapcan #'window-list (frame-list))) + + ((eq avy-all-windows t) + (window-list)) + + ((null avy-all-windows) + (list (selected-window))) + + (t + (error "Unrecognized option: %S" avy-all-windows)))) + +(defcustom avy-all-windows-alt nil + "The alternative `avy-all-windows' for use with \\[universal-argument]." + :type '(choice + (const :tag "Current window" nil) + (const :tag "All windows on the current frame" t) + (const :tag "All windows on all frames" all-frames))) + +(defmacro avy-dowindows (flip &rest body) + "Depending on FLIP and `avy-all-windows' run BODY in each or selected window." + (declare (indent 1) + (debug (form body))) + `(let ((avy-all-windows (if ,flip + avy-all-windows-alt + avy-all-windows))) + (dolist (wnd (avy-window-list)) + (with-selected-window wnd + (unless (memq major-mode avy-ignored-modes) + ,@body))))) + +(defun avy-resume () + "Stub to hold last avy command. +Commands using `avy-with' macro can be resumed." + (interactive)) + +(defmacro avy-with (command &rest body) + "Set `avy-keys' according to COMMAND and execute BODY. +Set `avy-style' according to COMMAND as well." + (declare (indent 1) + (debug (form body))) + `(let ((avy-keys (or (cdr (assq ',command avy-keys-alist)) + avy-keys)) + (avy-style (or (cdr (assq ',command avy-styles-alist)) + avy-style)) + (avy-command ',command)) + (setq avy-action nil) + (setf (symbol-function 'avy-resume) + (lambda () + (interactive) + ,@(if (eq command 'avy-goto-char-timer) + (cdr body) + body))) + ,@body)) + +(defun avy-action-goto (pt) + "Goto PT." + (let ((frame (window-frame (selected-window)))) + (unless (equal frame (selected-frame)) + (select-frame-set-input-focus frame) + (raise-frame frame)) + (goto-char pt))) + +(defun avy-forward-item () + (if (eq avy-command 'avy-goto-line) + (end-of-line) + (forward-sexp)) + (point)) + +(defun avy-action-mark (pt) + "Mark sexp at PT." + (goto-char pt) + (set-mark (point)) + (avy-forward-item)) + +(defun avy-action-copy (pt) + "Copy sexp starting on PT." + (save-excursion + (let (str) + (goto-char pt) + (avy-forward-item) + (setq str (buffer-substring pt (point))) + (kill-new str) + (message "Copied: %s" str))) + (let ((dat (ring-ref avy-ring 0))) + (select-frame-set-input-focus + (window-frame (cdr dat))) + (select-window (cdr dat)) + (goto-char (car dat)))) + +(defun avy-action-yank (pt) + "Yank sexp starting at PT at the current point." + (avy-action-copy pt) + (yank) + t) + +(defun avy-action-yank-line (pt) + "Yank sexp starting at PT at the current point." + (let ((avy-command 'avy-goto-line)) + (avy-action-yank pt))) + +(defun avy-action-kill-move (pt) + "Kill sexp at PT and move there." + (goto-char pt) + (avy-forward-item) + (kill-region pt (point)) + (message "Killed: %s" (current-kill 0)) + (point)) + +(defun avy-action-kill-stay (pt) + "Kill sexp at PT." + (save-excursion + (goto-char pt) + (avy-forward-item) + (kill-region pt (point)) + (just-one-space)) + (message "Killed: %s" (current-kill 0)) + (select-window + (cdr + (ring-ref avy-ring 0))) + t) + +(defun avy-action-zap-to-char (pt) + "Kill from point up to PT." + (if (> pt (point)) + (kill-region (point) pt) + (kill-region pt (point)))) + +(defun avy-action-teleport (pt) + "Kill sexp starting on PT and yank into the current location." + (avy-action-kill-stay pt) + (select-window + (cdr + (ring-ref avy-ring 0))) + (save-excursion + (yank)) + t) + +(declare-function flyspell-correct-word-before-point "flyspell") + +(defcustom avy-flyspell-correct-function #'flyspell-correct-word-before-point + "Function called to correct word by `avy-action-ispell' when +`flyspell-mode' is enabled." + :type 'function) + +(defun avy-action-ispell (pt) + "Auto correct word at PT." + (save-excursion + (goto-char pt) + (cond + ((eq avy-command 'avy-goto-line) + (ispell-region + (line-beginning-position) + (line-end-position))) + ((bound-and-true-p flyspell-mode) + (funcall avy-flyspell-correct-function)) + ((looking-at-p "\\b") + (ispell-word)) + (t + (progn + (backward-word) + (when (looking-at-p "\\b") + (ispell-word))))))) + +(defvar avy-pre-action #'avy-pre-action-default + "Function to call before `avy-action' is called.") + +(defun avy-pre-action-default (res) + (avy-push-mark) + (when (and (consp res) + (windowp (cdr res))) + (let* ((window (cdr res)) + (frame (window-frame window))) + (unless (equal frame (selected-frame)) + (select-frame-set-input-focus frame)) + (select-window window)))) + +(defun avy--process-1 (candidates overlay-fn &optional cleanup-fn) + (let ((len (length candidates))) + (cond ((= len 0) + nil) + ((and (= len 1) avy-single-candidate-jump) + (car candidates)) + (t + (unwind-protect + (progn + (avy--make-backgrounds + (avy-window-list)) + (cond ((eq avy-style 'de-bruijn) + (avy-read-de-bruijn + candidates avy-keys)) + ((eq avy-style 'words) + (avy-read-words + candidates avy-words)) + (t + (avy-read (avy-tree candidates avy-keys) + overlay-fn + (or cleanup-fn #'avy--remove-leading-chars))))) + (avy--done)))))) + +(defvar avy-last-candidates nil + "Store the last candidate list.") + +(defun avy--last-candidates-cycle (advancer) + (let* ((avy-last-candidates + (cl-remove-if-not + (lambda (x) (equal (cdr x) (selected-window))) + avy-last-candidates)) + (min-dist + (apply #'min + (mapcar (lambda (x) (abs (- (caar x) (point)))) avy-last-candidates))) + (pos + (cl-position-if + (lambda (x) + (= (- (caar x) (point)) min-dist)) + avy-last-candidates))) + (funcall advancer pos avy-last-candidates))) + +(defun avy-prev () + "Go to the previous candidate of the last `avy-read'." + (interactive) + (avy--last-candidates-cycle + (lambda (pos lst) + (when (> pos 0) + (goto-char (caar (nth (1- pos) lst))))))) + +(defun avy-next () + "Go to the next candidate of the last `avy-read'." + (interactive) + (avy--last-candidates-cycle + (lambda (pos lst) + (when (< pos (1- (length lst))) + (goto-char (caar (nth (1+ pos) lst))))))) + +;;;###autoload +(defun avy-process (candidates &optional overlay-fn cleanup-fn) + "Select one of CANDIDATES using `avy-read'. +Use OVERLAY-FN to visualize the decision overlay. +CLEANUP-FN should take no arguments and remove the effects of +multiple OVERLAY-FN invocations." + (setq overlay-fn (or overlay-fn (avy--style-fn avy-style))) + (setq cleanup-fn (or cleanup-fn #'avy--remove-leading-chars)) + (unless (and (consp (car candidates)) + (windowp (cdar candidates))) + (setq candidates + (mapcar (lambda (x) (cons x (selected-window))) + candidates))) + (setq avy-last-candidates (copy-sequence candidates)) + (let ((original-cands (copy-sequence candidates)) + (res (avy--process-1 candidates overlay-fn cleanup-fn))) + (cond + ((null res) + (if (and (eq avy-style 'words) candidates) + (avy-process original-cands overlay-fn cleanup-fn) + (message "zero candidates") + t)) + ((eq res 'restart) + (avy-process original-cands overlay-fn cleanup-fn)) + ;; ignore exit from `avy-handler-function' + ((eq res 'exit)) + ((eq res 'abort) + nil) + (t + (funcall avy-pre-action res) + (setq res (car res)) + (funcall (or avy-action 'avy-action-goto) + (if (consp res) + (car res) + res)) + res)))) + +(define-obsolete-function-alias 'avy--process 'avy-process + "0.4.0") + +(defvar avy--overlays-back nil + "Hold overlays for when `avy-background' is t.") + +(defun avy--make-backgrounds (wnd-list) + "Create a dim background overlay for each window on WND-LIST." + (when avy-background + (setq avy--overlays-back + (mapcar (lambda (w) + (let ((ol (make-overlay + (window-start w) + (window-end w) + (window-buffer w)))) + (overlay-put ol 'face 'avy-background-face) + (overlay-put ol 'window w) + ol)) + wnd-list)))) + +(defun avy--done () + "Clean up overlays." + (mapc #'delete-overlay avy--overlays-back) + (setq avy--overlays-back nil) + (avy--remove-leading-chars)) + +(defun avy--visible-p (s) + (let ((invisible (get-char-property s 'invisible))) + (or (null invisible) + (eq t buffer-invisibility-spec) + (null (assoc invisible buffer-invisibility-spec))))) + +(defun avy--next-visible-point () + "Return the next closest point without 'invisible property." + (let ((s (point))) + (while (and (not (= (point-max) (setq s (next-char-property-change s)))) + (not (avy--visible-p s)))) + s)) + +(defun avy--next-invisible-point () + "Return the next closest point with 'invisible property." + (let ((s (point))) + (while (and (not (= (point-max) (setq s (next-char-property-change s)))) + (avy--visible-p s))) + s)) + +(defun avy--find-visible-regions (rbeg rend) + "Return a list of all visible regions between RBEG and REND." + (setq rbeg (max rbeg (point-min))) + (setq rend (min rend (point-max))) + (when (< rbeg rend) + (let (visibles beg) + (save-excursion + (save-restriction + (narrow-to-region rbeg rend) + (setq beg (goto-char (point-min))) + (while (not (= (point) (point-max))) + (goto-char (avy--next-invisible-point)) + (push (cons beg (point)) visibles) + (setq beg (goto-char (avy--next-visible-point)))) + (nreverse visibles)))))) + +(defun avy--regex-candidates (regex &optional beg end pred group) + "Return all elements that match REGEX. +Each element of the list is ((BEG . END) . WND) +When PRED is non-nil, it's a filter for matching point positions. +When GROUP is non-nil, (BEG . END) should delimit that regex group." + (setq group (or group 0)) + (let ((case-fold-search (or avy-case-fold-search + (string= regex (downcase regex)))) + candidates) + (avy-dowindows current-prefix-arg + (dolist (pair (avy--find-visible-regions + (or beg (window-start)) + (or end (window-end (selected-window) t)))) + (save-excursion + (goto-char (car pair)) + (while (re-search-forward regex (cdr pair) t) + (when (avy--visible-p (1- (point))) + (when (or (null pred) + (funcall pred)) + (push (cons + (if (numberp group) + (cons (match-beginning group) + (match-end group)) + (funcall group)) + wnd) candidates))))))) + (nreverse candidates))) + +(defvar avy--overlay-offset 0 + "The offset to apply in `avy--overlay'.") + +(defvar avy--overlays-lead nil + "Hold overlays for leading chars.") + +(defun avy--remove-leading-chars () + "Remove leading char overlays." + (mapc #'delete-overlay avy--overlays-lead) + (setq avy--overlays-lead nil)) + +(defun avy--old-str (pt wnd) + "Return a one-char string at PT in WND." + (let ((old-str (with-selected-window wnd + (buffer-substring pt (1+ pt))))) + (if avy-background + (propertize old-str 'face 'avy-background-face) + old-str))) + +(defun avy--overlay (str beg end wnd &optional compose-fn) + "Create an overlay with STR from BEG to END in WND. +COMPOSE-FN is a lambda that concatenates the old string at BEG with STR." + (let ((eob (with-selected-window wnd (point-max)))) + (when (<= beg eob) + (let* ((beg (+ beg avy--overlay-offset)) + (ol (make-overlay beg (or end (1+ beg)) (window-buffer wnd))) + (old-str (if (eq beg eob) "" (avy--old-str beg wnd))) + (os-line-prefix (get-text-property 0 'line-prefix old-str)) + (os-wrap-prefix (get-text-property 0 'wrap-prefix old-str)) + other-ol) + (when os-line-prefix + (add-text-properties 0 1 `(line-prefix ,os-line-prefix) str)) + (when os-wrap-prefix + (add-text-properties 0 1 `(wrap-prefix ,os-wrap-prefix) str)) + (when (setq other-ol (cl-find-if + (lambda (o) (overlay-get o 'goto-address)) + (overlays-at beg))) + (add-text-properties + 0 (length old-str) + `(face ,(overlay-get other-ol 'face)) old-str)) + (overlay-put ol 'window wnd) + (overlay-put ol 'category 'avy) + (overlay-put ol (if (eq beg eob) + 'after-string + 'display) + (funcall + (or compose-fn #'concat) + str old-str)) + (push ol avy--overlays-lead))))) + +(defcustom avy-highlight-first nil + "When non-nil highlight the first decision char with `avy-lead-face-0'. +Do this even when the char is terminating." + :type 'boolean) + +(defun avy--key-to-char (c) + "If C is no character, translate it using `avy-key-to-char-alist'." + (cond ((characterp c) c) + ((cdr (assoc c avy-key-to-char-alist))) + ((mouse-event-p c) c) + (t + (error "Unknown key %s" c)))) + +(defun avy-candidate-beg (leaf) + "Return the start position for LEAF." + (cond ((numberp leaf) + leaf) + ((consp (car leaf)) + (caar leaf)) + (t + (car leaf)))) + +(defun avy-candidate-end (leaf) + "Return the end position for LEAF." + (cond ((numberp leaf) + leaf) + ((consp (car leaf)) + (cdar leaf)) + (t + (car leaf)))) + +(defun avy-candidate-wnd (leaf) + "Return the window for LEAF." + (if (consp leaf) + (cdr leaf) + (selected-window))) + +(defun avy--overlay-pre (path leaf) + "Create an overlay with PATH at LEAF. +PATH is a list of keys from tree root to LEAF. +LEAF is normally ((BEG . END) . WND)." + (if (with-selected-window (cdr leaf) + (bound-and-true-p visual-line-mode)) + (avy--overlay-at-full path leaf) + (let* ((path (mapcar #'avy--key-to-char path)) + (str (propertize (apply #'string (reverse path)) + 'face 'avy-lead-face))) + (when (or avy-highlight-first (> (length str) 1)) + (set-text-properties 0 1 '(face avy-lead-face-0) str)) + (setq str (concat + (propertize avy-current-path + 'face 'avy-lead-face-1) + str)) + (avy--overlay + str + (avy-candidate-beg leaf) nil + (avy-candidate-wnd leaf))))) + +(defun avy--overlay-at (path leaf) + "Create an overlay with PATH at LEAF. +PATH is a list of keys from tree root to LEAF. +LEAF is normally ((BEG . END) . WND)." + (let* ((path (mapcar #'avy--key-to-char path)) + (str (propertize + (string (car (last path))) + 'face 'avy-lead-face))) + (avy--overlay + str + (avy-candidate-beg leaf) nil + (avy-candidate-wnd leaf) + (lambda (str old-str) + (cond ((string= old-str "\n") + (concat str "\n")) + ;; add padding for wide-width character + ((eq (string-width old-str) 2) + (concat str " ")) + (t + str)))))) + +(defun avy--overlay-at-full (path leaf) + "Create an overlay with PATH at LEAF. +PATH is a list of keys from tree root to LEAF. +LEAF is normally ((BEG . END) . WND)." + (let* ((path (mapcar #'avy--key-to-char path)) + (str (propertize + (apply #'string (reverse path)) + 'face 'avy-lead-face)) + (len (length path)) + (beg (avy-candidate-beg leaf)) + (wnd (cdr leaf)) + end) + (dotimes (i len) + (set-text-properties i (1+ i) + `(face ,(nth i avy-lead-faces)) + str)) + (when (eq avy-style 'de-bruijn) + (setq str (concat + (propertize avy-current-path + 'face 'avy-lead-face-1) + str)) + (setq len (length str))) + (with-selected-window wnd + (save-excursion + (goto-char beg) + (let* ((lep (if (bound-and-true-p visual-line-mode) + (save-excursion + (end-of-visual-line) + (point)) + (line-end-position))) + ;; `end-of-visual-line' is bugged sometimes + (lep (if (< lep beg) + (line-end-position) + lep)) + (len-and-str (avy--update-offset-and-str len str lep))) + (setq len (car len-and-str)) + (setq str (cdr len-and-str)) + (setq end (if (= beg lep) + (1+ beg) + (min (+ beg + (if (eq (char-after) ?\t) + 1 + len)) + lep))) + (when (and (bound-and-true-p visual-line-mode) + (> len (- end beg)) + (not (eq lep beg))) + (setq len (- end beg)) + (let ((old-str (apply #'string (reverse path)))) + (setq str + (substring + (propertize + old-str + 'face + (if (= (length old-str) 1) + 'avy-lead-face + 'avy-lead-face-0)) + 0 len))))))) + (avy--overlay + str beg end wnd + (lambda (str old-str) + (cond ((string= old-str "\n") + (concat str "\n")) + ((string= old-str "\t") + (concat str (make-string (max (- tab-width len) 0) ?\ ))) + (t + ;; add padding for wide-width character + (if (eq (string-width old-str) 2) + (concat str " ") + str))))))) + +(defun avy--overlay-post (path leaf) + "Create an overlay with PATH at LEAF. +PATH is a list of keys from tree root to LEAF. +LEAF is normally ((BEG . END) . WND)." + (let* ((path (mapcar #'avy--key-to-char path)) + (str (propertize (apply #'string (reverse path)) + 'face 'avy-lead-face))) + (when (or avy-highlight-first (> (length str) 1)) + (set-text-properties 0 1 '(face avy-lead-face-0) str)) + (setq str (concat + (propertize avy-current-path + 'face 'avy-lead-face-1) + str)) + (avy--overlay + str + (avy-candidate-end leaf) nil + (avy-candidate-wnd leaf)))) + +(defun avy--update-offset-and-str (offset str lep) + "Recalculate the length of the new overlay at point. + +OFFSET is the previous overlay length. +STR is the overlay string that we wish to add. +LEP is the line end position. + +We want to add an overlay between point and END=point+OFFSET. +When other overlays already exist between point and END, set +OFFSET to be the difference between the start of the first +overlay and point. This is equivalent to truncating our new +overlay, so that it doesn't intersect with overlays that already +exist." + (let* ((wnd (selected-window)) + (beg (point)) + (oov (delq nil + (mapcar + (lambda (o) + (and (eq (overlay-get o 'category) 'avy) + (eq (overlay-get o 'window) wnd) + (overlay-start o))) + (overlays-in beg (min (+ beg offset) lep)))))) + (when oov + (setq offset (- (apply #'min oov) beg)) + (setq str (substring str 0 offset))) + (let ((other-ov (cl-find-if + (lambda (o) + (and (eq (overlay-get o 'category) 'avy) + (eq (overlay-start o) beg) + (not (eq (overlay-get o 'window) wnd)))) + (overlays-in (point) (min (+ (point) offset) lep))))) + (when (and other-ov + (> (overlay-end other-ov) + (+ beg offset))) + (setq str (concat str (buffer-substring + (+ beg offset) + (overlay-end other-ov)))) + (setq offset (- (overlay-end other-ov) + beg)))) + (cons offset str))) + +(defun avy--style-fn (style) + "Transform STYLE symbol to a style function." + (cl-case style + (pre #'avy--overlay-pre) + (at #'avy--overlay-at) + (at-full 'avy--overlay-at-full) + (post #'avy--overlay-post) + (de-bruijn #'avy--overlay-at-full) + (words #'avy--overlay-at-full) + (ignore #'ignore) + (t (error "Unexpected style %S" style)))) + +(cl-defun avy-jump (regex &key window-flip beg end action pred group) + "Jump to REGEX. +The window scope is determined by `avy-all-windows'. +When WINDOW-FLIP is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched. +ACTION is a function that takes point position as an argument. +When PRED is non-nil, it's a filter for matching point positions. +When GROUP is non-nil, it's either a match group in REGEX, or a function +that returns a cons of match beginning and end." + (setq avy-action (or action avy-action)) + (let ((avy-all-windows + (if window-flip + (not avy-all-windows) + avy-all-windows))) + (avy-process + (avy--regex-candidates regex beg end pred group)))) + +(defun avy--generic-jump (regex window-flip &optional beg end) + "Jump to REGEX. +The window scope is determined by `avy-all-windows'. +When WINDOW-FLIP is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched." + (declare (obsolete avy-jump "0.4.0")) + (let ((avy-all-windows + (if window-flip + (not avy-all-windows) + avy-all-windows))) + (avy-process + (avy--regex-candidates regex beg end)))) + +;;* Commands +;;;###autoload +(defun avy-goto-char (char &optional arg) + "Jump to the currently visible CHAR. +The window scope is determined by `avy-all-windows' (ARG negates it)." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-char + (avy-jump + (if (= 13 char) + "\n" + (regexp-quote (string char))) + :window-flip arg))) + +;;;###autoload +(defun avy-goto-char-in-line (char) + "Jump to the currently visible CHAR in the current line." + (interactive (list (read-char "char: " t))) + (avy-with avy-goto-char + (avy-jump + (regexp-quote (string char)) + :beg (line-beginning-position) + :end (line-end-position)))) + +;;;###autoload +(defun avy-goto-char-2 (char1 char2 &optional arg beg end) + "Jump to the currently visible CHAR1 followed by CHAR2. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched." + (interactive (list (let ((c1 (read-char "char 1: " t))) + (if (memq c1 '(? ?\b)) + (keyboard-quit) + c1)) + (let ((c2 (read-char "char 2: " t))) + (cond ((eq c2 ?) + (keyboard-quit)) + ((memq c2 avy-del-last-char-by) + (keyboard-escape-quit) + (call-interactively 'avy-goto-char-2)) + (t + c2))) + current-prefix-arg + nil nil)) + (when (eq char1 ? ) + (setq char1 ?\n)) + (when (eq char2 ? ) + (setq char2 ?\n)) + (avy-with avy-goto-char-2 + (avy-jump + (regexp-quote (string char1 char2)) + :window-flip arg + :beg beg + :end end))) + +;;;###autoload +(defun avy-goto-char-2-above (char1 char2 &optional arg) + "Jump to the currently visible CHAR1 followed by CHAR2. +This is a scoped version of `avy-goto-char-2', where the scope is +the visible part of the current buffer up to point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char 1: " t) + (read-char "char 2: " t) + current-prefix-arg)) + (avy-with avy-goto-char-2-above + (avy-goto-char-2 + char1 char2 arg + (window-start) (point)))) + +;;;###autoload +(defun avy-goto-char-2-below (char1 char2 &optional arg) + "Jump to the currently visible CHAR1 followed by CHAR2. +This is a scoped version of `avy-goto-char-2', where the scope is +the visible part of the current buffer following point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char 1: " t) + (read-char "char 2: " t) + current-prefix-arg)) + (avy-with avy-goto-char-2-below + (avy-goto-char-2 + char1 char2 arg + (point) (window-end (selected-window) t)))) + +;;;###autoload +(defun avy-isearch () + "Jump to one of the current isearch candidates." + (interactive) + (avy-with avy-isearch + (let ((avy-background nil) + (avy-case-fold-search case-fold-search)) + (prog1 + (avy-process + (avy--regex-candidates (if isearch-regexp + isearch-string + (regexp-quote isearch-string)))) + (isearch-done))))) + +;;;###autoload +(defun avy-goto-word-0 (arg &optional beg end) + "Jump to a word start. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched." + (interactive "P") + (avy-with avy-goto-word-0 + (avy-jump avy-goto-word-0-regexp + :window-flip arg + :beg beg + :end end))) + +;;;###autoload +(defun avy-goto-whitespace-end (arg &optional beg end) + "Jump to the end of a whitespace sequence. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched." + (interactive "P") + (avy-with avy-goto-whitespace-end + (avy-jump "[ \t]+\\|\n[ \t]*" + :window-flip arg + :beg beg + :end end + :group (lambda () (cons (point) (1+ (point))))))) + +(defun avy-goto-word-0-above (arg) + "Jump to a word start between window start and point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (avy-with avy-goto-word-0 + (avy-goto-word-0 arg (window-start) (point)))) + +(defun avy-goto-word-0-below (arg) + "Jump to a word start between point and window end. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (avy-with avy-goto-word-0 + (avy-goto-word-0 arg (point) (window-end (selected-window) t)))) + +(defun avy-goto-whitespace-end-above (arg) + "Jump to the end of a whitespace sequence between point and window end. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (avy-with avy-goto-whitespace-end + (avy-goto-whitespace-end arg (window-start) (point)))) + +(defun avy-goto-whitespace-end-below (arg) + "Jump to the end of a whitespace sequence between window start and point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (avy-with avy-goto-whitespace-end + (avy-goto-whitespace-end arg (point) (window-end (selected-window) t)))) + +;;;###autoload +(defun avy-goto-word-1 (char &optional arg beg end symbol) + "Jump to the currently visible CHAR at a word start. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched. +When SYMBOL is non-nil, jump to symbol start instead of word start." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-word-1 + (let* ((str (string char)) + (regex (cond ((string= str ".") + "\\.") + ((and avy-word-punc-regexp + (string-match avy-word-punc-regexp str)) + (regexp-quote str)) + ((<= char 26) + str) + (t + (concat + (if symbol "\\_<" "\\b") + str))))) + (avy-jump regex + :window-flip arg + :beg beg + :end end)))) + +;;;###autoload +(defun avy-goto-word-1-above (char &optional arg) + "Jump to the currently visible CHAR at a word start. +This is a scoped version of `avy-goto-word-1', where the scope is +the visible part of the current buffer up to point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-word-1 + (avy-goto-word-1 char arg (window-start) (point)))) + +;;;###autoload +(defun avy-goto-word-1-below (char &optional arg) + "Jump to the currently visible CHAR at a word start. +This is a scoped version of `avy-goto-word-1', where the scope is +the visible part of the current buffer following point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-word-1 + (avy-goto-word-1 char arg (point) (window-end (selected-window) t)))) + +;;;###autoload +(defun avy-goto-symbol-1 (char &optional arg) + "Jump to the currently visible CHAR at a symbol start. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-symbol-1 + (avy-goto-word-1 char arg nil nil t))) + +;;;###autoload +(defun avy-goto-symbol-1-above (char &optional arg) + "Jump to the currently visible CHAR at a symbol start. +This is a scoped version of `avy-goto-symbol-1', where the scope is +the visible part of the current buffer up to point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-symbol-1-above + (avy-goto-word-1 char arg (window-start) (point) t))) + +;;;###autoload +(defun avy-goto-symbol-1-below (char &optional arg) + "Jump to the currently visible CHAR at a symbol start. +This is a scoped version of `avy-goto-symbol-1', where the scope is +the visible part of the current buffer following point. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-symbol-1-below + (avy-goto-word-1 char arg (point) (window-end (selected-window) t) t))) + +(declare-function subword-backward "subword") +(defvar subword-backward-regexp) + +(defcustom avy-subword-extra-word-chars '(?{ ?= ?} ?* ?: ?> ?<) + "A list of characters that should temporarily match \"\\w\". +This variable is used by `avy-goto-subword-0' and `avy-goto-subword-1'." + :type '(repeat character)) + +;;;###autoload +(defun avy-goto-subword-0 (&optional arg predicate beg end) + "Jump to a word or subword start. +The window scope is determined by `avy-all-windows' (ARG negates it). + +When PREDICATE is non-nil it's a function of zero parameters that +should return true. + +BEG and END narrow the scope where candidates are searched." + (interactive "P") + (require 'subword) + (avy-with avy-goto-subword-0 + (let ((case-fold-search nil) + (subword-backward-regexp + "\\(\\(\\W\\|[[:lower:][:digit:]]\\)\\([!-/:@`~[:upper:]]+\\W*\\)\\|\\W\\w+\\)") + candidates) + (avy-dowindows arg + (let ((syn-tbl (copy-syntax-table))) + (dolist (char avy-subword-extra-word-chars) + (modify-syntax-entry char "w" syn-tbl)) + (with-syntax-table syn-tbl + (let ((ws (or beg (window-start))) + window-cands) + (save-excursion + (goto-char (or end (window-end (selected-window) t))) + (subword-backward) + (while (> (point) ws) + (when (or (null predicate) + (and predicate (funcall predicate))) + (unless (not (avy--visible-p (point))) + (push (cons (cons (point) (1+ (point))) + (selected-window)) window-cands))) + (subword-backward)) + (and (= (point) ws) + (or (null predicate) + (and predicate (funcall predicate))) + (not (get-char-property (point) 'invisible)) + (push (cons (cons (point) (1+ (point))) + (selected-window)) window-cands))) + (setq candidates (nconc candidates window-cands)))))) + (avy-process candidates)))) + +;;;###autoload +(defun avy-goto-subword-1 (char &optional arg) + "Jump to the currently visible CHAR at a subword start. +The window scope is determined by `avy-all-windows' (ARG negates it). +The case of CHAR is ignored." + (interactive (list (read-char "char: " t) + current-prefix-arg)) + (avy-with avy-goto-subword-1 + (let ((char (downcase char))) + (avy-goto-subword-0 + arg (lambda () + (and (char-after) + (eq (downcase (char-after)) char))))))) + +;;;###autoload +(defun avy-goto-word-or-subword-1 () + "Forward to `avy-goto-subword-1' or `avy-goto-word-1'. +Which one depends on variable `subword-mode'." + (interactive) + (if (bound-and-true-p subword-mode) + (call-interactively #'avy-goto-subword-1) + (call-interactively #'avy-goto-word-1))) + +(defvar visual-line-mode) + +(defcustom avy-indent-line-overlay nil + "When non-nil, `avy-goto-line' will display the line overlay next to the first non-whitespace character of each line." + :type 'boolean) + +(defun avy--line-cands (&optional arg beg end bottom-up) + "Get candidates for selecting a line. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched. +When BOTTOM-UP is non-nil, display avy candidates from top to bottom" + (let (candidates) + (avy-dowindows arg + (let ((ws (or beg (window-start)))) + (save-excursion + (save-restriction + (narrow-to-region ws (or end (window-end (selected-window) t))) + (goto-char (point-min)) + (while (< (point) (point-max)) + (when (member (get-char-property + (max (1- (point)) ws) 'invisible) '(nil org-link)) + (push (cons + (if (eq avy-style 'post) + (line-end-position) + (save-excursion + (when avy-indent-line-overlay + (skip-chars-forward " \t")) + (point))) + (selected-window)) candidates)) + (if visual-line-mode + (line-move-visual 1 t) + (forward-line 1))))))) + (if bottom-up + candidates + (nreverse candidates)))) + +(defun avy--linum-strings () + "Get strings for `avy-linum-mode'." + (let* ((lines (mapcar #'car (avy--line-cands))) + (line-tree (avy-tree lines avy-keys)) + (line-list nil)) + (avy-traverse + line-tree + (lambda (path _leaf) + (let ((str (propertize (apply #'string (reverse path)) + 'face 'avy-lead-face))) + (when (> (length str) 1) + (set-text-properties 0 1 '(face avy-lead-face-0) str)) + (push str line-list)))) + (nreverse line-list))) + +(defvar linum-available) +(defvar linum-overlays) +(defvar linum-format) +(declare-function linum--face-width "linum") + +(define-minor-mode avy-linum-mode + "Minor mode that uses avy hints for `linum-mode'." + :group 'avy + (if avy-linum-mode + (progn + (require 'linum) + (advice-add 'linum-update-window :around 'avy--linum-update-window) + (linum-mode 1)) + (advice-remove 'linum-update-window 'avy--linum-update-window) + (linum-mode -1))) + +(defun avy--linum-update-window (_ win) + "Update line numbers for the portion visible in window WIN." + (goto-char (window-start win)) + (let ((line (line-number-at-pos)) + (limit (window-end win t)) + (fmt (cond ((stringp linum-format) linum-format) + ((eq linum-format 'dynamic) + (let ((w (length (number-to-string + (count-lines (point-min) (point-max)))))) + (concat "%" (number-to-string w) "d"))))) + (width 0) + (avy-strs (when avy-linum-mode + (avy--linum-strings)))) + (run-hooks 'linum-before-numbering-hook) + ;; Create an overlay (or reuse an existing one) for each + ;; line visible in this window, if necessary. + (while (and (not (eobp)) (< (point) limit)) + (let* ((str + (cond (avy-linum-mode + (pop avy-strs)) + (fmt + (propertize (format fmt line) 'face 'linum)) + (t + (funcall linum-format line)))) + (visited (catch 'visited + (dolist (o (overlays-in (point) (point))) + (when (equal-including-properties + (overlay-get o 'linum-str) str) + (unless (memq o linum-overlays) + (push o linum-overlays)) + (setq linum-available (delq o linum-available)) + (throw 'visited t)))))) + (setq width (max width (length str))) + (unless visited + (let ((ov (if (null linum-available) + (make-overlay (point) (point)) + (move-overlay (pop linum-available) (point) (point))))) + (push ov linum-overlays) + (overlay-put ov 'before-string + (propertize " " 'display `((margin left-margin) ,str))) + (overlay-put ov 'linum-str str)))) + ;; Text may contain those nasty intangible properties, but that + ;; shouldn't prevent us from counting those lines. + (let ((inhibit-point-motion-hooks t)) + (forward-line)) + (setq line (1+ line))) + (when (display-graphic-p) + (setq width (ceiling + (/ (* width 1.0 (linum--face-width 'linum)) + (frame-char-width))))) + (set-window-margins win width (cdr (window-margins win))))) + +(defun avy--line (&optional arg beg end bottom-up) + "Select a line. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'. +BEG and END narrow the scope where candidates are searched. +When BOTTOM-UP is non-nil, display avy candidates from top to bottom" + (setq avy-action (or avy-action #'identity)) + (let ((avy-style (if avy-linum-mode + (progn + (message "Goto line:") + 'ignore) + avy-style))) + (avy-process + (avy--line-cands arg beg end bottom-up)))) + +;;;###autoload +(defun avy-goto-line (&optional arg) + "Jump to a line start in current buffer. + +When ARG is 1, jump to lines currently visible, with the option +to cancel to `goto-line' by entering a number. + +When ARG is 4, negate the window scope determined by +`avy-all-windows'. + +Otherwise, forward to `goto-line' with ARG." + (interactive "p") + (setq arg (or arg 1)) + (if (not (memq arg '(1 4))) + (progn + (goto-char (point-min)) + (forward-line (1- arg))) + (avy-with avy-goto-line + (let* ((avy-handler-old avy-handler-function) + (avy-handler-function + (lambda (char) + (if (or (< char ?0) + (> char ?9)) + (funcall avy-handler-old char) + (let ((line (read-from-minibuffer + "Goto line: " (string char)))) + (when line + (avy-push-mark) + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- (string-to-number line)))) + (throw 'done 'exit)))))) + (r (avy--line (eq arg 4)))) + (when (and (not (memq r '(t nil))) (eq avy-action #'identity)) + (avy-action-goto r)))))) + +;;;###autoload +(defun avy-goto-line-above (&optional offset bottom-up) + "Goto visible line above the cursor. +OFFSET changes the distance between the closest key to the cursor and +the cursor +When BOTTOM-UP is non-nil, display avy candidates from top to bottom" + (interactive) + (if offset + (setq offset (+ 2 (- offset)))) + (let* ((avy-all-windows nil) + (r (avy--line nil (window-start) + (line-beginning-position (or offset 1)) + bottom-up))) + (unless (eq r t) + (avy-action-goto r)))) + +;;;###autoload +(defun avy-goto-line-below (&optional offset bottom-up) + "Goto visible line below the cursor. +OFFSET changes the distance between the closest key to the cursor and +the cursor +When BOTTOM-UP is non-nil, display avy candidates from top to bottom" + (interactive) + (if offset + (setq offset (+ offset 1))) + (let* ((avy-all-windows nil) + (r (avy--line + nil (line-beginning-position (or offset 2)) + (window-end (selected-window) t) + bottom-up))) + (unless (eq r t) + (avy-action-goto r)))) + +(defcustom avy-line-insert-style 'above + "How to insert the newly copied/cut line." + :type '(choice + (const :tag "Above" above) + (const :tag "Below" below))) + +;;;###autoload +(defun avy-goto-end-of-line (&optional arg) + "Call `avy-goto-line' and move to the end of the line." + (interactive "p") + (avy-goto-line arg) + (end-of-line)) + +;;;###autoload +(defun avy-copy-line (arg) + "Copy a selected line above the current line. +ARG lines can be used." + (interactive "p") + (let ((initial-window (selected-window))) + (avy-with avy-copy-line + (let* ((start (avy--line)) + (str (buffer-substring-no-properties + start + (save-excursion + (goto-char start) + (move-end-of-line arg) + (point))))) + (select-window initial-window) + (cond ((eq avy-line-insert-style 'above) + (beginning-of-line) + (save-excursion + (insert str "\n"))) + ((eq avy-line-insert-style 'below) + (end-of-line) + (insert "\n" str) + (beginning-of-line)) + (t + (user-error "Unexpected `avy-line-insert-style'"))))))) + +;;;###autoload +(defun avy-move-line (arg) + "Move a selected line above the current line. +ARG lines can be used." + (interactive "p") + (let ((initial-window (selected-window))) + (avy-with avy-move-line + (let ((start (avy--line))) + (save-excursion + (goto-char start) + (kill-whole-line arg)) + (select-window initial-window) + (cond ((eq avy-line-insert-style 'above) + (beginning-of-line) + (save-excursion + (insert + (current-kill 0)))) + ((eq avy-line-insert-style 'below) + (end-of-line) + (newline) + (save-excursion + (insert (substring (current-kill 0) 0 -1)))) + (t + (user-error "Unexpected `avy-line-insert-style'"))))))) + +;;;###autoload +(defun avy-copy-region (arg) + "Select two lines and copy the text between them to point. + +The window scope is determined by `avy-all-windows' or +`avy-all-windows-alt' when ARG is non-nil." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-copy-region + (let* ((beg (save-selected-window + (avy--line arg))) + (end (avy--line arg)) + (str (buffer-substring-no-properties + beg + (save-excursion + (goto-char end) + (line-end-position))))) + (select-window initial-window) + (cond ((eq avy-line-insert-style 'above) + (beginning-of-line) + (save-excursion + (insert str "\n"))) + ((eq avy-line-insert-style 'below) + (end-of-line) + (newline) + (save-excursion + (insert str))) + (t + (user-error "Unexpected `avy-line-insert-style'"))))))) + +;;;###autoload +(defun avy-move-region () + "Select two lines and move the text between them above the current line." + (interactive) + (avy-with avy-move-region + (let* ((initial-window (selected-window)) + (beg (avy--line)) + (end (avy--line)) + text) + (when (> beg end) + (cl-rotatef beg end)) + (setq end (save-excursion + (goto-char end) + (1+ (line-end-position)))) + (setq text (buffer-substring beg end)) + (move-beginning-of-line nil) + (delete-region beg end) + (select-window initial-window) + (insert text)))) + +;;;###autoload +(defun avy-kill-region (arg) + "Select two lines and kill the region between them. + +The window scope is determined by `avy-all-windows' or +`avy-all-windows-alt' when ARG is non-nil." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-kill-region + (let* ((beg (save-selected-window + (list (avy--line arg) (selected-window)))) + (end (list (avy--line arg) (selected-window)))) + (cond + ((not (numberp (car beg))) + (user-error "Fail to select the beginning of region")) + ((not (numberp (car end))) + (user-error "Fail to select the end of region")) + ;; Restrict operation to same window. It's better if it can be + ;; different windows but same buffer; however, then the cloned + ;; buffers with different narrowed regions might cause problem. + ((not (equal (cdr beg) (cdr end))) + (user-error "Selected points are not in the same window")) + ((< (car beg) (car end)) + (save-excursion + (kill-region + (car beg) + (progn (goto-char (car end)) (forward-visible-line 1) (point))))) + (t + (save-excursion + (kill-region + (progn (goto-char (car beg)) (forward-visible-line 1) (point)) + (car end))))))) + (select-window initial-window))) + +;;;###autoload +(defun avy-kill-ring-save-region (arg) + "Select two lines and save the region between them to the kill ring. +The window scope is determined by `avy-all-windows'. +When ARG is non-nil, do the opposite of `avy-all-windows'." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-kill-ring-save-region + (let* ((beg (save-selected-window + (list (avy--line arg) (selected-window)))) + (end (list (avy--line arg) (selected-window)))) + (cond + ((not (numberp (car beg))) + (user-error "Fail to select the beginning of region")) + ((not (numberp (car end))) + (user-error "Fail to select the end of region")) + ((not (equal (cdr beg) (cdr end))) + (user-error "Selected points are not in the same window")) + ((< (car beg) (car end)) + (save-excursion + (kill-ring-save + (car beg) + (progn (goto-char (car end)) (forward-visible-line 1) (point))))) + (t + (save-excursion + (kill-ring-save + (progn (goto-char (car beg)) (forward-visible-line 1) (point)) + (car end))))))) + (select-window initial-window))) + +;;;###autoload +(defun avy-kill-whole-line (arg) + "Select line and kill the whole selected line. + +With a numerical prefix ARG, kill ARG line(s) starting from the +selected line. If ARG is negative, kill backward. + +If ARG is zero, kill the selected line but exclude the trailing +newline. + +\\[universal-argument] 3 \\[avy-kil-whole-line] kill three lines +starting from the selected line. \\[universal-argument] -3 + +\\[avy-kill-whole-line] kill three lines backward including the +selected line." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-kill-whole-line + (let* ((start (avy--line))) + (if (not (numberp start)) + (user-error "Fail to select the line to kill") + (save-excursion (goto-char start) + (kill-whole-line arg))))) + (select-window initial-window))) + +;;;###autoload +(defun avy-kill-ring-save-whole-line (arg) + "Select line and save the whole selected line as if killed, but don’t kill it. + +This command is similar to `avy-kill-whole-line', except that it +saves the line(s) as if killed, but does not kill it(them). + +With a numerical prefix ARG, kill ARG line(s) starting from the +selected line. If ARG is negative, kill backward. + +If ARG is zero, kill the selected line but exclude the trailing +newline." + (interactive "P") + (let ((initial-window (selected-window))) + (avy-with avy-kill-ring-save-whole-line + (let* ((start (avy--line))) + (if (not (numberp start)) + (user-error "Fail to select the line to kill") + (save-excursion + (let ((kill-read-only-ok t) + (buffer-read-only t)) + (goto-char start) + (kill-whole-line arg)))))) + (select-window initial-window))) + +;;;###autoload +(defun avy-setup-default () + "Setup the default shortcuts." + (eval-after-load "isearch" + '(define-key isearch-mode-map (kbd "C-'") 'avy-isearch))) + +(defcustom avy-timeout-seconds 0.5 + "How many seconds to wait for the second char." + :type 'float) + +(defcustom avy-enter-times-out t + "Whether enter exits avy-goto-char-timer early. If nil it matches newline" + :type 'boolean) + +(defvar avy-text "" + "Store the input read by `avy--read-candidates'.") + +(defun avy--read-candidates (&optional re-builder) + "Read as many chars as possible and return their occurrences. +At least one char must be read, and then repeatedly one next char +may be read if it is entered before `avy-timeout-seconds'. DEL +deletes the last char entered, and RET exits with the currently +read string immediately instead of waiting for another char for +`avy-timeout-seconds'. +The format of the result is the same as that of `avy--regex-candidates'. +This function obeys `avy-all-windows' setting. +RE-BUILDER is a function that takes a string and returns a regex. +When nil, `regexp-quote' is used. +If a group is captured, the first group is highlighted. +Otherwise, the whole regex is highlighted." + (setq avy-text "") + (let ((re-builder (or re-builder #'regexp-quote)) + char break overlays regex) + (unwind-protect + (progn + (avy--make-backgrounds + (avy-window-list)) + (while (and (not break) + (setq char + (read-char (format "%d char%s: " + (length overlays) + (if (string= avy-text "") + avy-text + (format " (%s)" avy-text))) + t + (and (not (string= avy-text "")) + avy-timeout-seconds)))) + ;; Unhighlight + (dolist (ov overlays) + (delete-overlay ov)) + (setq overlays nil) + (cond + ;; Handle RET + ((= char 13) + (if avy-enter-times-out + (setq break t) + (setq avy-text (concat avy-text (list ?\n))))) + ;; Handle C-h, DEL + ((memq char avy-del-last-char-by) + (let ((l (length avy-text))) + (when (>= l 1) + (setq avy-text (substring avy-text 0 (1- l)))))) + ;; Handle ESC + ((= char 27) + (keyboard-quit)) + (t + (setq avy-text (concat avy-text (list char))))) + ;; Highlight + (when (>= (length avy-text) 1) + (let ((case-fold-search + (or avy-case-fold-search (string= avy-text (downcase avy-text)))) + found) + (avy-dowindows current-prefix-arg + (dolist (pair (avy--find-visible-regions + (window-start) + (window-end (selected-window) t))) + (save-excursion + (goto-char (car pair)) + (setq regex (funcall re-builder avy-text)) + (while (re-search-forward regex (cdr pair) t) + (unless (not (avy--visible-p (1- (point)))) + (let* ((idx (if (= (length (match-data)) 4) 1 0)) + (ov (make-overlay + (match-beginning idx) (match-end idx)))) + (setq found t) + (push ov overlays) + (overlay-put + ov 'window (selected-window)) + (overlay-put + ov 'face 'avy-goto-char-timer-face))))))) + ;; No matches at all, so there's surely a typo in the input. + (unless found (beep))))) + (nreverse (mapcar (lambda (ov) + (cons (cons (overlay-start ov) + (overlay-end ov)) + (overlay-get ov 'window))) + overlays))) + (dolist (ov overlays) + (delete-overlay ov)) + (avy--done)))) + +(defvar avy--old-cands nil) + +;;;###autoload +(defun avy-goto-char-timer (&optional arg) + "Read one or many consecutive chars and jump to the first one. +The window scope is determined by `avy-all-windows' (ARG negates it)." + (interactive "P") + (let ((avy-all-windows (if arg + (not avy-all-windows) + avy-all-windows))) + (avy-with avy-goto-char-timer + (setq avy--old-cands (avy--read-candidates)) + (avy-process avy--old-cands)))) + +(defun avy-push-mark () + "Store the current point and window." + (let ((inhibit-message t)) + (ring-insert avy-ring + (cons (point) (selected-window))) + (unless (region-active-p) + (push-mark)))) + +(defun avy-pop-mark () + "Jump back to the last location of `avy-push-mark'." + (interactive) + (let (res) + (condition-case nil + (progn + (while (not (window-live-p + (cdr (setq res (ring-remove avy-ring 0)))))) + (let* ((window (cdr res)) + (frame (window-frame window))) + (when (and (frame-live-p frame) + (not (eq frame (selected-frame)))) + (select-frame-set-input-focus frame)) + (select-window window) + (goto-char (car res)))) + (error + (set-mark-command 4))))) + +;; ** Org-mode +(defvar org-reverse-note-order) +(declare-function org-refile "org") +(declare-function org-back-to-heading "org") +(declare-function org-reveal "org") + +(defvar org-after-refile-insert-hook) + +(defun avy-org-refile-as-child () + "Refile current heading as first child of heading selected with `avy.'" + ;; Inspired by `org-teleport': http://kitchingroup.cheme.cmu.edu/blog/2016/03/18/Org-teleport-headlines/ + (interactive) + (let* ((org-reverse-note-order t) + (marker (save-excursion + (avy-with avy-goto-line + (unless (eq 't (avy-jump (rx bol (1+ "*") (1+ space)))) + ;; `avy-jump' returns t when aborted with C-g. + (point-marker))))) + (filename (buffer-file-name (or (buffer-base-buffer (marker-buffer marker)) + (marker-buffer marker)))) + (rfloc (list nil filename nil marker)) + ;; Ensure the refiled heading is visible. + (org-after-refile-insert-hook (if (member 'org-reveal org-after-refile-insert-hook) + org-after-refile-insert-hook + (cons #'org-reveal org-after-refile-insert-hook)))) + (when marker + ;; Only attempt refile if avy session was not aborted. + (org-refile nil nil rfloc)))) + +(defun avy-org-goto-heading-timer (&optional arg) + "Read one or many characters and jump to matching Org headings. +The window scope is determined by `avy-all-windows' (ARG negates it)." + (interactive "P") + (let ((avy-all-windows (if arg + (not avy-all-windows) + avy-all-windows))) + (avy-with avy-goto-char-timer + (avy-process + (avy--read-candidates + (lambda (input) + (format "^\\*+ .*\\(%s\\)" input)))) + (org-back-to-heading)))) + +(provide 'avy) + +;;; avy.el ends here diff --git a/lisp/biblio-core.el b/lisp/biblio-core.el new file mode 100644 index 00000000..58b7f62f --- /dev/null +++ b/lisp/biblio-core.el @@ -0,0 +1,889 @@ +;;; biblio-core.el --- A framework for looking up and displaying bibliographic entries -*- lexical-binding: t -*- + +;; Copyright (C) 2016 Clément Pit-Claudel + +;; Author: Clément Pit-Claudel +;; Version: 0.2.1 +;; Package-Version: 20200416.307 +;; Package-Commit: eb9baf1d2bf6a073d24ccb717025baa693e98f3e +;; Package-Requires: ((emacs "24.3") (let-alist "1.0.4") (seq "1.11") (dash "2.12.1")) +;; Keywords: bib, tex, convenience, hypermedia +;; URL: https://github.com/cpitclaudel/biblio.el + +;; 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 . + +;;; Commentary: +;; A framework for browsing bibliographic search results. This is the core +;; package; for user interfaces, see any of `biblio-crossref', `biblio-dblp', `biblio-doi', +;; `biblio-arxiv', `biblio-hal' and `biblio-dissemin', which are part of the `biblio' package. + +;;; Code: + +(require 'bibtex) +(require 'browse-url) +(require 'hl-line) +(require 'ido) +(require 'json) +(require 'url-queue) + +(require 'dash) +(require 'let-alist) +(require 'seq) + +(defvar-local biblio--target-buffer nil + "Buffer into which BibTeX entries should be inserted. +This variable is local to each search results buffer.") + +(defvar-local biblio--search-terms nil + "Keywords that led to a page of bibliographic search results.") + +(defvar-local biblio--backend nil + "Backend that produced a page of bibliographic search results.") + +(defgroup biblio nil + "A browser for bibliographic information." + :group 'communication) + +(defgroup biblio-core nil + "Core of the biblio package." + :group 'biblio) + +(defgroup biblio-faces nil + "Faces of the biblio package." + :group 'biblio) + +(defcustom biblio-synchronous nil + "Whether bibliographic queries should be synchronous." + :group 'biblio-core + :type 'boolean) + +(defcustom biblio-authors-limit 10 + "Maximum number of authors to display per paper." + :group 'biblio-core + :type 'integer) + +;;; Compatibility + +(defun biblio-alist-get (key alist) + "Copy of Emacs 25's `alist-get', minus default. +Get the value associated to KEY in ALIST, or nil." + (cdr (assq key alist))) + +(defun biblio--plist-to-alist (plist) + "Copy of Emacs 25's `json--plist-to-alist'. +Return an alist of the property-value pairs in PLIST." + (let (res) + (while plist + (let ((prop (pop plist)) + (val (pop plist))) + (push (cons prop val) res))) + (nreverse res))) + +;;; Utilities + +(defconst biblio--bibtex-entry-format + (list 'opts-or-alts 'numerical-fields 'page-dashes 'whitespace + 'inherit-booktitle 'realign 'last-comma 'delimiters + 'unify-case 'braces 'strings 'sort-fields) + "Format to use in `biblio-format-bibtex'. +See `bibtex-entry-format' for details; this list is all +transformations, except errors for missing fields. +Also see `biblio-cleanup-bibtex-function'.") + +(defun biblio--cleanup-bibtex-1 (dialect autokey) + "Cleanup BibTeX entry starting at point. +DIALECT is `BibTeX' or `biblatex'. AUTOKEY: see `biblio-format-bibtex'." + (let ((bibtex-entry-format biblio--bibtex-entry-format) + (bibtex-align-at-equal-sign t) + (bibtex-autokey-edit-before-use nil)) + ;; Use biblatex to allow for e.g. @Online + ;; Use BibTeX to allow for e.g. @TechReport + (bibtex-set-dialect dialect t) + (bibtex-clean-entry autokey))) + +(defun biblio--cleanup-bibtex (autokey) + "Default value of `biblio-cleanup-bibtex-function'. +AUTOKEY: See `biblio-format-bibtex'." + (save-excursion + (when (search-forward "@data{" nil t) + (replace-match "@misc{"))) + (ignore-errors ;; See https://github.com/crosscite/citeproc-doi-server/issues/12 + (condition-case _ + (biblio--cleanup-bibtex-1 'biblatex autokey) + (error (biblio--cleanup-bibtex-1 'BibTeX autokey))))) + +(defcustom biblio-cleanup-bibtex-function + #'biblio--cleanup-bibtex + "Function to clean up BibTeX entries. +This function is called in a `bibtex-mode' buffer containing an +unprocessed, potentially invalid BibTeX (or BibLaTeX) entry, and +should clean it up in place. It should take a single argument, +AUTOKEY, indicating whether the entry needs a new key." + :group 'biblio + :type 'function) + +(defun biblio-format-bibtex (bibtex &optional autokey) + "Format BIBTEX entry. +With non-nil AUTOKEY, automatically generate a key for BIBTEX." + (with-temp-buffer + (bibtex-mode) + (save-excursion + (insert (biblio-strip bibtex))) + (if (fboundp 'font-lock-ensure) (font-lock-ensure) + (with-no-warnings (font-lock-fontify-buffer))) + (when (functionp biblio-cleanup-bibtex-function) + (funcall biblio-cleanup-bibtex-function autokey)) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun biblio--beginning-of-response-body () + "Move point to beginning of response body." + (goto-char (point-min)) + (unless (re-search-forward "^\n" nil t) + (error "Invalid response from server: %S" (buffer-string)))) + +(defun biblio-response-as-utf-8 () + "Extract body of response." + (set-buffer-multibyte t) + (decode-coding-region (point) (point-max) 'utf-8 t)) + +(defun biblio-decode-url-buffer (coding) + "Decode URL buffer with CODING." + (set-buffer-multibyte t) ;; URL buffer is unibyte + (decode-coding-region (point-min) (point-max) coding)) + +(defun biblio--event-error-code (event) + "Extract HTTP error code from EVENT, if any." + (pcase event + (`(:error . (error ,source ,details)) + (cons source details)))) + +(eval-and-compile + (define-error 'biblio--url-error "URL retrieval error.")) + +(defun biblio--throw-on-unexpected-errors (errors allowed-errors) + "Throw an url-error for any error in ERRORS not in ALLOWED-ERRORS." + (dolist (err errors) + (cond ((eq (car err) 'url-queue-timeout) + (signal 'biblio--url-error 'timeout)) + ((not (member err allowed-errors)) + (signal 'biblio--url-error err))))) + +(defun biblio--extract-errors (events) + "Extract errors from EVENTS." + (delq nil (mapcar #'biblio--event-error-code (biblio--plist-to-alist events)))) + +(defun biblio-generic-url-callback (callback &optional cleanup-function &rest allowed-errors) + "Make an `url'-ready callback from CALLBACK. +CALLBACK is called with no arguments; the buffer containing the +server's response is current at the time of the call, and killed +after the call returns. Call CLEANUP-FUNCTION before checking +for errors. If the request returns one of the errors in +ALLOWED-ERRORS, CALLBACK is instead called with one argument, the +list of allowed errors that occurred instead of a buffer. If the +request returns another error, an exception is raised." + (lambda (events) + (let ((target-buffer (current-buffer))) + (unwind-protect + (progn + (funcall (or cleanup-function #'ignore)) + (condition-case err + (-if-let* ((errors (biblio--extract-errors events))) + (progn + (biblio--throw-on-unexpected-errors errors allowed-errors) + (funcall callback errors)) + (biblio--beginning-of-response-body) + (delete-region (point-min) (point)) + (funcall callback)) + (error (message "Error while processing request: %S" err)))) + (kill-buffer target-buffer))))) + +(defun biblio-url-retrieve (url callback) + "Wrapper around `url-queue-retrieve'. +URL and CALLBACK; see `url-queue-retrieve'" + (message "Fetching %s" url) + (if biblio-synchronous + (with-current-buffer (url-retrieve-synchronously url) + (funcall callback nil)) + (setq url-queue-timeout 1) + (url-queue-retrieve url callback))) + +(defun biblio-strip (str) + "Remove spaces surrounding STR." + (when str + (->> str + (replace-regexp-in-string "[ \t\n\r]+\\'" "") + (replace-regexp-in-string "\\`[ \t\n\r]+" "")))) + +(defun biblio-cleanup-doi (doi) + "Cleanup DOI string." + (biblio-strip (replace-regexp-in-string "https?://\\(dx\\.\\)?doi\\.org/" "" doi))) + +(defun biblio-remove-empty (strs) + "Remove empty sequences from STRS." + (seq-remove #'seq-empty-p strs)) + +(defun biblio-join-1 (sep strs) + "Join non-empty elements of STRS with SEP." + (declare (indent 1)) + (let ((strs (biblio-remove-empty strs))) + (mapconcat #'identity strs sep))) + +(defun biblio-join (sep &rest strs) + "Join non-empty elements of STRS with SEP." + (declare (indent 1)) + (biblio-join-1 sep strs)) + +(defmacro biblio--with-text-property (prop value &rest body) + "Set PROP to VALUE on text inserted by BODY." + (declare (indent 2) + (debug t)) + (let ((beg-var (make-symbol "beg"))) + `(let ((,beg-var (point))) + ,@body + (put-text-property ,beg-var (point) ,prop ,value)))) + +(defmacro biblio-with-fontification (face &rest body) + "Apply FACE to text inserted by BODY." + (declare (indent 1) + (debug t)) + (let ((beg-var (make-symbol "beg"))) + `(let ((,beg-var (point))) + ,@body + (font-lock-append-text-property ,beg-var (point) 'face ,face)))) + +;;; Help with major mode + +(defsubst biblio--as-list (x) + "Make X a list, if it isn't." + (if (consp x) x (list x))) + +(defun biblio--map-keymap (func map) + "Call `map-keymap' on FUNC and MAP, and collect the results." + (let ((out)) + (map-keymap (lambda (&rest args) (push (apply func args) out)) map) + out)) + +(defun biblio--flatten-map (keymap &optional prefix) + "Flatten KEYMAP, prefixing its keys with PREFIX. +This should really be in Emacs core (in Elisp), instead of being +implemented in C (at least for sparse keymaps). Don't run this on +non-sparse keymaps." + (nreverse + (cond + ((keymapp keymap) + (seq-map (lambda (key-value) + "Add PREFIX to key in KEY-VALUE." + (cons (append prefix (biblio--as-list (car key-value))) + (cdr key-value))) + (delq nil + (apply + #'seq-concatenate + 'list (biblio--map-keymap + (lambda (k v) + "Return a list of bindings in V, prefixed by K." + (biblio--flatten-map v (biblio--as-list k))) + keymap))))) + ;; This breaks if keymap is a symbol whose function cell is a keymap + ((symbolp keymap) + (list (cons prefix keymap)))))) + +(defun biblio--group-alist (alist) + "Return a copy of ALIST whose keys are lists of keys, grouped by value. +That is, if two key map to `eq' values, they are grouped." + (let ((map (make-hash-table :test 'eq)) + (new-alist nil)) + (pcase-dolist (`(,key . ,value) alist) + (puthash value (cons key (gethash value map)) map)) + (pcase-dolist (`(,_ . ,value) alist) + (-when-let* ((keys (gethash value map))) + (push (cons (nreverse keys) value) new-alist) + (puthash value nil map))) + (nreverse new-alist))) + +(defun biblio--quote (str) + "Quote STR and call `substitute-command-keys' on it." + (if str (substitute-command-keys (concat "`" str "'")) "")) + +(defun biblio--quote-keys (keys) + "Quote and concatenate keybindings in KEYS." + (mapconcat (lambda (keyseq) + (biblio--quote (ignore-errors (help-key-description keyseq nil)))) + keys ", ")) + +(defun biblio--brief-docs (command) + "Return first line of documentation of COMMAND." + (let ((docs (or (ignore-errors (documentation command t)) ""))) + (string-match "\\(.*\\)$" docs) + (match-string-no-properties 1 docs))) + +(defun biblio--help-with-major-mode-1 (keyseqs-command) + "Print help on KEYSEQS-COMMAND to standard output." + ;; (biblio-with-fontification 'font-lock-function-name-face + (insert (format "%s (%S)\n" + (biblio--quote-keys (car keyseqs-command)) + (cdr keyseqs-command))) + (biblio-with-fontification 'font-lock-doc-face + (insert (format " %s\n\n" (biblio--brief-docs (cdr keyseqs-command)))))) + +(defun biblio--help-with-major-mode () + "Display help with current major mode." + (let ((buf (format "*%S help*" major-mode))) + (with-help-window buf + (princ (format "Help with %s\n\n" (biblio--quote (symbol-name major-mode)))) + (let ((bindings (nreverse + (biblio--group-alist + (biblio--flatten-map + (current-local-map)))))) + (with-current-buffer buf + (seq-do #'biblio--help-with-major-mode-1 bindings)))) + buf)) + +;;; Interaction + +(defconst biblio--search-result-marker-regexp "^> " + "Indicator of a search result.") + +(defun biblio--selection-move (move-fn search-fn) + "Move using MOVE-FN, then call SEARCH-FN and go to first match." + (let ((target (point))) + (save-excursion + (funcall move-fn) + (when (funcall search-fn biblio--search-result-marker-regexp nil t) + (setq target (match-end 0)))) + (goto-char target))) + +(defun biblio-get-url (metadata) + "Compute a url from METADATA. +Uses .url, and .doi as a fallback." + (let-alist metadata + (if .url .url + (when .doi + (concat "https://doi.org/" (url-encode-url .doi)))))) + +(defun biblio--selection-browse () + "Open the web page of the current entry in a web browser." + (interactive) + (-if-let* ((url (biblio-get-url (biblio--selection-metadata-at-point)))) + (browse-url url) + (user-error "This record does not contain a URL"))) + +(defun biblio--selection-browse-direct () + "Open the full text of the current entry in a web browser." + (interactive) + (-if-let* ((url (biblio-alist-get 'direct-url (biblio--selection-metadata-at-point)))) + (browse-url url) + (user-error "This record does not contain a direct URL (try arXiv or HAL)"))) + +(defun biblio--selection-next () + "Move to next search result." + (interactive) + (biblio--selection-move #'end-of-line #'re-search-forward)) + +(defun biblio--selection-first () + "Move to first search result." + (goto-char (point-min)) + (biblio--selection-move #'ignore #'re-search-forward)) + +(defun biblio--selection-previous () + "Move to previous search result." + (interactive) + (biblio--selection-move #'beginning-of-line #'re-search-backward)) + +(defun biblio--selection-copy-callback (bibtex entry) + "Add BIBTEX (from ENTRY) to kill ring." + (kill-new bibtex) + (message "Killed bibtex entry for %S." + (biblio--prepare-title (biblio-alist-get 'title entry)))) + +(defun biblio--selection-copy () + "Copy BibTeX of current entry at point." + (interactive) + (biblio--selection-forward-bibtex #'biblio--selection-copy-callback)) + +(defun biblio--selection-copy-quit () + "Copy BibTeX of current entry at point and close results." + (interactive) + (biblio--selection-forward-bibtex #'biblio--selection-copy-callback t)) + +(defun biblio--target-window () + "Get the window of the source buffer." + (get-buffer-window biblio--target-buffer)) + +(defun biblio--selection-insert-callback (bibtex entry) + "Add BIBTEX (from ENTRY) to kill ring." + (let ((target-buffer biblio--target-buffer)) + (with-selected-window (or (biblio--target-window) (selected-window)) + (with-current-buffer target-buffer + (insert bibtex "\n\n")))) + (message "Inserted bibtex entry for %S." + (biblio--prepare-title (biblio-alist-get 'title entry)))) + +(defun biblio--selection-insert () + "Insert BibTeX of current entry into source buffer." + (interactive) + (biblio--selection-forward-bibtex #'biblio--selection-insert-callback)) + +(defun biblio--selection-insert-quit () + "Insert BibTeX of current entry into source buffer and close results." + (interactive) + (biblio--selection-forward-bibtex #'biblio--selection-insert-callback t)) + +(defun biblio--selection-metadata-at-point () + "Return the metadata of the entry at point." + (or (get-text-property (point) 'biblio-metadata) + (user-error "No entry at point"))) + +(defcustom biblio-bibtex-use-autokey nil + "Whether to generate new BibTeX keys for inserted entries." + :type '(choice (const :tag "Keep original BibTeX keys" nil) + (const :tag "Generate new BibTeX keys" t)) + :group 'biblio + :package-version '(biblio . "0.2.1")) + +(defun biblio--selection-forward-bibtex (forward-to &optional quit) + "Retrieve BibTeX for entry at point and pass it to FORWARD-TO. +If QUIT is set, also kill the results buffer." + (let* ((metadata (biblio--selection-metadata-at-point)) + (results-buffer (current-buffer))) + (progn + (funcall (biblio-alist-get 'backend metadata) + 'forward-bibtex metadata + (lambda (bibtex) + (with-current-buffer results-buffer + (funcall + forward-to + (biblio-format-bibtex bibtex biblio-bibtex-use-autokey) + metadata)))) + (when quit (quit-window))))) + +(defun biblio--selection-change-buffer (buffer-name) + "Change buffer in which BibTeX results will be inserted. +BUFFER-NAME is the name of the new target buffer." + (interactive (list (read-buffer "Buffer to insert entries into: "))) + (let ((buffer (get-buffer buffer-name))) + (if (buffer-local-value 'buffer-read-only buffer) + (user-error "%s is read-only" (buffer-name buffer)) + (setq biblio--target-buffer buffer)))) + +(defvar biblio-selection-mode-actions-alist nil + "An alist of extensions for `biblio-selection-mode'. +Each element should be in the for (LABEL . FUNCTION); FUNCTION +will be called with the metadata of the current item.") + +(defun biblio--completing-read-function () + "Return ido, unless user picked another completion package." + (if (eq completing-read-function #'completing-read-default) + #'ido-completing-read + completing-read-function)) + +(defun biblio-completing-read (prompt collection &optional predicate require-match + initial-input hist def inherit-input-method) + "Complete using `biblio-completing-read-function'. +PROMPT, COLLECTION, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, +HIST, DEF, INHERIT-INPUT-METHOD: see `completing-read'." + (let ((completing-read-function (biblio--completing-read-function))) + (completing-read prompt collection predicate require-match + initial-input hist def inherit-input-method))) + +(defun biblio-completing-read-alist (prompt collection &optional predicate require-match + initial-input hist def inherit-input-method) + "Same as `biblio-completing-read', when COLLECTION in an alist. +Complete with the `car's, and return the `cdr' of the result. +PROMPT, COLLECTION, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, +HIST, DEF, INHERIT-INPUT-METHOD: see `completing-read'." + (let ((choices (mapcar #'car collection))) + (cdr (assoc (biblio-completing-read + prompt choices predicate require-match + initial-input hist def inherit-input-method) + collection)))) + +(defun biblio--read-selection-extended-action () + "Read an action from `biblio-selection-mode-actions-alist'." + (biblio-completing-read-alist + "Action: " biblio-selection-mode-actions-alist nil t)) + +(defun biblio--selection-extended-action (action) + "Run an ACTION with metadata of current entry. +Interactively, query for ACTION from +`biblio-selection-mode-actions-alist'." + (interactive (list (biblio--read-selection-extended-action))) + (let* ((metadata (biblio--selection-metadata-at-point))) + (funcall action metadata))) + +(defun biblio--selection-help () + "Show help on local keymap." + (interactive) + (biblio--help-with-major-mode)) + +(defvar biblio-selection-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'biblio--selection-previous) + (define-key map (kbd "C-p") #'biblio--selection-previous) + (define-key map (kbd "") #'biblio--selection-next) + (define-key map (kbd "C-n") #'biblio--selection-next) + (define-key map (kbd "RET") #'biblio--selection-browse) + (define-key map (kbd "") #'biblio--selection-browse-direct) + (define-key map (kbd "C-RET") #'biblio--selection-browse-direct) + (define-key map (kbd "M-w") #'biblio--selection-copy) + (define-key map (kbd "c") #'biblio--selection-copy) + (define-key map (kbd "C-w") #'biblio--selection-copy-quit) + (define-key map (kbd "C") #'biblio--selection-copy-quit) + (define-key map (kbd "i") #'biblio--selection-insert) + (define-key map (kbd "C-y") #'biblio--selection-insert-quit) + (define-key map (kbd "I") #'biblio--selection-insert-quit) + (define-key map (kbd "b") #'biblio--selection-change-buffer) + (define-key map (kbd "x") #'biblio--selection-extended-action) + (define-key map (kbd "?") #'biblio--selection-help) + (define-key map (kbd "h") #'biblio--selection-help) + (define-key map (kbd "q") #'quit-window) + map) + "Keybindings for Bibliographic search results.") + +(defconst biblio--selection-mode-name-base "Bibliographic search results") + +(defun biblio--selection-mode-name () + "Compute a modeline string for `biblio-selection-mode'." + (concat biblio--selection-mode-name-base + (if (bufferp biblio--target-buffer) + (format " (→ %s)" + (buffer-name biblio--target-buffer)) + ""))) + +(define-derived-mode biblio-selection-mode fundamental-mode biblio--selection-mode-name-base + "Browse bibliographic search results. +\\{biblio-selection-mode-map}" + (hl-line-mode) + (visual-line-mode) + (setq-local truncate-lines nil) + (setq-local cursor-type nil) + (setq-local buffer-read-only t) + (setq-local mode-name '(:eval (biblio--selection-mode-name))) + (setq-local + header-line-format + `(:eval + (concat + (ignore-errors + (propertize " " 'display '(space :align-to 0) 'face 'fringe)) + (substitute-command-keys + (biblio-join " " + "\\[biblio--selection-help]: Help" + "\\[biblio--selection-insert],\\[biblio--selection-insert-quit]: Insert BibTex" + "\\[biblio--selection-copy],\\[biblio--selection-copy-quit]: Copy BibTeX" + "\\[biblio--selection-extended-action]: Extended action" + "\\[biblio--selection-browse]: Open in browser" + "\\[biblio--selection-change-buffer]: Change buffer")))))) + +;;; Printing search results + +(defun biblio-parenthesize (str) + "Add parentheses to STR, if not empty." + (if (seq-empty-p str) "" + (concat "(" str ")"))) + +(defun biblio-insert-with-prefix (prefix &rest strs) + "Like INSERT with PREFIX and STRS, but set `wrap-prefix'. +That is, the inserted text gets a `wrap-prefix' made of enough +white space to align with the end of PREFIX." + (declare (indent 1)) + (biblio--with-text-property 'wrap-prefix (make-string (length prefix) ?\s) + (apply #'insert prefix strs))) + +(defface biblio-detail-header-face + '((t :slant normal)) + "Face used for headers of details in `biblio-selection-mode'." + :group 'biblio-faces) + +(defun biblio--insert-detail (prefix items newline) + "Insert PREFIX followed by ITEMS, if ITEMS has non-empty entries. +If ITEMS is a list or vector, join its entries with “, ”. If +NEWLINE is non-nil, add a newline before the main text." + (when (or (vectorp items) (listp items)) + (setq items (biblio-join-1 ", " items))) + (unless (seq-empty-p items) + (when newline (insert "\n")) + (let ((fontified (propertize prefix 'face 'biblio-detail-header-face))) + (biblio-insert-with-prefix fontified items)))) + +(defun biblio--nonempty-string-p (str) + "Return STR if STR is non-empty." + (unless (seq-empty-p str) + str)) + +(defun biblio--cleanup-field (text) + "Cleanup TEXT for presentation to the user." + (when text (biblio-strip (replace-regexp-in-string "[ \r\n\t]+" " " text)))) + +(defun biblio--prepare-authors (authors) + "Cleanup and join list of AUTHORS." + (let* ((authors (biblio-remove-empty (seq-map #'biblio-strip authors))) + (num-authors (length authors))) + ;; Only truncate when significantly above limit + (when (> num-authors (+ 2 biblio-authors-limit)) + (let* ((last (nthcdr biblio-authors-limit authors))) + (setcar last (format "… (%d more)" (- num-authors biblio-authors-limit))) + (setcdr last nil))) + (if authors (biblio-join-1 ", " authors) + "(no authors)"))) + +(defun biblio--prepare-title (title &optional year) + "Cleanup TITLE and add YEAR for presentation to the user." + (concat (or (biblio--nonempty-string-p (biblio--cleanup-field title)) + "(no title)") + (if year (format " [%s]" year) ""))) + +(defun biblio--browse-url (button) + "Open web browser on page pointed to by BUTTON." + (browse-url (button-get button 'target))) + +(defun biblio-make-url-button (url &optional label) + "Make a text button pointing to URL. +With non-nil LABEL, use that instead of URL to label the button." + (unless (seq-empty-p url) + (with-temp-buffer + (insert-text-button (or label url) + 'target url + 'follow-link t + 'action #'biblio--browse-url) + (buffer-string)))) + +(defun biblio--references-redundant-p (references url) + "Check whether REFERENCES are all containted in URL. + +This is commonly the case with DOIs, which don't need to be +displayed if they are already in the `dx.doi.org' url." + (and (stringp url) + (seq-every-p (lambda (ref) (string-match-p (regexp-quote ref) url)) + references))) + +(defun biblio-insert-result (item &optional no-sep) + "Print a (prepared) bibliographic search result ITEM. +With NO-SEP, do not add space after the record. + +This command expects ITEM to be a single alist, in the following format: + + ((title . \"Title of entry\") + (authors . (\"Author 1\" \"Author 2\" …)) + (container . \"Where this was published (which journal, conference, …)\") + (type . \"Type of document (journal paper, proceedings, report, …)\") + (category . \"Category of this document (aka primary topic)\") + (publisher . \"Publisher of this document\") + (references . \"Identifier(s) of this document (DOI, DBLP id, Handle, …)\") + (open-access-status . \"Open access status of this document\") + (url . \"Relevant URL\") + (year . \"Publication year as a string, if available\") + (direct-url . \"Direct URL of paper (typically PDF)\")) + +Each of `container', `type', `category', `publisher', +`references', and `open-access-status' may be a list; in that +case, entries of the list are displayed comma-separated. All +entries are optional. + +`crossref--extract-interesting-fields' and `dblp--extract-interesting-fields' +provide examples of how to build such a result." + (biblio--with-text-property 'biblio-metadata item + (let-alist item + (biblio-with-fontification 'font-lock-function-name-face + (biblio-insert-with-prefix "> " (biblio--prepare-title .title .year))) + (insert "\n") + (biblio-with-fontification 'font-lock-doc-face + (biblio-insert-with-prefix " " (biblio--prepare-authors .authors))) + (biblio-with-fontification 'font-lock-comment-face + (biblio--insert-detail " In: " .container t) + (biblio--insert-detail " Type: " .type t) + (biblio--insert-detail " Category: " .category t) + (biblio--insert-detail " Publisher: " .publisher t) + ;; (-when-let* ((year (and (numberp .year) (number-to-string .year)))) + ;; (if .publisher + ;; (insert (format " (%s)" year)) + ;; (biblio--insert-detail " Publication date: " year t))) + (let ((references (remq nil .references))) + (unless (biblio--references-redundant-p references .url) + (biblio--insert-detail " References: " references t))) + (biblio--insert-detail " Open Access: " .open-access-status t) + (biblio--insert-detail " URL: " (list (biblio-make-url-button .url) + (biblio-make-url-button .direct-url)) + t)) + (unless no-sep + (insert "\n\n"))))) + +(defface biblio-results-header-face + '((t :height 1.5 :weight bold :inherit font-lock-preprocessor-face)) + "Face used for general search results header in `biblio-selection-mode'." + :group 'biblio-faces) + +(defun biblio--search-results-header (&optional loading-p) + "Compute a header for the current `selection-mode' buffer. +With LOADING-P, mention that results are being loaded." + (format "%s search results for %s%s" + (funcall biblio--backend 'name) + (biblio--quote biblio--search-terms) + (if loading-p " (loading…)" ""))) + +(defun biblio--make-results-buffer (target-buffer search-terms backend) + "Set up the results buffer for TARGET-BUFFER, SEARCH-TERMS and BACKEND." + (with-current-buffer (get-buffer-create + (format "*%s search*" (funcall backend 'name))) + (let ((inhibit-read-only t)) + (erase-buffer) + (biblio-selection-mode) + (setq biblio--target-buffer target-buffer) + (setq biblio--search-terms search-terms) + (setq biblio--backend backend) + (biblio--insert-header (biblio--search-results-header t)) + (setq buffer-read-only t) + (current-buffer)))) + +(defun biblio--insert-header (header) + "Prettify and insert HEADER in current buffer." + (when header + (biblio--with-text-property 'line-spacing 0.5 + (biblio--with-text-property 'line-height 1.75 + (biblio-with-fontification 'biblio-results-header-face + (insert header "\n")))))) + +(defun biblio-insert-results (items &optional header) + "Populate current buffer with ITEMS and HEADER, then display it." + (let ((inhibit-read-only t)) + (erase-buffer) + (biblio--insert-header header) + (seq-do #'biblio-insert-result items)) + (pop-to-buffer (current-buffer)) + (biblio--selection-first) + (hl-line-highlight)) + +(defun biblio--tag-backend (backend items) + "Add (backend . BACKEND) to each alist in ITEMS." + (seq-map (lambda (i) (cons `(backend . ,backend) i)) items)) + +(defun biblio--callback (results-buffer backend) + "Generate a search results callback for RESULTS-BUFFER. +Results are parsed with (BACKEND 'parse-buffer)." + (biblio-generic-url-callback + (lambda () ;; no allowed errors, so no arguments + "Parse results of bibliographic search." + (let ((results (biblio--tag-backend backend (funcall backend 'parse-buffer)))) + (with-current-buffer results-buffer + (biblio-insert-results results (biblio--search-results-header))) + (message "Tip: learn to browse results with `h'"))))) + +;;; Searching + +(defvar biblio--search-history nil) + +(defvar biblio-backends nil + "List of biblio backends. +This list is generally populated through `biblio-init-hook', +which is called by `biblio-collect-backends'. + + +Each backend is a function that take a variable number of +arguments. The first argument is a command; the rest are +arguments to this specific command. The command is one of the +following: + +`name': (no arguments) The name of the backend, displayed when picking a +backend from a list. + +`prompt': (no arguments) The string used when querying the user for a search +term to feed this backend. + +`url': (one argument, QUERY) Create a URL to query the backend's API. + +`parse-buffer': (no arguments) Parse the contents of the current +buffer and return a list of results. At the time of the call, +the current buffer contains the results of querying a url +returned by (THIS-BACKEND `url' QUERY). The format of individual +results is described in the docstring of `biblio-insert-result'). + +`forward-bibtex': (two arguments, METADATA and FORWARD-TO) +Produce a BibTeX record from METADATA (one of the elements of the +list produced by `parse-buffer') and call FORWARD-TO on it. + +For examples of backends, see one of `biblio-crossref-backend', +`biblio-dblp-backend', `biblio-arxiv-backend', etc. + + +To register your backend automatically, you may want to add a +`register' command: + +`register': Add the current backend to `biblio-backends'. +Something like (add-to-list \\='biblio-backends \\='THIS-BACKEND). + +Then it's enough to add your backend to `biblio-init-hook': + +;;;###autoload +\(add-hook \\='biblio-init-hook \\='YOUR-BACKEND-HERE).") + +(defvar biblio-init-hook nil + "Hook run before every search. +Each function is called with one argument, `register'. This +makes it possible to register backends by adding them directly to +this hook, and making them react to `register' by adding +themselves to biblio-backends.") + +(defun biblio-collect-backends () + "Populate `biblio-backends' and return that." + (run-hook-with-args 'biblio-init-hook 'register) + biblio-backends) + +(defun biblio--named-backends () + "Collect an alist of (NAME . BACKEND)." + (seq-map (lambda (b) (cons (funcall b 'name) b)) (biblio-collect-backends))) + +(defun biblio--read-backend () + "Run `biblio-init-hook', then read a backend from `biblio-backend'." + (biblio-completing-read-alist "Backend: " (biblio--named-backends) nil t)) + +(defun biblio--read-query (backend) + "Interactively read a query. +Get prompt string from BACKEND." + (let* ((prompt (funcall backend 'prompt))) + (read-string prompt nil 'biblio--search-history))) + +(defun biblio--lookup-1 (backend query) + "Just like `biblio-lookup' on BACKEND and QUERY, but never prompt." + (let ((results-buffer (biblio--make-results-buffer (current-buffer) query backend))) + (biblio-url-retrieve + (funcall backend 'url query) + (biblio--callback results-buffer backend)) + results-buffer)) + +;;;###autoload +(defun biblio-lookup (&optional backend query) + "Perform a search using BACKEND, and QUERY. +Prompt for any missing or nil arguments. BACKEND should be a +function obeying the interface described in the docstring of +`biblio-backends'. Returns the buffer in which results will be +inserted." + (interactive) + (unless backend (setq backend (biblio--read-backend))) + (unless query (setq query (biblio--read-query backend))) + (biblio--lookup-1 backend query)) + +(defun biblio-kill-buffers () + "Kill all `biblio-selection-mode' buffers." + (interactive) + (dolist (buf (buffer-list)) + (when (and (buffer-live-p buf) + (eq (buffer-local-value 'major-mode buf) + 'biblio-selection-mode)) + (kill-buffer buf)))) + +;; Local Variables: +;; nameless-current-name: "biblio" +;; checkdoc-arguments-in-order-flag: nil +;; End: + +(provide 'biblio-core) +;;; biblio-core.el ends here diff --git a/lisp/bibtex-completion.el b/lisp/bibtex-completion.el new file mode 100644 index 00000000..44b028a8 --- /dev/null +++ b/lisp/bibtex-completion.el @@ -0,0 +1,1586 @@ +;;; bibtex-completion.el --- A BibTeX backend for completion frameworks + +;; Author: Titus von der Malsburg +;; Justin Burkett +;; Maintainer: Titus von der Malsburg +;; URL: https://github.com/tmalsburg/helm-bibtex +;; Package-Version: 20200513.852 +;; Package-Commit: 8a0dd9841316793aacddea744d6b8ca4a7857a35 +;; Version: 1.0.0 +;; Package-Requires: ((parsebib "1.0") (s "1.9.0") (dash "2.6.0") (f "0.16.2") (cl-lib "0.5") (biblio "0.2") (emacs "26.1")) + +;; 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 . + +;;; Commentary: + +;; A BibTeX backend for completion frameworks + +;; There are currently two fronends: helm-bibtex and ivy-bibtex. +;; +;; See the github page for details: +;; +;; https://github.com/tmalsburg/helm-bibtex + +;;; Code: + +(require 'browse-url) +(require 'parsebib) +(require 'cl-lib) +(require 'dash) +(require 's) +(require 'f) +(require 'biblio) +(require 'filenotify) +(require 'org-capture) + +;; Silence byte-compiler +(declare-function reftex-what-macro "reftex-parse") +(declare-function reftex-get-bibfile-list "reftex-cite") +(declare-function outline-show-all "outline") +(declare-function org-narrow-to-subtree "org") +(declare-function org-cycle-hide-drawers "org") +(declare-function org-find-property "org") +(declare-function org-show-entry "org") +(declare-function org-entry-get "org") +(declare-function org-element-parse-buffer "org-element") +(declare-function org-element-map "org-element") +(declare-function org-element-property "org-element") + +(defgroup bibtex-completion nil + "Helm plugin for searching entries in a BibTeX bibliography." + :group 'completion) + +(defcustom bibtex-completion-bibliography nil + "The BibTeX file or list of BibTeX files. +Org-bibtex users can also specify org mode bibliography files, in +which case it will be assumed that a BibTeX file exists with the +same name and extension bib instead of org. If the bib file has a +different name, use a cons cell `(\"orgfile.org\" . \"bibfile.bib\")' instead." + :group 'bibtex-completion + :type '(choice file (repeat file))) + +(defcustom bibtex-completion-library-path nil + "A directory or list of directories in which PDFs are stored. +Bibtex-completion assumes that the names of these PDFs are +composed of the BibTeX-key plus a \".pdf\" suffix." + :group 'bibtex-completion + :type '(choice directory (repeat directory))) + +(defcustom bibtex-completion-pdf-open-function 'find-file + "The function used for opening PDF files. +This can be an arbitrary function that takes one argument: the +path to the PDF file. The default is `find-file' which opens the +PDF in Emacs (either with docview or, if installed, the much +superior pdf-tools. When set to +`helm-open-file-with-default-tool', the systems default viewer +for PDFs is used." + :group 'bibtex-completion + :type 'function) + +(defcustom bibtex-completion-pdf-extension ".pdf" + "The extension of a BibTeX entry's \"PDF\" file. +This makes it possible to use another file type. It can also be a +list of file types, which are then tried sequentially until a +file is found. Beware that adding file types can reduce +performance for large bibliographies. This variable has no +effect if PDFs are referenced via the file field." + :group 'bibtex-completion + :type 'string) + +(defcustom bibtex-completion-find-additional-pdfs nil + "If non-nil, all files whose base name starts with the BibTeX key and ends with `bibtex-completion-pdf-extension' are considered as PDFs, not only \".\". +Note that for performance reasons, an entry is only marked as +having a PDF if \". (length (car it)) 0) entry-alist) + (cl-acons "" "" + (gethash (downcase crossref) entry-hash))))) + entry))))) + +(defun bibtex-completion-make-entry-hash (files reparsed-files) + "Return a hash table of all potentially cross-referenced bibliography entries in FILES, assuming that only those files in REPARSED-FILES were reparsed whereas the other files in FILES were up-to-date. +Only entries whose type belongs to +`bibtex-completion-cross-referenced-entry-types' are included in +the hash table." + (cl-loop + with entries = + (cl-loop + for file in files + for entries = (cddr (assoc file bibtex-completion-cache)) + if (member file reparsed-files) + ;; Entries are alists of \(FIELD . VALUE\) pairs. + append entries + ;; Entries are \(STRING . ALIST\) conses. + else + append (mapcar 'cdr entries)) + with ht = (make-hash-table :test #'equal :size (length entries)) + for entry in entries + for key = (bibtex-completion-get-value "=key=" entry) + if (member (downcase (bibtex-completion-get-value "=type=" entry)) + bibtex-completion-cross-referenced-entry-types) + do (puthash (downcase key) entry ht) + finally return ht)) + +(defun bibtex-completion-make-candidate (entry) + "Return a candidate for ENTRY." + (cons (bibtex-completion-clean-string + (s-join " " (-map #'cdr entry))) + entry)) + +(defun bibtex-completion-parse-bibliography (&optional ht-strings) + "Parse the BibTeX entries listed in the current buffer and return a list of entries in the order in which they appeared in the BibTeX file. +Also do some preprocessing of the entries. + +If HT-STRINGS is provided it is assumed to be a hash table." + (goto-char (point-min)) + (cl-loop + with fields = (append '("title" "crossref") + (-map (lambda (it) (if (symbolp it) (symbol-name it) it)) + bibtex-completion-additional-search-fields)) + for entry-type = (parsebib-find-next-item) + while entry-type + unless (member-ignore-case entry-type '("preamble" "string" "comment")) + collect (let* ((entry (parsebib-read-entry entry-type (point) ht-strings)) + (fields (append + (list (if (assoc-string "author" entry 'case-fold) + "author" + "editor") + (if (assoc-string "date" entry 'case-fold) + "date" + "year")) + fields))) + (-map (lambda (it) + (cons (downcase (car it)) (cdr it))) + (bibtex-completion-prepare-entry entry fields))))) + +(defun bibtex-completion-get-entry (entry-key) + "Given a BibTeX key this function scans all bibliographies listed in `bibtex-completion-bibliography' and returns an alist of the record with that key. +Fields from crossreferenced entries are appended to the requested entry." + (let* ((entry (bibtex-completion-get-entry1 entry-key)) + (crossref (bibtex-completion-get-value "crossref" entry)) + (crossref (when crossref (bibtex-completion-get-entry1 crossref)))) + (bibtex-completion-remove-duplicated-fields (append entry crossref)))) + +(defun bibtex-completion-get-entry1 (entry-key &optional do-not-find-pdf) + (let ((bib (bibtex-completion-normalize-bibliography 'bibtex))) + (with-temp-buffer + (mapc #'insert-file-contents bib) + (goto-char (point-min)) + (if (re-search-forward (concat "^[ \t]*@\\(" parsebib--bibtex-identifier + "\\)[[:space:]]*[\(\{][[:space:]]*" + (regexp-quote entry-key) "[[:space:]]*,") + nil t) + (let ((entry-type (match-string 1))) + (reverse (bibtex-completion-prepare-entry + (parsebib-read-entry entry-type (point) bibtex-completion-string-hash-table) nil do-not-find-pdf))) + (progn + (display-warning :warning (concat "Bibtex-completion couldn't find entry with key \"" entry-key "\".")) + nil))))) + +(defun bibtex-completion-find-pdf-in-field (key-or-entry) + "Return the path of the PDF specified in the field `bibtex-completion-pdf-field' if that file exists. +Returns nil if no file is specified, or if the specified file +does not exist, or if `bibtex-completion-pdf-field' is nil." + (when bibtex-completion-pdf-field + (let* ((entry (if (stringp key-or-entry) + (bibtex-completion-get-entry1 key-or-entry t) + key-or-entry)) + (value (bibtex-completion-get-value bibtex-completion-pdf-field entry))) + (cond + ((not value) nil) ; Field not defined. + ((f-file? value) (list value)) ; A bare full path was found. + ((-any 'f-file? (--map (f-join it (f-filename value)) (-flatten bibtex-completion-library-path))) (-filter 'f-file? (--map (f-join it (f-filename value)) (-flatten bibtex-completion-library-path)))) + (t ; Zotero/Mendeley/JabRef format: + (let ((value (replace-regexp-in-string "\\([^\\]\\);" "\\1\^^" value))) + (cl-loop ; Looping over the files: + for record in (s-split "\^^" value) + ; Replace unescaped colons by field separator: + for record = (replace-regexp-in-string "\\([^\\]\\|^\\):" "\\1\^_" record) + ; Unescape stuff: + for record = (replace-regexp-in-string "\\\\\\(.\\)" "\\1" record) + ; Now we can safely split: + for record = (s-split "\^_" record) + for file-name = (nth 0 record) + for path = (or (nth 1 record) "") + for paths = (if (s-match "^[A-Z]:" path) + (list path) ; Absolute Windows path + ; Something else: + (append + (list + path + file-name + (f-join (f-root) path) ; Mendeley #105 + (f-join (f-root) path file-name)) ; Mendeley #105 + (--map (f-join it path) + (-flatten bibtex-completion-library-path)) ; Jabref #100 + (--map (f-join it path file-name) + (-flatten bibtex-completion-library-path)))) ; Jabref #100 + for result = (-first (lambda (path) + (if (and (not (s-blank-str? path)) + (f-exists? path)) + path nil)) paths) + if result collect result))))))) + + +(defun bibtex-completion-find-pdf-in-library (key-or-entry &optional find-additional) + "Searches the directories in `bibtex-completion-library-path' for a PDF whose name is composed of the BibTeX key plus `bibtex-completion-pdf-extension'. +The path of the first matching PDF is returned. + +If FIND-ADDITIONAL is non-nil, the paths of all PDFs whose name +starts with the BibTeX key and ends with +`bibtex-completion-pdf-extension' are returned instead." + (let* ((key (if (stringp key-or-entry) + key-or-entry + (bibtex-completion-get-value "=key=" key-or-entry))) + (main-pdf (cl-loop + for dir in (-flatten bibtex-completion-library-path) + append (cl-loop + for ext in (-flatten bibtex-completion-pdf-extension) + collect (f-join dir (s-concat key ext)))))) + (if find-additional + (sort ; move main pdf on top of the list if needed + (cl-loop + for dir in (-flatten bibtex-completion-library-path) + append (directory-files dir t + (s-concat "^" (regexp-quote key) + ".*\\(" + (mapconcat 'regexp-quote + (-flatten bibtex-completion-pdf-extension) + "\\|") + "\\)$"))) + (lambda (x y) + (and (member x main-pdf) + (not (member y main-pdf))))) + (-flatten (-first 'f-file? main-pdf))))) + +(defun bibtex-completion-find-pdf (key-or-entry &optional find-additional) + "Return the path of the PDF associated with the specified entry KEY-OR-ENTRY. +This is either the path(s) specified in the field +`bibtex-completion-pdf-field' or, if that does not exist, the +first PDF in any of the directories in +`bibtex-completion-library-path' whose name is composed of the +the BibTeX key plus `bibtex-completion-pdf-extension' (or if +FIND-ADDITIONAL is non-nil, all PDFs in +`bibtex-completion-library-path' whose name starts with the +BibTeX key and ends with `bibtex-completion-pdf-extension'). +Returns nil if no PDF is found." + (or (bibtex-completion-find-pdf-in-field key-or-entry) + (bibtex-completion-find-pdf-in-library key-or-entry find-additional))) + +(defun bibtex-completion-find-note-multiple-files (entry-key) + "Find note file associated with entry ENTRY-KEY in the default directory. +The default directory is `bibtex-completion-notes-path'. If the +note file doesn’t exist, return nil." + (and bibtex-completion-notes-path + (f-directory? bibtex-completion-notes-path) + (f-file? (f-join bibtex-completion-notes-path + (s-concat entry-key + bibtex-completion-notes-extension))))) + +(defun bibtex-completion-find-note-one-file (entry-key) + "Find notes associated with entry ENTRY-KEY in the single notes file. +The single notes file is the one specified in +`bibtex-completion-notes-path'. If no note exists, return nil." + (and bibtex-completion-notes-path + (f-file? bibtex-completion-notes-path) + (member entry-key bibtex-completion-cached-notes-keys))) + +;; This defvar allows other packages like org-roam-bibtex to customize +;; the back-end for storing notes. +(defvar bibtex-completion-find-note-functions + (list #'bibtex-completion-find-note-multiple-files + #'bibtex-completion-find-note-one-file) + "List of functions to use to find note files. +The functions should accept one argument: the key of the BibTeX +entry and return non-nil if notes exist for that entry.") + +(defun bibtex-completion-prepare-entry (entry &optional fields do-not-find-pdf) + "Prepare ENTRY for display. +ENTRY is an alist representing an entry as returned by +`parsebib-read-entry'. All the fields not in FIELDS are removed +from ENTRY, with the exception of the \"=type=\" and \"=key=\" +fields. If FIELDS is empty, all fields are kept. Also add a +=has-pdf= and/or =has-note= field, if they exist for ENTRY. If +DO-NOT-FIND-PDF is non-nil, this function does not attempt to +find a PDF file." + (when entry ; entry may be nil, in which case just return nil + (let* ((fields (when fields (append fields (list "=type=" "=key=" "=has-pdf=" "=has-note=")))) + ; Check for PDF: + (entry (if (and (not do-not-find-pdf) (bibtex-completion-find-pdf entry)) + (cons (cons "=has-pdf=" bibtex-completion-pdf-symbol) entry) + entry)) + (entry-key (cdr (assoc "=key=" entry))) + ; Check for notes: + (entry (if (cl-some #'identity + (mapcar (lambda (fn) + (funcall fn entry-key)) + bibtex-completion-find-note-functions)) + (cons (cons "=has-note=" bibtex-completion-notes-symbol) entry) + entry)) + ; Remove unwanted fields: + (entry (if fields + (--filter (member-ignore-case (car it) fields) entry) + entry))) + ;; Normalize case of entry type: + (setcdr (assoc "=type=" entry) (downcase (cdr (assoc "=type=" entry)))) + ;; Remove duplicated fields: + (bibtex-completion-remove-duplicated-fields entry)))) + +(defun bibtex-completion-remove-duplicated-fields (entry) + "Remove duplicated fields from ENTRY." + (cl-remove-duplicates entry + :test (lambda (x y) (string= (s-downcase x) (s-downcase y))) + :key 'car :from-end t)) + + +(defun bibtex-completion-format-entry (entry width) + "Formats a BibTeX ENTRY for display in results list. +WIDTH is the width of the results list. The display format is +governed by the variable `bibtex-completion-display-formats'." + (let* ((format + (or (assoc-string (bibtex-completion-get-value "=type=" entry) + bibtex-completion-display-formats-internal + 'case-fold) + (assoc t bibtex-completion-display-formats-internal))) + (format-string (cadr format))) + (s-format + format-string + (lambda (field) + (let* ((field (split-string field ":")) + (field-name (car field)) + (field-width (cadr field)) + (field-value (bibtex-completion-get-value field-name entry))) + (when (and (string= field-name "author") + (not field-value)) + (setq field-value (bibtex-completion-get-value "editor" entry))) + (when (and (string= field-name "year") + (not field-value)) + (setq field-value (car (split-string (bibtex-completion-get-value "date" entry "") "-")))) + (setq field-value (bibtex-completion-clean-string (or field-value " "))) + (when (member field-name '("author" "editor")) + (setq field-value (bibtex-completion-shorten-authors field-value))) + (if (not field-width) + field-value + (setq field-width (string-to-number field-width)) + (truncate-string-to-width + field-value + (if (> field-width 0) + field-width + (- width (cddr format))) + 0 ?\s))))))) + + +(defun bibtex-completion-clean-string (s) + "Remove quoting and superfluous white space from BibTeX field value in S." + (if s (replace-regexp-in-string "[\n\t ]+" " " + (replace-regexp-in-string "[\"{}]+" "" s)) + nil)) + +(defun bibtex-completion-shorten-authors (authors) + "Return a comma-separated list of the surnames in AUTHORS." + (if authors + (cl-loop for a in (s-split " and " authors) + for p = (s-split "," a t) + for sep = "" then ", " + concat sep + if (eq 1 (length p)) + concat (-last-item (s-split " +" (car p) t)) + else + concat (car p)) + nil)) + + +(defun bibtex-completion-open-pdf (keys &optional fallback-action) + "Open the PDFs associated with the marked entries using the function specified in `bibtex-completion-pdf-open-function'. +If multiple PDFs are found for an entry, ask for the one to open +using `completion-read'. If FALLBACK-ACTION is non-nil, it is +called in case no PDF is found." + (dolist (key keys) + (let ((pdf (bibtex-completion-find-pdf key bibtex-completion-find-additional-pdfs))) + (cond + ((> (length pdf) 1) + (let* ((pdf (f-uniquify-alist pdf)) + (choice (completing-read "File to open: " (mapcar 'cdr pdf) nil t)) + (file (car (rassoc choice pdf)))) + (funcall bibtex-completion-pdf-open-function file))) + (pdf + (funcall bibtex-completion-pdf-open-function (car pdf))) + (fallback-action + (funcall fallback-action (list key))) + (t + (message "No PDF(s) found for this entry: %s" + key)))))) + +(defun bibtex-completion-open-url-or-doi (keys) + "Open the URL or DOI associated with entries in KEYS in a browser." + (dolist (key keys) + (let* ((entry (bibtex-completion-get-entry key)) + (url (bibtex-completion-get-value "url" entry)) + (doi (bibtex-completion-get-value "doi" entry)) + (browse-url-browser-function + (or bibtex-completion-browser-function + browse-url-browser-function))) + (if url + (browse-url url) + (if doi (browse-url + (s-concat "http://dx.doi.org/" doi)) + (message "No URL or DOI found for this entry: %s" + key)))))) + +(defun bibtex-completion-open-any (keys) + "Open the PDFs associated with the marked entries using the function specified in `bibtex-completion-pdf-open-function'. +If multiple PDFs are found for an entry, ask for the one to open +using `completion-read'. If no PDF is found, try to open a URL +or DOI in the browser instead." + (bibtex-completion-open-pdf keys 'bibtex-completion-open-url-or-doi)) + +(defun bibtex-completion-format-citation-default (keys) + "Default formatter for keys, separates multiple keys in KEYS with commas." + (s-join ", " keys)) + +(defvar bibtex-completion-cite-command-history nil + "History list for LaTeX citation commands.") + +(defun bibtex-completion-format-citation-cite (keys) + "Formatter for LaTeX citation commands. +Prompts for the command and for arguments if the commands can +take any. If point is inside or just after a citation command, +only adds KEYS to it." + (let (macro) + (cond + ((and (require 'reftex-parse nil t) + (setq macro (reftex-what-macro 1)) + (stringp (car macro)) + (string-match "\\`\\\\cite\\|cite\\'" (car macro))) + ;; We are inside a cite macro. Insert key at point, with appropriate delimiters. + (delete-horizontal-space) + (concat (pcase (preceding-char) + (?\{ "") + (?, " ") + (_ ", ")) + (s-join ", " keys) + (if (member (following-char) '(?\} ?,)) + "" + ", "))) + ((and (equal (preceding-char) ?\}) + (require 'reftex-parse nil t) + (save-excursion + (forward-char -1) + (setq macro (reftex-what-macro 1))) + (stringp (car macro)) + (string-match "\\`\\\\cite\\|cite\\'" (car macro))) + ;; We are right after a cite macro. Append key and leave point at the end. + (delete-char -1) + (delete-horizontal-space t) + (concat (pcase (preceding-char) + (?\{ "") + (?, " ") + (_ ", ")) + (s-join ", " keys) + "}")) + (t + ;; We are not inside or right after a cite macro. Insert a full citation. + (let* ((initial (when bibtex-completion-cite-default-as-initial-input + bibtex-completion-cite-default-command)) + (default (unless bibtex-completion-cite-default-as-initial-input + bibtex-completion-cite-default-command)) + (default-info (if default (format " (default \"%s\")" default) "")) + (cite-command (completing-read + (format "Cite command%s: " default-info) + bibtex-completion-cite-commands nil nil initial + 'bibtex-completion-cite-command-history default nil))) + (if (member cite-command '("nocite" "supercite")) ; These don't want arguments. + (format "\\%s{%s}" cite-command (s-join ", " keys)) + (let ((prenote (if bibtex-completion-cite-prompt-for-optional-arguments + (read-from-minibuffer "Prenote: ") + "")) + (postnote (if bibtex-completion-cite-prompt-for-optional-arguments + (read-from-minibuffer "Postnote: ") + ""))) + (cond ((not (string= "" prenote)) + (format "\\%s[%s][%s]{%s}" cite-command prenote postnote (s-join ", " keys))) + ((not (string= "" postnote)) + (format "\\%s[%s]{%s}" cite-command postnote (s-join ", " keys))) + (t + (format "\\%s{%s}" cite-command (s-join ", " keys))))))))))) + +(defun bibtex-completion-format-citation-pandoc-citeproc (keys) + "Format pandoc-citeproc citations for the entries in KEYS." + (let* ((prenote (if bibtex-completion-cite-prompt-for-optional-arguments (read-from-minibuffer "Prenote: ") "")) + (postnote (if bibtex-completion-cite-prompt-for-optional-arguments (read-from-minibuffer "Postnote: ") "")) + (prenote (if (string= "" prenote) "" (concat prenote " "))) + (postnote (if (string= "" postnote) "" (concat ", " postnote)))) + (format "[%s%s%s]" prenote (s-join "; " (--map (concat "@" it) keys)) postnote))) + +(defun bibtex-completion-format-citation-ebib (keys) + "Format ebib references for keys in KEYS." + (s-join ", " + (--map (format "ebib:%s" it) keys))) + +(defun bibtex-completion-format-citation-org-link-to-PDF (keys) + "Format org-links to PDFs associated with entries in KEYS. +Uses first matching PDF if several are available. Entries for +which no PDF is available are omitted." + (s-join ", " (cl-loop + for key in keys + for pdfs = (bibtex-completion-find-pdf key bibtex-completion-find-additional-pdfs) + append (with-no-warnings (--map (org-make-link-string it key) pdfs))))) + +(defun bibtex-completion-format-citation-org-apa-link-to-PDF (keys) + "Format org-links to PDF for entries in KEYS. +Link text loosely follows APA format. Uses first matching PDF if +several are available." + (s-join ", " (cl-loop + for key in keys + for entry = (bibtex-completion-get-entry key) + for author = (bibtex-completion-shorten-authors + (or (bibtex-completion-get-value "author" entry) + (bibtex-completion-get-value "editor" entry))) + for year = (or (bibtex-completion-get-value "year" entry) + (car (split-string (bibtex-completion-get-value "date" entry "") "-"))) + for pdf = (car (bibtex-completion-find-pdf key)) + if pdf + collect (with-no-warnings (org-make-link-string pdf (format "%s (%s)" author year))) + else + collect (format "%s (%s)" author year)))) + +;; When you want to create a todo list about reading, I think using +;; PDF's title is more intuitive. +(defun bibtex-completion-format-citation-org-title-link-to-PDF (keys) + "Formatter org-links to PDFs associated with entries in KEYS. +Link text follows file title format. Uses first matching PDF if +several are available." + (s-join ", " (cl-loop + for key in keys + for entry = (bibtex-completion-get-entry key) + for title = (bibtex-completion-apa-get-value "title" entry) + for pdf = (or (car (bibtex-completion-find-pdf key)) + (bibtex-completion-get-value "url" entry)) + if pdf + collect (with-no-warnings (org-make-link-string pdf title)) + else + collect (format "%s" title)))) + +(defun bibtex-completion-insert-citation (keys) + "Insert citations for entries in KEYS at point. +The format depends on +`bibtex-completion-format-citation-functions'." + (let ((format-function + (cdr (or (assoc major-mode bibtex-completion-format-citation-functions) + (assoc 'default bibtex-completion-format-citation-functions))))) + (insert + (funcall format-function keys)))) + +(defun bibtex-completion-insert-reference (keys) + "Insert references for entries in KEYS." + (let* ((refs (--map + (s-word-wrap fill-column + (concat "\n- " (bibtex-completion-apa-format-reference it))) + keys))) + (insert "\n" (s-join "\n" refs) "\n"))) + +(defun bibtex-completion-apa-format-reference (key) + "Return a plain text reference in APA format for the publication specified by KEY." + (let* + ((entry (bibtex-completion-get-entry key)) + (ref (pcase (downcase (bibtex-completion-get-value "=type=" entry)) + ("article" + (s-format + "${author} (${year}). ${title}. ${journal}, ${volume}(${number}), ${pages}.${doi}" + 'bibtex-completion-apa-get-value entry)) + ("inproceedings" + (s-format + "${author} (${year}). ${title}. In ${editor}, ${booktitle} (pp. ${pages}). ${address}: ${publisher}." + 'bibtex-completion-apa-get-value entry)) + ("book" + (s-format + "${author} (${year}). ${title}. ${address}: ${publisher}." + 'bibtex-completion-apa-get-value entry)) + ("phdthesis" + (s-format + "${author} (${year}). ${title} (Doctoral dissertation). ${school}, ${address}." + 'bibtex-completion-apa-get-value entry)) + ("inbook" + (s-format + "${author} (${year}). ${title}. In ${editor} (Eds.), ${booktitle} (pp. ${pages}). ${address}: ${publisher}." + 'bibtex-completion-apa-get-value entry)) + ("incollection" + (s-format + "${author} (${year}). ${title}. In ${editor} (Eds.), ${booktitle} (pp. ${pages}). ${address}: ${publisher}." + 'bibtex-completion-apa-get-value entry)) + ("proceedings" + (s-format + "${editor} (Eds.). (${year}). ${booktitle}. ${address}: ${publisher}." + 'bibtex-completion-apa-get-value entry)) + ("unpublished" + (s-format + "${author} (${year}). ${title}. Unpublished manuscript." + 'bibtex-completion-apa-get-value entry)) + (_ + (s-format + "${author} (${year}). ${title}." + 'bibtex-completion-apa-get-value entry))))) + (replace-regexp-in-string "\\([.?!]\\)\\." "\\1" ref))) ; Avoid sequences of punctuation marks. + +(defun bibtex-completion-apa-get-value (field entry &optional default) + "Return FIELD or ENTRY formatted following the APA guidelines. +Return DEFAULT if FIELD is not present in ENTRY." + ;; Virtual fields: + (pcase field + ("author-or-editor" + ;; Avoid if-let and when-let because they're not working reliably + ;; in all versions of Emacs that we currently support: + (let ((value (bibtex-completion-get-value "author" entry))) + (if value + (bibtex-completion-apa-format-authors value) + (bibtex-completion-apa-format-editors + (bibtex-completion-get-value "editor" entry))))) + ("author-or-editor-abbrev" + (let* ((value (bibtex-completion-get-value "author" entry))) + (if value + (bibtex-completion-apa-format-authors-abbrev value) + (bibtex-completion-apa-format-editors-abbrev + (bibtex-completion-get-value "editor" entry))))) + ("author-abbrev" + (let ((value (bibtex-completion-get-value "author" entry))) + (when value + (bibtex-completion-apa-format-authors-abbrev value)))) + ("editor-abbrev" + (let ((value (bibtex-completion-get-value "editor" entry))) + (when value + (bibtex-completion-apa-format-editors-abbrev value)))) + (_ + ;; Real fields: + (let ((value (bibtex-completion-get-value field entry))) + (if value + (pcase field + ;; https://owl.english.purdue.edu/owl/resource/560/06/ + ("author" (bibtex-completion-apa-format-authors value)) + ("editor" (bibtex-completion-apa-format-editors value)) + ;; When referring to books, chapters, articles, or Web pages, + ;; capitalize only the first letter of the first word of a + ;; title and subtitle, the first word after a colon or a dash + ;; in the title, and proper nouns. Do not capitalize the first + ;; letter of the second word in a hyphenated compound word. + ("title" (replace-regexp-in-string ; remove braces + "[{}]" + "" + (replace-regexp-in-string ; remove macros + "\\\\[[:alpha:]]+{" + "" + (replace-regexp-in-string ; upcase initial letter + "^[[:alpha:]]" + 'upcase + (replace-regexp-in-string ; preserve stuff in braces from being downcased + "\\(^[^{]*{\\)\\|\\(}[^{]*{\\)\\|\\(}.*$\\)\\|\\(^[^{}]*$\\)" + (lambda (x) (downcase (s-replace "\\" "\\\\" x))) + value))))) + ("booktitle" value) + ;; Maintain the punctuation and capitalization that is used by + ;; the journal in its title. + ("pages" (s-join "–" (s-split "[^0-9]+" value t))) + ("doi" (s-concat " http://dx.doi.org/" value)) + ("year" (or value + (car (split-string (bibtex-completion-get-value "date" entry "") "-")))) + (_ value)) + ""))))) + +(defun bibtex-completion-apa-format-authors (value &optional abbrev) + "Format author list in VALUE in APA style. +When ABBREV is non-nil, format in abbreviated APA style instead." + (cl-loop for a in (s-split " and " value t) + if (s-index-of "{" a) + collect + (replace-regexp-in-string "[{}]" "" a) + into authors + else if (s-index-of "," a) + collect + (let ((p (s-split " *, *" a t))) + (concat + (car p) ", " + (s-join " " (-map (lambda (it) (concat (s-left 1 it) ".")) + (s-split " " (cadr p)))))) + into authors + else + collect + (let ((p (s-split " " a t))) + (concat + (-last-item p) ", " + (s-join " " (-map (lambda (it) (concat (s-left 1 it) ".")) + (-butlast p))))) + into authors + finally return + (let ((l (length authors))) + (cond + ((= l 1) (car authors)) + ((and abbrev (= l 2)) + (concat (s-join " & " authors))) + (abbrev + (format "%s et al." (car authors))) + ((< l 8) (concat (s-join ", " (-butlast authors)) + ", & " (-last-item authors))) + (t (concat (s-join ", " (-slice authors 0 7)) ", …")))))) + +(defun bibtex-completion-apa-format-authors-abbrev (value) + "Format author list in VALUE in abbreviated APA style." + (bibtex-completion-apa-format-authors value t)) + +(defun bibtex-completion-apa-format-editors (value &optional abbrev) + "Format editors in VALUE in APA style. +When ABBREV is non-nil, format in abbreviated APA style instead." + (cl-loop for a in (s-split " and " value t) + if (s-index-of "," a) + collect + (let ((p (s-split " *, *" a t))) + (concat + (s-join " " (-map (lambda (it) (concat (s-left 1 it) ".")) + (s-split " " (cadr p)))) + " " (car p))) + into editors + else + collect + (let ((p (s-split " " a t))) + (concat + (s-join " " (-map (lambda (it) (concat (s-left 1 it) ".")) + (-butlast p))) + " " (-last-item p))) + into editors + finally return + (let ((l (length editors))) + (cond + ((= l 1) (car editors)) + ((and abbrev (= l 2)) + (concat (s-join " & " editors))) + (abbrev + (format "%s et al." (car editors))) + ((< l 8) (concat (s-join ", " (-butlast editors)) + ", & " (-last-item editors))) + (t (concat (s-join ", " (-slice editors 0 7)) ", …")))))) + +(defun bibtex-completion-apa-format-editors-abbrev (value) + "Format editor list in VALUE in abbreviated APA style." + (bibtex-completion-apa-format-editors value t)) + +(defun bibtex-completion-get-value (field entry &optional default) + "Return the value for FIELD in ENTRY or DEFAULT if the value is not defined. +Surrounding curly braces are stripped." + (let ((value (cdr (assoc-string field entry 'case-fold)))) + (if value + (replace-regexp-in-string + "\\(^[[:space:]]*[\"{][[:space:]]*\\)\\|\\([[:space:]]*[\"}][[:space:]]*$\\)" + "" + (s-collapse-whitespace value)) + default))) + +(defun bibtex-completion-insert-key (keys) + "Insert BibTeX KEYS at point." + (insert + (funcall 'bibtex-completion-format-citation-default keys))) + +(defun bibtex-completion-insert-bibtex (keys) + "Insert BibTeX entries for entries in KEYS at point." + (insert (s-join "\n" (--map (bibtex-completion-make-bibtex it) keys)))) + +(defun bibtex-completion-make-bibtex (key) + "Create a self-contained BibTeX entry KEY. +Self-contained means that cross-referenced entries are merged." + (let* ((entry (bibtex-completion-get-entry key)) + (entry-type (bibtex-completion-get-value "=type=" entry))) + (format "@%s{%s,\n%s}\n" + entry-type key + (cl-loop + for field in entry + for name = (car field) + for value = (cdr field) + unless (member name + (append (-map (lambda (it) (if (symbolp it) (symbol-name it) it)) + bibtex-completion-no-export-fields) + '("=type=" "=key=" "=has-pdf=" "=has-note=" "crossref"))) + concat + (format " %s = {%s},\n" name value))))) + +(defun bibtex-completion-add-PDF-attachment (keys) + "Attach the PDFs of the entries with the given KEYS where available." + (dolist (key keys) + (let ((pdf (bibtex-completion-find-pdf key bibtex-completion-find-additional-pdfs))) + (if pdf + (mapc 'mml-attach-file pdf) + (message "No PDF(s) found for this entry: %s" + key))))) + +(define-minor-mode bibtex-completion-notes-mode + "Minor mode for managing notes." + :keymap (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") 'bibtex-completion-exit-notes-buffer) + (define-key map (kbd "C-c C-w") 'org-refile) + map) + (setq-local + header-line-format + (substitute-command-keys + " Finish \\[bibtex-completion-exit-notes-buffer], refile \\[org-refile]"))) + +;; Define global minor mode. This is needed to the toggle minor mode. +;;;###autoload +(define-globalized-minor-mode bibtex-completion-notes-global-mode bibtex-completion-notes-mode bibtex-completion-notes-mode) + +(defun bibtex-completion-exit-notes-buffer () + "Exit notes buffer and delete its window. +This will also disable `bibtex-completion-notes-mode' and remove +the header line." + (interactive) + (widen) + (bibtex-completion-notes-global-mode -1) + (setq-local + header-line-format nil) + (save-buffer) + (let ((window (get-buffer-window (get-file-buffer bibtex-completion-notes-path)))) + (if (and window (not (one-window-p window))) + (delete-window window) + (switch-to-buffer (other-buffer))))) + +(defun bibtex-completion-fill-template (entry template) + "Fill TEMPLATE according to info from ENTRY. + +First, the BibTeX fields are expanded (e.g. ${field-name}). +Then, the `org-capture' %-escapes are replaced with their values +according to `org-capture-templates'." + (let ((bibtex-exp (s-format template + 'bibtex-completion-apa-get-value + entry))) + ;; Delete trailing newline inserted by `org-capture-fill-template' + (substring + (->> bibtex-exp + ;; Escape newlines to prevent `org-capture-fill-template' from + ;; gobbling them + (replace-regexp-in-string "\n" "\\\\n") + (org-capture-fill-template) + ;; Restore newlines + (replace-regexp-in-string "\\\\n" "\n")) + 0 -1))) + +;; The purpose of this defvar is to allow other packages like +;; org-roam-bibtex to customize the back-end used for notes. +(defvar bibtex-completion-edit-notes-function + #'bibtex-completion-edit-notes-default + "Function used to edit notes. +The function should accept one argument, a list of BibTeX keys.") + +;; TODO Split this function into two, one for one file per note and +;; the other for one file for all notes. +(defun bibtex-completion-edit-notes-default (keys) + "Open the notes associated with the entries in KEYS. +Creates new notes where none exist yet." + (dolist (key keys) + (let* ((entry (bibtex-completion-get-entry key)) + (year (or (bibtex-completion-get-value "year" entry) + (car (split-string (bibtex-completion-get-value "date" entry "") "-")))) + (entry (push (cons "year" year) entry))) + (if (and bibtex-completion-notes-path + (f-directory? bibtex-completion-notes-path)) + ; One notes file per publication: + (let* ((path (f-join bibtex-completion-notes-path + (s-concat key bibtex-completion-notes-extension)))) + (find-file path) + (unless (f-exists? path) + ;; First expand BibTeX variables, then org-capture template vars: + (insert (bibtex-completion-fill-template + entry + bibtex-completion-notes-template-multiple-files)))) + ; One file for all notes: + (unless (and buffer-file-name + (f-same? bibtex-completion-notes-path buffer-file-name)) + (find-file-other-window bibtex-completion-notes-path)) + (widen) + (outline-show-all) + (goto-char (point-min)) + (if (re-search-forward (format bibtex-completion-notes-key-pattern (regexp-quote key)) nil t) + ; Existing entry found: + (when (eq major-mode 'org-mode) + (org-narrow-to-subtree) + (re-search-backward "^\*+ " nil t) + (org-cycle-hide-drawers nil) + (bibtex-completion-notes-mode 1)) + ; Create a new entry: + (goto-char (point-max)) + (save-excursion (insert (bibtex-completion-fill-template + entry + bibtex-completion-notes-template-one-file))) + (re-search-forward "^*+ " nil t)) + (when (eq major-mode 'org-mode) + (org-narrow-to-subtree) + (re-search-backward "^\*+ " nil t) + (org-cycle-hide-drawers nil) + (goto-char (point-max)) + (bibtex-completion-notes-mode 1)) + ;; Move point to ‘%?’ if it’s included in the pattern + (when (save-excursion + (progn (goto-char (point-min)) + (re-search-forward "%\\?" nil t))) + (let ((beginning (match-beginning 0)) + (end (match-end 0))) + (delete-region beginning end) + (goto-char beginning))))))) + +(defun bibtex-completion-edit-notes (keys) + "Open the notes associated with KEYS using `bibtex-completion-edit-notes-function'." + (funcall bibtex-completion-edit-notes-function keys)) + +(defun bibtex-completion-show-entry (keys) + "Show the first entry in KEYS in the relevant BibTeX file." + (catch 'break + (dolist (bib-file (bibtex-completion-normalize-bibliography 'main)) + (let ((key (car keys)) + (buf (or (get-file-buffer bib-file) + (find-buffer-visiting bib-file)))) + (find-file bib-file) + (widen) + (if (eq major-mode 'org-mode) + (let* ((prop (if (boundp 'org-bibtex-key-property) + org-bibtex-key-property + "CUSTOM_ID")) + (match (org-find-property prop key))) + (when match + (goto-char match) + (org-show-entry) + (throw 'break t))) + (goto-char (point-min)) + (when (re-search-forward + (concat "^@\\(" parsebib--bibtex-identifier + "\\)[[:space:]]*[\(\{][[:space:]]*" + (regexp-quote key) "[[:space:]]*,") nil t) + (throw 'break t))) + (unless buf + (kill-buffer)))))) + +(defun bibtex-completion-add-pdf-to-library (keys) + "Add a PDF to the library for the first entry in KEYS. +The PDF can be added either from an open buffer, a file, or a +URL." + (let* ((key (car keys)) + (source (char-to-string + (read-char-choice "Add pdf from [b]uffer, [f]ile, or [u]rl? " '(?b ?f ?u)))) + (buffer (when (string= source "b") + (read-buffer-to-switch "Add pdf buffer: "))) + (file (when (string= source "f") + (expand-file-name (read-file-name "Add pdf file: " nil nil t)))) + (url (when (string= source "u") + (read-string "Add pdf URL: "))) + (path (-flatten (list bibtex-completion-library-path))) + (path (if (cdr path) + (completing-read "Add pdf to: " path nil t) + (car path))) + (pdf (expand-file-name (completing-read "Rename pdf to: " + (--map (s-concat key it) + (-flatten bibtex-completion-pdf-extension)) + nil nil key) + path))) + (cond + (buffer + (with-current-buffer buffer + (write-file pdf t))) + (file + (copy-file file pdf 1)) + (url + (url-copy-file url pdf 1))))) + +(defun bibtex-completion-fallback-action (url-or-function search-expression) + "Execute fallback option. +Could consist of opening an URL or executing a function, +depending of type of URL-OR-FUNCTION (`stringp' or `function'). +If string, SEARCH-EXPRESSION will be inserted at %s in string. +If function, it will be called with SEARCH-EXPRESSION as +argument." + (let ((browse-url-browser-function + (or bibtex-completion-browser-function + browse-url-browser-function))) + (cond + ((stringp url-or-function) + (browse-url (format url-or-function (url-hexify-string search-expression)))) + ((functionp url-or-function) + (funcall url-or-function search-expression)) + (t (error "Don't know how to interpret this: %s" url-or-function))))) + +(defun bibtex-completion-fallback-candidates () + "Compile list of fallback options. +These consist of the online resources defined in +`bibtex-completion-fallback-options' plus one entry for each +bibliography file that will open that file for editing." + (let ((bib-files (bibtex-completion-normalize-bibliography 'main))) + (-concat + (--map (cons (s-concat "Create new entry in " (f-filename it)) + `(lambda (_search-expression) (find-file ,it) (goto-char (point-max)) (newline))) + bib-files) + bibtex-completion-fallback-options))) + +(defun bibtex-completion-find-local-bibliography () + "Return a list of BibTeX files associated with the current file. +If the current file is a BibTeX file, return this +file. Otherwise, try to use `reftex' to find the associated +BibTeX files. If this fails, return nil." + (or (and (buffer-file-name) + (string= (or (f-ext (buffer-file-name)) "") "bib") + (list (buffer-file-name))) + (and (buffer-file-name) + (require 'reftex-cite nil t) + (ignore-errors (reftex-get-bibfile-list))))) + +(defun bibtex-completion-key-at-point () + "Return the key of the BibTeX entry at point. +If the current file is a BibTeX file, return the key of the entry +at point. Otherwise, try to use `reftex' to check whether point +is at a citation macro, and if so return the key at +point. Otherwise, if the current file is an org mode file, return +the value of `org-bibtex-key-property' (or default to +\"CUSTOM_ID\"). Otherwise, return nil." + (or (and (eq major-mode 'bibtex-mode) + (save-excursion + (bibtex-beginning-of-entry) + (and (looking-at bibtex-entry-maybe-empty-head) + (bibtex-key-in-head)))) + (and (require 'reftex-parse nil t) + (save-excursion + (skip-chars-backward "[:space:],;}") + (let ((macro (reftex-what-macro 1))) + (and (stringp (car macro)) + (string-match "\\`\\\\cite\\|cite\\'" (car macro)) + ;; allow '_' in citekeys + (let ((temp-syn-table (make-syntax-table))) + (modify-syntax-entry ?_ "_" temp-syn-table) + (with-syntax-table temp-syn-table + (thing-at-point 'symbol))))))) + (and (eq major-mode 'org-mode) + (let (key) + (and (setq key (org-entry-get nil + (if (boundp 'org-bibtex-key-property) + org-bibtex-key-property + "CUSTOM_ID") + t)) + ;; KEY may be the empty string the the property is + ;; present but has no value + (> (length key) 0) + key))))) + +(provide 'bibtex-completion) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions obsolete) +;; coding: utf-8 +;; indent-tabs-mode: nil +;; End: + +;;; bibtex-completion.el ends here diff --git a/lisp/bind-key.el b/lisp/bind-key.el new file mode 100644 index 00000000..803d78ef --- /dev/null +++ b/lisp/bind-key.el @@ -0,0 +1,456 @@ +;;; bind-key.el --- A simple way to manage personal keybindings + +;; Copyright (c) 2012-2017 John Wiegley + +;; Author: John Wiegley +;; Maintainer: John Wiegley +;; Created: 16 Jun 2012 +;; Modified: 29 Nov 2017 +;; Version: 2.4 +;; Package-Version: 20191110.416 +;; Package-Commit: 7d925367ef0857d513d62eab4cb57b7436b9ffe9 +;; Keywords: keys keybinding config dotemacs +;; URL: https://github.com/jwiegley/use-package + +;; 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, 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 gnu emacs; see the file copying. if not, write to the +;; free software foundation, inc., 59 temple place - suite 330, +;; boston, ma 02111-1307, usa. + +;;; Commentary: + +;; If you have lots of keybindings set in your .emacs file, it can be hard to +;; know which ones you haven't set yet, and which may now be overriding some +;; new default in a new emacs version. This module aims to solve that +;; problem. +;; +;; Bind keys as follows in your .emacs: +;; +;; (require 'bind-key) +;; +;; (bind-key "C-c x" 'my-ctrl-c-x-command) +;; +;; If the keybinding argument is a vector, it is passed straight to +;; `define-key', so remapping a key with `[remap COMMAND]' works as +;; expected: +;; +;; (bind-key [remap original-ctrl-c-x-command] 'my-ctrl-c-x-command) +;; +;; If you want the keybinding to override all minor modes that may also bind +;; the same key, use the `bind-key*' form: +;; +;; (bind-key* "" 'other-window) +;; +;; If you want to rebind a key only in a particular keymap, use: +;; +;; (bind-key "C-c x" 'my-ctrl-c-x-command some-other-mode-map) +;; +;; To unbind a key within a keymap (for example, to stop your favorite major +;; mode from changing a binding that you don't want to override everywhere), +;; use `unbind-key': +;; +;; (unbind-key "C-c x" some-other-mode-map) +;; +;; To bind multiple keys at once, or set up a prefix map, a `bind-keys' macro +;; is provided. It accepts keyword arguments, please see its documentation +;; for a detailed description. +;; +;; To add keys into a specific map, use :map argument +;; +;; (bind-keys :map dired-mode-map +;; ("o" . dired-omit-mode) +;; ("a" . some-custom-dired-function)) +;; +;; To set up a prefix map, use `:prefix-map' and `:prefix' arguments (both are +;; required) +;; +;; (bind-keys :prefix-map my-customize-prefix-map +;; :prefix "C-c c" +;; ("f" . customize-face) +;; ("v" . customize-variable)) +;; +;; You can combine all the keywords together. Additionally, +;; `:prefix-docstring' can be specified to set documentation of created +;; `:prefix-map' variable. +;; +;; To bind multiple keys in a `bind-key*' way (to be sure that your bindings +;; will not be overridden by other modes), you may use `bind-keys*' macro: +;; +;; (bind-keys* +;; ("C-o" . other-window) +;; ("C-M-n" . forward-page) +;; ("C-M-p" . backward-page)) +;; +;; After Emacs loads, you can see a summary of all your personal keybindings +;; currently in effect with this command: +;; +;; M-x describe-personal-keybindings +;; +;; This display will tell you if you've overridden a default keybinding, and +;; what the default was. Also, it will tell you if the key was rebound after +;; your binding it with `bind-key', and what it was rebound it to. + +;;; Code: + +(require 'cl-lib) +(require 'easy-mmode) + +(defgroup bind-key nil + "A simple way to manage personal keybindings" + :group 'emacs) + +(defcustom bind-key-column-widths '(18 . 40) + "Width of columns in `describe-personal-keybindings'." + :type '(cons integer integer) + :group 'bind-key) + +(defcustom bind-key-segregation-regexp + "\\`\\(\\(C-[chx] \\|M-[gso] \\)\\([CM]-\\)?\\|.+-\\)" + "Regular expression used to divide key sets in the output from +\\[describe-personal-keybindings]." + :type 'regexp + :group 'bind-key) + +(defcustom bind-key-describe-special-forms nil + "If non-nil, extract docstrings from lambdas, closures and keymaps if possible." + :type 'boolean + :group 'bind-key) + +;; Create override-global-mode to force key remappings + +(defvar override-global-map (make-keymap) + "override-global-mode keymap") + +(define-minor-mode override-global-mode + "A minor mode so that keymap settings override other modes." + t "") + +;; the keymaps in `emulation-mode-map-alists' take precedence over +;; `minor-mode-map-alist' +(add-to-list 'emulation-mode-map-alists + `((override-global-mode . ,override-global-map))) + +(defvar personal-keybindings nil + "List of bindings performed by `bind-key'. + +Elements have the form ((KEY . [MAP]) CMD ORIGINAL-CMD)") + +;;;###autoload +(defmacro bind-key (key-name command &optional keymap predicate) + "Bind KEY-NAME to COMMAND in KEYMAP (`global-map' if not passed). + +KEY-NAME may be a vector, in which case it is passed straight to +`define-key'. Or it may be a string to be interpreted as +spelled-out keystrokes, e.g., \"C-c C-z\". See documentation of +`edmacro-mode' for details. + +COMMAND must be an interactive function or lambda form. + +KEYMAP, if present, should be a keymap and not a quoted symbol. +For example: + + (bind-key \"M-h\" #'some-interactive-function my-mode-map) + +If PREDICATE is non-nil, it is a form evaluated to determine when +a key should be bound. It must return non-nil in such cases. +Emacs can evaluate this form at any time that it does redisplay +or operates on menu data structures, so you should write it so it +can safely be called at any time." + (let ((namevar (make-symbol "name")) + (keyvar (make-symbol "key")) + (kdescvar (make-symbol "kdesc")) + (bindingvar (make-symbol "binding"))) + `(let* ((,namevar ,key-name) + (,keyvar (if (vectorp ,namevar) ,namevar + (read-kbd-macro ,namevar))) + (,kdescvar (cons (if (stringp ,namevar) ,namevar + (key-description ,namevar)) + (quote ,keymap))) + (,bindingvar (lookup-key (or ,keymap global-map) ,keyvar))) + (let ((entry (assoc ,kdescvar personal-keybindings)) + (details (list ,command + (unless (numberp ,bindingvar) + ,bindingvar)))) + (if entry + (setcdr entry details) + (add-to-list 'personal-keybindings (cons ,kdescvar details)))) + ,(if predicate + `(define-key (or ,keymap global-map) ,keyvar + '(menu-item "" nil :filter (lambda (&optional _) + (when ,predicate + ,command)))) + `(define-key (or ,keymap global-map) ,keyvar ,command))))) + +;;;###autoload +(defmacro unbind-key (key-name &optional keymap) + "Unbind the given KEY-NAME, within the KEYMAP (if specified). +See `bind-key' for more details." + `(progn + (bind-key ,key-name nil ,keymap) + (setq personal-keybindings + (cl-delete-if #'(lambda (k) + ,(if keymap + `(and (consp (car k)) + (string= (caar k) ,key-name) + (eq (cdar k) ',keymap)) + `(and (stringp (car k)) + (string= (car k) ,key-name)))) + personal-keybindings)))) + +;;;###autoload +(defmacro bind-key* (key-name command &optional predicate) + "Similar to `bind-key', but overrides any mode-specific bindings." + `(bind-key ,key-name ,command override-global-map ,predicate)) + +(defun bind-keys-form (args keymap) + "Bind multiple keys at once. + +Accepts keyword arguments: +:map MAP - a keymap into which the keybindings should be + added +:prefix KEY - prefix key for these bindings +:prefix-map MAP - name of the prefix map that should be created + for these bindings +:prefix-docstring STR - docstring for the prefix-map variable +:menu-name NAME - optional menu string for prefix map +:filter FORM - optional form to determine when bindings apply + +The rest of the arguments are conses of keybinding string and a +function symbol (unquoted)." + (let (map + doc + prefix-map + prefix + filter + menu-name + pkg) + + ;; Process any initial keyword arguments + (let ((cont t)) + (while (and cont args) + (if (cond ((and (eq :map (car args)) + (not prefix-map)) + (setq map (cadr args))) + ((eq :prefix-docstring (car args)) + (setq doc (cadr args))) + ((and (eq :prefix-map (car args)) + (not (memq map '(global-map + override-global-map)))) + (setq prefix-map (cadr args))) + ((eq :prefix (car args)) + (setq prefix (cadr args))) + ((eq :filter (car args)) + (setq filter (cadr args)) t) + ((eq :menu-name (car args)) + (setq menu-name (cadr args))) + ((eq :package (car args)) + (setq pkg (cadr args)))) + (setq args (cddr args)) + (setq cont nil)))) + + (when (or (and prefix-map (not prefix)) + (and prefix (not prefix-map))) + (error "Both :prefix-map and :prefix must be supplied")) + + (when (and menu-name (not prefix)) + (error "If :menu-name is supplied, :prefix must be too")) + + (unless map (setq map keymap)) + + ;; Process key binding arguments + (let (first next) + (while args + (if (keywordp (car args)) + (progn + (setq next args) + (setq args nil)) + (if first + (nconc first (list (car args))) + (setq first (list (car args)))) + (setq args (cdr args)))) + + (cl-flet + ((wrap (map bindings) + (if (and map pkg (not (memq map '(global-map + override-global-map)))) + `((if (boundp ',map) + ,(macroexp-progn bindings) + (eval-after-load + ,(if (symbolp pkg) `',pkg pkg) + ',(macroexp-progn bindings)))) + bindings))) + + (append + (when prefix-map + `((defvar ,prefix-map) + ,@(when doc `((put ',prefix-map 'variable-documentation ,doc))) + ,@(if menu-name + `((define-prefix-command ',prefix-map nil ,menu-name)) + `((define-prefix-command ',prefix-map))) + ,@(if (and map (not (eq map 'global-map))) + (wrap map `((bind-key ,prefix ',prefix-map ,map ,filter))) + `((bind-key ,prefix ',prefix-map nil ,filter))))) + (wrap map + (cl-mapcan + (lambda (form) + (let ((fun (and (cdr form) (list 'function (cdr form))))) + (if prefix-map + `((bind-key ,(car form) ,fun ,prefix-map ,filter)) + (if (and map (not (eq map 'global-map))) + `((bind-key ,(car form) ,fun ,map ,filter)) + `((bind-key ,(car form) ,fun nil ,filter)))))) + first)) + (when next + (bind-keys-form (if pkg + (cons :package (cons pkg next)) + next) map))))))) + +;;;###autoload +(defmacro bind-keys (&rest args) + "Bind multiple keys at once. + +Accepts keyword arguments: +:map MAP - a keymap into which the keybindings should be + added +:prefix KEY - prefix key for these bindings +:prefix-map MAP - name of the prefix map that should be created + for these bindings +:prefix-docstring STR - docstring for the prefix-map variable +:menu-name NAME - optional menu string for prefix map +:filter FORM - optional form to determine when bindings apply + +The rest of the arguments are conses of keybinding string and a +function symbol (unquoted)." + (macroexp-progn (bind-keys-form args nil))) + +;;;###autoload +(defmacro bind-keys* (&rest args) + (macroexp-progn (bind-keys-form args 'override-global-map))) + +(defun get-binding-description (elem) + (cond + ((listp elem) + (cond + ((memq (car elem) '(lambda function)) + (if (and bind-key-describe-special-forms + (stringp (nth 2 elem))) + (nth 2 elem) + "#")) + ((eq 'closure (car elem)) + (if (and bind-key-describe-special-forms + (stringp (nth 3 elem))) + (nth 3 elem) + "#")) + ((eq 'keymap (car elem)) + "#") + (t + elem))) + ;; must be a symbol, non-symbol keymap case covered above + ((and bind-key-describe-special-forms (keymapp elem)) + (let ((doc (get elem 'variable-documentation))) + (if (stringp doc) doc elem))) + ((symbolp elem) + elem) + (t + "#"))) + +(defun compare-keybindings (l r) + (let* ((regex bind-key-segregation-regexp) + (lgroup (and (string-match regex (caar l)) + (match-string 0 (caar l)))) + (rgroup (and (string-match regex (caar r)) + (match-string 0 (caar r)))) + (lkeymap (cdar l)) + (rkeymap (cdar r))) + (cond + ((and (null lkeymap) rkeymap) + (cons t t)) + ((and lkeymap (null rkeymap)) + (cons nil t)) + ((and lkeymap rkeymap + (not (string= (symbol-name lkeymap) (symbol-name rkeymap)))) + (cons (string< (symbol-name lkeymap) (symbol-name rkeymap)) t)) + ((and (null lgroup) rgroup) + (cons t t)) + ((and lgroup (null rgroup)) + (cons nil t)) + ((and lgroup rgroup) + (if (string= lgroup rgroup) + (cons (string< (caar l) (caar r)) nil) + (cons (string< lgroup rgroup) t))) + (t + (cons (string< (caar l) (caar r)) nil))))) + +;;;###autoload +(defun describe-personal-keybindings () + "Display all the personal keybindings defined by `bind-key'." + (interactive) + (with-output-to-temp-buffer "*Personal Keybindings*" + (princ (format (concat "Key name%s Command%s Comments\n%s %s " + "---------------------\n") + (make-string (- (car bind-key-column-widths) 9) ? ) + (make-string (- (cdr bind-key-column-widths) 8) ? ) + (make-string (1- (car bind-key-column-widths)) ?-) + (make-string (1- (cdr bind-key-column-widths)) ?-))) + (let (last-binding) + (dolist (binding + (setq personal-keybindings + (sort personal-keybindings + (lambda (l r) + (car (compare-keybindings l r)))))) + + (if (not (eq (cdar last-binding) (cdar binding))) + (princ (format "\n\n%s: %s\n%s\n\n" + (cdar binding) (caar binding) + (make-string (+ 21 (car bind-key-column-widths) + (cdr bind-key-column-widths)) ?-))) + (if (and last-binding + (cdr (compare-keybindings last-binding binding))) + (princ "\n"))) + + (let* ((key-name (caar binding)) + (at-present (lookup-key (or (symbol-value (cdar binding)) + (current-global-map)) + (read-kbd-macro key-name))) + (command (nth 1 binding)) + (was-command (nth 2 binding)) + (command-desc (get-binding-description command)) + (was-command-desc (and was-command + (get-binding-description was-command))) + (at-present-desc (get-binding-description at-present)) + ) + (let ((line + (format + (format "%%-%ds%%-%ds%%s\n" (car bind-key-column-widths) + (cdr bind-key-column-widths)) + key-name (format "`%s\'" command-desc) + (if (string= command-desc at-present-desc) + (if (or (null was-command) + (string= command-desc was-command-desc)) + "" + (format "was `%s\'" was-command-desc)) + (format "[now: `%s\']" at-present))))) + (princ (if (string-match "[ \t]+\n" line) + (replace-match "\n" t t line) + line)))) + + (setq last-binding binding))))) + +(provide 'bind-key) + +;; Local Variables: +;; outline-regexp: ";;;\\(;* [^\s\t\n]\\|###autoload\\)\\|(" +;; indent-tabs-mode: nil +;; End: + +;;; bind-key.el ends here diff --git a/lisp/cl-libify.el b/lisp/cl-libify.el new file mode 100644 index 00000000..c598e058 --- /dev/null +++ b/lisp/cl-libify.el @@ -0,0 +1,137 @@ +;;; cl-libify.el --- Update elisp code to use cl-lib instead of cl -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Steve Purcell + +;; Author: Steve Purcell +;; Keywords: lisp +;; Homepage: https://github.com/purcell/cl-libify +;; Package-Requires: ((emacs "25")) +;; Package-Version: 20181130.230 +;; Package-X-Original-Version: 0 + +;; 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 . + +;;; Commentary: + +;; `cl' is a deprecated library, and elisp authors should use `cl-lib' +;; instead. In most cases, this is a matter of requiring "cl-lib" and +;; adding a "cl-" prefix to symbols that came from "cl". + +;; This library provides an interactive command, `cl-libify', which +;; replaces usages of "cl" symbols with their "cl-lib" equivalent, +;; optionally prompting for each + +;; Note that some cl functions do not have exact replacements, +;; e.g. `flet', so further code changes might still be necessary. + +;; You can also use `cl-libify-mark-cl-symbols-obsolete' to mark old +;; `cl' names as obsolete, so that the byte compiler will help flag +;; their use. + +;;; Code: + + +(require 'cl-lib) +(eval-when-compile + (with-no-warnings + (require 'cl))) + +(defconst cl-libify-function-alias-alist + (eval-when-compile + (cl-loop for s being the symbols + for sf = (symbol-function s) + for nm = (symbol-name s) + when (and sf + (symbolp sf) + (not (string= (symbol-name sf) nm)) + (string-prefix-p "cl-" (symbol-name sf)) + (not (string-prefix-p "cl-" nm))) + collect (cons s sf))) + "Alist of symbols pairs mapping cl functions to their cl-lib equivalents.") + +(defconst cl-libify-var-alias-alist + (eval-when-compile + (cl-loop for s being the symbols + for sf = (indirect-variable s) + for nm = (symbol-name s) + when (and (not (eq sf s)) + (not (string= (symbol-name sf) nm)) + (string-prefix-p "cl-" (symbol-name sf)) + (not (string-prefix-p "cl-" nm))) + collect (cons s sf))) + "Alist of symbols pairs mapping cl variables to their cl-lib equivalents.") + +(defconst cl-libify-other-functions + '( + lexical-let + lexical-let* + flet + labels + define-setf-expander + defsetf + define-modify-macro) + "Functions from `cl' which have no direct `cl-lib' equivalent.") + +;;;###autoload +(defun cl-libify (beg end) + "Replace cl symbol names between BEG and END with their cl-lib equivalents. + +If no region is supplied, this operates on the entire +buffer. With prefix argument PROMPT, ask the user to confirm each +replacement." + (interactive "r") + (unless (use-region-p) + (setq beg (point-min) + end (point-max))) + (let ((prompt current-prefix-arg)) + (cl-libify--replace-in-region prompt beg end "[(']" cl-libify-function-alias-alist) + (cl-libify--replace-in-region prompt beg end "" cl-libify-var-alias-alist))) + +(defun cl-libify--replace-in-region (prompt beg end prefix alist) + "Between BEG and END, replace keys of ALIST with their matching values. +Keys must be distinct symbols which follow the regexp PREFIX. +That regexp must not contain any capture groups. When PROMPT is +non-nil, ask the user to confirm each replacement." + (save-excursion + (goto-char beg) + (let ((end-marker (set-marker (make-marker) end)) + (pat (regexp-opt (mapcar 'symbol-name (mapcar 'car alist)) 'symbols))) + (while (search-forward-regexp (concat prefix pat) end-marker t) + (unless (cl-libify--in-string-or-comment) + (let* ((orig (match-string 1)) + (replacement (symbol-name (alist-get (intern orig) alist)))) + (when (or (null prompt) + (let ((msg (format "Replace `%s' with `%s'?" orig replacement))) + (save-match-data (y-or-n-p msg)))) + (replace-match replacement t t nil 1)))))))) + +(defun cl-libify--in-string-or-comment () + "Return non-nil if point is within a string or comment." + (let ((ppss (syntax-ppss))) + (or (car (setq ppss (nthcdr 3 ppss))) + (car (setq ppss (cdr ppss))) + (nth 3 ppss)))) + +;;;###autoload +(defun cl-libify-mark-cl-symbols-obsolete () + "Make all the `cl' vars and functions obsolete so that byte compilation will flag their use." + (interactive) + (pcase-dolist (`(,old . ,new) cl-libify-function-alias-alist) + (make-obsolete old new "cl-lib")) + (pcase-dolist (`(,old . ,new) cl-libify-var-alias-alist) + (make-obsolete-variable old new "cl-lib"))) + + +(provide 'cl-libify) +;;; cl-libify.el ends here diff --git a/lisp/company-anaconda.el b/lisp/company-anaconda.el new file mode 100644 index 00000000..937dc734 --- /dev/null +++ b/lisp/company-anaconda.el @@ -0,0 +1,155 @@ +;;; company-anaconda.el --- Anaconda backend for company-mode -*- lexical-binding: t; -*- + +;; Copyright (C) 2013-2018 by Artem Malyshev + +;; Author: Artem Malyshev +;; URL: https://github.com/proofit404/anaconda-mode +;; Package-Version: 20200404.1859 +;; Package-Commit: da1566db41a68809ef7f91ebf2de28118067c89b +;; Version: 0.2.0 +;; Package-Requires: ((company "0.8.0") (anaconda-mode "0.1.1") (cl-lib "0.5.0") (dash "2.6.0") (s "1.9")) + +;; 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 . + +;;; Commentary: + +;; See the README for more details. + +;;; Code: + +(require 'anaconda-mode) +(require 'company) +(require 'python) +(require 'cl-lib) +(require 'rx) +(require 'dash) +(require 's) + +(defgroup company-anaconda nil + "Company back-end for Python code completion." + :group 'programming) + +(defcustom company-anaconda-annotation-function + 'company-anaconda-annotation + "Function that returns candidate annotations." + :group 'company-anaconda + :type 'function) + +(defcustom company-anaconda-case-insensitive t + "Use case insensitive candidates match." + :group 'company-anaconda + :type 'boolean) + +(defun company-anaconda-at-the-end-of-identifier () + "Check if the cursor at the end of completable identifier." + (let ((limit (line-beginning-position))) + (or + ;; We can't determine at this point if we can complete on a space + (looking-back " " limit) + ;; At the end of the symbol, but not the end of int number + (and (looking-at "\\_>") + (not (looking-back "\\_<\\(0[bo]\\)?[[:digit:]]+" limit)) + (not (looking-back "\\_<0x[[:xdigit:]]+" limit))) + ;; After the dot, but not when it's a dot after int number + ;; Although identifiers like "foo1.", "foo111.", or "foo1baz2." are ok + (and (looking-back "\\." (- (point) 1)) + (not (looking-back "\\_<[[:digit:]]+\\." limit))) + ;; After dot in float constant like "1.1." or ".1." + (or (looking-back "\\_<[[:digit:]]+\\.[[:digit:]]+\\." limit) + (looking-back "\\.[[:digit:]]+\\." limit))))) + +(defun company-anaconda-prefix () + "Grab prefix at point." + (and anaconda-mode + (not (company-in-string-or-comment)) + (company-anaconda-at-the-end-of-identifier) + (let* ((line-start (line-beginning-position)) + (start + (save-excursion + (if (not (re-search-backward + (python-rx + (or whitespace open-paren close-paren string-delimiter)) + line-start + t 1)) + line-start + (forward-char (length (match-string-no-properties 0))) + (point)))) + (symbol (buffer-substring-no-properties start (point)))) + (if (or (s-ends-with-p "." symbol) + (string-match-p + (rx (* space) word-start (or "from" "import") word-end space) + (buffer-substring-no-properties line-start (point)))) + (cons symbol t) + (if (s-blank-p symbol) + 'stop + symbol))))) + +(defun company-anaconda-candidates (callback given-prefix) + "Pass candidates list for GIVEN-PREFIX to the CALLBACK asynchronously." + (anaconda-mode-call + "company_complete" + (lambda (result) + (funcall callback + (--map + (let ((candidate (s-concat given-prefix (aref it 0)))) + (put-text-property 0 1 'struct it candidate) + candidate) + result))))) + +(defun company-anaconda-annotation (candidate) + "Return the description property of CANDIDATE inside chevrons." + (--when-let (aref (get-text-property 0 'struct candidate) 1) + (concat "<" it ">"))) + +(defun company-anaconda-doc-buffer (candidate) + "Return documentation buffer for chosen CANDIDATE." + (let ((docstring (aref (get-text-property 0 'struct candidate) 2))) + (unless (s-blank? docstring) + (anaconda-mode-documentation-view (vector (vector "" docstring)))))) + +(defun company-anaconda-meta (candidate) + "Return short documentation string for chosen CANDIDATE." + (let ((docstring (aref (get-text-property 0 'struct candidate) 2))) + (unless (s-blank? docstring) + (car (s-split-up-to "\n" docstring 1))))) + +(defun company-anaconda-location (candidate) + "Return location (path . line) for chosen CANDIDATE." + (-when-let* ((struct (get-text-property 0 'struct candidate)) + (module-path (pythonic-emacs-readable-file-name (aref struct 3))) + (line (aref struct 4))) + (cons module-path line))) + +;;;###autoload +(defun company-anaconda (command &optional arg &rest _args) + "Anaconda backend for company-mode. +See `company-backends' for more info about COMMAND and ARG." + (interactive (list 'interactive)) + (cl-case command + (interactive (company-begin-backend 'company-anaconda)) + (prefix (company-anaconda-prefix)) + (candidates (cons :async + (let ((given-prefix (s-chop-suffix (company-grab-symbol) arg))) + (lambda (callback) + (company-anaconda-candidates callback given-prefix))))) + (doc-buffer (company-anaconda-doc-buffer arg)) + (meta (company-anaconda-meta arg)) + (annotation (funcall company-anaconda-annotation-function arg)) + (location (company-anaconda-location arg)) + (ignore-case company-anaconda-case-insensitive) + (sorted t))) + +(provide 'company-anaconda) + +;;; company-anaconda.el ends here diff --git a/lisp/company-ledger.el b/lisp/company-ledger.el new file mode 100644 index 00000000..75e877c7 --- /dev/null +++ b/lisp/company-ledger.el @@ -0,0 +1,117 @@ +;;; company-ledger.el --- Fuzzy auto-completion for Ledger & friends -*- lexical-binding: t -*- + +;; Copyright (C) 2018-2020 Debanjum Singh Solanky + +;; Author: Debanjum Singh Solanky +;; Description: Fuzzy auto-completion for ledger & friends +;; Keywords: abbrev, matching, auto-complete, beancount, ledger, company +;; Package-Version: 20200726.1825 +;; Package-Commit: 9fe9e3b809d6d2bc13c601953f696f43b09ea296 +;; Version: 0.1.0 +;; Package-Requires: ((emacs "24.3") (company "0.8.0")) +;; URL: https://github.com/debanjum/company-ledger + +;; This file is NOT part of GNU Emacs. + +;;; License + +;; 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, 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; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. + +;;; Commentary: +;; +;; `company-mode' backend for `ledger-mode', `beancount-mode' and +;; similar plain-text accounting modes. Provides fuzzy completion +;; for transactions, prices and other date prefixed entries. +;; See Readme for detailed setup and usage description. +;; +;; Detailed Description +;; -------------------- +;; - Provides auto-completion based on words on current line +;; - The words on the current line can be partial and in any order +;; - The candidate entities are reverse sorted by location in file +;; - Candidates are paragraphs starting with YYYY[-/]MM[-/]DD +;; +;; Minimal Setup +;; ------------- +;; (with-eval-after-load 'company +;; (add-to-list 'company-backends 'company-ledger)) +;; +;; Use-Package Setup +;; ----------------- +;; (use-package company-ledger +;; :ensure company +;; :init +;; (with-eval-after-load 'company +;; (add-to-list 'company-backends 'company-ledger))) + +;;; Code: + +(require 'cl-lib) +(require 'company) + +(defun company-ledger--regexp-filter (regexp list) + "Use REGEXP to filter LIST of strings." + (let (new) + (dolist (string list) + (when (string-match regexp string) + (setq new (cons string new)))) + new)) + +(defun company-ledger--get-all-postings () + "Get all paragraphs in buffer containing YYYY[-/]MM[-/]DD in them." + (company-ledger--regexp-filter + "[0-9][0-9][0-9][0-9][-/][0-9][0-9][-/][0-9][0-9]" + (mapcar (lambda (s) (substring s 1)) + (split-string (buffer-string) "^$" t)))) + +(defun company-ledger--fuzzy-word-match (prefix candidate) + "Return non-nil if each (partial) word in PREFIX is also in CANDIDATE." + (eq nil + (memq nil + (mapcar + (lambda (pre) (string-match-p (regexp-quote pre) candidate)) + (split-string prefix))))) + +(defun company-ledger--next-line-empty-p () + "Return non-nil if next line empty else false." + (save-excursion + (beginning-of-line) + (forward-line 1) + (or (looking-at "[[:space:]]*$") + (eolp) + (eobp)))) + +;;;###autoload +(defun company-ledger (command &optional arg &rest ignored) + "Fuzzy company back-end for ledger, beancount and other ledger-like modes. +Provide completion info based on COMMAND and ARG. IGNORED, not used." + (interactive (list 'interactive)) + (cl-case command + (interactive (company-begin-backend 'company-ledger)) + + (prefix (and (or (bound-and-true-p beancount-mode) + (derived-mode-p 'ledger-mode)) + (company-ledger--next-line-empty-p) + (thing-at-point 'line t))) + + (candidates + (cl-remove-if-not + (lambda (c) (company-ledger--fuzzy-word-match arg c)) + (company-ledger--get-all-postings))) + (sorted t))) + +(provide 'company-ledger) +;;; company-ledger.el ends here diff --git a/lisp/company-quickhelp.el b/lisp/company-quickhelp.el new file mode 100644 index 00000000..ba78c978 --- /dev/null +++ b/lisp/company-quickhelp.el @@ -0,0 +1,271 @@ +;;; company-quickhelp.el --- Popup documentation for completion candidates + +;; Copyright (C) 2016, Lars Andersen + +;; Author: Lars Andersen +;; URL: https://www.github.com/expez/company-quickhelp +;; Package-Version: 20200626.1245 +;; Package-Commit: c401603685edafa82454fbf045c835e055e8bc56 +;; Keywords: company popup documentation quickhelp +;; Version: 2.2.0 +;; Package-Requires: ((emacs "24.3") (company "0.8.9") (pos-tip "0.4.6")) + +;; This file is not 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 . + +;;; Commentary: + +;; When idling on a completion candidate the documentation for the +;; candidate will pop up after `company-quickhelp-delay' seconds. + +;;; Usage: +;; put (company-quickhelp-mode) in your init.el to activate +;; `company-quickhelp-mode'. + +;; You can adjust the time it takes for the documentation to pop up by +;; changing `company-quickhelp-delay' + +;;; Code: +(require 'company) +(require 'pos-tip) +(require 'cl-lib) + +(defgroup company-quickhelp nil + "Documentation popups for `company-mode'" + :group 'company) + +(defcustom company-quickhelp-use-propertized-text nil + "Allow the text to have properties like color, font size, etc." + :type '(choice (boolean :tag "Allow")) + :group 'company-quickhelp) + +(defcustom company-quickhelp-delay 0.5 + "Delay, in seconds, before the quickhelp popup appears. + +If set to nil the popup won't automatically appear, but can still +be triggered manually using `company-quickhelp-show'." + :type '(choice (number :tag "Delay in seconds") + (const :tag "Don't popup help automatically" nil)) + :group 'company-quickhelp) + +(defcustom company-quickhelp-max-lines nil + "When not NIL, limits the number of lines in the popup." + :type '(choice (integer :tag "Max lines to show in popup") + (const :tag "Don't limit the number of lines shown" nil)) + :group 'company-quickhelp) + +(defcustom company-quickhelp-color-foreground nil + "Popup text foreground color." + :type '(choice (color) + (const :tag "Default" nil)) + :group 'company-quickhelp) + +(defcustom company-quickhelp-color-background nil + "Popup text background color." + :type '(choice (color) + (const :tag "Default" nil)) + :group 'company-quickhelp) + +(defvar-local company-quickhelp--timer nil + "Quickhelp idle timer.") + +(defvar-local company-quickhelp--original-tooltip-width company-tooltip-minimum-width + "The documentation popup breaks inexplicably when we transition + from a large pseudo-tooltip to a small one. We solve this by + overriding `company-tooltip-minimum-width' and save the + original value here so we can restore it.") + +(defun company-quickhelp-frontend (command) + "`company-mode' front-end showing documentation in a `pos-tip' popup." + (pcase command + (`post-command (when company-quickhelp-delay + (company-quickhelp--set-timer))) + (`hide + (when company-quickhelp-delay + (company-quickhelp--cancel-timer)) + (company-quickhelp--hide)))) + +(defun company-quickhelp--skip-footers-backwards () + "Skip backwards over footers and blank lines." + (beginning-of-line) + (while (and (not (= (point-at-eol) (point-min))) + (or + ;; [back] appears at the end of the help elisp help buffer + (looking-at-p "\\[back\\]") + ;; [source] cider's help buffer contains a link to source + (looking-at-p "\\[source\\]") + (looking-at-p "^\\s-*$"))) + (forward-line -1))) + +(defun company-quickhelp--goto-max-line () + "Go to last line to display in popup." + (if company-quickhelp-max-lines + (forward-line company-quickhelp-max-lines) + (goto-char (point-max)))) + +(defun company-quickhelp--docstring-from-buffer (start) + "Fetch docstring from START." + (goto-char start) + (company-quickhelp--goto-max-line) + (let ((truncated (< (point-at-eol) (point-max)))) + (company-quickhelp--skip-footers-backwards) + (list :doc (buffer-substring start (point-at-eol)) + :truncated truncated))) + +(defun company-quickhelp--completing-read (prompt candidates &rest rest) + "`cider', and probably other libraries, prompt the user to +resolve ambiguous documentation requests. Instead of failing we +just grab the first candidate and press forward." + (car candidates)) + +(defun company-quickhelp--fetch-docstring (backend) + "Fetch docstring from BACKEND." + (let ((quickhelp-str (company-call-backend 'quickhelp-string backend))) + (if (stringp quickhelp-str) + (with-temp-buffer + (insert quickhelp-str) + (company-quickhelp--docstring-from-buffer (point-min))) + (let ((doc (company-call-backend 'doc-buffer backend))) + (when doc + ;; The company backend can either return a buffer with the doc or a + ;; cons containing the doc buffer and a position at which to start + ;; reading. + (let ((doc-buffer (if (consp doc) (car doc) doc)) + (doc-begin (when (consp doc) (cdr doc)))) + (with-current-buffer doc-buffer + (company-quickhelp--docstring-from-buffer (or doc-begin (point-min)))))))))) + +(defun company-quickhelp--doc (selected) + (cl-letf (((symbol-function 'completing-read) + #'company-quickhelp--completing-read)) + (let* ((doc-and-meta (company-quickhelp--fetch-docstring selected)) + (truncated (plist-get doc-and-meta :truncated)) + (doc (plist-get doc-and-meta :doc))) + (unless (member doc '(nil "")) + (if truncated + (concat doc "\n\n[...]") + doc))))) + +(defun company-quickhelp-manual-begin () + "Manually trigger the `company-quickhelp' popup for the +currently active `company' completion candidate." + (interactive) + ;; This might seem a bit roundabout, but when I attempted to call + ;; `company-quickhelp--show' in a more direct manner it triggered a + ;; redisplay of company's list of completion candidates which looked + ;; quite weird. + (let ((company-quickhelp-delay 0.01)) + (company-quickhelp--set-timer))) + +(defun company-quickhelp--hide () + (when (company-quickhelp-pos-tip-available-p) + (pos-tip-hide))) + +(defun company-quickhelp--show () + (when (company-quickhelp-pos-tip-available-p) + (company-quickhelp--cancel-timer) + (while-no-input + (let* ((selected (nth company-selection company-candidates)) + (doc (let ((inhibit-message t)) + (company-quickhelp--doc selected))) + (width 80) + (timeout 300) + (ovl company-pseudo-tooltip-overlay) + (overlay-width (* (frame-char-width) + (if ovl (overlay-get ovl 'company-width) 0))) + (overlay-position (* (frame-char-width) + (- (if ovl (overlay-get ovl 'company-column) 1) 1))) + (x-gtk-use-system-tooltips nil) + (fg-bg `(,company-quickhelp-color-foreground + . ,company-quickhelp-color-background)) + (pos (save-excursion + (goto-char (min (overlay-start ovl) (point))) + (line-beginning-position))) + (dy (if (and ovl (< (overlay-get ovl 'company-height) 0)) + 0 + (frame-char-height)))) + (when (and ovl doc) + (with-no-warnings + (if company-quickhelp-use-propertized-text + (let* ((frame (window-frame (selected-window))) + (max-width (pos-tip-x-display-width frame)) + (max-height (pos-tip-x-display-height frame)) + (w-h (pos-tip-string-width-height doc))) + (cond + ((> (car w-h) width) + (setq doc (pos-tip-fill-string doc width nil 'none nil max-height) + w-h (pos-tip-string-width-height doc))) + ((or (> (car w-h) max-width) + (> (cdr w-h) max-height)) + (setq doc (pos-tip-truncate-string doc max-width max-height) + w-h (pos-tip-string-width-height doc)))) + (pos-tip-show-no-propertize doc fg-bg pos nil timeout + (pos-tip-tooltip-width (car w-h) (frame-char-width frame)) + (pos-tip-tooltip-height (cdr w-h) (frame-char-height frame) frame) + nil (+ overlay-width overlay-position) dy)) + (pos-tip-show doc fg-bg pos nil timeout width nil + (+ overlay-width overlay-position) dy)))))))) + +(defun company-quickhelp--set-timer () + (when (or (null company-quickhelp--timer) + (eq this-command #'company-quickhelp-manual-begin)) + (setq company-quickhelp--timer + (run-with-idle-timer company-quickhelp-delay nil + 'company-quickhelp--show)))) + +(defun company-quickhelp--cancel-timer () + (when (timerp company-quickhelp--timer) + (cancel-timer company-quickhelp--timer) + (setq company-quickhelp--timer nil))) + +(defun company-quickhelp-hide () + (company-cancel)) + + +(defun company-quickhelp-pos-tip-available-p () + "Return t if and only if pos-tip is expected work in the current frame." + (and + (fboundp 'x-hide-tip) + (fboundp 'x-show-tip) + (not (memq window-system (list nil 'pc))))) + +(defun company-quickhelp--enable () + (add-hook 'focus-out-hook #'company-quickhelp-hide nil t) + (setq-local company-quickhelp--original-tooltip-width company-tooltip-minimum-width) + (setq-local company-tooltip-minimum-width (max company-tooltip-minimum-width 40)) + (make-local-variable 'company-frontends) + (add-to-list 'company-frontends 'company-quickhelp-frontend :append)) + +(defun company-quickhelp--disable () + (remove-hook 'focus-out-hook #'company-quickhelp-hide t) + (company-quickhelp--cancel-timer) + (setq-local company-tooltip-minimum-width company-quickhelp--original-tooltip-width) + (setq-local company-frontends (delq 'company-quickhelp-frontend company-frontends))) + +;;;###autoload +(define-minor-mode company-quickhelp-local-mode + "Provides documentation popups for `company-mode' using `pos-tip'." + :global nil + (if company-quickhelp-local-mode + (company-quickhelp--enable) + (company-quickhelp--disable))) + +;;;###autoload +(define-globalized-minor-mode company-quickhelp-mode + company-quickhelp-local-mode company-quickhelp-local-mode) + +(provide 'company-quickhelp) + +;;; company-quickhelp.el ends here diff --git a/lisp/counsel.el b/lisp/counsel.el new file mode 100644 index 00000000..2f09ac54 --- /dev/null +++ b/lisp/counsel.el @@ -0,0 +1,6841 @@ +;;; counsel.el --- Various completion functions using Ivy -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2019 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; URL: https://github.com/abo-abo/swiper +;; Package-Version: 20200619.1030 +;; Package-Commit: d951004c7f3ebf98d55fc5a80a3471ec95b6db05 +;; Version: 0.13.0 +;; Package-Requires: ((emacs "24.5") (swiper "0.13.0")) +;; Keywords: convenience, matching, tools + +;; This file is 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 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. + +;; For a full copy of the GNU General Public License +;; see . + +;;; Commentary: + +;; Just call one of the interactive functions in this file to complete +;; the corresponding thing using `ivy'. +;; +;; Currently available: +;; - Symbol completion for Elisp, Common Lisp, Python, Clojure, C, C++. +;; - Describe functions for Elisp: function, variable, library, command, +;; bindings, theme. +;; - Navigation functions: imenu, ace-line, semantic, outline. +;; - Git utilities: git-files, git-grep, git-log, git-stash, git-checkout. +;; - Grep utilities: grep, ag, pt, recoll, ack, rg. +;; - System utilities: process list, rhythmbox, linux-app. +;; - Many more. + +;;; Code: + +(require 'swiper) + +(require 'compile) +(require 'dired) + +(eval-when-compile + (require 'subr-x)) + +(defgroup counsel nil + "Completion functions using Ivy." + :group 'matching + :prefix "counsel-") + +;;* Utility +(defun counsel--elisp-to-pcre (regex &optional look-around) + "Convert REGEX from Elisp format to PCRE format, on best-effort basis. +REGEX may be of any format returned by an Ivy regex function, +namely a string or a list. The return value is always a string. + +Note that incorrect results may be returned for sufficiently +complex regexes." + (if (consp regex) + (if (and look-around + (or (cdr regex) + (not (cdar regex)))) + (concat + "^" + (mapconcat + (lambda (pair) + (let ((subexp (counsel--elisp-to-pcre (car pair)))) + (format "(?%c.*%s)" + (if (cdr pair) ?= ?!) + subexp))) + regex + "")) + (mapconcat + (lambda (pair) + (let ((subexp (counsel--elisp-to-pcre (car pair)))) + (if (string-match-p "|" subexp) + (format "(?:%s)" subexp) + subexp))) + (cl-remove-if-not #'cdr regex) + ".*")) + (replace-regexp-in-string + "\\\\[(){}|`']\\|[()]" + (lambda (s) + (or (cdr (assoc s '(("\\(" . "(") + ("\\)" . ")") + ("(" . "\\(") + (")" . "\\)") + ("\\{" . "{") + ("\\}" . "}") + ("\\|" . "|") + ("\\`" . "^") + ("\\'" . "$")))) + (error + "Unexpected error in `counsel--elisp-to-pcre' (got match %S)" s))) + regex t t))) + +(defun counsel-directory-name (dir) + "Return the name of directory DIR with a slash." + (file-name-as-directory + (file-name-nondirectory + (directory-file-name dir)))) + +(defun counsel-string-compose (prefix str) + "Make PREFIX the display prefix of STR through text properties." + (let ((str (copy-sequence str))) + (put-text-property + 0 1 'display + (concat prefix (substring str 0 1)) + str) + str)) + +(defun counsel-require-program (cmd) + "Check system for program used in CMD, printing error if not found. +CMD is either a string or a list of strings. +To skip the `executable-find' check, start the string with a space." + (unless (and (stringp cmd) (string-match-p "^ " cmd)) + (let ((program (if (listp cmd) + (car cmd) + (car (split-string cmd))))) + (or (and (stringp program) + (not (string= program "")) + (executable-find program)) + (user-error "Required program \"%s\" not found in your path" program))))) + +(declare-function eshell-split-path "esh-util") + +(defun counsel-prompt-function-dir () + "Return prompt appended with the parent directory." + (require 'esh-util) + (let* ((dir (ivy-state-directory ivy-last)) + (parts (nthcdr 3 (eshell-split-path dir))) + (dir (format " [%s]: " (if parts (apply #'concat "..." parts) dir)))) + (ivy-add-prompt-count + (replace-regexp-in-string ; Insert dir before any trailing colon. + "\\(?:: ?\\)?\\'" dir (ivy-state-prompt ivy-last) t t)))) + +(defalias 'counsel--flatten + ;; Added in Emacs 27.1 + (if (fboundp 'flatten-tree) + #'flatten-tree + (lambda (tree) + (let (elems) + (while (consp tree) + (let ((elem (pop tree))) + (while (consp elem) + (push (cdr elem) tree) + (setq elem (car elem))) + (if elem (push elem elems)))) + (if tree (push tree elems)) + (nreverse elems)))) + "Compatibility shim for `flatten-tree'.") + +(defun counsel--format (formatter &rest args) + "Like `format' but FORMATTER can be a list. +When FORMATTER is a list, only `%s' is replaced with ARGS. + +Return a list or string depending on input." + (cond + ((listp formatter) + (counsel--flatten (mapcar + (lambda (it) (if (equal it "%s") (pop args) it)) + formatter))) + (t (apply #'format formatter args)))) + +;;* Async Utility +(defvar counsel--async-time nil + "Store the time when a new process was started. +Or the time of the last minibuffer update.") + +(defvar counsel--async-start nil + "Store the time when a new process was started.") + +(defvar counsel--async-timer nil + "Timer used to dispose `counsel--async-command.") + +(defvar counsel--async-duration nil + "Store the time a process takes to gather all its candidates. +The time is measured in seconds.") + +(defvar counsel--async-exit-code-plist () + "Associate commands with their exit code descriptions. +This plist maps commands to a plist mapping their exit codes to +descriptions.") + +(defvar counsel--async-last-error-string nil + "When the process returned non-0, store the output here.") + +(defun counsel-set-async-exit-code (cmd number str) + "For CMD, associate NUMBER exit code with STR." + (let ((plist (plist-get counsel--async-exit-code-plist cmd))) + (setq counsel--async-exit-code-plist + (plist-put counsel--async-exit-code-plist + cmd + (plist-put plist number str))))) + +(defvar counsel-async-split-string-re-alist '((t . "[\r\n]")) + "Store the regexp for splitting shell command output.") + +(defvar counsel-async-ignore-re-alist nil + "An alist of regexp matching candidates to ignore in `counsel--async-filter'.") + +(defvar counsel--async-last-command nil + "Store the last command ran by `counsel--async-command-1'.") + +(defun counsel--async-command-1 (cmd &optional sentinel filter name) + "Start and return new counsel process by calling CMD. +CMD can be either a shell command as a string, or a list of the +program name to be called directly, followed by its arguments. +If the default counsel process or one with NAME already exists, +kill it and its associated buffer before starting a new one. +Give the process the functions SENTINEL and FILTER, which default +to `counsel--async-sentinel' and `counsel--async-filter', +respectively." + (counsel-delete-process name) + (setq name (or name " *counsel*")) + (when (get-buffer name) + (kill-buffer name)) + (setq counsel--async-last-command cmd) + (let* ((buf (get-buffer-create name)) + (proc (if (listp cmd) + (apply #'start-file-process name buf cmd) + (start-file-process-shell-command name buf cmd)))) + (setq counsel--async-time (current-time)) + (setq counsel--async-start counsel--async-time) + (set-process-sentinel proc (or sentinel #'counsel--async-sentinel)) + (set-process-filter proc (or filter #'counsel--async-filter)) + proc)) + +(defcustom counsel-async-command-delay 0 + "Number of seconds to wait before spawning another async command." + :type 'number) + +(defun counsel--async-command (&rest args) + "Like `counsel--async-command-1', with same ARGS, but debounced. +Calls to `counsel--async-command-1' are separated by at least +`counsel-async-command-delay' seconds, so as to avoid issues +caused by spawning too many subprocesses too quickly." + (if (zerop counsel-async-command-delay) + (apply #'counsel--async-command-1 args) + (when counsel--async-timer + (cancel-timer counsel--async-timer)) + (setq counsel--async-timer + (apply #'run-with-timer + counsel-async-command-delay + nil + #'counsel--async-command-1 + args)))) + +(defun counsel--split-string (&optional str) + (split-string + (or str (buffer-string)) + (ivy-alist-setting counsel-async-split-string-re-alist) + t)) + +(defun counsel--sync-sentinel-on-exit (process) + (if (zerop (process-exit-status process)) + (let ((cur (ivy-state-current ivy-last))) + (ivy--set-candidates + (ivy--sort-maybe + (with-current-buffer (process-buffer process) + (counsel--split-string)))) + (when counsel--async-start + (setq counsel--async-duration + (time-to-seconds (time-since counsel--async-start)))) + (let ((re (ivy-re-to-str ivy-regex))) + (if ivy--old-cands + (if (eq (ivy-alist-setting ivy-index-functions-alist) 'ivy-recompute-index-zero) + (ivy-set-index 0) + (ivy--recompute-index re ivy--all-candidates)) + ;; index was changed before a long-running query exited + (unless (string= cur (nth ivy--index ivy--all-candidates)) + (let ((func (ivy-alist-setting ivy-index-functions-alist))) + (if func + (funcall func re ivy--all-candidates) + (ivy--preselect-index + (if (> (length re) 0) + cur + (ivy-state-preselect ivy-last)) + ivy--all-candidates)))))) + (setq ivy--old-cands ivy--all-candidates) + (if ivy--all-candidates + (ivy--exhibit) + (ivy--insert-minibuffer ""))) + (setq counsel--async-last-error-string + (with-current-buffer (process-buffer process) (buffer-string))) + (setq ivy--all-candidates + (let ((status (process-exit-status process)) + (plist (plist-get counsel--async-exit-code-plist + (ivy-state-caller ivy-last)))) + (list (or (plist-get plist status) + (format "error code %d" status))))) + (setq ivy--old-cands ivy--all-candidates) + (ivy--exhibit))) + +(defun counsel--async-sentinel (process _msg) + "Sentinel function for an asynchronous counsel PROCESS." + (when (eq (process-status process) 'exit) + (counsel--sync-sentinel-on-exit process))) + +(defcustom counsel-async-filter-update-time 500000 + "The amount of microseconds to wait until updating `counsel--async-filter'." + :type 'integer) + +(defun counsel--async-filter (process str) + "Receive from PROCESS the output STR. +Update the minibuffer with the amount of lines collected every +`counsel-async-filter-update-time' microseconds since the last update." + (with-current-buffer (process-buffer process) + (insert str)) + (when (time-less-p (list 0 0 counsel-async-filter-update-time) + (time-since counsel--async-time)) + (let (numlines) + (with-current-buffer (process-buffer process) + (setq numlines (count-lines (point-min) (point-max))) + (ivy--set-candidates + (let ((lines (counsel--split-string)) + (ignore-re (ivy-alist-setting counsel-async-ignore-re-alist))) + (if (stringp ignore-re) + (cl-remove-if (lambda (line) + (string-match-p ignore-re line)) + lines) + lines)))) + (let ((ivy--prompt (format "%d++ %s" numlines (ivy-state-prompt ivy-last)))) + (ivy--insert-minibuffer (ivy--format ivy--all-candidates))) + (setq counsel--async-time (current-time))))) + +(defun counsel-delete-process (&optional name) + "Delete current counsel process or that with NAME." + (let ((process (get-process (or name " *counsel*")))) + (when process + (delete-process process)))) + +;;* Completion at point +(define-obsolete-function-alias 'counsel-el 'complete-symbol "<2020-05-20 Wed>") +(define-obsolete-function-alias 'counsel-cl 'complete-symbol "<2020-05-20 Wed>") +(define-obsolete-function-alias 'counsel-jedi 'complete-symbol "<2020-05-20 Wed>") +(define-obsolete-function-alias 'counsel-clj 'complete-symbol "<2020-05-20 Wed>") + +;;** `counsel-company' +(defvar company-candidates) +(defvar company-common) +(defvar company-prefix) +(declare-function company-abort "ext:company") +(declare-function company-complete "ext:company") +(declare-function company-mode "ext:company") +(declare-function company-call-backend "ext:company") +(declare-function company--clean-string "ext:company") + +;;;###autoload +(defun counsel-company () + "Complete using `company-candidates'." + (interactive) + (company-mode 1) + (unless company-candidates + (company-complete)) + (let ((len (cond ((let (l) + (and company-common + (string= company-common + (buffer-substring + (- (point) (setq l (length company-common))) + (point))) + l))) + (company-prefix + (length company-prefix))))) + (when len + (setq ivy-completion-beg (- (point) len)) + (setq ivy-completion-end (point)) + (ivy-read "Candidate: " company-candidates + :action #'ivy-completion-in-region-action + :caller 'counsel-company)))) + +(ivy-configure 'counsel-company + :display-transformer-fn #'counsel--company-display-transformer + :unwind-fn #'company-abort) + +(defun counsel--company-display-transformer (s) + (concat s (let ((annot (company-call-backend 'annotation s))) + (when annot + (company--clean-string annot))))) + +;;** `counsel-irony' +(declare-function irony-completion-candidates-async "ext:irony-completion") +(declare-function irony-completion-symbol-bounds "ext:irony-completion") +(declare-function irony-completion-annotation "ext:irony-completion") + +;;;###autoload +(defun counsel-irony () + "Inline C/C++ completion using Irony." + (interactive) + (irony-completion-candidates-async 'counsel-irony-callback)) + +(defun counsel-irony-callback (candidates) + "Callback function for Irony to search among CANDIDATES." + (interactive) + (let* ((symbol-bounds (irony-completion-symbol-bounds)) + (beg (car symbol-bounds)) + (end (cdr symbol-bounds)) + (prefix (buffer-substring-no-properties beg end))) + (setq ivy-completion-beg beg + ivy-completion-end end) + (ivy-read "code: " (mapcar #'counsel-irony-annotate candidates) + :predicate (lambda (candidate) + (string-prefix-p prefix (car candidate))) + :caller 'counsel-irony + :action #'ivy-completion-in-region-action))) + +(defun counsel-irony-annotate (x) + "Make Ivy candidate from Irony candidate X." + (cons (concat (car x) (irony-completion-annotation x)) + (car x))) + +(add-to-list 'ivy-display-functions-alist '(counsel-irony . ivy-display-function-overlay)) + +;;* Elisp symbols +;;** `counsel-describe-variable' +(defvar counsel-describe-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-.") #'counsel-find-symbol) + (define-key map (kbd "C-,") #'counsel--info-lookup-symbol) + map)) + +(ivy-set-actions + 'counsel-describe-variable + '(("I" counsel-info-lookup-symbol "info") + ("d" counsel--find-symbol "definition"))) + +(defvar counsel-describe-symbol-history () + "History list for variable and function names. +Used by commands `counsel-describe-symbol', +`counsel-describe-variable', and `counsel-describe-function'.") + +(defun counsel-find-symbol () + "Jump to the definition of the current symbol." + (interactive) + (ivy-exit-with-action #'counsel--find-symbol)) +(put 'counsel-find-symbol 'no-counsel-M-x t) + +(defun counsel--info-lookup-symbol () + "Lookup the current symbol in the info docs." + (interactive) + (ivy-exit-with-action #'counsel-info-lookup-symbol)) + +(defvar find-tag-marker-ring) +(declare-function xref-push-marker-stack "xref") + +(defalias 'counsel--push-xref-marker + ;; Added in Emacs 25.1. + (if (require 'xref nil t) + #'xref-push-marker-stack + (require 'etags) + (lambda (&optional m) + (ring-insert (with-no-warnings find-tag-marker-ring) (or m (point-marker))))) + "Compatibility shim for `xref-push-marker-stack'.") + +(defun counsel--find-symbol (x) + "Find symbol definition that corresponds to string X." + (with-ivy-window + (counsel--push-xref-marker) + (let ((full-name (get-text-property 0 'full-name x))) + (if full-name + (find-library full-name) + (let ((sym (read x))) + (cond ((and (eq (ivy-state-caller ivy-last) + 'counsel-describe-variable) + (boundp sym)) + (find-variable sym)) + ((fboundp sym) + (find-function sym)) + ((boundp sym) + (find-variable sym)) + ((or (featurep sym) + (locate-library + (prin1-to-string sym))) + (find-library + (prin1-to-string sym))) + (t + (error "Couldn't find definition of %s" + sym)))))))) + +(defun counsel--variable-p (symbol) + "Return non-nil if SYMBOL is a bound or documented variable." + (or (and (boundp symbol) + (not (keywordp symbol))) + (get symbol 'variable-documentation))) + +(defcustom counsel-describe-variable-function #'describe-variable + "Function to call to describe a variable passed as parameter." + :type 'function) + +(defun counsel-describe-variable-transformer (var) + "Propertize VAR if it's a custom variable." + (if (custom-variable-p (intern var)) + (ivy-append-face var 'ivy-highlight-face) + var)) + +;;;###autoload +(defun counsel-describe-variable () + "Forward to `describe-variable'. + +Variables declared using `defcustom' are highlighted according to +`ivy-highlight-face'." + (interactive) + (let ((enable-recursive-minibuffers t)) + (ivy-read "Describe variable: " obarray + :predicate #'counsel--variable-p + :require-match t + :history 'counsel-describe-symbol-history + :keymap counsel-describe-map + :preselect (ivy-thing-at-point) + :action (lambda (x) + (funcall counsel-describe-variable-function (intern x))) + :caller 'counsel-describe-variable))) + +(ivy-configure 'counsel-describe-variable + :parent 'counsel-describe-symbol + :display-transformer-fn #'counsel-describe-variable-transformer) + +;;** `counsel-describe-function' +(ivy-set-actions + 'counsel-describe-function + '(("I" counsel-info-lookup-symbol "info") + ("d" counsel--find-symbol "definition"))) + +(defcustom counsel-describe-function-function #'describe-function + "Function to call to describe a function passed as parameter." + :type 'function) + +(defun counsel-describe-function-transformer (function-name) + "Propertize FUNCTION-NAME if it's an interactive function." + (if (commandp (intern function-name)) + (ivy-append-face function-name 'ivy-highlight-face) + function-name)) + +(defun ivy-function-called-at-point () + (let ((f (function-called-at-point))) + (and f (symbol-name f)))) + +(defcustom counsel-describe-function-preselect #'ivy-thing-at-point + "Determine what `counsel-describe-function' should preselect." + :type '(radio + (function-item ivy-thing-at-point) + (function-item ivy-function-called-at-point))) + +;;;###autoload +(defun counsel-describe-function () + "Forward to `describe-function'. + +Interactive functions (i.e., commands) are highlighted according +to `ivy-highlight-face'." + (interactive) + (let ((enable-recursive-minibuffers t)) + (ivy-read "Describe function: " obarray + :predicate (lambda (sym) + (or (fboundp sym) + (get sym 'function-documentation))) + :require-match t + :history 'counsel-describe-symbol-history + :keymap counsel-describe-map + :preselect (funcall counsel-describe-function-preselect) + :action (lambda (x) + (funcall counsel-describe-function-function (intern x))) + :caller 'counsel-describe-function))) + +(ivy-configure 'counsel-describe-function + :parent 'counsel-describe-symbol + :display-transformer-fn #'counsel-describe-function-transformer) + +;;** `counsel-describe-symbol' +(defcustom counsel-describe-symbol-function #'describe-symbol + "Function to call to describe a symbol passed as parameter." + :type 'function) + +;;;###autoload +(defun counsel-describe-symbol () + "Forward to `describe-symbol'." + (interactive) + (unless (functionp 'describe-symbol) + (user-error "This command requires Emacs 25.1 or later")) + (require 'help-mode) + (let ((enable-recursive-minibuffers t)) + (ivy-read "Describe symbol: " obarray + :predicate (lambda (sym) + (cl-some (lambda (backend) + (funcall (cadr backend) sym)) + describe-symbol-backends)) + :require-match t + :history 'counsel-describe-symbol-history + :keymap counsel-describe-map + :preselect (ivy-thing-at-point) + :action (lambda (x) + (funcall counsel-describe-symbol-function (intern x))) + :caller 'counsel-describe-symbol))) + +(ivy-configure 'counsel-describe-symbol + :initial-input "^" + :sort-fn #'ivy-string<) + +(ivy-set-actions + 'counsel-describe-symbol + `(("I" ,#'counsel-info-lookup-symbol "info") + ("d" ,#'counsel--find-symbol "definition"))) + +;;** `counsel-set-variable' +(defvar counsel-set-variable-history nil + "Store history for `counsel-set-variable'.") + +(defun counsel-read-setq-expression (sym) + "Read and eval a setq expression for SYM." + (setq this-command 'eval-expression) + (let* ((minibuffer-completing-symbol t) + (sym-value (symbol-value sym)) + (expr (minibuffer-with-setup-hook + (lambda () + ;; Functions `elisp-eldoc-documentation-function' and + ;; `elisp-completion-at-point' added in Emacs 25.1. + (add-function :before-until (local 'eldoc-documentation-function) + #'elisp-eldoc-documentation-function) + (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil t) + (run-hooks 'eval-expression-minibuffer-setup-hook) + (goto-char (minibuffer-prompt-end)) + (forward-char 6) + (insert (format "%S " sym))) + (read-from-minibuffer "Eval: " + (format + (if (and sym-value (or (consp sym-value) + (symbolp sym-value))) + "(setq '%S)" + "(setq %S)") + sym-value) + read-expression-map t + 'read-expression-history)))) + expr)) + +(defun counsel--setq-doconst (x) + "Return a cons of description and value for X. +X is an item of a radio- or choice-type defcustom." + (when (listp x) + (let ((v (car-safe (last x))) + (tag (and (eq (car x) 'const) + (plist-get (cdr x) :tag)))) + (when (and (or v tag) (not (eq v 'function))) + (cons + (concat + (when tag + (concat tag ": ")) + (if (stringp v) v (prin1-to-string v))) + (if (symbolp v) + (list 'quote v) + v)))))) + +(declare-function lv-message "ext:lv") +(declare-function lv-delete-window "ext:lv") +(declare-function custom-variable-documentation "cus-edit") + +(defface counsel-variable-documentation + '((t :inherit font-lock-comment-face)) + "Face for displaying Lisp documentation." + :group 'ivy-faces) + +;;;###autoload +(defun counsel-set-variable (sym) + "Set a variable SYM, with completion. + +When the selected variable is a `defcustom' with the type boolean +or radio, offer completion of all possible values. + +Otherwise, offer a variant of `eval-expression', with the initial +input corresponding to the chosen variable. + +With a prefix arg, restrict list to variables defined using +`defcustom'." + (interactive (list (intern + (ivy-read "Set variable: " obarray + :predicate (if current-prefix-arg + #'custom-variable-p + #'counsel--variable-p) + :history 'counsel-set-variable-history + :preselect (ivy-thing-at-point))))) + (let ((doc (and (require 'cus-edit) + (require 'lv nil t) + (not (string= "nil" (custom-variable-documentation sym))) + (propertize (custom-variable-documentation sym) + 'face 'counsel-variable-documentation))) + sym-type + cands) + (unwind-protect + (progn + (when doc + (lv-message (ivy--quote-format-string doc))) + (if (and (boundp sym) + (setq sym-type (get sym 'custom-type)) + (cond + ((and (consp sym-type) + (memq (car sym-type) '(choice radio))) + (setq cands (delq nil (mapcar #'counsel--setq-doconst + (cdr sym-type))))) + ((eq sym-type 'boolean) + (setq cands '(("nil" . nil) ("t" . t)))) + (t nil))) + (let* ((sym-val (symbol-value sym)) + (res (ivy-read (format "Set (%S <%s>): " sym sym-val) + cands + :preselect (prin1-to-string sym-val)))) + (when res + (setq res + (if (assoc res cands) + (cdr (assoc res cands)) + (read res))) + (kill-new (format "(setq %S %S)" sym res)) + (set sym (if (and (listp res) (eq (car res) 'quote)) + (cadr res) + res)))) + (unless (boundp sym) + (set sym nil)) + (let ((expr (counsel-read-setq-expression sym))) + (kill-new (format "%S" expr)) + (eval-expression expr)))) + (when doc + (lv-delete-window))))) + +;;** `counsel-apropos' +;;;###autoload +(defun counsel-apropos () + "Show all matching symbols. +See `apropos' for further information on what is considered +a symbol and how to search for them." + (interactive) + (ivy-read "Search for symbol (word list or regexp): " obarray + :predicate (lambda (sym) + (or (fboundp sym) + (boundp sym) + (facep sym) + (symbol-plist sym))) + :history 'counsel-apropos-history + :preselect (ivy-thing-at-point) + :action (lambda (pattern) + (when (string= pattern "") + (user-error "Please specify a pattern")) + ;; If the user selected a candidate form the list, we use + ;; a pattern which matches only the selected symbol. + (if (memq this-command '(ivy-immediate-done ivy-alt-done)) + ;; Regexp pattern are passed verbatim, other input is + ;; split into words. + (if (string= (regexp-quote pattern) pattern) + (apropos (split-string pattern "[ \t]+" t)) + (apropos pattern)) + (apropos (concat "\\`" pattern "\\'")))) + :caller 'counsel-apropos)) + +(ivy-configure 'counsel-apropos + :sort-fn #'ivy-string<) + +;;** `counsel-info-lookup-symbol' +(defvar info-lookup-mode) +(declare-function info-lookup-guess-default "info-look") +(declare-function info-lookup->completions "info-look") +(declare-function info-lookup->mode-value "info-look") +(declare-function info-lookup-select-mode "info-look") +(declare-function info-lookup-change-mode "info-look") +(declare-function info-lookup "info-look") + +;;;###autoload +(defun counsel-info-lookup-symbol (symbol &optional mode) + "Forward SYMBOL to `info-lookup-symbol' with ivy completion. +With prefix arg MODE a query for the symbol help mode is offered." + (interactive + (progn + (require 'info-look) + ;; Courtesy of `info-lookup-interactive-arguments' + (let* ((topic 'symbol) + (mode (cond (current-prefix-arg + (info-lookup-change-mode topic)) + ((info-lookup->mode-value + topic (info-lookup-select-mode)) + info-lookup-mode) + ((info-lookup-change-mode topic)))) + (enable-recursive-minibuffers t)) + (list (ivy-read "Describe symbol: " (info-lookup->completions topic mode) + :history 'info-lookup-history + :preselect (info-lookup-guess-default topic mode) + :caller 'counsel-info-lookup-symbol) + mode)))) + (info-lookup-symbol symbol mode)) + +(ivy-configure 'counsel-info-lookup-symbol + :sort-fn #'ivy-string<) + +;;** `counsel-M-x' +(defface counsel-key-binding + '((t :inherit font-lock-keyword-face)) + "Face used by `counsel-M-x' for key bindings." + :group 'ivy-faces) + +(defface counsel-active-mode + '((t :inherit font-lock-builtin-face)) + "Face used by `counsel-M-x' for activated modes." + :group 'ivy-faces) + +(defcustom counsel-alias-expand t + "When non-nil, show the expansion of aliases in `counsel-M-x'." + :type 'boolean + :group 'ivy) + +(defun counsel-M-x-transformer (cmd) + "Return CMD annotated with its active key binding, if any." + (let* ((sym (intern cmd)) + (alias (symbol-function sym)) + (key (where-is-internal sym nil t))) + (when (or (eq sym major-mode) + (and + (memq sym minor-mode-list) + (boundp sym) + (buffer-local-value sym (ivy-state-buffer ivy-last)))) + (setq cmd (propertize cmd 'face 'counsel-active-mode))) + (concat cmd + (when (and (symbolp alias) counsel-alias-expand) + (format " (%s)" alias)) + (when key + ;; Prefer `' over `C-x 6' where applicable + (let ((i (cl-search [?\C-x ?6] key))) + (when i + (let ((dup (vconcat (substring key 0 i) [f2] (substring key (+ i 2)))) + (map (current-global-map))) + (when (equal (lookup-key map key) + (lookup-key map dup)) + (setq key dup))))) + (setq key (key-description key)) + (put-text-property 0 (length key) 'face 'counsel-key-binding key) + (format " (%s)" key))))) + +(defvar amx-initialized) +(defvar amx-cache) +(declare-function amx-initialize "ext:amx") +(declare-function amx-detect-new-commands "ext:amx") +(declare-function amx-update "ext:amx") +(declare-function amx-rank "ext:amx") +(defvar smex-initialized-p) +(defvar smex-ido-cache) +(declare-function smex-initialize "ext:smex") +(declare-function smex-detect-new-commands "ext:smex") +(declare-function smex-update "ext:smex") +(declare-function smex-rank "ext:smex") + +(defun counsel--M-x-externs () + "Return `counsel-M-x' candidates from external packages. +The return value is a list of strings. The currently supported +packages are, in order of precedence, `amx' and `smex'." + (cond ((require 'amx nil t) + (unless amx-initialized + (amx-initialize)) + (when (amx-detect-new-commands) + (amx-update)) + (mapcar (lambda (entry) + (symbol-name (car entry))) + amx-cache)) + ((require 'smex nil t) + (unless smex-initialized-p + (smex-initialize)) + (when (smex-detect-new-commands) + (smex-update)) + smex-ido-cache))) + +(defun counsel--M-x-prompt () + "String for `M-x' plus the string representation of `current-prefix-arg'." + (concat (cond ((null current-prefix-arg) + nil) + ((eq current-prefix-arg '-) + "- ") + ((integerp current-prefix-arg) + (format "%d " current-prefix-arg)) + ((= (car current-prefix-arg) 4) + "C-u ") + (t + (format "%d " (car current-prefix-arg)))) + "M-x ")) + +(defvar counsel-M-x-history nil + "History for `counsel-M-x'.") + +(defun counsel-M-x-action (cmd) + "Execute CMD." + (setq cmd (intern + (subst-char-in-string ?\s ?- (string-remove-prefix "^" cmd)))) + (cond ((bound-and-true-p amx-initialized) + (amx-rank cmd)) + ((bound-and-true-p smex-initialized-p) + (smex-rank cmd))) + (setq prefix-arg current-prefix-arg) + (setq this-command cmd) + (setq real-this-command cmd) + (command-execute cmd 'record)) + +;;;###autoload +(defun counsel-M-x (&optional initial-input) + "Ivy version of `execute-extended-command'. +Optional INITIAL-INPUT is the initial input in the minibuffer. +This function integrates with either the `amx' or `smex' package +when available, in that order of precedence." + (interactive) + ;; When `counsel-M-x' returns, `last-command' would be set to + ;; `counsel-M-x' because :action hasn't been invoked yet. + ;; Instead, preserve the old value of `this-command'. + (setq this-command last-command) + (setq real-this-command real-last-command) + (let ((externs (counsel--M-x-externs))) + (ivy-read (counsel--M-x-prompt) (or externs obarray) + :predicate (if externs + (lambda (x) + (not (get (intern x) 'no-counsel-M-x))) + (lambda (sym) + (and (commandp sym) + (not (get sym 'byte-obsolete-info)) + (not (get sym 'no-counsel-M-x))))) + :require-match t + :history 'counsel-M-x-history + :action #'counsel-M-x-action + :keymap counsel-describe-map + :initial-input initial-input + :caller 'counsel-M-x))) + +(ivy-configure 'counsel-M-x + :initial-input "^" + :display-transformer-fn #'counsel-M-x-transformer) + +(ivy-set-actions + 'counsel-M-x + `(("d" counsel--find-symbol "definition") + ("h" ,(lambda (x) (funcall counsel-describe-function-function (intern x))) "help"))) + +;;** `counsel-command-history' +(defun counsel-command-history-action-eval (cmd) + "Eval the command CMD." + (eval (read cmd))) + +(defun counsel-command-history-action-edit-and-eval (cmd) + "Edit and eval the command CMD." + (edit-and-eval-command "Eval: " (read cmd))) + +(ivy-set-actions + 'counsel-command-history + '(("r" counsel-command-history-action-eval "eval command") + ("e" counsel-command-history-action-edit-and-eval "edit and eval command"))) + +;;;###autoload +(defun counsel-command-history () + "Show the history of commands." + (interactive) + (ivy-read "Command: " (mapcar #'prin1-to-string command-history) + :require-match t + :action #'counsel-command-history-action-eval + :caller 'counsel-command-history)) + +;;** `counsel-load-library' +(defun counsel-library-candidates () + "Return a list of completion candidates for `counsel-load-library'." + (let ((suffix (concat (regexp-opt '(".el" ".el.gz") t) "\\'")) + (cands (make-hash-table :test #'equal)) + short-name + old-val + dir-parent + res) + (dolist (dir load-path) + (setq dir (or dir default-directory)) ;; interpret nil in load-path as default-directory + (when (file-directory-p dir) + (dolist (file (file-name-all-completions "" dir)) + (when (string-match suffix file) + (unless (string-match "pkg.elc?$" file) + (setq short-name (substring file 0 (match-beginning 0))) + (if (setq old-val (gethash short-name cands)) + (progn + ;; assume going up directory once will resolve name clash + (setq dir-parent (counsel-directory-name (cdr old-val))) + (puthash short-name + (cons + (counsel-string-compose dir-parent (car old-val)) + (cdr old-val)) + cands) + (setq dir-parent (counsel-directory-name dir)) + (puthash (concat dir-parent short-name) + (cons + (propertize + (counsel-string-compose + dir-parent short-name) + 'full-name (expand-file-name file dir)) + dir) + cands)) + (puthash short-name + (cons (propertize + short-name + 'full-name (expand-file-name file dir)) + dir) + cands))))))) + (maphash (lambda (_k v) (push (car v) res)) cands) + (nreverse res))) + +;;;###autoload +(defun counsel-load-library () + "Load a selected the Emacs Lisp library. +The libraries are offered from `load-path'." + (interactive) + (let ((cands (counsel-library-candidates))) + (ivy-read "Load library: " cands + :action (lambda (x) + (load-library + (get-text-property 0 'full-name x))) + :keymap counsel-describe-map))) + +(ivy-set-actions + 'counsel-load-library + '(("d" counsel--find-symbol "definition"))) + +;;** `counsel-find-library' +(declare-function find-library-name "find-func") +(defun counsel-find-library-other-window (library) + (let ((buf (find-file-noselect (find-library-name library)))) + (pop-to-buffer buf 'other-window))) + +(defun counsel-find-library-other-frame (library) + (let ((buf (find-file-noselect (find-library-name library)))) + (condition-case nil + (switch-to-buffer-other-frame buf) + (error (pop-to-buffer buf))))) + +(ivy-set-actions + 'counsel-find-library + '(("j" counsel-find-library-other-window "other window") + ("f" counsel-find-library-other-frame "other frame"))) + +;;;###autoload +(defun counsel-find-library () + "Visit a selected the Emacs Lisp library. +The libraries are offered from `load-path'." + (interactive) + (let ((cands (counsel-library-candidates))) + (ivy-read "Find library: " cands + :action #'counsel--find-symbol + :keymap counsel-describe-map + :caller 'counsel-find-library))) + +;;** `counsel-load-theme' +(declare-function powerline-reset "ext:powerline") + +(defun counsel-load-theme-action (x) + "Disable current themes and load theme X." + (condition-case nil + (progn + (mapc #'disable-theme custom-enabled-themes) + (load-theme (intern x) t) + (when (fboundp 'powerline-reset) + (powerline-reset))) + (error "Problem loading theme %s" x))) + +;;;###autoload +(defun counsel-load-theme () + "Forward to `load-theme'. +Usable with `ivy-resume', `ivy-next-line-and-call' and +`ivy-previous-line-and-call'." + (interactive) + (ivy-read "Load custom theme: " + (mapcar 'symbol-name + (custom-available-themes)) + :action #'counsel-load-theme-action + :caller 'counsel-load-theme)) + +;;** `counsel-descbinds' +(ivy-set-actions + 'counsel-descbinds + '(("d" counsel-descbinds-action-find "definition") + ("I" counsel-descbinds-action-info "info") + ("x" counsel-descbinds-action-exec "execute"))) + +(defvar counsel-descbinds-history nil + "History for `counsel-descbinds'.") + +(defun counsel--descbinds-cands (&optional prefix buffer) + "Get key bindings starting with PREFIX in BUFFER. +See `describe-buffer-bindings' for further information." + (let ((buffer (or buffer (current-buffer))) + (re-exclude (regexp-opt + '("" "" "" + "" "" "" + "" "" + "" ""))) + res) + (with-temp-buffer + (let ((indent-tabs-mode t)) + (describe-buffer-bindings buffer prefix)) + (goto-char (point-min)) + ;; Skip the "Key translations" section + (re-search-forward " ") + (forward-char 1) + (while (not (eobp)) + (when (looking-at "^\\([^\t\n]+\\)[\t ]*\\(.*\\)$") + (let ((key (match-string 1)) + (fun (match-string 2)) + cmd) + (unless (or (member fun '("??" "self-insert-command")) + (string-match re-exclude key) + (not (or (commandp (setq cmd (intern-soft fun))) + (member fun '("Prefix Command"))))) + (push + (cons (format + "%-15s %s" + (propertize key 'face 'counsel-key-binding) + fun) + (cons key cmd)) + res)))) + (forward-line 1))) + (nreverse res))) + +(defcustom counsel-descbinds-function #'describe-function + "Function to call to describe a function passed as parameter." + :type 'function) + +(defun counsel-descbinds-action-describe (x) + "Describe function of candidate X. +See `describe-function' for further information." + (let ((cmd (cddr x))) + (funcall counsel-descbinds-function cmd))) + +(defun counsel-descbinds-action-exec (x) + "Run candidate X. +See `execute-extended-command' for further information." + (let ((cmd (cddr x))) + (command-execute cmd 'record))) + +(defun counsel-descbinds-action-find (x) + "Find symbol definition of candidate X. +See `counsel--find-symbol' for further information." + (let ((cmd (cddr x))) + (counsel--find-symbol (symbol-name cmd)))) + +(defun counsel-descbinds-action-info (x) + "Display symbol definition of candidate X, as found in the relevant manual. +See `info-lookup-symbol' for further information." + (let ((cmd (cddr x))) + (counsel-info-lookup-symbol (symbol-name cmd)))) + +;;;###autoload +(defun counsel-descbinds (&optional prefix buffer) + "Show a list of all defined keys and their definitions. +If non-nil, show only bindings that start with PREFIX. +BUFFER defaults to the current one." + (interactive) + (ivy-read "Bindings: " (counsel--descbinds-cands prefix buffer) + :action #'counsel-descbinds-action-describe + :history 'counsel-descbinds-history + :caller 'counsel-descbinds)) + +;;** `counsel-describe-face' +(defcustom counsel-describe-face-function #'describe-face + "Function to call to describe a face or face name argument." + :type 'function) + +(defun counsel--face-at-point () + "Return name of face around point. +Try detecting a face name in the text around point before falling +back to the face of the character after point, and finally the +`default' face." + (symbol-name (or (face-at-point t) 'default))) + +;;;###autoload +(defun counsel-describe-face () + "Completion for `describe-face'." + (interactive) + (ivy-read "Face: " (face-list) + :require-match t + :history 'face-name-history + :preselect (counsel--face-at-point) + :action counsel-describe-face-function + :caller 'counsel-describe-face)) + +(ivy-configure 'counsel-describe-face + :sort-fn #'ivy-string<) + +(defun counsel-customize-face (name) + "Customize face with NAME." + (customize-face (intern name))) + +(defun counsel-customize-face-other-window (name) + "Customize face with NAME in another window." + (customize-face-other-window (intern name))) + +(ivy-set-actions + 'counsel-describe-face + '(("c" counsel-customize-face "customize") + ("C" counsel-customize-face-other-window "customize other window"))) + +;;** `counsel-faces' +(defvar counsel--faces-format "%-40s %s") + +(defun counsel--faces-format-function (names) + "Format NAMES according to `counsel--faces-format'." + (let ((formatter + (lambda (name) + (format counsel--faces-format name + (propertize list-faces-sample-text + 'face (intern name)))))) + (ivy--format-function-generic + (lambda (name) + (funcall formatter (ivy--add-face name 'ivy-current-match))) + formatter names "\n"))) + +;;;###autoload +(defun counsel-faces () + "Complete faces with preview. +Actions are provided by default for describing or customizing the +selected face." + (interactive) + (let* ((names (mapcar #'symbol-name (face-list))) + (counsel--faces-format + (format "%%-%ds %%s" + (apply #'max 0 (mapcar #'string-width names))))) + (ivy-read "Face: " names + :require-match t + :history 'face-name-history + :preselect (counsel--face-at-point) + :action counsel-describe-face-function + :caller 'counsel-faces))) + +(ivy-configure 'counsel-faces + :parent 'counsel-describe-face + :format-fn #'counsel--faces-format-function) + +(ivy-set-actions + 'counsel-faces + '(("c" counsel-customize-face "customize") + ("C" counsel-customize-face-other-window "customize other window"))) + +;;* Git +;;** `counsel-git' +(defvar counsel-git-cmd "git ls-files -z --full-name --" + "Command for `counsel-git'.") + +(ivy-set-actions + 'counsel-git + '(("j" find-file-other-window "other window") + ("x" counsel-find-file-extern "open externally"))) + +(defun counsel--dominating-file (file &optional dir) + "Look up directory hierarchy for FILE, starting in DIR. +Like `locate-dominating-file', but DIR defaults to +`default-directory' and the return value is expanded." + (and (setq dir (locate-dominating-file (or dir default-directory) file)) + (expand-file-name dir))) + +(defun counsel-locate-git-root () + "Return the root of the Git repository containing the current buffer." + (or (counsel--git-root) + (error "Not in a Git repository"))) + +(defun counsel-git-cands (dir) + (let ((default-directory dir)) + (split-string + (shell-command-to-string counsel-git-cmd) + "\0" + t))) + +;;;###autoload +(defun counsel-git (&optional initial-input) + "Find file in the current Git repository. +INITIAL-INPUT can be given as the initial minibuffer input." + (interactive) + (counsel-require-program counsel-git-cmd) + (let ((default-directory (counsel-locate-git-root))) + (ivy-read "Find file: " (counsel-git-cands default-directory) + :initial-input initial-input + :action #'counsel-git-action + :caller 'counsel-git))) + +(ivy-configure 'counsel-git + :occur #'counsel-git-occur) + +(defun counsel-git-action (x) + "Find file X in current Git repository." + (with-ivy-window + (let ((default-directory (ivy-state-directory ivy-last))) + (find-file x)))) + +(defun counsel-git-occur (&optional _cands) + "Occur function for `counsel-git' using `counsel-cmd-to-dired'." + (cd (ivy-state-directory ivy-last)) + (counsel-cmd-to-dired + (counsel--expand-ls + (format "%s | %s | xargs ls" + (replace-regexp-in-string "\\(-0\\)\\|\\(-z\\)" "" counsel-git-cmd) + (counsel--file-name-filter))))) + +(defvar counsel-dired-listing-switches "-alh" + "Switches passed to `ls' for `counsel-cmd-to-dired'.") + +(defun counsel-cmd-to-dired (full-cmd &optional filter) + "Adapted from `find-dired'." + (let ((inhibit-read-only t)) + (erase-buffer) + (dired-mode default-directory counsel-dired-listing-switches) + (insert " " default-directory ":\n") + (let ((point (point))) + (insert " " full-cmd "\n") + (dired-insert-set-properties point (point))) + (setq-local dired-sort-inhibit t) + (setq-local revert-buffer-function + (lambda (_1 _2) (counsel-cmd-to-dired full-cmd))) + (setq-local dired-subdir-alist + (list (cons default-directory (point-min-marker)))) + (let ((proc (start-process-shell-command + "counsel-cmd" (current-buffer) full-cmd))) + (set-process-filter proc filter) + (set-process-sentinel + proc + (lambda (process _msg) + (when (and (eq (process-status process) 'exit) + (zerop (process-exit-status process))) + (goto-char (point-min)) + (forward-line 2) + (dired-move-to-filename))))))) + +;;** `counsel-git-grep' +(defvar counsel-git-grep-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-l") 'ivy-call-and-recenter) + (define-key map (kbd "M-q") 'counsel-git-grep-query-replace) + (define-key map (kbd "C-c C-m") 'counsel-git-grep-switch-cmd) + (define-key map (kbd "C-x C-d") 'counsel-cd) + map)) + +(defvar counsel-git-grep-cmd-default "git --no-pager grep -n --no-color -I -e \"%s\"" + "Initial command for `counsel-git-grep'.") + +(defvar counsel-git-grep-cmd nil + "Store the command for `counsel-git-grep'.") + +(defvar counsel-git-grep-history nil + "History for `counsel-git-grep'.") + +(defvar counsel-git-grep-cmd-history + (list counsel-git-grep-cmd-default) + "History for `counsel-git-grep' shell commands.") + +(defcustom counsel-grep-post-action-hook nil + "Hook that runs after the point moves to the next candidate. +Typical value: '(recenter)." + :type 'hook) + +(defcustom counsel-git-grep-cmd-function #'counsel-git-grep-cmd-function-default + "How a git-grep shell call is built from the input. +This function should set `ivy--old-re'." + :type '(radio + (function-item counsel-git-grep-cmd-function-default) + (function-item counsel-git-grep-cmd-function-ignore-order) + (function :tag "Other"))) + +(defun counsel-git-grep-cmd-function-default (str) + (format counsel-git-grep-cmd + (setq ivy--old-re + (if (eq ivy--regex-function #'ivy--regex-fuzzy) + (replace-regexp-in-string + "\n" "" (ivy--regex-fuzzy str)) + (ivy--regex str t))))) + +(defun counsel-git-grep-cmd-function-ignore-order (str) + (setq ivy--old-re (ivy--regex str t)) + (let ((parts (split-string str " " t))) + (concat + "git --no-pager grep --full-name -n --no-color -i -e " + (mapconcat #'shell-quote-argument parts " --and -e ")))) + +(defun counsel-git-grep-function (string) + "Grep in the current Git repository for STRING." + (or + (ivy-more-chars) + (progn + (counsel--async-command + (concat + (funcall counsel-git-grep-cmd-function string) + (if (ivy--case-fold-p string) " -i" ""))) + nil))) + +(defun counsel-git-grep-action (x) + "Go to occurrence X in current Git repository." + (when (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" x) + (let ((file-name (match-string-no-properties 1 x)) + (line-number (match-string-no-properties 2 x))) + (find-file (expand-file-name + file-name + (ivy-state-directory ivy-last))) + (goto-char (point-min)) + (forward-line (1- (string-to-number line-number))) + (when (re-search-forward (ivy--regex ivy-text t) (line-end-position) t) + (when swiper-goto-start-of-match + (goto-char (match-beginning 0)))) + (swiper--ensure-visible) + (run-hooks 'counsel-grep-post-action-hook) + (unless (eq ivy-exit 'done) + (swiper--cleanup) + (swiper--add-overlays (ivy--regex ivy-text)))))) + +(defun counsel-git-grep-transformer (str) + "Highlight file and line number in STR." + (when (string-match "\\`\\([^:]+\\):\\([^:]+\\):" str) + (add-face-text-property (match-beginning 1) (match-end 1) + 'ivy-grep-info nil str) + (add-face-text-property (match-beginning 2) (match-end 2) + 'ivy-grep-line-number nil str)) + str) + +(defvar counsel-git-grep-projects-alist nil + "An alist of project directory to \"git-grep\" command. +Allows to automatically use a custom \"git-grep\" command for all +files in a project.") + +(defun counsel--git-grep-cmd-and-proj (cmd) + (let ((dd (expand-file-name default-directory)) + proj) + (cond + ((stringp cmd)) + (current-prefix-arg + (if (setq proj + (cl-find-if + (lambda (x) + (string-match (car x) dd)) + counsel-git-grep-projects-alist)) + (setq cmd (cdr proj)) + (setq cmd + (ivy-read "cmd: " counsel-git-grep-cmd-history + :history 'counsel-git-grep-cmd-history + :re-builder #'ivy--regex)) + (setq counsel-git-grep-cmd-history + (delete-dups counsel-git-grep-cmd-history)))) + (t + (setq cmd counsel-git-grep-cmd-default))) + (cons proj cmd))) + +(defun counsel--call (command &optional result-fn) + "Synchronously call COMMAND and return its output as a string. +COMMAND comprises the program name followed by its arguments, as +in `make-process'. Signal `file-error' and emit a warning if +COMMAND fails. Obey file handlers based on `default-directory'. +On success, RESULT-FN is called in output buffer with no arguments." + (let ((stderr (make-temp-file "counsel-call-stderr-")) + status) + (unwind-protect + (with-temp-buffer + (setq status (apply #'process-file (car command) nil + (list t stderr) nil (cdr command))) + (if (eq status 0) + (if result-fn + (funcall result-fn) + ;; Return all output except trailing newline. + (buffer-substring (point-min) + (- (point) + (if (eq (bobp) (bolp)) + 0 + 1)))) + ;; Convert process status into error list. + (setq status (list 'file-error + (mapconcat #'identity `(,@command "failed") " ") + status)) + ;; Print stderr contents, if any, to *Warnings* buffer. + (let ((msg (condition-case err + (unless (zerop (cadr (insert-file-contents + stderr nil nil nil t))) + (buffer-string)) + (error (error-message-string err))))) + (lwarn 'ivy :warning "%s" (apply #'concat + (error-message-string status) + (and msg (list "\n" msg))))) + ;; Signal `file-error' with process status. + (signal (car status) (cdr status)))) + (delete-file stderr)))) + +(defun counsel--command (&rest command) + "Forward COMMAND to `counsel--call'." + (counsel--call command)) + +(defun counsel--grep-unwind () + (counsel-delete-process) + (swiper--cleanup)) + +;;;###autoload +(defun counsel-git-grep (&optional initial-input initial-directory cmd) + "Grep for a string in the current Git repository. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. +When CMD is a string, use it as a \"git grep\" command. +When CMD is non-nil, prompt for a specific \"git grep\" command." + (interactive) + (let ((proj-and-cmd (counsel--git-grep-cmd-and-proj cmd)) + proj) + (setq proj (car proj-and-cmd)) + (setq counsel-git-grep-cmd (cdr proj-and-cmd)) + (counsel-require-program counsel-git-grep-cmd) + (let ((collection-function + (if proj + #'counsel-git-grep-proj-function + #'counsel-git-grep-function)) + (default-directory (or initial-directory + (if proj + (car proj) + (counsel-locate-git-root))))) + (ivy-read "git grep: " collection-function + :initial-input initial-input + :dynamic-collection t + :keymap counsel-git-grep-map + :action #'counsel-git-grep-action + :history 'counsel-git-grep-history + :require-match t + :caller 'counsel-git-grep)))) + +(defun counsel--git-grep-index (_re-str cands) + (let (name ln) + (cond + (ivy--old-cands + (ivy-recompute-index-swiper-async nil cands)) + ((unless (with-ivy-window + (when buffer-file-name + (setq ln (line-number-at-pos)) + (setq name (file-name-nondirectory buffer-file-name)))) + 0)) + ;; Closest to current line going forwards. + ((let ((beg (1+ (length name)))) + (cl-position-if (lambda (x) + (and (string-prefix-p name x) + (>= (string-to-number (substring x beg)) ln))) + cands))) + ;; Closest to current line going backwards. + ((cl-position-if (lambda (x) + (string-prefix-p name x)) + cands + :from-end t)) + (t 0)))) + +(ivy-configure 'counsel-git-grep + :occur #'counsel-git-grep-occur + :unwind-fn #'counsel--grep-unwind + :index-fn #'counsel--git-grep-index + :display-transformer-fn #'counsel-git-grep-transformer + :grep-p t + :exit-codes '(1 "No matches found")) + +(defun counsel-git-grep-proj-function (str) + "Grep for STR in the current Git repository." + (or + (ivy-more-chars) + (let ((regex (setq ivy--old-re + (ivy--regex str t)))) + (counsel--async-command + (concat + (format counsel-git-grep-cmd regex) + (if (ivy--case-fold-p str) " -i" ""))) + nil))) + +(defun counsel-git-grep-switch-cmd () + "Set `counsel-git-grep-cmd' to a different value." + (interactive) + (setq counsel-git-grep-cmd + (ivy-read "cmd: " counsel-git-grep-cmd-history + :history 'counsel-git-grep-cmd-history)) + (setq counsel-git-grep-cmd-history + (delete-dups counsel-git-grep-cmd-history)) + (unless (ivy-state-dynamic-collection ivy-last) + (setq ivy--all-candidates + (all-completions "" 'counsel-git-grep-function)))) + +(defun counsel--normalize-grep-match (str) + ;; Prepend ./ if necessary: + (unless (ivy--starts-with-dotslash str) + (setq str (concat "./" str))) + ;; Remove column info if any: + (save-match-data + (when (string-match + "[^\n:]+?[^\n/:]:[\t ]*[1-9][0-9]*[\t ]*:\\([1-9][0-9]*:\\)" + str) + (setq str (replace-match "" t t str 1)))) + str) + +(defun counsel--git-grep-occur-cmd (input) + (let* ((regex ivy--old-re) + (positive-pattern (replace-regexp-in-string + ;; git-grep can't handle .*? + "\\.\\*\\?" ".*" + (ivy-re-to-str regex))) + (negative-patterns + (if (stringp regex) "" + (mapconcat (lambda (x) + (and (null (cdr x)) + (format "| grep -v %s" (car x)))) + regex + " ")))) + (concat + (format counsel-git-grep-cmd positive-pattern) + negative-patterns + (if (ivy--case-fold-p input) " -i" "")))) + +(defun counsel-git-grep-occur (&optional _cands) + "Generate a custom occur buffer for `counsel-git-grep'." + (counsel-grep-like-occur #'counsel--git-grep-occur-cmd)) + +(defun counsel-git-grep-query-replace () + "Start `query-replace' with string to replace from last search string." + (interactive) + (unless (window-minibuffer-p) + (user-error + "Should only be called in the minibuffer through `counsel-git-grep-map'")) + (let* ((enable-recursive-minibuffers t) + (from (ivy--regex ivy-text)) + (to (query-replace-read-to from "Query replace" t))) + (ivy-exit-with-action + (lambda (_) + (let (done-buffers) + (dolist (cand ivy--old-cands) + (when (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" cand) + (with-ivy-window + (let ((file-name (match-string-no-properties 1 cand))) + (setq file-name (expand-file-name + file-name + (ivy-state-directory ivy-last))) + (unless (member file-name done-buffers) + (push file-name done-buffers) + (find-file file-name) + (goto-char (point-min))) + (perform-replace from to t t nil)))))))))) + +;;** `counsel-git-stash' +(defun counsel-git-stash-kill-action (x) + "Add git stash command to kill ring. +The git command applies the stash entry where candidate X was found in." + (when (string-match "\\([^:]+\\):" x) + (kill-new (message (format "git stash apply %s" (match-string 1 x)))))) + +;;;###autoload +(defun counsel-git-stash () + "Search through all available git stashes." + (interactive) + (let* ((default-directory (counsel-locate-git-root)) + (cands (split-string (shell-command-to-string + "IFS=$'\n' +for i in `git stash list --format=\"%gd\"`; do + git stash show -p $i | grep -H --label=\"$i\" \"$1\" +done") "\n" t))) + (ivy-read "git stash: " cands + :action #'counsel-git-stash-kill-action + :caller 'counsel-git-stash))) + +;;** `counsel-git-log' +(defvar counsel-git-log-cmd "GIT_PAGER=cat git log --no-color --grep '%s'" + "Command used for \"git log\".") + +(defun counsel-git-log-function (_) + "Search for `ivy-regex' in git log." + (or + (ivy-more-chars) + (progn + ;; `counsel--yank-pop-format-function' uses this + (setq ivy--old-re ivy-regex) + (counsel--async-command + ;; "git log --grep" likes to have groups quoted e.g. \(foo\). + ;; But it doesn't like the non-greedy ".*?". + (format counsel-git-log-cmd + (replace-regexp-in-string "\\.\\*\\?" ".*" + (ivy-re-to-str ivy--old-re)))) + nil))) + +(defun counsel-git-log-action (x) + "Add candidate X to kill ring." + (message "%S" (kill-new x))) + +(declare-function magit-show-commit "ext:magit-diff") + +(defun counsel-git-log-show-commit-action (log-entry) + "Visit the commit corresponding to LOG-ENTRY." + (require 'magit-diff) + (let ((commit (substring-no-properties log-entry 0 (string-match-p "\\W" log-entry)))) + (magit-show-commit commit))) + +(ivy-set-actions + 'counsel-git-log + '(("v" counsel-git-log-show-commit-action "visit commit"))) + +;;** `counsel-git-change-worktree' +(defun counsel-git-change-worktree-action (git-root-dir tree) + "Find the corresponding file in the worktree located at tree. +The current buffer is assumed to be in a subdirectory of GIT-ROOT-DIR. +TREE is the selected candidate." + (let* ((new-root-dir (counsel-git-worktree-parse-root tree)) + (tree-filename (file-relative-name buffer-file-name git-root-dir)) + (file-name (expand-file-name tree-filename new-root-dir))) + (find-file file-name))) + +(defun counsel-git-worktree-list () + "List worktrees in the Git repository containing the current buffer." + (let ((default-directory (counsel-locate-git-root))) + (split-string (shell-command-to-string "git worktree list") "\n" t))) + +(defun counsel-git-worktree-parse-root (tree) + "Return worktree from candidate TREE." + (substring tree 0 (string-match-p " " tree))) + +(defun counsel-git-close-worktree-files-action (root-dir) + "Close all buffers from the worktree located at ROOT-DIR." + (setq root-dir (counsel-git-worktree-parse-root root-dir)) + (save-excursion + (dolist (buf (buffer-list)) + (set-buffer buf) + (and buffer-file-name + (string= "." (file-relative-name root-dir (counsel-locate-git-root))) + (kill-buffer buf))))) + +(ivy-set-actions + 'counsel-git-change-worktree + '(("k" counsel-git-close-worktree-files-action "kill all"))) + +;;;###autoload +(defun counsel-git-change-worktree () + "Find the file corresponding to the current buffer on a different worktree." + (interactive) + (let ((default-directory (counsel-locate-git-root))) + (ivy-read "Select worktree: " + (or (cl-delete default-directory (counsel-git-worktree-list) + :key #'counsel-git-worktree-parse-root :test #'string=) + (error "No other worktrees")) + :action (lambda (tree) + (counsel-git-change-worktree-action + (ivy-state-directory ivy-last) tree)) + :require-match t + :caller 'counsel-git-change-worktree))) + +;;** `counsel-git-checkout' +(defun counsel-git-checkout-action (branch) + "Switch branch by invoking git-checkout(1). +The command is passed a single argument comprising all characters +in BRANCH up to, but not including, the first space +character (#x20), or the string's end if it lacks a space." + (shell-command + (format "git checkout %s" + (shell-quote-argument + (substring branch 0 (string-match-p " " branch)))))) + +(defun counsel-git-branch-list () + "Return list of branches in the current Git repository. +Value comprises all local and remote branches bar the one +currently checked out." + (cl-mapcan (lambda (line) + (and (string-match "\\`[[:blank:]]+" line) + (list (substring line (match-end 0))))) + (let ((default-directory (counsel-locate-git-root))) + (split-string (shell-command-to-string "git branch -vv --all") + "\n" t)))) + +;;;###autoload +(defun counsel-git-checkout () + "Call the \"git checkout\" command." + (interactive) + (ivy-read "Checkout branch: " (counsel-git-branch-list) + :action #'counsel-git-checkout-action + :caller 'counsel-git-checkout)) + +(defvar counsel-yank-pop-truncate-radius) + +(defun counsel--git-log-format-function (str) + (let ((counsel-yank-pop-truncate-radius 5)) + (counsel--yank-pop-format-function str))) + +;;;###autoload +(defun counsel-git-log () + "Call the \"git log --grep\" shell command." + (interactive) + (ivy-read "Grep log: " #'counsel-git-log-function + :dynamic-collection t + :action #'counsel-git-log-action + :caller 'counsel-git-log)) + +(ivy-configure 'counsel-git-log + :height 4 + :unwind-fn #'counsel-delete-process + :format-fn #'counsel--git-log-format-function) + +(add-to-list 'counsel-async-split-string-re-alist '(counsel-git-log . "^commit ")) +(add-to-list 'counsel-async-ignore-re-alist '(counsel-git-log . "^[ \n]*$")) + +;;* File +;;** `counsel-find-file' +(defvar counsel-find-file-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-DEL") 'counsel-up-directory) + (define-key map (kbd "C-") 'counsel-up-directory) + (define-key map (kbd "`") (ivy-make-magic-action 'counsel-find-file "b")) + (define-key map [remap undo] 'counsel-find-file-undo) + map)) + +(when (executable-find "git") + (add-to-list 'ivy-ffap-url-functions 'counsel-github-url-p) + (add-to-list 'ivy-ffap-url-functions 'counsel-emacs-url-p)) +(add-to-list 'ivy-ffap-url-functions 'counsel-url-expand) +(defun counsel-find-file-cd-bookmark-action (_) + "Reset `counsel-find-file' from selected directory." + (ivy-read "cd: " + (progn + (ivy--virtual-buffers) + (delete-dups + (mapcar (lambda (x) (file-name-directory (cdr x))) + ivy--virtual-buffers))) + :action (lambda (x) + (let ((default-directory (file-name-directory x))) + (counsel-find-file))))) + +(defcustom counsel-root-command "sudo" + "Command to gain root privileges." + :type 'string) + +(defun counsel-find-file-as-root (x) + "Find file X with root privileges." + (counsel-require-program counsel-root-command) + (let* ((host (file-remote-p x 'host)) + (file-name (format "/%s:%s:%s" + counsel-root-command + (or host "") + (expand-file-name + (if host + (file-remote-p x 'localname) + x))))) + ;; If the current buffer visits the same file we are about to open, + ;; replace the current buffer with the new one. + (if (eq (current-buffer) (get-file-buffer x)) + (find-alternate-file file-name) + (find-file file-name)))) + +(defun counsel--yes-or-no-p (fmt &rest args) + "Ask user a yes or no question created using FMT and ARGS. +If Emacs 26 user option `read-answer-short' is bound, use it to +choose between `yes-or-no-p' and `y-or-n-p'; otherwise default to +`yes-or-no-p'." + (funcall (if (and (boundp 'read-answer-short) + (cond ((eq read-answer-short t)) + ((eq read-answer-short 'auto) + (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)))) + #'y-or-n-p + #'yes-or-no-p) + (apply #'format fmt args))) + +(defun counsel-find-file-copy (x) + "Copy file X." + (require 'dired-aux) + (counsel--find-file-1 "Copy file to: " + ivy--directory + (lambda (new-name) + (dired-copy-file x new-name 1)) + 'counsel-find-file-copy)) + +(defun counsel-find-file-delete (x) + "Delete file X." + (when (or delete-by-moving-to-trash + ;; `dired-delete-file', which see, already prompts for directories + (eq t (car (file-attributes x))) + (counsel--yes-or-no-p "Delete %s? " x)) + (dired-delete-file x dired-recursive-deletes delete-by-moving-to-trash) + (dired-clean-up-after-deletion x) + (let ((win (and (not (eq ivy-exit 'done)) + (active-minibuffer-window)))) + (when win (with-selected-window win (ivy--cd ivy--directory)))))) + +(defun counsel-find-file-move (x) + "Move or rename file X." + (require 'dired-aux) + (counsel--find-file-1 "Rename file to: " + ivy--directory + (lambda (new-name) + (dired-rename-file x new-name 1)) + 'counsel-find-file-move)) + +(defun counsel-find-file-mkdir-action (_x) + "Create a directory and any nonexistent parent dirs from `ivy-text'." + (let ((dir (file-name-as-directory + (expand-file-name ivy-text ivy--directory))) + (win (and (not (eq ivy-exit 'done)) + (active-minibuffer-window)))) + (make-directory dir t) + (when win (with-selected-window win (ivy--cd dir))))) + +(ivy-set-actions + 'counsel-find-file + '(("j" find-file-other-window "other window") + ("f" find-file-other-frame "other frame") + ("b" counsel-find-file-cd-bookmark-action "cd bookmark") + ("x" counsel-find-file-extern "open externally") + ("r" counsel-find-file-as-root "open as root") + ("R" find-file-read-only "read only") + ("l" find-file-literally "open literally") + ("k" counsel-find-file-delete "delete") + ("c" counsel-find-file-copy "copy file") + ("m" counsel-find-file-move "move or rename") + ("d" counsel-find-file-mkdir-action "mkdir"))) + +(defcustom counsel-find-file-at-point nil + "When non-nil, add file-at-point to the list of candidates." + :type 'boolean) + +(defcustom counsel-preselect-current-file nil + "When non-nil, preselect current file in list of candidates." + :type 'boolean) + +(defcustom counsel-find-file-ignore-regexp nil + "A regexp of files to ignore while in `counsel-find-file'. +These files are un-ignored if `ivy-text' matches them. The +common way to show all files is to start `ivy-text' with a dot. + +Example value: \"\\(?:\\`[#.]\\)\\|\\(?:[#~]\\'\\)\". This will hide +temporary and lock files. +\\ +Choosing the dotfiles option, \"\\`\\.\", might be convenient, +since you can still access the dotfiles if your input starts with +a dot. The generic way to toggle ignored files is \\[ivy-toggle-ignore], +but the leading dot is a lot faster." + :type `(choice + (const :tag "None" nil) + (const :tag "Dotfiles and Lockfiles" "\\(?:\\`\\|[/\\]\\)\\(?:[#.]\\)") + (const :tag "Ignored Extensions" + ,(regexp-opt completion-ignored-extensions)) + (regexp :tag "Regex"))) + +(defvar counsel--find-file-predicate nil + "When non-nil, `counsel--find-file-matcher' will use this predicate.") + +(defun counsel--find-file-matcher (regexp candidates) + "Return REGEXP matching CANDIDATES. +Skip some dotfiles unless `ivy-text' requires them." + (let ((res + (ivy--re-filter + regexp candidates + (lambda (re-str) + (lambda (x) + (string-match re-str (directory-file-name x))))))) + (when counsel--find-file-predicate + (let ((default-directory ivy--directory)) + (setq res (cl-remove-if-not counsel--find-file-predicate res)))) + (if (or (null ivy-use-ignore) + (null counsel-find-file-ignore-regexp) + (string-match-p counsel-find-file-ignore-regexp ivy-text)) + res + (or (cl-remove-if + (lambda (x) + (and + (string-match-p counsel-find-file-ignore-regexp x) + (not (member x ivy-extra-directories)))) + res) + res)))) + +(declare-function ffap-guesser "ffap") + +(defvar counsel-find-file-speedup-remote t + "Speed up opening remote files by disabling `find-file-hook' for them.") + +(defcustom counsel-find-file-extern-extensions '("mp4" "mkv" "xlsx") + "List of extensions that make `counsel-find-file' use `counsel-find-file-extern'." + :type '(repeat string)) + +(defun counsel-find-file-action (x) + "Find file X." + (with-ivy-window + (cond ((and counsel-find-file-speedup-remote + (file-remote-p ivy--directory)) + (let ((find-file-hook nil)) + (find-file (expand-file-name x ivy--directory)))) + ((member (file-name-extension x) counsel-find-file-extern-extensions) + (counsel-find-file-extern x)) + (t + (find-file (expand-file-name x ivy--directory)))))) + +(defun counsel--preselect-file () + "Return candidate to preselect during filename completion. +The preselect behavior can be customized via user options +`counsel-find-file-at-point' and +`counsel-preselect-current-file', which see." + (or + (when counsel-find-file-at-point + (require 'ffap) + (let ((f (ffap-guesser))) + (when (and f (not (ivy-ffap-url-p f))) + (expand-file-name f)))) + (and counsel-preselect-current-file + buffer-file-name + (file-name-nondirectory buffer-file-name)))) + +(defun counsel--find-file-1 (prompt initial-input action caller) + (let ((default-directory + (if (eq major-mode 'dired-mode) + (dired-current-directory) + default-directory))) + (ivy-read prompt #'read-file-name-internal + :matcher #'counsel--find-file-matcher + :initial-input initial-input + :action action + :preselect (counsel--preselect-file) + :require-match 'confirm-after-completion + :history 'file-name-history + :keymap counsel-find-file-map + :caller caller))) + +;;;###autoload +(defun counsel-find-file (&optional initial-input) + "Forward to `find-file'. +When INITIAL-INPUT is non-nil, use it in the minibuffer during completion." + (interactive) + (counsel--find-file-1 + "Find file: " initial-input + #'counsel-find-file-action + 'counsel-find-file)) + +(ivy-configure 'counsel-find-file + :parent 'read-file-name-internal + :occur #'counsel-find-file-occur) + +(defvar counsel-find-file-occur-cmd "ls -a | %s | xargs -d '\\n' ls -d --group-directories-first" + "Format string for `counsel-find-file-occur'.") + +(defvar counsel-find-file-occur-use-find (not (eq system-type 'gnu/linux)) + "When non-nil, `counsel-find-file-occur' will use \"find\" as the base cmd.") + +(defun counsel--expand-ls (cmd) + "Expand CMD that ends in \"ls\" with switches." + (concat cmd " " counsel-dired-listing-switches " | sed -e \"s/^/ /\"")) + +(defvar counsel-file-name-filter-alist + '(("ag -i '%s'" . t) + ("ack -i '%s'" . t) + ("perl -ne '/(.*%s.*)/i && print \"$1\\n\";'" . t) + ("grep -i -E '%s'")) + "Alist of file name filtering commands. +The car is a shell command and the cdr is t when the shell +command supports look-arounds. The executable for the commands +will be checked for existence via `executable-find'. The first +one that exists will be used.") + +(defun counsel--file-name-filter (&optional use-ignore) + "Return a command that filters a file list to match ivy candidates. +If USE-IGNORE is non-nil, try to generate a command that respects +`counsel-find-file-ignore-regexp'." + (let ((regex ivy--old-re)) + (if (= 0 (length regex)) + "cat" + (let ((filter-cmd (cl-find-if + (lambda (x) + (executable-find + (car (split-string (car x))))) + counsel-file-name-filter-alist)) + cmd) + (when (and use-ignore ivy-use-ignore + counsel-find-file-ignore-regexp + (cdr filter-cmd) + (not (string-match-p counsel-find-file-ignore-regexp ivy-text)) + (not (string-match-p counsel-find-file-ignore-regexp + (or (car ivy--old-cands) "")))) + (let ((ignore-re (list (counsel--elisp-to-pcre + counsel-find-file-ignore-regexp)))) + (setq regex (if (stringp regex) + (list ignore-re (cons regex t)) + (cons ignore-re regex))))) + (setq cmd (format (car filter-cmd) + (counsel--elisp-to-pcre regex (cdr filter-cmd)))) + (if (string-match-p "csh\\'" shell-file-name) + (replace-regexp-in-string "\\?!" "?\\\\!" cmd) + cmd))))) + +(defun counsel--occur-cmd-find () + (let ((cmd (format + "find . -maxdepth 1 | %s | xargs -I {} find {} -maxdepth 0 -ls" + (counsel--file-name-filter t)))) + (concat + (counsel--cmd-to-dired-by-type "d" cmd) + " && " + (counsel--cmd-to-dired-by-type "f" cmd)))) + +(defun counsel--cmd-to-dired-by-type (type cmd) + (let ((exclude-dots + (if (string-match "^\\." ivy-text) + "" + " | grep -v '/\\\\.'"))) + (replace-regexp-in-string + " | grep" + (concat " -type " type exclude-dots " | grep") cmd))) + +(defun counsel-find-file-occur (&optional _cands) + (require 'find-dired) + (cd ivy--directory) + (if counsel-find-file-occur-use-find + (counsel-cmd-to-dired + (counsel--occur-cmd-find) + 'find-dired-filter) + (counsel-cmd-to-dired + (counsel--expand-ls + (format counsel-find-file-occur-cmd + (if (string-match-p "grep" counsel-find-file-occur-cmd) + ;; for backwards compatibility + (counsel--elisp-to-pcre ivy--old-re) + (counsel--file-name-filter t))))))) + +(defvar counsel-up-directory-level t + "Control whether `counsel-up-directory' goes up a level or always a directory. + +If non-nil, then `counsel-up-directory' will remove the final level of the path. +For example: /a/long/path/file.jpg => /a/long/path/ + /a/long/path/ => /a/long/ + +If nil, then `counsel-up-directory' will go up a directory. +For example: /a/long/path/file.jpg => /a/long/ + /a/long/path/ => /a/long/") + +(defun counsel-up-directory () + "Go to the parent directory preselecting the current one. + +If the current directory is remote and it's not possible to go up any +further, make the remote prefix editable. + +See variable `counsel-up-directory-level'." + (interactive) + (let* ((cur-dir (directory-file-name (expand-file-name ivy--directory))) + (up-dir (file-name-directory cur-dir))) + (if (and (file-remote-p cur-dir) (string-equal cur-dir up-dir)) + (progn + ;; make the remote prefix editable + (setq ivy--old-cands nil) + (setq ivy--old-re nil) + (ivy-set-index 0) + (setq ivy--directory "") + (setq ivy--all-candidates nil) + (ivy-set-text "") + (delete-minibuffer-contents) + (insert up-dir)) + (if (and counsel-up-directory-level (not (string= ivy-text ""))) + (delete-region (line-beginning-position) (line-end-position)) + (ivy--cd up-dir) + (setf (ivy-state-preselect ivy-last) + (file-name-as-directory (file-name-nondirectory cur-dir))))))) + +(defun counsel-down-directory () + "Descend into the current directory." + (interactive) + (ivy--directory-enter)) + +(defun counsel-find-file-undo () + (interactive) + (if (string= ivy-text "") + (let ((dir (progn + (pop ivy--directory-hist) + (pop ivy--directory-hist)))) + (when dir + (ivy--cd dir))) + (undo))) + +(defun counsel-at-git-issue-p () + "When point is at an issue in a Git-versioned file, return the issue string." + (and (looking-at "#[0-9]+") + (or (eq (vc-backend buffer-file-name) 'Git) + (memq major-mode '(magit-commit-mode vc-git-log-view-mode)) + (bound-and-true-p magit-commit-mode)) + (match-string-no-properties 0))) + +(defun counsel-github-url-p () + "Return a Github issue URL at point." + (counsel-require-program "git") + (let ((url (counsel-at-git-issue-p))) + (when url + (let ((origin (shell-command-to-string + "git remote get-url origin")) + user repo) + (cond ((string-match "\\`git@github.com:\\([^/]+\\)/\\(.*\\)\\.git$" + origin) + (setq user (match-string 1 origin)) + (setq repo (match-string 2 origin))) + ((string-match "\\`https://github.com/\\([^/]+\\)/\\(.*\\)$" + origin) + (setq user (match-string 1 origin)) + (setq repo (match-string 2 origin)))) + (when user + (setq url (format "https://github.com/%s/%s/issues/%s" + user repo (substring url 1)))))))) + +(defun counsel-emacs-url-p () + "Return a Debbugs issue URL at point." + (counsel-require-program "git") + (let ((url (counsel-at-git-issue-p))) + (when url + (let ((origin (shell-command-to-string + "git remote get-url origin"))) + (when (string-match "git.sv.gnu.org:/srv/git/emacs.git" origin) + (format "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s" + (substring url 1))))))) + +(defvar counsel-url-expansions-alist nil + "Map of regular expressions to expansions. + +This variable should take the form of a list of (REGEXP . FORMAT) +pairs. + +`counsel-url-expand' will expand the word at point according to +FORMAT for the first matching REGEXP. FORMAT can be either a +string or a function. If it is a string, it will be used as the +format string for the `format' function, with the word at point +as the next argument. If it is a function, it will be called +with the word at point as the sole argument. + +For example, a pair of the form: + '(\"\\`BSERV-[[:digit:]]+\\'\" . \"https://jira.atlassian.com/browse/%s\") +will expand to URL `https://jira.atlassian.com/browse/BSERV-100' +when the word at point is BSERV-100. + +If the format element is a function, more powerful +transformations are possible. As an example, + '(\"\\`issue\\([[:digit:]]+\\)\\'\" . + (lambda (word) + (concat \"https://debbugs.gnu.org/cgi/bugreport.cgi?bug=\" + (match-string 1 word)))) +trims the \"issue\" prefix from the word at point before creating the URL.") + +(defun counsel-url-expand () + "Expand word at point using `counsel-url-expansions-alist'. +The first pair in the list whose regexp matches the word at point +will be expanded according to its format. This function is +intended to be used in `ivy-ffap-url-functions' to browse the +result as a URL." + (let ((word-at-point (current-word))) + (when word-at-point + (cl-some + (lambda (pair) + (let ((regexp (car pair)) + (formatter (cdr pair))) + (when (string-match regexp word-at-point) + (if (functionp formatter) + (funcall formatter word-at-point) + (format formatter word-at-point))))) + counsel-url-expansions-alist)))) + +;;** `counsel-dired' +(declare-function dired "dired") + +;;;###autoload +(defun counsel-dired (&optional initial-input) + "Forward to `dired'. +When INITIAL-INPUT is non-nil, use it in the minibuffer during completion." + (interactive) + (let ((counsel--find-file-predicate #'file-directory-p)) + (counsel--find-file-1 + "Dired (directory): " initial-input + (lambda (d) (dired (expand-file-name d))) + 'counsel-dired))) + +(ivy-configure 'counsel-dired + :parent 'read-file-name-internal) + +;;** `counsel-recentf' +(defvar recentf-list) +(declare-function recentf-mode "recentf") + +(defcustom counsel-recentf-include-xdg-list nil + "Include recently used files listed by XDG-compliant environments. +Examples of such environments are GNOME and KDE. See the URL +`https://www.freedesktop.org/wiki/Specifications/desktop-bookmark-spec'." + :type 'boolean + :link '(url-link "\ +https://www.freedesktop.org/wiki/Specifications/desktop-bookmark-spec")) + +;;;###autoload +(defun counsel-recentf () + "Find a file on `recentf-list'." + (interactive) + (require 'recentf) + (recentf-mode) + (ivy-read "Recentf: " (counsel-recentf-candidates) + :action (lambda (f) + (with-ivy-window + (find-file f))) + :require-match t + :caller 'counsel-recentf)) + +(ivy-set-actions + 'counsel-recentf + `(("j" find-file-other-window "other window") + ("f" find-file-other-frame "other frame") + ("x" counsel-find-file-extern "open externally") + ("d" ,(lambda (file) (setq recentf-list (delete file recentf-list))) + "delete from recentf"))) + +(defun counsel-recentf-candidates () + "Return candidates for `counsel-recentf'. + +When `counsel-recentf-include-xdg-list' is non-nil, also include +the files in said list, sorting the combined list by file access +time." + (if (and counsel-recentf-include-xdg-list + (>= emacs-major-version 26)) + (delete-dups + (sort (nconc (mapcar #'substring-no-properties recentf-list) + (counsel--recentf-get-xdg-recent-files)) + (lambda (file1 file2) + (cond ((file-remote-p file1) + nil) + ((file-remote-p file2)) + (t + ;; Added in Emacs 26.1. + (declare-function file-attribute-access-time "files" + (attributes)) + (time-less-p (file-attribute-access-time + (file-attributes file2)) + (file-attribute-access-time + (file-attributes file1)))))))) + (mapcar #'substring-no-properties recentf-list))) + +(defalias 'counsel--xml-parse-region + (if (cond ((fboundp 'libxml-available-p) + ;; Added in Emacs 27.1. + (libxml-available-p)) + ((fboundp 'libxml-parse-xml-region) + ;; Checking for `fboundp' is not enough on Windows, where it + ;; will return non-nil even if the library is not installed. + (with-temp-buffer + (insert "") + (libxml-parse-xml-region (point-min) (point-max))))) + (lambda (&optional beg end) + (libxml-parse-xml-region (or beg (point-min)) (or end (point-max)))) + #'xml-parse-region) + "Compatibility shim for `libxml-parse-xml-region'. +For convenience, BEG and END default to `point-min' and +`point-max', respectively. + +\(fn &optional BEG END)") + +(defun counsel--recentf-get-xdg-recent-files () + "Return list of XDG recent files. + +This information is parsed from the file \"recently-used.xbel\", +which lists both files and directories, under `xdg-data-home'. +This function uses the `dom' library from Emacs 25.1 or later." + (unless (require 'dom nil t) + (user-error "This function requires Emacs 25.1 or later")) + (declare-function dom-attr "dom" (node attr)) + (declare-function dom-by-tag "dom" (dom tag)) + (let ((file-of-recent-files + (expand-file-name "recently-used.xbel" (counsel--xdg-data-home)))) + (unless (file-readable-p file-of-recent-files) + (user-error "List of XDG recent files not found: %s" + file-of-recent-files)) + (cl-mapcan (lambda (bookmark-node) + (let* ((file (dom-attr bookmark-node 'href)) + (file (string-remove-prefix "file://" file)) + (file (url-unhex-string file t)) + (file (decode-coding-string file 'utf-8 t))) + (and (file-exists-p file) + (list file)))) + (let ((dom (with-temp-buffer + (insert-file-contents file-of-recent-files) + (counsel--xml-parse-region)))) + (nreverse (dom-by-tag dom 'bookmark)))))) + +(defun counsel-buffer-or-recentf-candidates () + "Return candidates for `counsel-buffer-or-recentf'." + (require 'recentf) + (recentf-mode) + (let ((buffers + (delq nil + (mapcar (lambda (b) + (when (buffer-file-name b) + (buffer-file-name b))) + (buffer-list))))) + (append + buffers + (cl-remove-if (lambda (f) (member f buffers)) + (counsel-recentf-candidates))))) + +;;;###autoload +(defun counsel-buffer-or-recentf () + "Find a buffer visiting a file or file on `recentf-list'." + (interactive) + (ivy-read "Buffer File or Recentf: " (counsel-buffer-or-recentf-candidates) + :action (lambda (s) + (with-ivy-window + (if (bufferp s) + (switch-to-buffer s) + (find-file s)))) + :require-match t + :caller 'counsel-buffer-or-recentf)) + +(ivy-configure 'counsel-buffer-or-recentf + :display-transformer-fn #'counsel-buffer-or-recentf-transformer) + +(ivy-set-actions + 'counsel-buffer-or-recentf + '(("j" find-file-other-window "other window") + ("f" find-file-other-frame "other frame") + ("x" counsel-find-file-extern "open externally"))) + +(defun counsel-buffer-or-recentf-transformer (var) + "Propertize VAR if it's a buffer visiting a file." + (if (member var (mapcar #'buffer-file-name (buffer-list))) + (ivy-append-face var 'ivy-highlight-face) + var)) + +;;** `counsel-bookmark' +(defcustom counsel-bookmark-avoid-dired nil + "If non-nil, open directory bookmarks with `counsel-find-file'. +By default `counsel-bookmark' opens a dired buffer for directories." + :type 'boolean) + +(defvar bookmark-alist) +(declare-function bookmark-location "bookmark") +(declare-function bookmark-all-names "bookmark") +(declare-function bookmark-get-filename "bookmark") +(declare-function bookmark-maybe-load-default-file "bookmark") + +;;;###autoload +(defun counsel-bookmark () + "Forward to `bookmark-jump' or `bookmark-set' if bookmark doesn't exist." + (interactive) + (require 'bookmark) + (ivy-read "Create or jump to bookmark: " + (bookmark-all-names) + :history 'bookmark-history + :action (lambda (x) + (cond ((and counsel-bookmark-avoid-dired + (member x (bookmark-all-names)) + (file-directory-p (bookmark-location x))) + (with-ivy-window + (let ((default-directory (bookmark-location x))) + (counsel-find-file)))) + ((member x (bookmark-all-names)) + (with-ivy-window + (bookmark-jump x))) + (t + (bookmark-set x)))) + :caller 'counsel-bookmark)) + +(defun counsel--apply-bookmark-fn (fn) + "Return a function applying FN to a bookmark's location." + (lambda (bookmark) + (funcall fn (bookmark-location bookmark)))) + +(ivy-set-actions + 'counsel-bookmark + `(("d" bookmark-delete "delete") + ("e" bookmark-rename "edit") + ("s" bookmark-set "overwrite") + ("x" ,(counsel--apply-bookmark-fn #'counsel-find-file-extern) + "open externally") + ("r" ,(counsel--apply-bookmark-fn #'counsel-find-file-as-root) + "open as root"))) + +;;** `counsel-bookmarked-directory' +(defun counsel-bookmarked-directory--candidates () + "Get a list of bookmarked directories sorted by file path." + (bookmark-maybe-load-default-file) + (sort (cl-remove-if-not + #'ivy--dirname-p + (delq nil (mapcar #'bookmark-get-filename bookmark-alist))) + #'string<)) + +;;;###autoload +(defun counsel-bookmarked-directory () + "Ivy interface for bookmarked directories. + +With a prefix argument, this command creates a new bookmark which points to the +current value of `default-directory'." + (interactive) + (require 'bookmark) + (ivy-read "Bookmarked directory: " + (counsel-bookmarked-directory--candidates) + :caller 'counsel-bookmarked-directory + :action #'dired)) + +(ivy-set-actions 'counsel-bookmarked-directory + `(("j" dired-other-window "other window") + ("x" counsel-find-file-extern "open externally") + ("r" counsel-find-file-as-root "open as root") + ("f" ,(lambda (dir) + (let ((default-directory dir)) + (call-interactively #'find-file))) + "find-file"))) + +;;** `counsel-file-register' +;;;###autoload +(defun counsel-file-register () + "Search file in register. + +You cannot use Emacs' normal register commands to create file +registers. Instead you must use the `set-register' function like +so: `(set-register ?i \"/home/eric/.emacs.d/init.el\")'. Now you +can use `C-x r j i' to open that file." + (interactive) + (ivy-read "File Register: " + ;; Use the `register-alist' variable to filter out file + ;; registers. Each entry for a file register will have the + ;; following layout: + ;; + ;; (NUMBER 'file . "string/path/to/file") + ;; + ;; So we go through each entry and see if the `cadr' is + ;; `eq' to the symbol `file'. If so then add the filename + ;; (`cddr') which `ivy-read' will use for its choices. + (mapcar (lambda (register-alist-entry) + (if (eq 'file (cadr register-alist-entry)) + (cddr register-alist-entry))) + register-alist) + :require-match t + :history 'counsel-file-register + :caller 'counsel-file-register + :action (lambda (register-file) + (with-ivy-window (find-file register-file))))) + +(ivy-configure 'counsel-file-register + :sort-fn #'ivy-string<) + +(ivy-set-actions + 'counsel-file-register + '(("j" find-file-other-window "other window"))) + +;;** `counsel-locate' +(defcustom counsel-locate-cmd (cond ((memq system-type '(darwin berkeley-unix)) + 'counsel-locate-cmd-noregex) + ((and (eq system-type 'windows-nt) + (executable-find "es.exe")) + 'counsel-locate-cmd-es) + (t + 'counsel-locate-cmd-default)) + "The function for producing a locate command string from the input. + +The function takes a string - the current input, and returns a +string - the full shell command to run." + :type '(choice + (const :tag "Default" counsel-locate-cmd-default) + (const :tag "No regex" counsel-locate-cmd-noregex) + (const :tag "mdfind" counsel-locate-cmd-mdfind) + (const :tag "everything" counsel-locate-cmd-es))) + +(ivy-set-actions + 'counsel-locate + '(("x" counsel-locate-action-extern "xdg-open") + ("r" counsel-find-file-as-root "open as root") + ("d" counsel-locate-action-dired "dired"))) + +(defvar counsel-locate-history nil + "History for `counsel-locate'.") + +;;;###autoload +(defun counsel-locate-action-extern (x) + "Pass X to `xdg-open' or equivalent command via the shell." + (interactive "FFile: ") + (if (and (eq system-type 'windows-nt) + (fboundp 'w32-shell-execute)) + (w32-shell-execute "open" x) + (call-process-shell-command (format "%s %s" + (cl-case system-type + (darwin "open") + (cygwin "cygstart") + (t "xdg-open")) + (shell-quote-argument x)) + nil 0))) + +(defalias 'counsel-find-file-extern #'counsel-locate-action-extern) + +(declare-function dired-jump "dired-x") + +(defun counsel-locate-action-dired (x) + "Use `dired-jump' on X." + (dired-jump nil x)) + +(defun counsel-locate-cmd-default (input) + "Return a shell command based on INPUT." + (counsel-require-program "locate") + (format "locate -i --regex '%s'" + (counsel--elisp-to-pcre + (ivy--regex input)))) + +(defun counsel-locate-cmd-noregex (input) + "Return a shell command based on INPUT." + (counsel-require-program "locate") + (format "locate -i '%s'" input)) + +(defun counsel-locate-cmd-mdfind (input) + "Return a shell command based on INPUT." + (counsel-require-program "mdfind") + (format "mdfind -name '%s'" input)) + +(defvar w32-ansi-code-page) + +(defun counsel-locate-cmd-es (input) + "Return a shell command based on INPUT." + (counsel-require-program "es.exe") + (let ((raw-string (format "es.exe -i -p -r %s" + (counsel--elisp-to-pcre + (ivy--regex input t))))) + ;; W32 don't use Unicode by default, so we encode search command + ;; to local codepage to support searching filename contains non-ASCII + ;; characters. + (if (and (eq system-type 'windows-nt) + (boundp 'w32-ansi-code-page)) + (encode-coding-string raw-string + (intern (format "cp%d" w32-ansi-code-page))) + raw-string))) + +(defun counsel-locate-function (input) + "Call the \"locate\" shell command with INPUT." + (or + (ivy-more-chars) + (progn + (counsel--async-command + (funcall counsel-locate-cmd input)) + '("" "working...")))) + +(defcustom counsel-locate-db-path "~/.local/mlocate.db" + "Location where to put the locatedb in case your home folder is encrypted." + :type 'file) + +(defun counsel-file-stale-p (fname seconds) + "Return non-nil if FNAME was modified more than SECONDS ago." + (> (time-to-seconds + (time-subtract + (current-time) + (nth 5 (file-attributes fname)))) + seconds)) + +(defun counsel--locate-updatedb () + (when (file-exists-p "~/.Private") + (let ((db-fname (expand-file-name counsel-locate-db-path))) + (setenv "LOCATE_PATH" db-fname) + (when (or (not (file-exists-p db-fname)) + (counsel-file-stale-p db-fname 60)) + (message "Updating %s..." db-fname) + (counsel--command + "updatedb" "-l" "0" "-o" db-fname "-U" (expand-file-name "~")))))) + +;;;###autoload +(defun counsel-locate (&optional initial-input) + "Call the \"locate\" shell command. +INITIAL-INPUT can be given as the initial minibuffer input." + (interactive) + (counsel--locate-updatedb) + (ivy-read "Locate: " #'counsel-locate-function + :initial-input initial-input + :dynamic-collection t + :history 'counsel-locate-history + :action (lambda (file) + (when file + (with-ivy-window + (find-file + (concat (file-remote-p default-directory) file))))) + :caller 'counsel-locate)) + +(ivy-configure 'counsel-locate + :unwind-fn #'counsel-delete-process + :exit-codes '(1 "Nothing found")) + +;;** `counsel-tracker' +(defun counsel-tracker-function (input) + "Call the \"tracker\" shell command with INPUT." + (or + (ivy-more-chars) + (progn + (counsel--async-command + (format + "tracker sparql -q \"SELECT ?url WHERE { ?s a nfo:FileDataObject ; nie:url ?url . FILTER (STRSTARTS (?url, 'file://$HOME/')) . FILTER regex(?url, '%s') }\" | tail -n +2 | head -n -1" + (counsel--elisp-to-pcre (funcall ivy--regex-function input)))) + '("" "working...")))) + +(defun counsel-tracker-transformer (str) + (if (string-match "file:///" str) + (decode-coding-string (url-unhex-string (substring str 9)) 'utf-8) + str)) + +;;;###autoload +(defun counsel-tracker () + (interactive) + (ivy-read "Tracker: " 'counsel-tracker-function + :dynamic-collection t + :action (lambda (s) (find-file (counsel-tracker-transformer s))) + :caller 'counsel-tracker)) + +(ivy-configure 'counsel-tracker + :display-transformer-fn #'counsel-tracker-transformer + :unwind-fn #'counsel-delete-process) + +;;** `counsel-fzf' +(defvar counsel-fzf-cmd "fzf -f \"%s\"" + "Command for `counsel-fzf'.") + +(defvar counsel--fzf-dir nil + "Store the base fzf directory.") + +(defvar counsel-fzf-dir-function 'counsel-fzf-dir-function-projectile + "Function that returns a directory for fzf to use.") + +(defun counsel-fzf-dir-function-projectile () + (if (and + (fboundp 'projectile-project-p) + (fboundp 'projectile-project-root) + (projectile-project-p)) + (projectile-project-root) + default-directory)) + +(defun counsel-fzf-function (str) + (let ((default-directory counsel--fzf-dir)) + (setq ivy--old-re (ivy--regex-fuzzy str)) + (counsel--async-command + (format counsel-fzf-cmd str))) + nil) + +;;;###autoload +(defun counsel-fzf (&optional initial-input initial-directory fzf-prompt) + "Open a file using the fzf shell command. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. +FZF-PROMPT, if non-nil, is passed as `ivy-read' prompt argument." + (interactive + (let ((fzf-basename (car (split-string counsel-fzf-cmd)))) + (list nil + (when current-prefix-arg + (counsel-read-directory-name (concat + fzf-basename + " in directory: ")))))) + (counsel-require-program counsel-fzf-cmd) + (setq counsel--fzf-dir + (or initial-directory + (funcall counsel-fzf-dir-function))) + (ivy-read (or fzf-prompt "fzf: ") + #'counsel-fzf-function + :initial-input initial-input + :re-builder #'ivy--regex-fuzzy + :dynamic-collection t + :action #'counsel-fzf-action + :caller 'counsel-fzf)) + +(ivy-configure 'counsel-fzf + :occur #'counsel-fzf-occur + :unwind-fn #'counsel-delete-process + :exit-codes '(1 "Nothing found")) + +(defun counsel-fzf-action (x) + "Find file X in current fzf directory." + (with-ivy-window + (let ((default-directory counsel--fzf-dir)) + (find-file x)))) + +(defun counsel-fzf-occur (&optional _cands) + "Occur function for `counsel-fzf' using `counsel-cmd-to-dired'." + (cd counsel--fzf-dir) + (counsel-cmd-to-dired + (counsel--expand-ls + (format + "%s --print0 | xargs -0 ls" + (format counsel-fzf-cmd ivy-text))))) + +(ivy-set-actions + 'counsel-fzf + '(("x" counsel-locate-action-extern "xdg-open") + ("d" counsel-locate-action-dired "dired"))) + +;;** `counsel-dpkg' +;;;###autoload +(defun counsel-dpkg () + "Call the \"dpkg\" shell command." + (interactive) + (counsel-require-program "dpkg") + (let ((cands (mapcar + (lambda (x) + (let ((y (split-string x " +"))) + (cons (format "%-40s %s" + (ivy--truncate-string + (nth 1 y) 40) + (nth 4 y)) + (mapconcat #'identity y " ")))) + (split-string + (shell-command-to-string "dpkg -l | tail -n+6") "\n" t)))) + (ivy-read "dpkg: " cands + :action (lambda (x) + (message (cdr x))) + :caller 'counsel-dpkg))) + +;;** `counsel-rpm' +;;;###autoload +(defun counsel-rpm () + "Call the \"rpm\" shell command." + (interactive) + (counsel-require-program "rpm") + (let ((cands (mapcar + (lambda (x) + (let ((y (split-string x "|"))) + (cons (format "%-40s %s" + (ivy--truncate-string + (nth 0 y) 40) + (nth 1 y)) + (mapconcat #'identity y " ")))) + (split-string + (shell-command-to-string "rpm -qa --qf \"%{NAME}|%{SUMMARY}\\n\"") "\n" t)))) + (ivy-read "rpm: " cands + :action (lambda (x) + (message (cdr x))) + :caller 'counsel-rpm))) + +(defun counsel--find-return-list (args) + (unless (listp args) + (user-error + "`counsel-file-jump-args' is a list now; please customize accordingly")) + (counsel--call + (cons find-program args) + (lambda () + (let (files) + (goto-char (point-min)) + (while (< (point) (point-max)) + (when (looking-at "\\./") + (goto-char (match-end 0))) + (push (buffer-substring (point) (line-end-position)) files) + (beginning-of-line 2)) + (nreverse files))))) + +(defcustom counsel-file-jump-args (split-string ". -name .git -prune -o -type f -print") + "Arguments for the `find-command' when using `counsel-file-jump'." + :type '(repeat string)) + +;;** `counsel-file-jump' +;;;###autoload +(defun counsel-file-jump (&optional initial-input initial-directory) + "Jump to a file below the current directory. +List all files within the current directory or any of its sub-directories. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search." + (interactive + (list nil + (when current-prefix-arg + (counsel-read-directory-name "From directory: ")))) + (counsel-require-program find-program) + (let ((default-directory (or initial-directory default-directory))) + (ivy-read "Find file: " + (counsel--find-return-list counsel-file-jump-args) + :matcher #'counsel--find-file-matcher + :initial-input initial-input + :action #'find-file + :preselect (counsel--preselect-file) + :require-match 'confirm-after-completion + :history 'file-name-history + :caller 'counsel-file-jump))) + +(ivy-set-actions + 'counsel-file-jump + `(("d" ,(lambda (x) + (dired (or (file-name-directory x) default-directory))) + "open in dired"))) + +(defcustom counsel-dired-jump-args (split-string ". -name .git -prune -o -type d -print") + "Arguments for the `find-command' when using `counsel-dired-jump'." + :type '(repeat string)) + +;;** `counsel-dired-jump' +;;;###autoload +(defun counsel-dired-jump (&optional initial-input initial-directory) + "Jump to a directory (see `dired-jump') below the current directory. +List all sub-directories within the current directory. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search." + (interactive + (list nil + (when current-prefix-arg + (counsel-read-directory-name "From directory: ")))) + (counsel-require-program find-program) + (let ((default-directory (or initial-directory default-directory))) + (ivy-read "Find directory: " + (cdr + (counsel--find-return-list counsel-dired-jump-args)) + :matcher #'counsel--find-file-matcher + :initial-input initial-input + :action (lambda (d) (dired-jump nil (expand-file-name d))) + :history 'file-name-history + :keymap counsel-find-file-map + :caller 'counsel-dired-jump))) + +;;* Grep +;;** `counsel-ag' +(defvar counsel-ag-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-l") 'ivy-call-and-recenter) + (define-key map (kbd "M-q") 'counsel-git-grep-query-replace) + (define-key map (kbd "C-'") 'swiper-avy) + (define-key map (kbd "C-x C-d") 'counsel-cd) + map)) + +(defcustom counsel-ag-base-command "ag --vimgrep %s" + "Format string to use in `counsel-ag-function' to construct the command. +The %s will be replaced by optional extra ag arguments followed by the +regex string." + :type '(radio + (const "ag --vimgrep %s") + (const "ag --nocolor --nogroup %s") + (string :tag "custom"))) + +(defvar counsel-ag-command nil) + +(defvar counsel--grep-tool-look-around t) + +(defvar counsel--regex-look-around nil) + +(defconst counsel--command-args-separator " -- ") + +(defun counsel--split-command-args (arguments) + "Split ARGUMENTS into its switches and search-term parts. +Return pair of corresponding strings (SWITCHES . SEARCH-TERM)." + (if (string-match counsel--command-args-separator arguments) + (let ((args (substring arguments (match-end 0))) + (search-term (substring arguments 0 (match-beginning 0)))) + (if (string-prefix-p "-" arguments) + (cons search-term args) + (cons args search-term))) + (cons "" arguments))) + +(defun counsel--format-ag-command (extra-args needle) + "Construct a complete `counsel-ag-command' as a string. +EXTRA-ARGS is a string of the additional arguments. +NEEDLE is the search string." + (counsel--format counsel-ag-command + (if (listp counsel-ag-command) + (if (string-match " \\(--\\) " extra-args) + (counsel--format + (split-string (replace-match "%s" t t extra-args 1)) + needle) + (nconc (split-string extra-args) needle)) + (if (string-match " \\(--\\) " extra-args) + (replace-match needle t t extra-args 1) + (concat extra-args " " needle))))) + +(defun counsel--grep-regex (str) + (counsel--elisp-to-pcre + (setq ivy--old-re + (funcall (ivy-state-re-builder ivy-last) str)) + counsel--regex-look-around)) + +(defun counsel--ag-extra-switches (regex) + "Get additional switches needed for look-arounds." + (and (stringp counsel--regex-look-around) + ;; using look-arounds + (string-match-p "\\`\\^(\\?[=!]" regex) + (concat " " counsel--regex-look-around " "))) + +(defun counsel-ag-function (string) + "Grep in the current directory for STRING." + (let* ((command-args (counsel--split-command-args string)) + (search-term (cdr command-args))) + (or + (let ((ivy-text search-term)) + (ivy-more-chars)) + (let* ((default-directory (ivy-state-directory ivy-last)) + (regex (counsel--grep-regex search-term)) + (switches (concat (car command-args) + (counsel--ag-extra-switches regex) + (if (ivy--case-fold-p string) + " -i " + " -s ")))) + (counsel--async-command (counsel--format-ag-command + switches + (funcall (if (listp counsel-ag-command) #'identity + #'shell-quote-argument) + regex))) + nil)))) + +;;;###autoload +(cl-defun counsel-ag (&optional initial-input initial-directory extra-ag-args ag-prompt + &key caller) + "Grep for a string in the current directory using ag. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. +EXTRA-AG-ARGS string, if non-nil, is appended to `counsel-ag-base-command'. +AG-PROMPT, if non-nil, is passed as `ivy-read' prompt argument. +CALLER is passed to `ivy-read'." + (interactive) + (setq counsel-ag-command counsel-ag-base-command) + (setq counsel--regex-look-around counsel--grep-tool-look-around) + (counsel-require-program counsel-ag-command) + (let ((prog-name (car (if (listp counsel-ag-command) counsel-ag-command + (split-string counsel-ag-command))))) + (when current-prefix-arg + (setq initial-directory + (or initial-directory + (counsel-read-directory-name (concat + prog-name + " in directory: ")))) + (setq extra-ag-args + (or extra-ag-args + (read-from-minibuffer (format "%s args: " prog-name))))) + (setq counsel-ag-command (counsel--format-ag-command (or extra-ag-args "") "%s")) + (let ((default-directory (or initial-directory + (counsel--git-root) + default-directory))) + (ivy-read (or ag-prompt + (concat prog-name ": ")) + #'counsel-ag-function + :initial-input initial-input + :dynamic-collection t + :keymap counsel-ag-map + :history 'counsel-git-grep-history + :action #'counsel-git-grep-action + :require-match t + :caller (or caller 'counsel-ag))))) + +(ivy-configure 'counsel-ag + :occur #'counsel-ag-occur + :unwind-fn #'counsel--grep-unwind + :display-transformer-fn #'counsel-git-grep-transformer + :grep-p t + :exit-codes '(1 "No matches found")) + +(defun counsel-read-directory-name (prompt &optional default) + "Read a directory name from user, a (partial) replacement of `read-directory-name'." + (let ((counsel--find-file-predicate #'file-directory-p)) + (ivy-read prompt + #'read-file-name-internal + :matcher #'counsel--find-file-matcher + :def default + :history 'file-name-history + :keymap counsel-find-file-map + :caller 'counsel-read-directory-name))) + +(ivy-configure 'counsel-read-directory-name + :parent 'read-file-name-internal) + +(defun counsel-cd () + "Change the directory for the currently running Ivy grep-like command. +Works for `counsel-git-grep', `counsel-ag', etc." + (interactive) + (counsel-delete-process) + (let* ((input ivy-text) + (enable-recursive-minibuffers t) + (def-dir (buffer-file-name (ivy-state-buffer ivy-last))) + (def-dir (and def-dir (file-name-directory def-dir))) + (new-dir (counsel-read-directory-name "cd: " def-dir))) + (ivy-quit-and-run + (funcall (ivy-state-caller ivy-last) input new-dir)))) + +(defun counsel--grep-smart-case-flag () + (if (ivy--case-fold-p ivy-text) + "-i" + (if (and (stringp counsel-ag-base-command) + (string-match-p "\\`pt" counsel-ag-base-command)) + "-S" + "-s"))) + +(defun counsel-grep-like-occur (cmd-template) + (unless (eq major-mode 'ivy-occur-grep-mode) + (ivy-occur-grep-mode) + (setq default-directory (ivy-state-directory ivy-last))) + (ivy-set-text + (and (string-match "\"\\(.*\\)\"" (buffer-name)) + (match-string 1 (buffer-name)))) + (let* ((cmd + (if (functionp cmd-template) + (funcall cmd-template ivy-text) + (let* ((command-args (counsel--split-command-args ivy-text)) + (regex (counsel--grep-regex (cdr command-args))) + (all-args (append + (when (car command-args) + (split-string (car command-args))) + (counsel--ag-extra-switches regex) + (list + (counsel--grep-smart-case-flag) + regex)))) + (if (stringp cmd-template) + (counsel--format + cmd-template + (mapconcat #'shell-quote-argument all-args " ")) + (cl-mapcan + (lambda (x) (if (string= x "%s") (copy-sequence all-args) (list x))) + cmd-template))))) + (cands (counsel--split-string + (if (stringp cmd) + (shell-command-to-string cmd) + (counsel--call cmd))))) + (swiper--occur-insert-lines (mapcar #'counsel--normalize-grep-match cands)))) + +(defun counsel-ag-occur (&optional _cands) + "Generate a custom occur buffer for `counsel-ag'." + (counsel-grep-like-occur + counsel-ag-command)) + +;;** `counsel-pt' +(defcustom counsel-pt-base-command "pt --nocolor --nogroup -e %s" + "Alternative to `counsel-ag-base-command' using pt." + :type 'string) + +;;;###autoload +(defun counsel-pt (&optional initial-input) + "Grep for a string in the current directory using pt. +INITIAL-INPUT can be given as the initial minibuffer input. +This uses `counsel-ag' with `counsel-pt-base-command' instead of +`counsel-ag-base-command'." + (interactive) + (let ((counsel-ag-base-command counsel-pt-base-command) + (counsel--grep-tool-look-around nil)) + (counsel-ag initial-input nil nil nil :caller 'counsel-pt))) + +(ivy-configure 'counsel-pt + :unwind-fn #'counsel--grep-unwind + :display-transformer-fn #'counsel-git-grep-transformer + :grep-p t) + +;;** `counsel-ack' +(defcustom counsel-ack-base-command + (concat + (file-name-nondirectory + (or (executable-find "ack-grep") "ack")) + " --nocolor --nogroup %s") + "Alternative to `counsel-ag-base-command' using ack." + :type 'string) + +;;;###autoload +(defun counsel-ack (&optional initial-input) + "Grep for a string in the current directory using ack. +INITIAL-INPUT can be given as the initial minibuffer input. +This uses `counsel-ag' with `counsel-ack-base-command' replacing +`counsel-ag-base-command'." + (interactive) + (let ((counsel-ag-base-command counsel-ack-base-command) + (counsel--grep-tool-look-around t)) + (counsel-ag + initial-input nil nil nil + :caller 'counsel-ack))) + + +;;** `counsel-rg' +(defcustom counsel-rg-base-command + (split-string + (if (memq system-type '(ms-dos windows-nt)) + "rg -M 240 --with-filename --no-heading --line-number --color never %s --path-separator / ." + "rg -M 240 --with-filename --no-heading --line-number --color never %s")) + "Alternative to `counsel-ag-base-command' using ripgrep. + +Note: don't use single quotes for the regex." + :type '(choice + (repeat :tag "List to be used in `process-file'." string) + (string :tag "String to be used in `shell-command-to-string'."))) + +(defun counsel--rg-targets () + "Return a list of files to operate on, based on `dired-mode' marks." + (when (eq major-mode 'dired-mode) + (let ((files + (dired-get-marked-files 'no-dir nil nil t))) + (when (or (cdr files) + (when (string-match-p "\\*ivy-occur" (buffer-name)) + (dired-toggle-marks) + (setq files (dired-get-marked-files 'no-dir)) + (dired-toggle-marks) + t)) + (delq t files))))) + +;;;###autoload +(defun counsel-rg (&optional initial-input initial-directory extra-rg-args rg-prompt) + "Grep for a string in the current directory using rg. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. +EXTRA-RG-ARGS string, if non-nil, is appended to `counsel-rg-base-command'. +RG-PROMPT, if non-nil, is passed as `ivy-read' prompt argument. + +Example input with inclusion and exclusion file patterns: + require i -- -g*.el" + (interactive) + (let ((counsel-ag-base-command + (if (listp counsel-rg-base-command) + (append counsel-rg-base-command (counsel--rg-targets)) + (concat counsel-rg-base-command " " + (mapconcat #'shell-quote-argument (counsel--rg-targets) " ")))) + (counsel--grep-tool-look-around + (let ((rg (car (if (listp counsel-rg-base-command) counsel-rg-base-command + (split-string counsel-rg-base-command)))) + (switch "--pcre2")) + (and (eq 0 (call-process rg nil nil nil switch "--pcre2-version")) + switch)))) + (counsel-ag initial-input initial-directory extra-rg-args rg-prompt + :caller 'counsel-rg))) + +(ivy-configure 'counsel-rg + :occur #'counsel-ag-occur + :unwind-fn #'counsel--grep-unwind + :display-transformer-fn #'counsel-git-grep-transformer + :grep-p t + :exit-codes '(1 "No matches found")) + +;;** `counsel-grep' +(defvar counsel-grep-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-l") 'ivy-call-and-recenter) + (define-key map (kbd "M-q") 'swiper-query-replace) + (define-key map (kbd "C-'") 'swiper-avy) + map)) + +(defcustom counsel-grep-base-command "grep -E -n -e %s %s" + "Format string used by `counsel-grep' to build a shell command. +It should contain two %-sequences (see function `format') to be +substituted by the search regexp and file, respectively. Neither +%-sequence should be contained in single quotes." + :type 'string) + +(defvar counsel-grep-command nil) + +(defun counsel-grep-function (string) + "Grep in the current directory for STRING." + (or + (ivy-more-chars) + (let* ((regex (counsel--grep-regex string)) + (cmd (counsel--format + counsel-grep-command + (funcall (if (listp counsel-grep-command) #'identity + #'shell-quote-argument) + regex)))) + (counsel--async-command + (if (ivy--case-fold-p regex) + (if (listp cmd) (nconc (list (car cmd) "-i") (cdr cmd)) + (string-match " " cmd) + (replace-match " -i " nil nil cmd)) + cmd)) + nil))) + +(defvar counsel--grep-last-pos nil + "Store the last point and line that `counsel-grep-action' scrolled to. +This speeds up scrolling: instead of going to `point-min' and +`forward-line' with a huge arg (e.g. to scroll 50K lines), scroll +relative to the last position stored here.") + +(defun counsel-grep-action (x) + "Go to candidate X." + (with-ivy-window + (swiper--cleanup) + (let ((default-directory + (file-name-directory + (ivy-state-directory ivy-last))) + file-name line-number) + (when (cond ((string-match "\\`\\([0-9]+\\):\\(.*\\)\\'" x) + (setq file-name (buffer-file-name (ivy-state-buffer ivy-last))) + (setq line-number (match-string-no-properties 1 x))) + ((string-match "\\`\\([^:]+\\):\\([0-9]+\\):\\(.*\\)\\'" x) + (setq file-name (match-string-no-properties 1 x)) + (setq line-number (match-string-no-properties 2 x)))) + ;; If the file buffer is already open, just get it. Prevent doing + ;; `find-file', as that file could have already been opened using + ;; `find-file-literally'. + (with-current-buffer (or (get-file-buffer file-name) + (find-file file-name)) + (setq line-number (string-to-number line-number)) + (if (and counsel--grep-last-pos (= (point) (car counsel--grep-last-pos))) + (forward-line (- line-number (cdr counsel--grep-last-pos))) + (goto-char (point-min)) + (forward-line (1- line-number))) + (setq counsel--grep-last-pos (cons (point) line-number)) + (when (re-search-forward (ivy--regex ivy-text t) (line-end-position) t) + (when swiper-goto-start-of-match + (goto-char (match-beginning 0)))) + (run-hooks 'counsel-grep-post-action-hook) + (if (eq ivy-exit 'done) + (swiper--ensure-visible) + (isearch-range-invisible (line-beginning-position) + (line-end-position)) + (swiper--add-overlays (ivy--regex ivy-text)))))))) + +(defun counsel-grep-occur (&optional _cands) + "Generate a custom occur buffer for `counsel-grep'." + (counsel-grep-like-occur + (format + "grep -niE %%s %s /dev/null" + (shell-quote-argument + (file-name-nondirectory + (buffer-file-name + (ivy-state-buffer ivy-last))))))) + +(defvar counsel-grep-history nil + "History for `counsel-grep'.") + +;;;###autoload +(defun counsel-grep (&optional initial-input) + "Grep for a string in the file visited by the current buffer. +When non-nil, INITIAL-INPUT is the initial search pattern." + (interactive) + (unless buffer-file-name + (user-error "Current buffer is not visiting a file")) + (counsel-require-program counsel-grep-base-command) + (setq counsel-grep-command + (counsel--format counsel-grep-base-command "%s" + (funcall (if (listp counsel-grep-base-command) #'identity + #'shell-quote-argument) + (file-name-nondirectory + buffer-file-name)))) + (let ((default-directory (file-name-directory buffer-file-name)) + (init-point (point)) + res) + (unwind-protect + (setq res (ivy-read "grep: " #'counsel-grep-function + :initial-input initial-input + :dynamic-collection t + :require-match t + :preselect + (when (< (- (line-end-position) (line-beginning-position)) 300) + (format "%d:%s" + (line-number-at-pos) + (regexp-quote + (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))))) + :keymap counsel-grep-map + :history 'counsel-grep-history + :re-builder #'ivy--regex + :action #'counsel-grep-action + :caller 'counsel-grep)) + (unless res + (goto-char init-point))))) + +(ivy-configure 'counsel-grep + :update-fn 'auto + :unwind-fn #'counsel--grep-unwind + :index-fn #'ivy-recompute-index-swiper-async + :occur #'counsel-grep-occur + :more-chars 2 + :grep-p t + :exit-codes '(1 "")) + +;;;###autoload +(defun counsel-grep-backward (&optional initial-input) + "Grep for a string in the file visited by the current buffer going +backward similar to `swiper-backward'. When non-nil, INITIAL-INPUT is +the initial search pattern." + (interactive) + (let ((ivy-index-functions-alist + '((counsel-grep . ivy-recompute-index-swiper-async-backward)))) + (counsel-grep initial-input))) + +;;** `counsel-grep-or-swiper' +(defcustom counsel-grep-swiper-limit 300000 + "Buffer size threshold for `counsel-grep-or-swiper'. +When the number of characters in a buffer exceeds this threshold, +`counsel-grep' will be used instead of `swiper'." + :type 'integer) + +(defcustom counsel-grep-use-swiper-p #'counsel-grep-use-swiper-p-default + "When this function returns non-nil, call `swiper', else `counsel-grep'." + :type '(choice + (const :tag "Rely on `counsel-grep-swiper-limit'." + counsel-grep-use-swiper-p-default) + (const :tag "Always use `counsel-grep'." ignore) + (function :tag "Custom"))) + +(defun counsel-grep-use-swiper-p-default () + (<= (buffer-size) + (/ counsel-grep-swiper-limit + (if (eq major-mode 'org-mode) 4 1)))) + +;;;###autoload +(defun counsel-grep-or-swiper (&optional initial-input) + "Call `swiper' for small buffers and `counsel-grep' for large ones. +When non-nil, INITIAL-INPUT is the initial search pattern." + (interactive) + (if (or (not buffer-file-name) + (buffer-narrowed-p) + (ignore-errors + (file-remote-p buffer-file-name)) + (jka-compr-get-compression-info buffer-file-name) + (funcall counsel-grep-use-swiper-p)) + (swiper initial-input) + (when (file-writable-p buffer-file-name) + (save-buffer)) + (counsel-grep initial-input))) + +;;** `counsel-grep-or-swiper-backward' +;;;###autoload +(defun counsel-grep-or-swiper-backward (&optional initial-input) + "Call `swiper-backward' for small buffers and `counsel-grep-backward' for +large ones. When non-nil, INITIAL-INPUT is the initial search pattern." + (interactive) + (let ((ivy-index-functions-alist + '((swiper . ivy-recompute-index-swiper-backward) + (counsel-grep . ivy-recompute-index-swiper-async-backward)))) + (counsel-grep-or-swiper initial-input))) + +;;** `counsel-recoll' +(defun counsel-recoll-function (str) + "Run recoll for STR." + (or + (ivy-more-chars) + (progn + (counsel--async-command + (format "recoll -t -b %s" + (shell-quote-argument str))) + nil))) + +;; This command uses the recollq command line tool that comes together +;; with the recoll (the document indexing database) source: +;; https://www.lesbonscomptes.com/recoll/download.html +;; You need to build it yourself (together with recoll): +;; cd ./query && make && sudo cp recollq /usr/local/bin +;; You can try the GUI version of recoll with: +;; sudo apt-get install recoll +;; Unfortunately, that does not install recollq. +;;;###autoload +(defun counsel-recoll (&optional initial-input) + "Search for a string in the recoll database. +You'll be given a list of files that match. +Selecting a file will launch `swiper' for that file. +INITIAL-INPUT can be given as the initial minibuffer input." + (interactive) + (counsel-require-program "recoll") + (ivy-read "recoll: " 'counsel-recoll-function + :initial-input initial-input + :dynamic-collection t + :history 'counsel-git-grep-history + :action (lambda (x) + (when (string-match "file://\\(.*\\)\\'" x) + (let ((file-name (match-string 1 x))) + (find-file file-name) + (unless (string-match "pdf$" x) + (swiper ivy-text))))) + :caller 'counsel-recoll)) + +(ivy-configure 'counsel-recoll + :unwind-fn #'counsel-delete-process) + +;;* Org +;;** `counsel-org-tag' +(defvar counsel-org-tags nil + "Store the current list of tags.") + +(defvar org-outline-regexp) +(defvar org-indent-mode) +(defvar org-indent-indentation-per-level) +(defvar org-tags-column) +(declare-function org-get-tags-string "org") +(declare-function org-get-tags "org") +(declare-function org-make-tag-string "org") +(declare-function org-move-to-column "org-compat") + +(defun counsel--org-make-tag-string () + (if (fboundp #'org-make-tag-string) + ;; >= Org 9.2 + (org-make-tag-string (counsel--org-get-tags)) + (with-no-warnings + (org-get-tags-string)))) + +(defun counsel-org-change-tags (tags) + "Change tags of current org headline to TAGS." + (let ((current (counsel--org-make-tag-string)) + (col (current-column)) + level) + ;; Insert new tags at the correct column + (beginning-of-line 1) + (setq level (or (and (looking-at org-outline-regexp) + (- (match-end 0) (point) 1)) + 1)) + (cond + ((and (equal current "") (equal tags ""))) + ((re-search-forward + (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") + (line-end-position) t) + (if (equal tags "") + (delete-region + (match-beginning 0) + (match-end 0)) + (goto-char (match-beginning 0)) + (let* ((c0 (current-column)) + ;; compute offset for the case of org-indent-mode active + (di (if (bound-and-true-p org-indent-mode) + (* (1- org-indent-indentation-per-level) (1- level)) + 0)) + (p0 (if (equal (char-before) ?*) (1+ (point)) (point))) + (tc (+ org-tags-column (if (> org-tags-column 0) (- di) di))) + (c1 (max (1+ c0) (if (> tc 0) tc (- (- tc) (string-width tags))))) + (rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) + (replace-match rpl t t) + (and c0 indent-tabs-mode (tabify p0 (point))) + tags))) + (t (error "Tags alignment failed"))) + (org-move-to-column col))) + +(defun counsel-org--set-tags () + "Set tags of current org headline to `counsel-org-tags'." + (counsel-org-change-tags + (if counsel-org-tags + (format ":%s:" + (mapconcat #'identity counsel-org-tags ":")) + ""))) + +(defvar org-agenda-bulk-marked-entries) + +(declare-function org-get-at-bol "org") +(declare-function org-agenda-error "org-agenda") + +(defun counsel-org-tag-action (x) + "Add tag X to `counsel-org-tags'. +If X is already part of the list, remove it instead. Quit the selection if +X is selected by either `ivy-done', `ivy-alt-done' or `ivy-immediate-done', +otherwise continue prompting for tags." + (if (member x counsel-org-tags) + (progn + (setq counsel-org-tags (delete x counsel-org-tags))) + (unless (equal x "") + (setq counsel-org-tags (append counsel-org-tags (list x))) + (unless (member x ivy--all-candidates) + (setq ivy--all-candidates (append ivy--all-candidates (list x)))))) + (let ((prompt (counsel-org-tag-prompt))) + (setf (ivy-state-prompt ivy-last) prompt) + (setq ivy--prompt (concat "%-4d " prompt))) + (cond ((memq this-command '(ivy-done + ivy-alt-done + ivy-immediate-done)) + (if (eq major-mode 'org-agenda-mode) + (if (null org-agenda-bulk-marked-entries) + (let ((hdmarker (or (org-get-at-bol 'org-hd-marker) + (org-agenda-error)))) + (with-current-buffer (marker-buffer hdmarker) + (goto-char hdmarker) + (counsel-org--set-tags))) + (let ((add-tags (copy-sequence counsel-org-tags))) + (dolist (m org-agenda-bulk-marked-entries) + (with-current-buffer (marker-buffer m) + (save-excursion + (goto-char m) + (setq counsel-org-tags + (delete-dups + (append (counsel--org-get-tags) add-tags))) + (counsel-org--set-tags)))))) + (counsel-org--set-tags) + (unless (member x counsel-org-tags) + (message "Tag %S has been removed." x)))) + ((eq this-command 'ivy-call) + (with-selected-window (active-minibuffer-window) + (delete-minibuffer-contents))))) + +(defun counsel-org-tag-prompt () + "Return prompt for `counsel-org-tag'." + (format "Tags (%s): " + (mapconcat #'identity counsel-org-tags ", "))) + +(defvar org-setting-tags) +(defvar org-last-tags-completion-table) +(defvar org-tag-persistent-alist) +(defvar org-tag-alist) +(defvar org-complete-tags-always-offer-all-agenda-tags) + +(declare-function org-at-heading-p "org") +(declare-function org-back-to-heading "org") +(declare-function org-get-buffer-tags "org") +(declare-function org-global-tags-completion-table "org") +(declare-function org-agenda-files "org") +(declare-function org-agenda-set-tags "org-agenda") +(declare-function org-tags-completion-function "org") + +;;;###autoload +(defun counsel--org-get-tags () + (delete "" (condition-case nil + (org-get-tags nil t) + (error (org-get-tags))))) + +;;;###autoload +(defun counsel-org-tag () + "Add or remove tags in `org-mode'." + (interactive) + (save-excursion + (if (eq major-mode 'org-agenda-mode) + (if org-agenda-bulk-marked-entries + (setq counsel-org-tags nil) + (let ((hdmarker (or (org-get-at-bol 'org-hd-marker) + (org-agenda-error)))) + (with-current-buffer (marker-buffer hdmarker) + (goto-char hdmarker) + (setq counsel-org-tags (counsel--org-get-tags))))) + (unless (org-at-heading-p) + (org-back-to-heading t)) + (setq counsel-org-tags (counsel--org-get-tags))) + (let ((org-last-tags-completion-table + (append (and (or org-complete-tags-always-offer-all-agenda-tags + (eq major-mode 'org-agenda-mode)) + (org-global-tags-completion-table + (org-agenda-files))) + (unless (boundp 'org-current-tag-alist) + org-tag-persistent-alist) + (or (if (boundp 'org-current-tag-alist) + org-current-tag-alist + org-tag-alist) + (org-get-buffer-tags))))) + (ivy-read (counsel-org-tag-prompt) + (lambda (str _pred _action) + (delete-dups + (all-completions str #'org-tags-completion-function))) + :history 'org-tags-history + :action #'counsel-org-tag-action + :caller 'counsel-org-tag)))) + +(defvar org-version) + +;;;###autoload +(defun counsel-org-tag-agenda () + "Set tags for the current agenda item." + (interactive) + (cl-letf (((symbol-function (if (version< org-version "9.2") + 'org-set-tags + 'org-set-tags-command)) + #'counsel-org-tag)) + (org-agenda-set-tags))) + +(defcustom counsel-org-headline-display-tags nil + "If non-nil, display tags in matched `org-mode' headlines." + :type 'boolean) + +(defcustom counsel-org-headline-display-todo nil + "If non-nil, display todo keywords in matched `org-mode' headlines." + :type 'boolean) + +(defcustom counsel-org-headline-display-priority nil + "If non-nil, display priorities in matched `org-mode' headlines." + :type 'boolean) + +(defcustom counsel-org-headline-display-comment nil + "If non-nil, display COMMENT string in matched `org-mode' headlines." + :type 'boolean) + +(defcustom counsel-org-headline-display-statistics nil + "If non-nil, display statistics cookie in matched `org-mode' headlines." + :type 'boolean) + +(declare-function org-get-heading "org") +(declare-function org-goto-marker-or-bmk "org") +(declare-function outline-next-heading "outline") + +;;;###autoload +(defalias 'counsel-org-goto #'counsel-outline) + +(defcustom counsel-org-goto-all-outline-path-prefix nil + "Prefix for outline candidates in `counsel-org-goto-all'." + :type '(choice + (const :tag "None" nil) + (const :tag "File name" file-name) + (const :tag "File name (nondirectory part)" file-name-nondirectory) + (const :tag "Buffer name" buffer-name))) + +(defun counsel-org-goto-all--outline-path-prefix () + (cl-case counsel-org-goto-all-outline-path-prefix + (file-name buffer-file-name) + (file-name-nondirectory (file-name-nondirectory buffer-file-name)) + (buffer-name (buffer-name)))) + +(defvar counsel-outline-settings + '((emacs-lisp-mode + :outline-regexp ";;[;*]+[\s\t]+" + :outline-level counsel-outline-level-emacs-lisp) + (org-mode + :outline-title counsel-outline-title-org + :action counsel-org-goto-action + :history counsel-org-goto-history + :caller counsel-org-goto) + ;; markdown-mode package + (markdown-mode + :outline-title counsel-outline-title-markdown) + ;; Built-in mode or AUCTeX package + (latex-mode + :outline-title counsel-outline-title-latex)) + "Alist mapping major modes to their `counsel-outline' settings. + +Each entry is a pair (MAJOR-MODE . PLIST). `counsel-outline' +checks whether an entry exists for the current buffer's +MAJOR-MODE and, if so, loads the settings specified by PLIST +instead of the default settings. The following settings are +recognized: + +- `:outline-regexp' is a regexp to match the beginning of an + outline heading. It is only checked at the start of a line and + so need not start with \"^\". + Defaults to the value of the variable `outline-regexp'. + +- `:outline-level' is a function of no arguments which computes + the level of an outline heading. It is called with point at + the beginning of `outline-regexp' and with the match data + corresponding to `outline-regexp'. + Defaults to the value of the variable `outline-level'. + +- `:outline-title' is a function of no arguments which returns + the title of an outline heading. It is called with point at + the end of `outline-regexp' and with the match data + corresponding to `outline-regexp'. + Defaults to the function `counsel-outline-title'. + +- `:action' is a function of one argument, the selected outline + heading to jump to. This setting corresponds directly to its + eponymous `ivy-read' keyword, as used by `counsel-outline', so + the type of the function's argument depends on the value + returned by `counsel-outline-candidates'. + Defaults to the function `counsel-outline-action'. + +- `:history' is a history list, usually a symbol representing a + history list variable. It corresponds directly to its + eponymous `ivy-read' keyword, as used by `counsel-outline'. + Defaults to the symbol `counsel-outline-history'. + +- `:caller' is a symbol to uniquely identify the caller to + `ivy-read'. It corresponds directly to its eponymous + `ivy-read' keyword, as used by `counsel-outline'. + Defaults to the symbol `counsel-outline'. + +- `:display-style' overrides the variable + `counsel-outline-display-style'. + +- `:path-separator' overrides the variable + `counsel-outline-path-separator'. + +- `:face-style' overrides the variable + `counsel-outline-face-style'. + +- `:custom-faces' overrides the variable + `counsel-outline-custom-faces'.") + +;;;###autoload +(defun counsel-org-goto-all () + "Go to a different location in any org file." + (interactive) + (let (entries) + (dolist (b (buffer-list)) + (with-current-buffer b + (when (derived-mode-p 'org-mode) + (setq entries + (nconc entries + (counsel-outline-candidates + (cdr (assq 'org-mode counsel-outline-settings)) + (counsel-org-goto-all--outline-path-prefix))))))) + (ivy-read "Goto: " entries + :history 'counsel-org-goto-history + :action #'counsel-org-goto-action + :caller 'counsel-org-goto-all))) + +(defun counsel-org-goto-action (x) + "Go to headline in candidate X." + (org-goto-marker-or-bmk (cdr x))) + +(defun counsel--org-get-heading-args () + "Return list of arguments for `org-get-heading'. +Try to return the right number of arguments for the current Org +version. Argument values are based on the +`counsel-org-headline-display-*' user options." + (nbutlast (mapcar #'not (list counsel-org-headline-display-tags + counsel-org-headline-display-todo + counsel-org-headline-display-priority + counsel-org-headline-display-comment)) + ;; Added in Emacs 26.1. + (if (if (fboundp 'func-arity) + (< (cdr (func-arity #'org-get-heading)) 3) + (version< org-version "9.1.1")) + 2 0))) + +;;** `counsel-org-file' +(declare-function org-attach-dir "org-attach") +(declare-function org-attach-file-list "org-attach") +(defvar org-attach-directory) + +(defun counsel-org-files () + "Return list of all files under current Org attachment directories. +Filenames returned are relative to `default-directory'. For each +attachment directory associated with the current buffer, all +contained files are listed, so the return value could conceivably +include attachments of other Org buffers." + (require 'org-attach) + (let (dirs) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^:\\(ATTACH_DIR\\|ID\\):[\t ]+\\(.*\\)$" nil t) + (let ((dir (org-attach-dir))) + (when dir + (push dir dirs))))) + (cl-mapcan + (lambda (dir) + (mapcar (lambda (file) + (file-relative-name (expand-file-name file dir))) + (org-attach-file-list dir))) + (nreverse dirs)))) + +;;;###autoload +(defun counsel-org-file () + "Browse all attachments for current Org file." + (interactive) + (ivy-read "file: " (counsel-org-files) + :action #'counsel-locate-action-dired + :caller 'counsel-org-file)) + +;;** `counsel-org-entity' +(defvar org-entities) +(defvar org-entities-user) + +;;;###autoload +(defun counsel-org-entity () + "Complete Org entities using Ivy." + (interactive) + (require 'org) + (ivy-read "Entity: " (cl-loop for element in (append org-entities org-entities-user) + unless (stringp element) + collect (cons + (format "%20s | %20s | %20s | %s" + (cl-first element) ; name + (cl-second element) ; latex + (cl-fourth element) ; html + (cl-seventh element)) ; utf-8 + element)) + :require-match t + :action '(1 + ("u" (lambda (candidate) + (insert (cl-seventh (cdr candidate)))) "utf-8") + ("o" (lambda (candidate) + (insert "\\" (cl-first (cdr candidate)))) "org-entity") + ("l" (lambda (candidate) + (insert (cl-second (cdr candidate)))) "latex") + ("h" (lambda (candidate) + (insert (cl-fourth (cdr candidate)))) "html") + ("a" (lambda (candidate) + (insert (cl-fifth (cdr candidate)))) "ascii") + ("L" (lambda (candidate) + (insert (cl-sixth (cdr candidate))) "Latin-1"))))) + +;;** `counsel-org-capture' +(defvar org-capture-templates) +(defvar org-capture-templates-contexts) +(declare-function org-contextualize-keys "org") +(declare-function org-capture-goto-last-stored "org-capture") +(declare-function org-capture-goto-target "org-capture") +(declare-function org-capture-upgrade-templates "org-capture") + +;;;###autoload +(defun counsel-org-capture () + "Capture something." + (interactive) + (require 'org-capture) + (ivy-read "Capture template: " + (delq nil + (mapcar + (lambda (x) + (when (> (length x) 2) + (format "%-5s %s" (nth 0 x) (nth 1 x)))) + ;; We build the list of capture templates as in + ;; `org-capture-select-template': + (or (org-contextualize-keys + (org-capture-upgrade-templates org-capture-templates) + org-capture-templates-contexts) + '(("t" "Task" entry (file+headline "" "Tasks") + "* TODO %?\n %u\n %a"))))) + :require-match t + :action (lambda (x) + (org-capture nil (car (split-string x)))) + :caller 'counsel-org-capture)) + +(ivy-configure 'counsel-org-capture + :initial-input "^") + +(ivy-set-actions + 'counsel-org-capture + `(("t" ,(lambda (x) + (org-capture-goto-target (car (split-string x)))) + "go to target") + ("l" ,(lambda (_x) + (org-capture-goto-last-stored)) + "go to last stored") + ("p" ,(lambda (x) + (org-capture 0 (car (split-string x)))) + "insert template at point") + ("c" ,(lambda (_x) + (customize-variable 'org-capture-templates)) + "customize org-capture-templates"))) + +;;** `counsel-org-agenda-headlines' +(defvar org-odd-levels-only) +(declare-function org-set-startup-visibility "org") +(declare-function org-show-entry "org") +(declare-function org-map-entries "org") +(declare-function org-heading-components "org") + +(defun counsel-org-agenda-headlines-action-goto (headline) + "Go to the `org-mode' agenda HEADLINE." + (find-file (nth 1 headline)) + (org-set-startup-visibility) + (goto-char (nth 2 headline)) + (org-show-entry)) + +(ivy-set-actions + 'counsel-org-agenda-headlines + '(("g" counsel-org-agenda-headlines-action-goto "goto headline"))) + +(defvar counsel-org-agenda-headlines-history nil + "History for `counsel-org-agenda-headlines'.") + +(defcustom counsel-outline-display-style 'path + "The style used when displaying matched outline headings. + +If `headline', the title is displayed with leading stars +indicating the outline level. + +If `path', the path hierarchy is displayed. For each entry the +title is shown. Entries are separated with +`counsel-outline-path-separator'. + +If `title' or any other value, only the title of the heading is +displayed. + +For displaying tags and TODO keywords in `org-mode' buffers, see +`counsel-org-headline-display-tags' and +`counsel-org-headline-display-todo', respectively." + :type '(choice + (const :tag "Title only" title) + (const :tag "Headline" headline) + (const :tag "Path" path))) + +(defcustom counsel-outline-path-separator "/" + "String separating path entries in matched outline headings. +This variable has no effect unless +`counsel-outline-display-style' is set to `path'." + :type 'string) + +(declare-function org-get-outline-path "org") + +(defun counsel-org-agenda-headlines--candidates () + "Return a list of completion candidates for `counsel-org-agenda-headlines'." + (org-map-entries + (lambda () + (let* ((components (org-heading-components)) + (level (and (eq counsel-outline-display-style 'headline) + (make-string + (if org-odd-levels-only + (nth 1 components) + (nth 0 components)) + ?*))) + (todo (and counsel-org-headline-display-todo + (nth 2 components))) + (path (and (eq counsel-outline-display-style 'path) + (org-get-outline-path))) + (priority (and counsel-org-headline-display-priority + (nth 3 components))) + (text (nth 4 components)) + (tags (and counsel-org-headline-display-tags + (nth 5 components)))) + (list + (mapconcat + 'identity + (cl-remove-if 'null + (list + level + todo + (and priority (format "[#%c]" priority)) + (mapconcat 'identity + (append path (list text)) + counsel-outline-path-separator) + tags)) + " ") + buffer-file-name + (point)))) + nil + 'agenda)) + +;;;###autoload +(defun counsel-org-agenda-headlines () + "Choose from headers of `org-mode' files in the agenda." + (interactive) + (require 'org) + (let ((minibuffer-allow-text-properties t)) + (ivy-read "Org headline: " + (counsel-org-agenda-headlines--candidates) + :action #'counsel-org-agenda-headlines-action-goto + :history 'counsel-org-agenda-headlines-history + :caller 'counsel-org-agenda-headlines))) + +;;** `counsel-org-link' +(declare-function org-insert-link "ol") +(declare-function org-id-get-create "org-id") + +(defun counsel-org-link-action (x) + "Insert a link to X." + (let ((id (save-excursion + (goto-char (cdr x)) + (org-id-get-create)))) + (org-insert-link nil (concat "id:" id) (car x)))) + +;;;###autoload +(defun counsel-org-link () + "Insert a link to an headline with completion." + (interactive) + (ivy-read "Link: " (counsel-outline-candidates + '(:outline-title counsel-outline-title-org )) + :action #'counsel-org-link-action + :history 'counsel-org-link-history + :caller 'counsel-org-link)) + +;; Misc. Emacs +;;** `counsel-mark-ring' +(defface counsel--mark-ring-highlight + '((t (:inherit highlight))) + "Face for current `counsel-mark-ring' line." + :group 'ivy-faces) + +(defvar counsel--mark-ring-overlay nil + "Internal overlay to highlight line by candidate of `counsel-mark-ring'.") + +(defun counsel--mark-ring-add-highlight () + "Add highlight to current line." + (setq counsel--mark-ring-overlay + (make-overlay (line-beginning-position) (1+ (line-end-position)))) + (with-ivy-window + (overlay-put counsel--mark-ring-overlay 'face + 'counsel--mark-ring-highlight))) + +(defun counsel--mark-ring-delete-highlight () + "If `counsel-mark-ring' have highlight, delete highlight." + (if counsel--mark-ring-overlay (delete-overlay counsel--mark-ring-overlay))) + +(defvar counsel--mark-ring-calling-point 0 + "Internal variable to remember calling position.") + +(defun counsel--mark-ring-unwind () + "Return back to calling position of `counsel-mark-ring'." + (goto-char counsel--mark-ring-calling-point) + (counsel--mark-ring-delete-highlight)) + +(defun counsel--mark-ring-update-fn () + "Show preview by candidate." + (let ((pos (get-text-property 0 'point (ivy-state-current ivy-last)))) + (counsel--mark-ring-delete-highlight) + (with-ivy-window + (goto-char pos) + (counsel--mark-ring-add-highlight)))) + +;;;###autoload +(defun counsel-mark-ring () + "Browse `mark-ring' interactively. +Obeys `widen-automatically', which see." + (interactive) + (let* ((counsel--mark-ring-calling-point (point)) + (marks (copy-sequence mark-ring)) + (marks (delete-dups marks)) + (marks + ;; mark-marker is empty? + (if (equal (mark-marker) (make-marker)) + marks + (cons (copy-marker (mark-marker)) marks))) + (candidates (counsel-mark--get-candidates marks))) + (if candidates + (counsel-mark--ivy-read candidates 'counsel-mark-ring) + (message "Mark ring is empty")))) + +(defun counsel-mark--get-candidates (marks) + "Convert a list of MARKS into mark candidates. +candidates are simply strings formatted to have the line number of the +associated mark prepended to them and having an extra text property of +point to indicarte where the candidate mark is." + (when marks + (save-excursion + (save-restriction + ;; Widen, both to save `line-number-at-pos' the trouble + ;; and for `buffer-substring' to work. + (widen) + (let* ((width (length (number-to-string (line-number-at-pos (point-max))))) + (fmt (format "%%%dd %%s" width))) + (mapcar (lambda (mark) + (goto-char (marker-position mark)) + (let ((linum (line-number-at-pos)) + (line (buffer-substring + (line-beginning-position) (line-end-position)))) + (propertize (format fmt linum line) 'point (point)))) + marks)))))) + +(defun counsel-mark--ivy-read (candidates caller) + "call `ivy-read' with sane defaults for traversing marks. +CANDIDATES should be an alist with the `car' of the list being +the string displayed by ivy and the `cdr' being the point that +mark should take you to. + +NOTE This has been abstracted out into it's own method so it can +be used by both `counsel-mark-ring' and `counsel-evil-marks'" + (ivy-read "Mark: " candidates + :require-match t + :update-fn #'counsel--mark-ring-update-fn + :action (lambda (cand) + (let ((pos (get-text-property 0 'point cand))) + (when pos + (unless (<= (point-min) pos (point-max)) + (if widen-automatically + (widen) + (error "\ +Position of selected mark outside accessible part of buffer"))) + (goto-char pos)))) + :unwind #'counsel--mark-ring-unwind + :caller caller)) + +(ivy-configure 'counsel-mark-ring + :update-fn #'counsel--mark-ring-update-fn + :unwind-fn #'counsel--mark-ring-unwind + :sort-fn #'ivy-string<) + +;;** `counsel-evil-marks' +(defvar counsel-evil-marks-exclude-registers nil + "List of evil registers to not display in `counsel-evil-marks' by default. +Each member of the list should be a character (stored as an integer).") + +(defvar evil-markers-alist) +(declare-function evil-global-marker-p "ext:evil-common") + +(defun counsel-mark--get-evil-candidates (all-markers-p) + "Convert all evil MARKS in the current buffer to mark candidates. +Works like `counsel-mark--get-candidates' but also prepends the +register tied to a mark in the message string." + ;; evil doesn't provide a standalone method to access the list of + ;; marks in the current buffer, as it does with registers. + (let* ((all-markers + (append + (cl-remove-if (lambda (m) + (or (evil-global-marker-p (car m)) + (not (markerp (cdr m))))) + evil-markers-alist) + (cl-remove-if (lambda (m) + (or (not (evil-global-marker-p (car m))) + (not (markerp (cdr m))))) + (default-value 'evil-markers-alist)))) + + (all-markers + ;; with prefix, ignore register exclusion list. + (if all-markers-p + all-markers + (cl-remove-if-not + (lambda (x) (not (member (car x) counsel-evil-marks-exclude-registers))) + all-markers))) + ;; separate the markers from the evil registers + ;; for call to `counsel-mark--get-candidates' + (registers (mapcar #'car all-markers)) + (markers (mapcar #'cdr all-markers)) + (candidates (counsel-mark--get-candidates markers))) + (when candidates + (let (register candidate result) + (while (and (setq register (pop registers)) + (setq candidate (pop candidates))) + (let ((point (get-text-property 0 'point candidate)) + (evil-candidate + (format "[%s]: %s" + (propertize (char-to-string register) + 'face 'counsel-evil-register-face) + candidate))) + (push (propertize evil-candidate 'point point) result))) + result)))) + +;;;###autoload +(defun counsel-evil-marks (&optional arg) + "Ivy replacement for `evil-show-marks'. +By default, this function respects `counsel-evil-marks-exclude-registers'. +When ARG is non-nil, display all active evil registers." + (interactive "P") + (if (and (boundp 'evil-markers-alist) + (fboundp 'evil-global-marker-p)) + (let* ((counsel--mark-ring-calling-point (point)) + (candidates (counsel-mark--get-evil-candidates arg))) + (if candidates + (counsel-mark--ivy-read candidates 'counsel-evil-marks) + (message "no evil marks are active"))) + (user-error "Required feature `evil' not installed or loaded"))) + +;;** `counsel-package' +(defvar package--initialized) +(defvar package-alist) +(defvar package-archive-contents) +(defvar package-archives) +(defvar package-user-dir) +(declare-function package-installed-p "package") +(declare-function package-delete "package") +(declare-function package-desc-extras "package") + +(defvar counsel-package-history nil + "History for `counsel-package'.") + +(defun counsel--package-candidates () + "Return completion alist for `counsel-package'." + (unless package--initialized + (package-initialize t)) + (if (or (not package-archive-contents) + (cl-find-if (lambda (package-archive) + (let ((fname + (format + "%s/archives/%s/archive-contents" + package-user-dir (car package-archive)))) + (or (not (file-exists-p fname)) + (counsel-file-stale-p fname (* 4 60 60))))) + package-archives)) + (package-refresh-contents)) + (sort (mapcar (lambda (entry) + (cons (let ((pkg (car entry))) + (concat (if (package-installed-p pkg) "-" "+") + (symbol-name pkg))) + entry)) + package-archive-contents) + #'counsel--package-sort)) + +;;;###autoload +(defun counsel-package () + "Install or delete packages. + +Packages not currently installed are prefixed with \"+\", and +selecting one of these will try to install it. +Packages currently installed are prefixed with \"-\", and +selecting one of these will try to delete it. + +Additional actions:\\ + + \\[ivy-dispatching-done] d: Describe package + \\[ivy-dispatching-done] h: Visit package's homepage" + (interactive) + (require 'package) + (ivy-read "Packages (install +pkg or delete -pkg): " + (counsel--package-candidates) + :action #'counsel-package-action + :require-match t + :history 'counsel-package-history + :caller 'counsel-package)) + +(cl-pushnew '(counsel-package . "^+") ivy-initial-inputs-alist :key #'car) + +(defun counsel-package-action (package) + "Delete or install PACKAGE." + (setq package (cadr package)) + (if (package-installed-p package) + (package-delete (cadr (assq package package-alist))) + (package-install package))) + +(defun counsel-package-action-describe (package) + "Call `describe-package' on PACKAGE." + (describe-package (cadr package))) + +(defun counsel-package-action-homepage (package) + "Open homepage for PACKAGE in a WWW browser." + (let ((url (cdr (assq :url (package-desc-extras (nth 2 package)))))) + (if url + (browse-url url) + (message "No homepage specified for package `%s'" (nth 1 package))))) + +(defun counsel--package-sort (a b) + "Sort function for `counsel-package' candidates." + (let* ((a (car a)) + (b (car b)) + (a-inst (= (string-to-char a) ?+)) + (b-inst (= (string-to-char b) ?+))) + (or (and a-inst (not b-inst)) + (and (eq a-inst b-inst) (string-lessp a b))))) + +(ivy-set-actions + 'counsel-package + '(("d" counsel-package-action-describe "describe package") + ("h" counsel-package-action-homepage "open package homepage"))) + +;;** `counsel-tmm' +(defvar tmm-km-list nil) +(declare-function tmm-get-keymap "tmm") +(declare-function tmm--completion-table "tmm") +(declare-function tmm-get-keybind "tmm") + +(defun counsel-tmm-prompt (menu) + "Select and call an item from the MENU keymap." + (let (out + choice + chosen-string) + (setq tmm-km-list nil) + (map-keymap (lambda (k v) (tmm-get-keymap (cons k v))) menu) + (setq tmm-km-list (nreverse tmm-km-list)) + (setq out (ivy-read "Menu bar: " (tmm--completion-table tmm-km-list) + :require-match t)) + (setq choice (cdr (assoc out tmm-km-list))) + (setq chosen-string (car choice)) + (setq choice (cdr choice)) + (cond ((keymapp choice) + (counsel-tmm-prompt choice)) + ((and choice chosen-string) + (setq last-command-event chosen-string) + (call-interactively choice))))) + +(defvar tmm-table-undef) + +;;;###autoload +(defun counsel-tmm () + "Text-mode emulation of looking and choosing from a menu bar." + (interactive) + (require 'tmm) + (run-hooks 'menu-bar-update-hook) + (setq tmm-table-undef nil) + (counsel-tmm-prompt (tmm-get-keybind [menu-bar]))) + +;;** `counsel-yank-pop' +(defcustom counsel-yank-pop-truncate-radius 2 + "Number of context lines around `counsel-yank-pop' candidates." + :type 'integer) + +(defun counsel--yank-pop-truncate (str) + "Truncate STR for use in `counsel-yank-pop'." + (condition-case nil + (let* ((lines (split-string str "\n" t)) + (n (length lines)) + (re (ivy-re-to-str ivy--old-re)) + (first-match (cl-position-if + (lambda (s) (string-match re s)) + lines)) + (beg (max 0 (- first-match + counsel-yank-pop-truncate-radius))) + (end (min n (+ first-match + counsel-yank-pop-truncate-radius + 1))) + (seq (cl-subseq lines beg end))) + (if (null first-match) + (error "Could not match %s" str) + (when (> beg 0) + (setcar seq (concat "[...] " (car seq)))) + (when (< end n) + (setcar (last seq) + (concat (car (last seq)) " [...]"))) + (mapconcat #'identity seq "\n"))) + (error str))) + +(defcustom counsel-yank-pop-separator "\n" + "Separator for the kill ring strings in `counsel-yank-pop'." + :type '(choice + (const :tag "Plain" "\n") + (const :tag "Dashes" "\n----\n") + string)) + +(defun counsel--yank-pop-format-function (cand-pairs) + "Transform CAND-PAIRS into a string for `counsel-yank-pop'." + (ivy--format-function-generic + (lambda (str) + (mapconcat + (lambda (s) + (ivy--add-face s 'ivy-current-match)) + (split-string + (counsel--yank-pop-truncate str) "\n" t) + "\n")) + (lambda (str) + (counsel--yank-pop-truncate str)) + cand-pairs + (propertize counsel-yank-pop-separator 'face 'ivy-separator))) + +(defun counsel--yank-pop-position (s) + "Return position of S in `kill-ring' relative to last yank." + (or (cl-position s kill-ring-yank-pointer :test #'equal-including-properties) + (cl-position s kill-ring-yank-pointer :test #'equal) + (+ (or (cl-position s kill-ring :test #'equal-including-properties) + (cl-position s kill-ring :test #'equal)) + (- (length kill-ring-yank-pointer) + (length kill-ring))))) + +(defun counsel-string-non-blank-p (s) + "Return non-nil if S includes non-blank characters. +Newlines and carriage returns are considered blank." + (not (string-match-p "\\`[\n\r[:blank:]]*\\'" s))) + +(defcustom counsel-yank-pop-filter #'counsel-string-non-blank-p + "Unary filter function applied to `counsel-yank-pop' candidates. +All elements of `kill-ring' for which this function returns nil +will be destructively removed from `kill-ring' before completion. +All blank strings are deleted from `kill-ring' by default." + :type '(radio + (function-item counsel-string-non-blank-p) + (function-item identity) + (function :tag "Other"))) + +(defun counsel--yank-pop-kills () + "Return filtered `kill-ring' for `counsel-yank-pop' completion. +Both `kill-ring' and `kill-ring-yank-pointer' may be +destructively modified to eliminate duplicates under +`equal-including-properties', satisfy `counsel-yank-pop-filter', +and incorporate `interprogram-paste-function'." + ;; Protect against `kill-ring' and result of + ;; `interprogram-paste-function' both being nil + (ignore-errors (current-kill 0)) + ;; Keep things consistent with the rest of Emacs + (dolist (sym '(kill-ring kill-ring-yank-pointer)) + (set sym (cl-delete-duplicates + (cl-delete-if-not counsel-yank-pop-filter (symbol-value sym)) + :test #'equal-including-properties :from-end t))) + kill-ring) + +(defcustom counsel-yank-pop-after-point nil + "Whether `counsel-yank-pop' yanks after point. +Nil means `counsel-yank-pop' puts point at the end of the yanked +text and mark at its beginning, as per the default \\[yank]. +Non-nil means `counsel-yank-pop' swaps the resulting point and +mark, as per \\[universal-argument] \\[yank]." + :type 'boolean) + +(defun counsel-yank-pop-action (s) + "Like `yank-pop', but insert the kill corresponding to S. +Signal a `buffer-read-only' error if called from a read-only +buffer position." + (with-ivy-window + (barf-if-buffer-read-only) + (setq last-command 'yank) + (setq yank-window-start (window-start)) + (condition-case nil + ;; Avoid unexpected additions to `kill-ring' + (let (interprogram-paste-function) + (yank-pop (counsel--yank-pop-position s))) + (error + (insert s))) + (when (funcall (if counsel-yank-pop-after-point #'> #'<) + (point) (mark t)) + (exchange-point-and-mark t)))) + +(defun counsel-yank-pop-action-remove (s) + "Remove all occurrences of S from the kill ring." + (dolist (sym '(kill-ring kill-ring-yank-pointer)) + (set sym (cl-delete s (symbol-value sym) + :test #'equal-including-properties))) + ;; Update collection and preselect for next `ivy-call' + (setf (ivy-state-collection ivy-last) kill-ring) + (setf (ivy-state-preselect ivy-last) + (nth (min ivy--index (1- (length kill-ring))) + kill-ring)) + (ivy--reset-state ivy-last)) + +(defun counsel-yank-pop-action-rotate (s) + "Rotate the yanking point to S in the kill ring. +See `current-kill' for how this interacts with the window system +selection." + (let ((i (counsel--yank-pop-position s))) + ;; Avoid unexpected additions to `kill-ring' + (let (interprogram-paste-function) + (setf (ivy-state-preselect ivy-last) (current-kill i))) + ;; Manually change window system selection because `current-kill' won't + (when (and (zerop i) + yank-pop-change-selection + interprogram-cut-function) + (funcall interprogram-cut-function (car kill-ring-yank-pointer)))) + (ivy--reset-state ivy-last)) + +(defcustom counsel-yank-pop-preselect-last nil + "Whether `counsel-yank-pop' preselects the last kill by default. + +The command `counsel-yank-pop' always preselects the same kill +that `yank-pop' would have inserted, given the same prefix +argument. + +When `counsel-yank-pop-preselect-last' is nil (the default), the +prefix argument of `counsel-yank-pop' defaults to 1 (as per +`yank-pop'), which causes the next-to-last kill to be +preselected. Otherwise, the prefix argument defaults to 0, which +results in the most recent kill being preselected." + :type 'boolean) + +;; Moved to subr.el in Emacs 27.1. +(autoload 'xor "array") + +;;;###autoload +(defun counsel-yank-pop (&optional arg) + "Ivy replacement for `yank-pop'. +With a plain prefix argument (\\[universal-argument]), +temporarily toggle the value of `counsel-yank-pop-after-point'. +Any other value of ARG has the same meaning as in `yank-pop', but +`counsel-yank-pop-preselect-last' determines its default value. +See also `counsel-yank-pop-filter' for how to filter candidates. + +Note: Duplicate elements of `kill-ring' are always deleted." + ;; Do not specify `*' to allow browsing `kill-ring' in read-only buffers + (interactive "P") + (let ((kills (or (counsel--yank-pop-kills) + (error "Kill ring is empty or blank"))) + (preselect (let (interprogram-paste-function) + (current-kill (cond ((nlistp arg) + (prefix-numeric-value arg)) + (counsel-yank-pop-preselect-last 0) + (t 1)) + t))) + (counsel-yank-pop-after-point + (xor (consp arg) counsel-yank-pop-after-point))) + (unless (eq last-command 'yank) + (push-mark)) + (ivy-read "kill-ring: " kills + :require-match t + :preselect preselect + :action #'counsel-yank-pop-action + :caller 'counsel-yank-pop))) + +(ivy-configure 'counsel-yank-pop + :height 5 + :format-fn #'counsel--yank-pop-format-function) + +(ivy-set-actions + 'counsel-yank-pop + '(("d" counsel-yank-pop-action-remove "delete") + ("r" counsel-yank-pop-action-rotate "rotate"))) + +;;** `counsel-register' +(defvar counsel-register-actions + '(("\\`buffer" . jump-to-register) + ("\\`text" . insert-register) + ("\\`rectangle" . insert-register) + ("\\`window" . jump-to-register) + ("\\`frame" . jump-to-register) + ("\\`[-+]?[0-9]+\\(?:\\.[0-9]\\)?\\'" . insert-register) + ("\\`\\(?:the \\)?file " . jump-to-register) + ("\\`keyboard" . jump-to-register) + ("\\`file-query" . jump-to-register)) + "Alist of (REGEXP . FUNCTION) pairs for `counsel-register'. +Selecting a register whose description matches REGEXP specifies +FUNCTION as the action to take on the register.") + +(defvar counsel-register-history nil + "History for `counsel-register'.") + +(defun counsel-register-action (register) + "Default action for `counsel-register'. + +Call a function on REGISTER. The function is determined by +matching the register's value description against a regexp in +`counsel-register-actions'." + (let* ((val (get-text-property 0 'register register)) + (desc (register-describe-oneline val)) + (action (cdr (cl-assoc-if (lambda (re) (string-match-p re desc)) + counsel-register-actions)))) + (if action + (funcall action val) + (error "No action was found for register %s" + (single-key-description val))))) + +;;;###autoload +(defun counsel-register () + "Interactively choose a register." + (interactive) + (ivy-read "Register: " + (cl-mapcan + (lambda (reg) + (let ((s (funcall register-preview-function reg))) + (setq s (substring s 0 (string-match-p "[ \t\n\r]+\\'" s))) + (unless (string= s "") + (put-text-property 0 1 'register (car reg) s) + (list s)))) + register-alist) + :require-match t + :history 'counsel-register-history + :action #'counsel-register-action + :caller 'counsel-register)) + +(ivy-configure 'counsel-register + :sort-fn #'ivy-string<) + +;;** `counsel-evil-registers' +(defface counsel-evil-register-face + '((t (:inherit counsel-outline-1))) + "Face for highlighting `evil' registers in ivy." + :group 'ivy-faces) + +;;;###autoload +(defun counsel-evil-registers () + "Ivy replacement for `evil-show-registers'." + (interactive) + (if (fboundp 'evil-register-list) + (ivy-read "evil-registers: " + (cl-loop for (key . val) in (evil-register-list) + collect (format "[%s]: %s" + (propertize (char-to-string key) + 'face 'counsel-evil-register-face) + (if (stringp val) val ""))) + :require-match t + :action #'counsel-evil-registers-action + :caller 'counsel-evil-registers) + (user-error "Required feature `evil' not installed"))) + +(ivy-configure 'counsel-evil-registers + :height 5 + :format-fn #'counsel--yank-pop-format-function) + +(defun counsel-evil-registers-action (s) + "Paste contents of S, trimming the register part. + +S will be of the form \"[register]: content\"." + (with-ivy-window + (insert + (replace-regexp-in-string "\\`\\[.*?\\]: " "" s)))) + +;;** `counsel-imenu' +(defvar imenu-auto-rescan) +(defvar imenu-auto-rescan-maxout) +(declare-function imenu--subalist-p "imenu") +(declare-function imenu--make-index-alist "imenu") + +(defun counsel--imenu-candidates () + (require 'imenu) + (let* ((imenu-auto-rescan t) + (imenu-auto-rescan-maxout (if current-prefix-arg + (buffer-size) + imenu-auto-rescan-maxout)) + (items (imenu--make-index-alist t)) + (items (delete (assoc "*Rescan*" items) items)) + (items (if (eq major-mode 'emacs-lisp-mode) + (counsel-imenu-categorize-functions items) + items))) + (counsel-imenu-get-candidates-from items))) + +(defun counsel-imenu-get-candidates-from (alist &optional prefix) + "Create a list of (key . value) from ALIST. +PREFIX is used to create the key." + (cl-mapcan + (lambda (elm) + (if (imenu--subalist-p elm) + (counsel-imenu-get-candidates-from + (cl-loop for (e . v) in (cdr elm) collect + (cons e (if (integerp v) (copy-marker v) v))) + ;; pass the prefix to next recursive call + (concat prefix (if prefix ".") (car elm))) + (let ((key (concat + (when prefix + (concat + (propertize prefix 'face 'ivy-grep-info) + ": ")) + (car elm)))) + (list (cons key + (cons key (if (overlayp (cdr elm)) + (overlay-start (cdr elm)) + (cdr elm)))))))) + alist)) + +(defvar counsel-imenu-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-l") 'ivy-call-and-recenter) + map)) + +(defun counsel-imenu-categorize-functions (items) + "Categorize all the functions of imenu." + (let ((fns (cl-remove-if #'listp items :key #'cdr))) + (if fns + (nconc (cl-remove-if #'nlistp items :key #'cdr) + `(("Functions" ,@fns))) + items))) + +(defun counsel-imenu-action (x) + (with-ivy-window + (imenu (cdr x)))) + +(defvar counsel-imenu-history nil + "History for `counsel-imenu'.") + +;;;###autoload +(defun counsel-imenu () + "Jump to a buffer position indexed by imenu." + (interactive) + (ivy-read "imenu items: " (counsel--imenu-candidates) + :preselect (thing-at-point 'symbol) + :require-match t + :action #'counsel-imenu-action + :keymap counsel-imenu-map + :history 'counsel-imenu-history + :caller 'counsel-imenu)) + +;;** `counsel-list-processes' +(defun counsel-list-processes-action-delete (x) + "Delete process X." + (delete-process x) + (setf (ivy-state-collection ivy-last) + (setq ivy--all-candidates + (delete x ivy--all-candidates)))) + +(defun counsel-list-processes-action-switch (x) + "Switch to buffer of process X." + (let* ((proc (get-process x)) + (buf (and proc (process-buffer proc)))) + (if buf + (switch-to-buffer buf) + (message "Process %s doesn't have a buffer" x)))) + +;;;###autoload +(defun counsel-list-processes () + "Offer completion for `process-list'. +The default action deletes the selected process. +An extra action allows to switch to the process buffer." + (interactive) + (with-temp-buffer + (list-processes--refresh)) + (ivy-read "Process: " (mapcar #'process-name (process-list)) + :require-match t + :action + '(1 + ("o" counsel-list-processes-action-delete "kill") + ("s" counsel-list-processes-action-switch "switch")) + :caller 'counsel-list-processes)) + +;;** `counsel-ace-link' +(defun counsel-ace-link () + "Use Ivy completion for `ace-link'." + (interactive) + (let (collection action) + (cond ((eq major-mode 'Info-mode) + (setq collection 'ace-link--info-collect) + (setq action 'ace-link--info-action)) + ((eq major-mode 'help-mode) + (setq collection 'ace-link--help-collect) + (setq action 'ace-link--help-action)) + ((eq major-mode 'woman-mode) + (setq collection 'ace-link--woman-collect) + (setq action 'ace-link--woman-action)) + ((eq major-mode 'eww-mode) + (setq collection 'ace-link--eww-collect) + (setq action 'ace-link--eww-action)) + ((eq major-mode 'compilation-mode) + (setq collection 'ace-link--eww-collect) + (setq action 'ace-link--compilation-action)) + ((eq major-mode 'org-mode) + (setq collection 'ace-link--org-collect) + (setq action 'ace-link--org-action))) + (if (null collection) + (error "%S is not supported" major-mode) + (ivy-read "Ace-Link: " (funcall collection) + :action (lambda (x) (funcall action (cdr x))) + :require-match t + :caller 'counsel-ace-link)))) + +;;** `counsel-minibuffer-history' +;;;###autoload +(defun counsel-minibuffer-history () + "Browse minibuffer history." + (interactive) + (let ((enable-recursive-minibuffers t)) + (ivy-read "History: " (ivy-history-contents minibuffer-history-variable) + :keymap ivy-reverse-i-search-map + :action (lambda (x) + (insert (substring-no-properties (car x)))) + :caller 'counsel-minibuffer-history))) + +;;** `counsel-esh-history' +(defvar comint-input-ring-index) +(defvar eshell-history-index) +(defvar slime-repl-input-history-position) + +(defvar counsel-esh--index-last) +(defvar counsel-shell-history--index-last) +(defvar counsel-slime-repl-history--index-last) + +(defun counsel--browse-history-action (pair) + (let ((snd (cdr pair))) + (cl-case (ivy-state-caller ivy-last) + (counsel-esh-history + (setq eshell-history-index snd + counsel-esh--index-last snd)) + (counsel-shell-history + (setq comint-input-ring-index snd + counsel-shell-history--index-last snd)) + (counsel-slime-repl-history + (setq slime-repl-input-history-position snd + counsel-slime-repl-history--index-last snd))) + (ivy-completion-in-region-action (car pair)))) + +(cl-defun counsel--browse-history (ring &key caller) + "Use Ivy to navigate through RING." + (let* ((proc (get-buffer-process (current-buffer))) + (end (point)) + (beg (if proc + (min (process-mark proc) end) + end)) + (input (when (< beg end) + (concat "^" (buffer-substring beg end))))) + (setq ivy-completion-beg beg) + (setq ivy-completion-end end) + (ivy-read "History: " (ivy-history-contents ring) + :keymap ivy-reverse-i-search-map + :initial-input input + :action #'counsel--browse-history-action + :caller caller))) + +(defvar eshell-history-ring) +(defvar eshell-matching-input-from-input-string) + +(defvar counsel-esh--index-last nil + "Index corresponding to last selection with `counsel-esh-history'.") + +;;;###autoload +(defun counsel-esh-history () + "Browse Eshell history." + (interactive) + (require 'em-hist) + (counsel--browse-history eshell-history-ring + :caller #'counsel-esh-history)) + +(defadvice eshell-previous-matching-input (before + counsel-set-eshell-history-index + activate) + "Reassign `eshell-history-index'." + (when (and (memq last-command '(ivy-alt-done ivy-done)) + (equal (ivy-state-caller ivy-last) 'counsel-esh-history)) + (setq eshell-history-index counsel-esh--index-last))) + +(defvar comint-input-ring) +(defvar comint-matching-input-from-input-string) + +(defvar counsel-shell-history--index-last nil + "Index corresponding to last selection with `counsel-shell-history'.") + +;;;###autoload +(defun counsel-shell-history () + "Browse shell history." + (interactive) + (require 'comint) + (counsel--browse-history comint-input-ring + :caller #'counsel-shell-history)) + +(defadvice comint-previous-matching-input (before + counsel-set-comint-history-index + activate) + "Reassign `comint-input-ring-index'." + (when (and (memq last-command '(ivy-alt-done ivy-done)) + (equal (ivy-state-caller ivy-last) 'counsel-shell-history)) + (setq comint-input-ring-index counsel-shell-history--index-last))) + +(defvar slime-repl-input-history) + +(defvar counsel-slime-repl-history--index-last nil + "Index corresponding to last selection with `counsel-slime-repl-history'.") + +;;;###autoload +(defun counsel-slime-repl-history () + "Browse Slime REPL history." + (interactive) + (require 'slime-repl) + (counsel--browse-history slime-repl-input-history + :caller #'counsel-slime-repl-history)) + +;; TODO: add advice for slime-repl-input-previous/next to properly +;; reassign the ring index and match string + +;;** `counsel-hydra-heads' +(defvar hydra-curr-body-fn) +(declare-function hydra-keyboard-quit "ext:hydra") + +;;;###autoload +(defun counsel-hydra-heads () + "Call a head of the current/last hydra." + (interactive) + (let* ((base (substring + (prin1-to-string hydra-curr-body-fn) + 0 -4)) + (heads (eval (intern (concat base "heads")))) + (keymap (eval (intern (concat base "keymap")))) + (head-names + (mapcar (lambda (x) + (cons + (if (nth 2 x) + (format "[%s] %S (%s)" (nth 0 x) (nth 1 x) (nth 2 x)) + (format "[%s] %S" (nth 0 x) (nth 1 x))) + (lookup-key keymap (kbd (nth 0 x))))) + heads))) + (ivy-read "head: " head-names + :action (lambda (x) (call-interactively (cdr x)))) + (hydra-keyboard-quit))) +;;** `counsel-semantic' +(declare-function semantic-tag-start "semantic/tag") +(declare-function semantic-tag-class "semantic/tag") +(declare-function semantic-tag-name "semantic/tag") +(declare-function semantic-tag-put-attribute "semantic/tag") +(declare-function semantic-tag-get-attribute "semantic/tag") +(declare-function semantic-fetch-tags "semantic") +(declare-function semantic-format-tag-summarize "semantic/format") +(declare-function semantic-active-p "semantic/fw") + +(defun counsel-semantic-action (x) + "Got to semantic TAG." + (goto-char (semantic-tag-start (cdr x)))) + +(defvar counsel-semantic-history nil + "History for `counsel-semantic'.") + +(defun counsel-semantic-format-tag (tag) + "Return a pretty string representation of TAG." + (let ((depth (or (semantic-tag-get-attribute tag :depth) 0)) + (parent (semantic-tag-get-attribute tag :parent))) + (concat (make-string (* depth 2) ?\ ) + (if parent + (concat "(" parent ") ") + "") + (semantic-format-tag-summarize tag nil t)))) + +(defun counsel-flatten-forest (func treep forest) + "Use FUNC and TREEP to flatten FOREST. +FUNC is applied to each node. +TREEP is used to expand internal nodes." + (cl-labels ((reducer (forest out depth) + (dolist (tree forest) + (let ((this (cons (funcall func tree depth) out)) + (leafs (funcall treep tree))) + (setq out + (if leafs + (reducer leafs this (1+ depth)) + this)))) + out)) + (nreverse (reducer forest nil 0)))) + +(defun counsel-semantic-tags () + "Fetch semantic tags." + (counsel-flatten-forest + (lambda (tree depth) + (semantic-tag-put-attribute tree :depth depth)) + (lambda (tag) + (when (eq (semantic-tag-class tag) 'type) + (let ((name (semantic-tag-name tag))) + (mapcar + (lambda (x) (semantic-tag-put-attribute x :parent name)) + (semantic-tag-get-attribute tag :members))))) + (semantic-fetch-tags))) + +;;;###autoload +(defun counsel-semantic () + "Jump to a semantic tag in the current buffer." + (interactive) + (let ((tags (mapcar + (lambda (x) + (cons + (counsel-semantic-format-tag x) + x)) + (counsel-semantic-tags)))) + (ivy-read "tag: " tags + :action #'counsel-semantic-action + :history 'counsel-semantic-history + :caller 'counsel-semantic))) + +;;;###autoload +(defun counsel-semantic-or-imenu () + (interactive) + (require 'semantic/fw) + (if (semantic-active-p) + (counsel-semantic) + (counsel-imenu))) + +;;** `counsel-outline' +(declare-function org-trim "org-macs") + +(defcustom counsel-outline-face-style nil + "Determines how to style outline headings during completion. + +If `org', the faces `counsel-outline-1' through +`counsel-outline-8' are applied in a similar way to Org. +Note that no cycling is performed, so headings on levels 9 and +higher are not styled. + +If `verbatim', the faces used in the buffer are applied. For +simple headlines in `org-mode' buffers, this is usually the same +as the `org' setting, except that it depends on how much of the +buffer has been completely fontified. If your buffer exceeds a +certain size, headlines are styled lazily depending on which +parts of the tree are visible. Headlines which are not yet +styled in the buffer will appear unstyled in the minibuffer as +well. If your headlines contain parts which are fontified +differently than the headline itself (e.g. TODO keywords, tags, +links) and you want these parts to be styled properly, verbatim +is the way to go; otherwise you are probably better off using the +`org' setting instead. + +If `custom', the faces defined in `counsel-outline-custom-faces' +are applied. Note that no cycling is performed, so if there is +no face defined for a certain level, headlines on that level will +not be styled. + +If `nil', all headlines are highlighted using +`counsel-outline-default'. + +For displaying tags and TODO keywords in `org-mode' buffers, see +`counsel-org-headline-display-tags' and +`counsel-org-headline-display-todo', respectively." + :type '(choice + (const :tag "Same as org-mode" org) + (const :tag "Verbatim" verbatim) + (const :tag "Custom" custom) + (const :tag "No style" nil))) + +(defcustom counsel-outline-custom-faces nil + "List of faces for custom display of outline headings. + +Headlines on level N are fontified with the Nth entry of this +list, starting with N = 1. Headline levels with no corresponding +entry in this list will not be styled. + +This variable has no effect unless `counsel-outline-face-style' +is set to `custom'." + :type '(repeat face)) + +(defun counsel-outline-title () + "Return title of current outline heading. +Intended as a value for the `:outline-title' setting in +`counsel-outline-settings', which see." + (buffer-substring (point) (line-end-position))) + +(defun counsel-outline-title-org () + "Return title of current outline heading. +Like `counsel-outline-title' (which see), but for `org-mode' +buffers." + (let ((statistics-re "\\[[0-9]*\\(?:%\\|/[0-9]*\\)]") + (heading (apply #'org-get-heading (counsel--org-get-heading-args)))) + (cond (counsel-org-headline-display-statistics + heading) + (heading + (org-trim (replace-regexp-in-string statistics-re " " heading)))))) + +(defun counsel-outline-title-markdown () + "Return title of current outline heading. +Like `counsel-outline-title' (which see), but for +`markdown-mode' (from the eponymous package) buffers." + ;; `outline-regexp' is set by `markdown-mode' to match both setext + ;; (underline) and atx (hash) headings (see + ;; `markdown-regex-header'). + (or (match-string 1) ; setext heading title + (match-string 5))) ; atx heading title + +(defun counsel-outline-title-latex () + "Return title of current outline heading. +Like `counsel-outline-title' (which see), but for `latex-mode' +buffers." + ;; `outline-regexp' is set by `latex-mode' (see variable + ;; `latex-section-alist' for the built-in mode or function + ;; `LaTeX-outline-regexp' for the AUCTeX package) to match section + ;; macros, in which case we get the section name, as well as + ;; `\appendix', `\documentclass', `\begin{document}', and + ;; `\end{document}', in which case we simply return that. + (if (and (assoc (match-string 1) ; Macro name + (or (bound-and-true-p LaTeX-section-list) ; AUCTeX + (bound-and-true-p latex-section-alist))) ; Built-in + (progn + ;; Point is at end of macro name, skip stars and optional args + (skip-chars-forward "*") + (while (looking-at-p "\\[") + (forward-list)) + ;; First mandatory arg should be section title + (looking-at-p "{"))) + (buffer-substring (1+ (point)) (1- (progn (forward-list) (point)))) + (buffer-substring (line-beginning-position) (point)))) + +(defun counsel-outline-level-emacs-lisp () + "Return level of current outline heading. +Like `lisp-outline-level', but adapted for the `:outline-level' +setting in `counsel-outline-settings', which see." + (if (looking-at ";;\\([;*]+\\)") + (- (match-end 1) (match-beginning 1)) + (funcall outline-level))) + +(defvar counsel-outline--preselect 0 + "Index of the preselected candidate in `counsel-outline'.") + +(defun counsel-outline-candidates (&optional settings prefix) + "Return an alist of outline heading completion candidates. +Each element is a pair (HEADING . MARKER), where the string +HEADING is located at the position of MARKER. SETTINGS is a +plist entry from `counsel-outline-settings', which see. +PREFIX is a string prepended to all candidates." + (let* ((bol-regex (concat "^\\(?:" + (or (plist-get settings :outline-regexp) + outline-regexp) + "\\)")) + (outline-title-fn (or (plist-get settings :outline-title) + #'counsel-outline-title)) + (outline-level-fn (or (plist-get settings :outline-level) + outline-level)) + (display-style (or (plist-get settings :display-style) + counsel-outline-display-style)) + (path-separator (or (plist-get settings :path-separator) + counsel-outline-path-separator)) + (face-style (or (plist-get settings :face-style) + counsel-outline-face-style)) + (custom-faces (or (plist-get settings :custom-faces) + counsel-outline-custom-faces)) + (stack-level 0) + (orig-point (point)) + (stack (and prefix (list (counsel-outline--add-face + prefix 0 face-style custom-faces)))) + cands name level marker) + (save-excursion + (setq counsel-outline--preselect 0) + (goto-char (point-min)) + (while (re-search-forward bol-regex nil t) + (save-excursion + (setq name (or (save-match-data + (funcall outline-title-fn)) + "")) + (goto-char (match-beginning 0)) + (setq marker (point-marker)) + (setq level (funcall outline-level-fn)) + (cond ((eq display-style 'path) + ;; Update stack. The empty entry guards against incorrect + ;; headline hierarchies, e.g. a level 3 headline + ;; immediately following a level 1 entry. + (while (<= level stack-level) + (pop stack) + (cl-decf stack-level)) + (while (> level stack-level) + (push "" stack) + (cl-incf stack-level)) + (setf (car stack) + (counsel-outline--add-face + name level face-style custom-faces)) + (setq name (mapconcat #'identity + (reverse stack) + path-separator))) + (t + (when (eq display-style 'headline) + (setq name (concat (make-string level ?*) " " name))) + (setq name (counsel-outline--add-face + name level face-style custom-faces)))) + (push (cons name marker) cands)) + (unless (or (string= name "") + (< orig-point marker)) + (cl-incf counsel-outline--preselect)))) + (nreverse cands))) + +(defun counsel-outline--add-face (name level &optional face-style custom-faces) + "Set the `face' property on headline NAME according to LEVEL. +FACE-STYLE and CUSTOM-FACES override `counsel-outline-face-style' +and `counsel-outline-custom-faces', respectively, which determine +the face to apply." + (let ((face (cl-case (or face-style counsel-outline-face-style) + (verbatim) + (custom (nth (1- level) + (or custom-faces counsel-outline-custom-faces))) + (org (format "counsel-outline-%d" level)) + (t 'counsel-outline-default)))) + (when face + (put-text-property 0 (length name) 'face face name))) + name) + +(defun counsel-outline-action (x) + "Go to outline X." + (goto-char (cdr x))) + +;;;###autoload +(defun counsel-outline () + "Jump to an outline heading with completion." + (interactive) + (let ((settings (cdr (assq major-mode counsel-outline-settings)))) + (ivy-read "Outline: " (counsel-outline-candidates settings) + :action (or (plist-get settings :action) + #'counsel-outline-action) + :history (or (plist-get settings :history) + 'counsel-outline-history) + :preselect (max (1- counsel-outline--preselect) 0) + :caller (or (plist-get settings :caller) + 'counsel-outline)))) + +;;** `counsel-ibuffer' +(defvar counsel-ibuffer--buffer-name nil + "Name of the buffer to use for `counsel-ibuffer'.") + +;;;###autoload +(defun counsel-ibuffer (&optional name) + "Use ibuffer to switch to another buffer. +NAME specifies the name of the buffer (defaults to \"*Ibuffer*\")." + (interactive) + (setq counsel-ibuffer--buffer-name (or name "*Ibuffer*")) + (ivy-read "Switch to buffer: " (counsel-ibuffer--get-buffers) + :history 'counsel-ibuffer-history + :action #'counsel-ibuffer-visit-buffer + :caller 'counsel-ibuffer)) + +(declare-function ibuffer-update "ibuffer") +(declare-function ibuffer-current-buffer "ibuffer") +(declare-function ibuffer-forward-line "ibuffer") +(defvar ibuffer-movement-cycle) + +(defun counsel-ibuffer--get-buffers () + "Return list of buffer-related lines in Ibuffer as strings." + (let ((oldbuf (get-buffer counsel-ibuffer--buffer-name))) + (unless oldbuf + ;; Avoid messing with the user's precious window/frame configuration. + (save-window-excursion + (let ((display-buffer-overriding-action + '(display-buffer-same-window (inhibit-same-window . nil)))) + (ibuffer nil counsel-ibuffer--buffer-name nil t)))) + (with-current-buffer counsel-ibuffer--buffer-name + (when oldbuf + ;; Forcibly update possibly stale existing buffer. + (ibuffer-update nil t)) + (goto-char (point-min)) + (let ((ibuffer-movement-cycle nil) + entries) + (while (not (eobp)) + (ibuffer-forward-line 1 t) + (let ((buf (ibuffer-current-buffer))) + ;; We are only interested in buffers we can actually visit. + ;; This filters out headings and other unusable entries. + (when (buffer-live-p buf) + (push (cons (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + buf) + entries)))) + (nreverse entries))))) + +(defun counsel-ibuffer-visit-buffer (x) + "Switch to buffer of candidate X." + (switch-to-buffer (cdr x))) + +(defun counsel-ibuffer-visit-buffer-other-window (x) + "Switch to buffer of candidate X in another window." + (switch-to-buffer-other-window (cdr x))) + +(defun counsel-ibuffer-visit-ibuffer (_) + "Switch to Ibuffer buffer." + (switch-to-buffer counsel-ibuffer--buffer-name)) + +(ivy-set-actions + 'counsel-ibuffer + '(("j" counsel-ibuffer-visit-buffer-other-window "other window") + ("v" counsel-ibuffer-visit-ibuffer "switch to Ibuffer"))) + +;;** `counsel-switch-to-shell-buffer' +(defun counsel--buffers-with-mode (mode) + "Return names of buffers with MODE as their `major-mode'." + (let (bufs) + (dolist (buf (buffer-list)) + (when (eq (buffer-local-value 'major-mode buf) mode) + (push (buffer-name buf) bufs))) + (nreverse bufs))) + +(declare-function shell-mode "shell") + +;;;###autoload +(defun counsel-switch-to-shell-buffer () + "Switch to a shell buffer, or create one." + (interactive) + (ivy-read "Shell buffer: " (counsel--buffers-with-mode #'shell-mode) + :action #'counsel--switch-to-shell + :caller 'counsel-switch-to-shell-buffer)) + +(defun counsel--switch-to-shell (name) + "Display shell buffer with NAME and select its window. +Reuse any existing window already displaying the named buffer. +If there is no such buffer, start a new `shell' with NAME." + (if (get-buffer name) + (pop-to-buffer name '((display-buffer-reuse-window + display-buffer-same-window) + (inhibit-same-window . nil) + (reusable-frames . visible))) + (shell name))) + +;;** `counsel-unicode-char' +(defvar counsel-unicode-char-history nil + "History for `counsel-unicode-char'.") + +(defun counsel--unicode-names () + "Return formatted and sorted list of `ucs-names'. +The result of `ucs-names' is mostly, but not completely, sorted, +so this function ensures lexicographic order." + (let* (cands + (table (ucs-names)) ; Either hash map or alist + (fmt (lambda (name code) ; Common format function + (let ((cand (format "%06X %-58s %c" code name code))) + (put-text-property 0 1 'code code cand) + (push cand cands))))) + (if (not (hash-table-p table)) + ;; Support `ucs-names' returning an alist in Emacs < 26. + ;; The result of `ucs-names' comes pre-reversed so no need to repeat. + (dolist (entry table) + (funcall fmt (car entry) (cdr entry))) + (maphash fmt table) + ;; Reverse to speed up sorting + (setq cands (nreverse cands))) + (sort cands #'string-lessp))) + +(defvar counsel--unicode-table + (lazy-completion-table counsel--unicode-table counsel--unicode-names) + "Lazy completion table for `counsel-unicode-char'. +Candidates comprise `counsel--unicode-names', which see.") + +;;;###autoload +(defun counsel-unicode-char (&optional count) + "Insert COUNT copies of a Unicode character at point. +COUNT defaults to 1." + (interactive "p") + (setq ivy-completion-beg (point)) + (setq ivy-completion-end (point)) + (ivy-read "Unicode name: " counsel--unicode-table + :history 'counsel-unicode-char-history + :action (lambda (name) + (with-ivy-window + (delete-region ivy-completion-beg ivy-completion-end) + (setq ivy-completion-beg (point)) + (insert-char (get-text-property 0 'code name) count) + (setq ivy-completion-end (point)))) + :caller 'counsel-unicode-char)) + +(ivy-configure 'counsel-unicode-char + :sort-fn #'ivy-string<) + +(defun counsel-unicode-copy (name) + "Ivy action to copy the unicode from NAME to the kill ring." + (kill-new (char-to-string (get-text-property 0 'code name)))) + +(ivy-set-actions + 'counsel-unicode-char + '(("w" counsel-unicode-copy "copy"))) + +;;** `counsel-colors' +(defun counsel-colors-action-insert-hex (color) + "Insert the hexadecimal RGB value of COLOR." + (insert (get-text-property 0 'hex color))) + +(defun counsel-colors-action-kill-hex (color) + "Kill the hexadecimal RGB value of COLOR." + (kill-new (get-text-property 0 'hex color))) + +;;** `counsel-colors-emacs' +(defvar counsel-colors-emacs-history () + "History for `counsel-colors-emacs'.") + +(defun counsel-colors--name-to-hex (name) + "Return hexadecimal RGB value of color with NAME. + +Return nil if NAME does not designate a valid color." + (let ((rgb (color-name-to-rgb name))) + (when rgb + (apply #'color-rgb-to-hex rgb)))) + +(defvar shr-color-visible-luminance-min) +(declare-function shr-color-visible "shr-color") +(defvar counsel--colors-format "%-20s %s %s%s") + +(defun counsel--colors-emacs-format-function (colors) + "Format function for `counsel-colors-emacs'." + (require 'shr-color) + (let* ((blank (make-string 10 ?\s)) + (formatter + (lambda (color) + (let ((fg (list :foreground color))) + (format counsel--colors-format color + (propertize (get-text-property 0 'hex color) 'face fg) + (propertize blank 'face (list :background color)) + (propertize (mapconcat (lambda (dup) + (concat " " dup)) + (get-text-property 0 'dups color) + ",") + 'face fg)))))) + (ivy--format-function-generic + (lambda (color) + (let* ((hex (get-text-property 0 'hex color)) + (shr-color-visible-luminance-min 100) + (fg (cadr (shr-color-visible hex "black" t)))) + (propertize (funcall formatter color) + 'face (list :foreground fg :background hex)))) + formatter colors "\n"))) + +(defun counsel--colors-web-format-function (colors) + "Format function for `counsel-colors-web'." + (require 'shr-color) + (let* ((blank (make-string 10 ?\s)) + (formatter (lambda (color) + (let ((hex (get-text-property 0 'hex color))) + (format counsel--colors-format color + (propertize hex 'face (list :foreground hex)) + (propertize blank 'face (list :background hex))))))) + (ivy--format-function-generic + (lambda (color) + (let* ((hex (get-text-property 0 'hex color)) + (shr-color-visible-luminance-min 100) + (fg (cadr (shr-color-visible hex "black" t)))) + (propertize (funcall formatter color) + 'face (list :foreground fg :background hex)))) + formatter colors "\n"))) + +;;;###autoload +(defun counsel-colors-emacs () + "Show a list of all supported colors for a particular frame. + +You can insert or kill the name or hexadecimal RGB value of the +selected color." + (interactive) + (let* ((colors + (delete nil + (mapcar (lambda (cell) + (let* ((name (car cell)) + (dups (cdr cell)) + (hex (counsel-colors--name-to-hex name))) + (when hex + (propertize name 'hex hex 'dups dups)))) + (list-colors-duplicates)))) + (counsel--colors-format + (format "%%-%ds %%s %%s%%s" + (apply #'max 0 (mapcar #'string-width colors))))) + (ivy-read "Emacs color: " colors + :require-match t + :history 'counsel-colors-emacs-history + :action #'insert + :caller 'counsel-colors-emacs))) +(ivy-configure 'counsel-colors-emacs + :format-fn #'counsel--colors-emacs-format-function) + +(ivy-set-actions + 'counsel-colors-emacs + '(("h" counsel-colors-action-insert-hex "insert hexadecimal value") + ("H" counsel-colors-action-kill-hex "kill hexadecimal value"))) + +;;** `counsel-colors-web' +(defvar shr-color-html-colors-alist) + +(defun counsel-colors--web-alist () + "Return list of CSS colors for `counsel-colors-web'." + (require 'shr-color) + (let* ((alist (copy-alist shr-color-html-colors-alist)) + (mp (assoc "MediumPurple" alist)) + (pvr (assoc "PaleVioletRed" alist)) + (rp (assoc "RebeccaPurple" alist))) + ;; Backport GNU Emacs bug#30377 + (when mp (setcdr mp "#9370db")) + (when pvr (setcdr pvr "#db7093")) + (unless rp (push (cons "rebeccapurple" "#663399") alist)) + (sort (mapcar (lambda (cell) + (propertize (downcase (car cell)) + 'hex (downcase (cdr cell)))) + alist) + #'string-lessp))) + +(defvar counsel-colors-web-history () + "History for `counsel-colors-web'.") + +;;;###autoload +(defun counsel-colors-web () + "Show a list of all W3C web colors for use in CSS. + +You can insert or kill the name or hexadecimal RGB value of the +selected color." + (interactive) + (let* ((colors (counsel-colors--web-alist)) + (counsel--colors-format + (format "%%-%ds %%s %%s" + (apply #'max 0 (mapcar #'string-width colors))))) + (ivy-read "Web color: " colors + :require-match t + :history 'counsel-colors-web-history + :action #'insert + :caller 'counsel-colors-web))) + +(ivy-configure 'counsel-colors-web + :sort-fn #'ivy-string< + :format-fn #'counsel--colors-web-format-function) + +(ivy-set-actions + 'counsel-colors-web + '(("h" counsel-colors-action-insert-hex "insert hexadecimal value") + ("H" counsel-colors-action-kill-hex "kill hexadecimal value"))) + +;;** `counsel-fonts' +(defvar counsel-fonts-history () + "History for `counsel-fonts'.") + +;;;###autoload +(defun counsel-fonts () + "Show a list of all supported font families for a particular frame. + +You can insert or kill the name of the selected font." + (interactive) + (let ((current-font + (symbol-name (font-get (face-attribute 'default :font) :family)))) + (ivy-read "Font: " (delete-dups (font-family-list)) + :preselect current-font + :require-match t + :history 'counsel-fonts-history + :action #'insert + :caller 'counsel-fonts))) + +(ivy-configure 'counsel-fonts + :display-transformer-fn #'counsel--font-with-sample) + +(defun counsel--font-with-sample (font-name) + "Format function for `counsel-fonts'." + (format "%-75s%s" font-name + (propertize "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + 'face (list :family font-name)))) + +;;** `counsel-kmacro' +(defvar counsel-kmacro-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-k") #'counsel-kmacro-kill) + map)) + +(defun counsel-kmacro-kill () + "Kill the line, or delete the keyboard macro." + (interactive) + (if (not (eolp)) + (ivy-kill-line) + (counsel-kmacro-action-delete-kmacro + (assoc + (ivy-state-current ivy-last) + (ivy-state-collection ivy-last))) + (ivy--kill-current-candidate))) + +;;;###autoload +(defun counsel-kmacro () + "Interactively choose and run a keyboard macro. + +With prefix argument, run macro that many times. + +Macros are run using the current value of `kmacro-counter-value' +and their respective counter format. Displayed next to each macro is +the counter's format and initial value. + +One can use actions to copy the counter format or initial counter +value of a macro, using them for a new macro." + (interactive) + (if (or last-kbd-macro kmacro-ring) + (ivy-read + (concat "Execute macro (counter at " + (number-to-string (or kmacro-initial-counter-value kmacro-counter)) + "): ") + (counsel--kmacro-candidates) + :keymap counsel-kmacro-map + :require-match t + :action #'counsel-kmacro-action-run + :caller 'counsel-kmacro) + (user-error "No keyboard macros defined"))) + +(ivy-configure 'counsel-kmacro + :format-fn #'counsel--kmacro-format-function) + +(defcustom counsel-kmacro-separator "\n------------------------\n" + "Separator displayed between keyboard macros in `counsel-kmacro'." + :type 'string) + +(defun counsel--kmacro-format-function (formatted-kmacro) + "Transform FORMATTED-KMACRO into a string for `counsel-kmacro'." + (ivy--format-function-generic + (lambda (str) (ivy--add-face str 'ivy-current-match)) + (lambda (str) str) + formatted-kmacro + (propertize counsel-kmacro-separator 'face 'ivy-separator))) + +(defun counsel--kmacro-candidates () + "Create the list of keyboard macros used by `counsel-kmacro'. +This is a combination of `kmacro-ring' and, together in a list, `last-kbd-macro', +`kmacro-counter-format-start', and `kmacro-counter-value-start'." + (mapcar + (lambda (kmacro) + (cons + (concat "(" (nth 2 kmacro) "," (number-to-string (nth 1 kmacro)) "): " + (condition-case nil + (format-kbd-macro (if (listp kmacro) (car kmacro) kmacro) 1) + ;; Recover from error from `edmacro-fix-menu-commands'. + (error "Warning: Cannot display macros containing mouse clicks"))) + kmacro)) + (cons + (if (listp last-kbd-macro) + last-kbd-macro + (list + last-kbd-macro + kmacro-counter-value-start + kmacro-counter-format-start)) + kmacro-ring))) + +(defun counsel-kmacro-action-run (x) + "Run keyboard macro." + (let* ((actual-kmacro (cdr x)) + (kmacro-keys (nth 0 actual-kmacro)) + (kmacro-counter-format-start (nth 2 actual-kmacro))) + ;; With prefix argument, call the macro that many times. + (kmacro-call-macro (or current-prefix-arg 1) t nil kmacro-keys))) + +(defun counsel-kmacro-action-delete-kmacro (x) + "Delete a keyboard macro from within `counsel-kmacro'. + +Either delete a macro from `kmacro-ring', or set `last-kbd-macro' +to the popped head of the ring." + (let ((actual-macro (cdr x))) + (if (eq (nth 0 actual-macro) last-kbd-macro) + (setq last-kbd-macro + (if (eq kmacro-ring nil) + nil + (let ((prev-macro (pop kmacro-ring))) + (if (listp prev-macro) + (nth 0 prev-macro) + prev-macro)))) + (setq kmacro-ring (delq actual-macro kmacro-ring))))) + +(defun counsel-kmacro-action-copy-initial-counter-value (x) + "Pass an existing keyboard macro's original value to `kmacro-set-counter'. +This value will be used by the next executed macro, or as an +initial value by the next macro defined. + +Note that calling an existing macro that itself uses a counter +effectively resets the initial counter value for the next defined macro +to 0." + ;; NOTE: + ;; Calling `kmacro-start-macro' without an argument sets `kmacro-counter' + ;; to 0 if `kmacro-initial-counter'is nil, and sets `kmacro-initial-counter' + ;; to nil regardless. + ;; Using `kmacro-insert-counter' sets `kmacro-initial-counter' to nil. + (let* ((actual-kmacro (cdr x)) + (number (nth 1 actual-kmacro))) + (kmacro-set-counter number))) + +(defun counsel-kmacro-action-copy-counter-format-for-new-macro (x) + "Set `kmacro-default-counter-format' to an existing keyboard macro's counter format. +This will apply to the next macro a user defines." + (let* ((actual-kmacro (cdr x)) + (format (nth 2 actual-kmacro))) + (kmacro-set-format format))) + +(defun counsel-kmacro-action-cycle-ring-to-macro (x) + "Cycle `kmacro-ring' until `last-kbd-macro' is the selected macro. +This is convenient when using \\[kmacro-end-or-call-macro] to call macros. +Note that cycling the ring changes the starting value of the current macro +to changes the current macro counter." + (let ((actual-kmacro (cdr x))) + (unless (equal last-kbd-macro + (if (listp last-kbd-macro) + last-kbd-macro + (car actual-kmacro))) + (while (not (equal actual-kmacro + (car kmacro-ring))) + (kmacro-cycle-ring-previous)) + ;; Once selected macro is at the head of the ring, + ;; cycle one last time. + (kmacro-cycle-ring-previous)))) + +(defun counsel-kmacro-action-set-saved-starting-counter (x) + "Set the starting counter value of the chosen macro. + +By default, sets to current value of the counter. It has no +effect when selecting the current macro. + +Normally, when cycling keyboard macro ring with \\[kmacro-cycle-ring-previous] +or \\[kmacro-cycle-ring-next], the current value of the macro counter is +included with the current macro definition. Then, when cycling +back, that counter value is restored. This function is meant to +achieve something similar when cycling macros in the context of +using `counsel-kmacro', which does not use different counter +values when running different macros." + (let ((actual-kmacro (cdr x)) + (default-kmacro-counter-string (number-to-string kmacro-counter))) + (setq kmacro-ring (mapcar (lambda (this-macro-in-ring) + (if (equal this-macro-in-ring actual-kmacro) + (list (car this-macro-in-ring) + (read-from-minibuffer (concat "Set initial counter for macro (default: " + default-kmacro-counter-string + "): ") + nil nil t nil + default-kmacro-counter-string) + (cl-caddr this-macro-in-ring)) + this-macro-in-ring)) + kmacro-ring)))) + +(defun counsel-kmacro-action-execute-after-prompt (x) + "Execute an existing keyboard macro, prompting for a starting counter value, a +counter format, and the number of times to execute the macro. + +If called with a prefix, will suggest that value for both the +counter value and iteration amount." + (let* ((default-string (if current-prefix-arg + (number-to-string current-prefix-arg) + nil)) + (actual-kmacro (cdr x)) + (kmacro-keys (nth 0 actual-kmacro)) + (kmacro-starting-counter (number-to-string (nth 1 actual-kmacro))) + (kmacro-starting-format (nth 2 actual-kmacro)) + (number-of-iterations + (read-from-minibuffer + (concat "Enter number of iterations for macro (default: " + (or default-string (number-to-string 2)) + "): ") + nil nil t nil + (or default-string (number-to-string 2)))) + (kmacro-initial-counter-value + (read-from-minibuffer + (concat "Enter a starting counter for macro (default: " + (or default-string kmacro-starting-counter) + "): ") + nil nil t nil + (or default-string kmacro-starting-counter))) + (kmacro-counter-format-start + (symbol-name (read-from-minibuffer + (concat "Enter format for macro counter (default: " + kmacro-starting-format + "): ") + nil nil t nil + kmacro-starting-format)))) + (kmacro-call-macro number-of-iterations t nil kmacro-keys))) + +(ivy-set-actions + 'counsel-kmacro + '(("c" counsel-kmacro-action-cycle-ring-to-macro "cycle to") + ("d" counsel-kmacro-action-delete-kmacro "delete") + ("e" counsel-kmacro-action-execute-after-prompt "execute after prompt") + ("f" counsel-kmacro-action-copy-counter-format-for-new-macro "copy counter format for new macro") + ("s" counsel-kmacro-action-set-saved-starting-counter "set this counter value") + ("v" counsel-kmacro-action-copy-initial-counter-value "copy initial counter value"))) + +;;** `counsel-geiser-doc-look-up-manual' +(declare-function geiser-doc-manual-for-symbol "ext:geiser-doc") +(defvar geiser-completion-symbol-list-func) + +(defvar counsel-geiser-doc-look-up-manual-history () + "History for `counsel-geiser-doc-look-up-manual'.") + +;;;###autoload +(defun counsel-geiser-doc-look-up-manual () + "Search Scheme documentation." + (interactive) + (ivy-read "Symbol: " geiser-completion-symbol-list-func + :require-match t + :history 'counsel-geiser-doc-look-up-manual-history + :action (lambda (cand) + (geiser-doc-manual-for-symbol (intern cand))) + :caller 'counsel-geiser-doc-look-up-manual)) + +;;* Misc. OS +;;** `counsel-rhythmbox' +(declare-function dbus-call-method "dbus") +(declare-function dbus-get-property "dbus") + +(defun counsel--run (&rest program-and-args) + (let ((name (mapconcat #'identity program-and-args " "))) + (apply #'start-process name nil program-and-args) + name)) + +(defun counsel--sl (cmd) + "Shell command to list." + (split-string (shell-command-to-string cmd) "\n" t)) + +(defun counsel-rhythmbox-play-song (song) + "Let Rhythmbox play SONG." + (let ((first (string= (shell-command-to-string "pidof rhythmbox") "")) + (service "org.gnome.Rhythmbox3") + (path "/org/mpris/MediaPlayer2") + (interface "org.mpris.MediaPlayer2.Player")) + (when first + (counsel--run "nohup" "rhythmbox") + (sit-for 1.5)) + (dbus-call-method :session service path interface + "OpenUri" (cdr song)) + (let ((id (and first + (cdr (counsel--wmctrl-parse + (shell-command-to-string + "wmctrl -l -p | grep $(pidof rhythmbox)")))))) + (when id + (sit-for 0.2) + (counsel--run "wmctrl" "-ic" id))))) + +(defun counsel-rhythmbox-enqueue-song (song) + "Let Rhythmbox enqueue SONG." + (let ((service "org.gnome.Rhythmbox3") + (path "/org/gnome/Rhythmbox3/PlayQueue") + (interface "org.gnome.Rhythmbox3.PlayQueue")) + (dbus-call-method :session service path interface + "AddToQueue" (cdr song)))) + +(defun counsel-rhythmbox-playpause-current-song () + "Play/pause the current song." + (interactive) + (let ((service "org.gnome.Rhythmbox3") + (path "/org/mpris/MediaPlayer2") + (interface "org.mpris.MediaPlayer2.Player")) + (dbus-call-method :session service path interface + "PlayPause"))) + +(defun counsel-rhythmbox-toggle-shuffle (_song) + "Toggle Rhythmbox shuffle setting." + (let* ((old-order (counsel--command "dconf" "read" "/org/gnome/rhythmbox/player/play-order")) + (new-order (if (string= old-order "'shuffle'") + "'linear'" + "'shuffle'"))) + (counsel--command + "dconf" + "write" + "/org/gnome/rhythmbox/player/play-order" + new-order) + (message (if (string= new-order "'shuffle'") + "shuffle on" + "shuffle off")))) + +(defvar counsel-rhythmbox-history nil + "History for `counsel-rhythmbox'.") + +(defvar counsel-rhythmbox-songs nil) + +(defun counsel-rhythmbox-current-song () + "Return the currently playing song title." + (ignore-errors + (let* ((entry (dbus-get-property + :session + "org.mpris.MediaPlayer2.rhythmbox" + "/org/mpris/MediaPlayer2" + "org.mpris.MediaPlayer2.Player" + "Metadata")) + (artist (caar (cadr (assoc "xesam:artist" entry)))) + (album (cl-caadr (assoc "xesam:album" entry))) + (title (cl-caadr (assoc "xesam:title" entry)))) + (format "%s - %s - %s" artist album title)))) + +;;;###autoload +(defun counsel-rhythmbox (&optional arg) + "Choose a song from the Rhythmbox library to play or enqueue." + (interactive "P") + (require 'dbus) + (when (or arg (null counsel-rhythmbox-songs)) + (let* ((service "org.gnome.Rhythmbox3") + (path "/org/gnome/UPnP/MediaServer2/Library/all") + (interface "org.gnome.UPnP.MediaContainer2") + (nb-songs (dbus-get-property + :session service path interface "ChildCount"))) + (if (not nb-songs) + (error "Couldn't connect to Rhythmbox") + (setq counsel-rhythmbox-songs + (mapcar (lambda (x) + (cons + (format + "%s - %s - %s" + (cl-caadr (assoc "Artist" x)) + (cl-caadr (assoc "Album" x)) + (cl-caadr (assoc "DisplayName" x))) + (cl-caaadr (assoc "URLs" x)))) + (dbus-call-method + :session service path interface "ListChildren" + 0 nb-songs '("*"))))))) + (ivy-read "Rhythmbox: " counsel-rhythmbox-songs + :require-match t + :history 'counsel-rhythmbox-history + :preselect (counsel-rhythmbox-current-song) + :action + '(1 + ("p" counsel-rhythmbox-play-song "Play song") + ("e" counsel-rhythmbox-enqueue-song "Enqueue song") + ("s" counsel-rhythmbox-toggle-shuffle "Shuffle on/off")) + :caller 'counsel-rhythmbox)) + +;;** `counsel-linux-app' + +;; Added in Emacs 26.1. +(require 'xdg nil t) + +(defalias 'counsel--xdg-data-home + (if (fboundp 'xdg-data-home) + #'xdg-data-home + (lambda () + (let ((directory (getenv "XDG_DATA_HOME"))) + (if (or (null directory) (string= directory "")) + "~/.local/share" + directory)))) + "Compatibility shim for `xdg-data-home'.") + +(defalias 'counsel--xdg-data-dirs + (if (fboundp 'xdg-data-dirs) + #'xdg-data-dirs + (lambda () + (let ((path (getenv "XDG_DATA_DIRS"))) + (if (or (null path) (string= path "")) + '("/usr/local/share" "/usr/share") + (parse-colon-path path))))) + "Compatibility shim for `xdg-data-dirs'.") + +(defcustom counsel-linux-apps-directories + (mapcar (lambda (dir) (expand-file-name "applications" dir)) + (cons (counsel--xdg-data-home) + (counsel--xdg-data-dirs))) + "Directories in which to search for applications (.desktop files)." + :type '(repeat directory)) + +(defcustom counsel-linux-app-format-function #'counsel-linux-app-format-function-default + "Function to format Linux application names the `counsel-linux-app' menu. +The format function will be passed the application's name, comment, and command +as arguments." + :type '(choice + (const :tag "Command : Name - Comment" counsel-linux-app-format-function-default) + (const :tag "Name - Comment (Command)" counsel-linux-app-format-function-name-first) + (const :tag "Name - Comment" counsel-linux-app-format-function-name-only) + (const :tag "Command" counsel-linux-app-format-function-command-only) + (function :tag "Custom"))) + +(defface counsel-application-name + '((t :inherit font-lock-builtin-face)) + "Face for displaying executable names." + :group 'ivy-faces) + +(defface counsel-outline-1 + '((t :inherit org-level-1)) + "Face for displaying level 1 headings." + :group 'ivy-faces) + +(defface counsel-outline-2 + '((t :inherit org-level-2)) + "Face for displaying level 2 headings." + :group 'ivy-faces) + +(defface counsel-outline-3 + '((t :inherit org-level-3)) + "Face for displaying level 3 headings." + :group 'ivy-faces) + +(defface counsel-outline-4 + '((t :inherit org-level-4)) + "Face for displaying level 4 headings." + :group 'ivy-faces) + +(defface counsel-outline-5 + '((t :inherit org-level-5)) + "Face for displaying level 5 headings." + :group 'ivy-faces) + +(defface counsel-outline-6 + '((t :inherit org-level-6)) + "Face for displaying level 6 headings." + :group 'ivy-faces) + +(defface counsel-outline-7 + '((t :inherit org-level-7)) + "Face for displaying level 7 headings." + :group 'ivy-faces) + +(defface counsel-outline-8 + '((t :inherit org-level-8)) + "Face for displaying level 8 headings." + :group 'ivy-faces) + +(defface counsel-outline-default + '((t :inherit minibuffer-prompt)) + "Face for displaying headings." + :group 'ivy-faces) + +(defvar counsel-linux-apps-faulty nil + "List of faulty desktop files.") + +(defvar counsel--linux-apps-cache nil + "Cache of desktop files data.") + +(defvar counsel--linux-apps-cached-files nil + "List of cached desktop files.") + +(defvar counsel--linux-apps-cache-timestamp nil + "Time when we last updated the cached application list.") + +(defvar counsel--linux-apps-cache-format-function nil + "The function used to format the cached Linux application menu.") + +(defun counsel-linux-app-format-function-default (name comment exec) + "Default Linux application name formatter. +NAME is the name of the application, COMMENT its comment and EXEC +the command to launch it." + (format "% -45s: %s%s" + (propertize + (ivy--truncate-string exec 45) + 'face 'counsel-application-name) + name + (if comment + (concat " - " comment) + ""))) + +(defun counsel-linux-app-format-function-name-first (name comment exec) + "Format Linux application names with the NAME (and COMMENT) first. +EXEC is the command to launch the application." + (format "%s%s (%s)" + name + (if comment + (concat " - " comment) + "") + (propertize exec 'face 'counsel-application-name))) + +(defun counsel-linux-app-format-function-name-only (name comment _exec) + "Format Linux application names with the NAME (and COMMENT) only." + (format "%s%s" + name + (if comment + (concat " - " comment) + ""))) + +(defun counsel-linux-app-format-function-command-only (_name _comment exec) + "Display only the command EXEC when formatting Linux application names." + exec) + +(defun counsel-linux-apps-list-desktop-files () + "Return an alist of all Linux applications. +Each list entry is a pair of (desktop-name . desktop-file). +This function always returns its elements in a stable order." + (let ((hash (make-hash-table :test #'equal)) + result) + (dolist (dir counsel-linux-apps-directories) + (when (file-exists-p dir) + (let ((dir (file-name-as-directory dir))) + ;; Function `directory-files-recursively' added in Emacs 25.1. + (dolist (file (directory-files-recursively dir ".*\\.desktop$")) + (let ((id (subst-char-in-string ?/ ?- (file-relative-name file dir)))) + (when (and (not (gethash id hash)) (file-readable-p file)) + (push (cons id file) result) + (puthash id file hash))))))) + result)) + +(defun counsel-linux-app--parse-file (file) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (let ((start (re-search-forward "^\\[Desktop Entry\\] *$" nil t)) + (end (re-search-forward "^\\[" nil t)) + (visible t) + name comment exec) + (catch 'break + (unless start + (push file counsel-linux-apps-faulty) + (message "Warning: File %s has no [Desktop Entry] group" file) + (throw 'break nil)) + + (goto-char start) + (when (re-search-forward "^\\(Hidden\\|NoDisplay\\) *= *\\(1\\|true\\) *$" end t) + (setq visible nil)) + (setq name (match-string 1)) + + (goto-char start) + (unless (re-search-forward "^Type *= *Application *$" end t) + (throw 'break nil)) + (setq name (match-string 1)) + + (goto-char start) + (unless (re-search-forward "^Name *= *\\(.+\\)$" end t) + (push file counsel-linux-apps-faulty) + (message "Warning: File %s has no Name" file) + (throw 'break nil)) + (setq name (match-string 1)) + + (goto-char start) + (when (re-search-forward "^Comment *= *\\(.+\\)$" end t) + (setq comment (match-string 1))) + + (goto-char start) + (unless (re-search-forward "^Exec *= *\\(.+\\)$" end t) + ;; Don't warn because this can technically be a valid desktop file. + (throw 'break nil)) + (setq exec (match-string 1)) + + (goto-char start) + (when (re-search-forward "^TryExec *= *\\(.+\\)$" end t) + (let ((try-exec (match-string 1))) + (unless (locate-file try-exec exec-path nil #'file-executable-p) + (throw 'break nil)))) + (propertize + (funcall counsel-linux-app-format-function name comment exec) + 'visible visible))))) + +(defun counsel-linux-apps-parse (desktop-entries-alist) + "Parse the given alist of Linux desktop entries. +Each entry in DESKTOP-ENTRIES-ALIST is a pair of ((id . file-name)). +Any desktop entries that fail to parse are recorded in +`counsel-linux-apps-faulty'." + (let (result) + (setq counsel-linux-apps-faulty nil) + (dolist (entry desktop-entries-alist result) + (let* ((id (car entry)) + (file (cdr entry)) + (r (counsel-linux-app--parse-file file))) + (when r + (push (cons r id) result)))))) + +(defun counsel-linux-apps-list () + "Return list of all Linux desktop applications." + (let* ((new-desktop-alist (counsel-linux-apps-list-desktop-files)) + (new-files (mapcar 'cdr new-desktop-alist))) + (unless (and + (eq counsel-linux-app-format-function + counsel--linux-apps-cache-format-function) + (equal new-files counsel--linux-apps-cached-files) + (null (cl-find-if + (lambda (file) + (time-less-p + counsel--linux-apps-cache-timestamp + (nth 5 (file-attributes file)))) + new-files))) + (setq counsel--linux-apps-cache (counsel-linux-apps-parse new-desktop-alist)) + (setq counsel--linux-apps-cache-format-function counsel-linux-app-format-function) + (setq counsel--linux-apps-cache-timestamp (current-time)) + (setq counsel--linux-apps-cached-files new-files))) + counsel--linux-apps-cache) + + +(defun counsel-linux-app-action-default (desktop-shortcut) + "Launch DESKTOP-SHORTCUT." + (call-process "gtk-launch" nil 0 nil (cdr desktop-shortcut))) + +(defun counsel-linux-app-action-file (desktop-shortcut) + "Launch DESKTOP-SHORTCUT with a selected file." + (call-process "gtk-launch" nil 0 nil + (cdr desktop-shortcut) + (read-file-name "File: "))) + +(defun counsel-linux-app-action-open-desktop (desktop-shortcut) + "Open DESKTOP-SHORTCUT." + (let* ((app (cdr desktop-shortcut)) + (file (cdr (assoc app (counsel-linux-apps-list-desktop-files))))) + (if file + (find-file file) + (error "Could not find location of file %s" app)))) + +(ivy-set-actions + 'counsel-linux-app + '(("f" counsel-linux-app-action-file "run on a file") + ("d" counsel-linux-app-action-open-desktop "open desktop file"))) + +;;;###autoload +(defun counsel-linux-app (&optional arg) + "Launch a Linux desktop application, similar to Alt-. +When ARG is non-nil, ignore NoDisplay property in *.desktop files." + (interactive "P") + (ivy-read "Run a command: " (counsel-linux-apps-list) + :predicate (unless arg (lambda (x) (get-text-property 0 'visible (car x)))) + :action #'counsel-linux-app-action-default + :caller 'counsel-linux-app)) + +;;** `counsel-wmctrl' +(defun counsel-wmctrl-action (x) + "Select the desktop window that corresponds to X." + (counsel--run "wmctrl" "-i" "-a" (cdr x))) + +(defvar counsel-wmctrl-ignore '("XdndCollectionWindowImp" + "unity-launcher" "unity-panel" "unity-dash" + "Hud" "Desktop") + "List of window titles to ignore for `counsel-wmctrl'.") + +(defun counsel--wmctrl-parse (s) + (when (string-match "\\`\\([0-9a-fx]+\\) +\\([-0-9]+\\) +\\(?:[0-9]+\\) +\\([^ ]+\\) \\(.+\\)$" s) + (let ((title (match-string 4 s)) + (id (match-string 1 s))) + (unless (member title counsel-wmctrl-ignore) + (cons title id))))) + +;;;###autoload +(defun counsel-wmctrl () + "Select a desktop window using wmctrl." + (interactive) + (let* ((cands1 (counsel--sl "wmctrl -l -p")) + (cands2 (delq nil (mapcar #'counsel--wmctrl-parse cands1)))) + (ivy-read "window: " cands2 + :action #'counsel-wmctrl-action + :caller 'counsel-wmctrl))) + +(defvar counsel--switch-buffer-temporary-buffers nil + "Internal.") + +(defvar counsel--switch-buffer-previous-buffers nil + "Internal.") + +(defun counsel--switch-buffer-unwind () + "Clear temporary file buffers and restore `buffer-list'. +The buffers are those opened during a session of `counsel-switch-buffer'." + (mapc #'kill-buffer counsel--switch-buffer-temporary-buffers) + (mapc #'bury-buffer (cl-remove-if-not + #'buffer-live-p + counsel--switch-buffer-previous-buffers)) + (setq counsel--switch-buffer-temporary-buffers nil + counsel--switch-buffer-previous-buffers nil)) + +(defcustom counsel-switch-buffer-preview-virtual-buffers t + "When non-nil, `counsel-switch-buffer' will preview virtual buffers." + :type 'boolean) + +(defun counsel--switch-buffer-update-fn () + (unless counsel--switch-buffer-previous-buffers + (setq counsel--switch-buffer-previous-buffers (buffer-list))) + (let* ((virtual (assoc (ivy-state-current ivy-last) ivy--virtual-buffers))) + (when (member (ivy-state-current ivy-last) ivy-marked-candidates) + (setf (ivy-state-current ivy-last) + (substring (ivy-state-current ivy-last) (length ivy-mark-prefix)))) + (cond + ((get-buffer (ivy-state-current ivy-last)) + (let ((ivy-marked-candidates nil)) + (ivy-call))) + ((and counsel-switch-buffer-preview-virtual-buffers virtual (file-exists-p (cdr virtual))) + (let ((buf (ignore-errors + ;; may not open due to `large-file-warning-threshold' etc. + (find-file-noselect (cdr virtual))))) + (if buf + (progn + (push buf counsel--switch-buffer-temporary-buffers) + (ivy-call)) + ;; clean up the minibuffer so that there's no delay before + ;; the Ivy candidates are displayed once again + (message "")))) + (t + (with-ivy-window + (switch-to-buffer (ivy-state-buffer ivy-last))))))) + +;;;###autoload +(defun counsel-switch-buffer () + "Switch to another buffer. +Display a preview of the selected ivy completion candidate buffer +in the current window." + (interactive) + (let ((ivy-update-fns-alist + '((ivy-switch-buffer . counsel--switch-buffer-update-fn))) + (ivy-unwind-fns-alist + '((ivy-switch-buffer . counsel--switch-buffer-unwind)))) + (ivy-switch-buffer))) + +;;;###autoload +(defun counsel-switch-buffer-other-window () + "Switch to another buffer in another window. +Display a preview of the selected ivy completion candidate buffer +in the current window." + (interactive) + (let ((ivy-update-fns-alist + '((ivy-switch-buffer-other-window . counsel--switch-buffer-update-fn))) + (ivy-unwind-fns-alist + '((ivy-switch-buffer-other-window . counsel--switch-buffer-unwind)))) + (ivy-switch-buffer-other-window))) + +(defun counsel-open-buffer-file-externally (buffer) + "Open the file associated with BUFFER with an external program." + (when (zerop (length buffer)) + (user-error "Can't open that")) + (let* ((virtual (assoc buffer ivy--virtual-buffers)) + (filename (if virtual + (cdr virtual) + (buffer-file-name (get-buffer buffer))))) + (unless filename + (user-error "Can't open `%s' externally" buffer)) + (counsel-locate-action-extern (expand-file-name filename)))) + +(ivy-add-actions + 'ivy-switch-buffer + '(("x" counsel-open-buffer-file-externally "open externally"))) + +(ivy-set-actions + 'counsel-switch-buffer + '(("x" counsel-open-buffer-file-externally "open externally") + ("j" ivy--switch-buffer-other-window-action "other window"))) + +;;** `counsel-compile' +(defvar counsel-compile-history nil + "History for `counsel-compile'. + +This is a list of strings with additional properties which allow +the history to be filtered depending on the context of the call. +The properties include: + +`srcdir' + the root directory of the source code +`blddir' + the root directory of the build (in or outside the `srcdir') +`bldenv' + the build environment as passed to `compilation-environment' +`recursive' + the completion should be run again in `blddir' of this result +`cmd' + if set, pass only the substring with this property to `compile' + +This variable is suitable for addition to +`savehist-additional-variables'.") + +(defvar counsel-compile-root-functions + '(counsel--projectile-root + counsel--project-current + counsel--configure-root + counsel--git-root + counsel--dir-locals-root) + "Special hook to find the project root for compile commands. +Each function on this hook is called in turn with no arguments +and should return either a directory, or nil if no root was +found.") + +(defun counsel--compile-root () + "Return root of current project or signal an error on failure. +The root is determined by `counsel-compile-root-functions'." + (or (run-hook-with-args-until-success 'counsel-compile-root-functions) + (error "Couldn't find project root"))) + +(defun counsel--projectile-root () + "Return root of current projectile project or nil on failure. +Use `projectile-project-root' to determine the root." + (and (fboundp 'projectile-project-root) + (projectile-project-root))) + +(defun counsel--project-current () + "Return root of current project or nil on failure. +Use `project-current' to determine the root." + (and (fboundp 'project-current) + (cdr (project-current)))) + +(defun counsel--configure-root () + "Return root of current project or nil on failure. +Use the presence of a \"configure\" file to determine the root." + (counsel--dominating-file "configure")) + +(defun counsel--git-root () + "Return root of current project or nil on failure. +Use the presence of a \".git\" file to determine the root." + (counsel--dominating-file ".git")) + +(defun counsel--dir-locals-root () + "Return root of current project or nil on failure. +Use the presence of a `dir-locals-file' to determine the root." + (counsel--dominating-file dir-locals-file)) + +(defvar counsel-compile-local-builds + '(counsel-compile-get-filtered-history + counsel-compile-get-build-directories + counsel-compile-get-make-invocation) + "Additional compile invocations to feed into `counsel-compile'. + +This can either be a list of compile invocation strings or +functions that will provide such a list. You should customize +this if you want to provide specific non-standard build types to +`counsel-compile'. The default helpers are set up to handle +common build environments.") + +(defcustom counsel-compile-make-args "-k" + "Additional arguments for make. +You may, for example, want to add \"-jN\" for the number of cores +N in your system." + :type 'string) + +(defcustom counsel-compile-env nil + "List of environment variables for compilation to inherit. +Each element should be a string of the form ENVVARNAME=VALUE. This +list is passed to `compilation-environment'." + :type '(repeat (string :tag "ENVVARNAME=VALUE"))) + +(defvar counsel-compile-env-history nil + "History for `counsel-compile-env'.") + +(defvar counsel-compile-env-pattern + "[_[:digit:][:upper:]]+=[/[:alnum:]]*" + "Pattern to match valid environment variables.") + +(defcustom counsel-compile-make-pattern "\\`\\(?:GNUm\\|[Mm]\\)akefile\\'" + "Regexp for matching the names of Makefiles." + :type 'regexp) + +(defcustom counsel-compile-build-directories + '("build" "builds" "bld" ".build") + "List of potential build subdirectory names to check for." + :type '(repeat directory)) + +(defvar counsel-compile-phony-pattern "^\\.PHONY:[\t ]+\\(.+\\)$" + "Regexp for extracting phony targets from Makefiles.") + +;; This is loosely based on the Bash Make completion code +(defun counsel-compile--probe-make-targets (dir) + "Return a list of Make targets for DIR. + +Return an empty list is Make exits with an error. This might +happen because some sort of configuration needs to be done first +or the source tree is pristine and being used for multiple build +trees." + (let ((default-directory dir) + (targets nil)) + (with-temp-buffer + ;; 0 = no-rebuild, -q & 1 needs rebuild, 2 error (for GNUMake at + ;; least) + (when (< (call-process "make" nil t nil "-nqp") 2) + (goto-char (point-min)) + (while (re-search-forward counsel-compile-phony-pattern nil t) + (setq targets + (nconc targets (split-string + (match-string-no-properties 1))))))) + (sort targets #'string-lessp))) + +(defun counsel-compile--pretty-propertize (leader text face) + "Return a pretty string of the form \" LEADER TEXT\". +LEADER is propertized with a warning face and the remaining +text with FACE." + (concat (propertize (concat " " leader " ") + 'face + 'font-lock-warning-face) + (propertize text 'face face))) + +(defun counsel--compile-get-make-targets (srcdir &optional blddir) + "Return a list of Make targets for a given SRCDIR/BLDDIR combination. + +We search the Makefile for a list of phony targets which are +generally the top level targets a Make system provides. +The resulting strings are tagged with properties that +`counsel-compile-history' can use for filtering results." + (let ((fmt (format (propertize "make %s %%s" 'cmd t) + counsel-compile-make-args)) + (suffix (and blddir + (counsel-compile--pretty-propertize "in" blddir + 'dired-directory))) + (build-env (and counsel-compile-env + (counsel-compile--pretty-propertize + "with" + (mapconcat #'identity counsel-compile-env " ") + 'font-lock-variable-name-face))) + (props `(srcdir ,srcdir blddir ,blddir bldenv ,counsel-compile-env))) + (mapcar (lambda (target) + (setq target (concat (format fmt target) suffix build-env)) + (add-text-properties 0 (length target) props target) + target) + (counsel-compile--probe-make-targets (or blddir srcdir))))) + +(defun counsel-compile-get-make-invocation (&optional blddir) + "Have a look in the root directory for any build control files. + +The optional BLDDIR is useful for other helpers that have found +sub-directories that builds may be invoked in." + (let ((srcdir (counsel--compile-root))) + (when (directory-files (or blddir srcdir) nil + counsel-compile-make-pattern t) + (counsel--compile-get-make-targets srcdir blddir)))) + +(defun counsel--find-build-subdir (srcdir) + "Return builds subdirectory of SRCDIR, if one exists." + (cl-some (lambda (dir) + (setq dir (expand-file-name dir srcdir)) + (and (file-directory-p dir) dir)) + counsel-compile-build-directories)) + +(defun counsel--get-build-subdirs (blddir) + "Return all subdirs under BLDDIR sorted by modification time. +If there are non-directory files in BLDDIR, include BLDDIR in the +list as it may also be a build directory." + (let* ((files (directory-files-and-attributes + blddir t directory-files-no-dot-files-regexp t)) + (dirs (cl-remove-if-not #'cl-second files))) + ;; Any non-dir files? + (when (< (length dirs) + (length files)) + (push (cons blddir (file-attributes blddir)) dirs)) + (mapcar #'car (sort dirs (lambda (x y) + (time-less-p (nth 6 y) (nth 6 x))))))) + +(defun counsel-compile-get-build-directories (&optional dir) + "Return a list of potential build directories." + (let* ((srcdir (or dir (counsel--compile-root))) + (blddir (counsel--find-build-subdir srcdir)) + (props `(srcdir ,srcdir recursive t)) + (fmt (concat (propertize "Select build in " + 'face 'font-lock-warning-face) + (propertize "%s" 'face 'dired-directory)))) + (mapcar (lambda (subdir) + (let ((s (format fmt subdir))) + (add-text-properties 0 (length s) `(blddir ,subdir ,@props) s) + s)) + (and blddir (counsel--get-build-subdirs blddir))))) + +;; This is a workaround for the fact there is no concept of "project" +;; local variables (as opposed to for example buffer-local). So we +;; store all our history in a global list filter out the results we +;; don't want. +(defun counsel-compile-get-filtered-history (&optional dir) + "Return a compile history relevant to current project." + (let ((root (or dir (counsel--compile-root))) + history) + (dolist (item counsel-compile-history) + (let ((srcdir (get-text-property 0 'srcdir item)) + (blddir (get-text-property 0 'blddir item))) + (when (or (and srcdir (file-in-directory-p srcdir root)) + (and blddir (file-in-directory-p blddir root))) + (push item history)))) + (nreverse history))) + +(defun counsel--get-compile-candidates (&optional dir) + "Return the list of compile commands. +This is determined by `counsel-compile-local-builds', which see." + (let (cands) + (dolist (cmds counsel-compile-local-builds) + (when (functionp cmds) + (setq cmds (funcall cmds dir))) + (when cmds + (push (if (listp cmds) cmds (list cmds)) cands))) + (apply #'append (nreverse cands)))) + +;; This is a workaround to ensure we tag all the relevant metadata in +;; our compile history. This also allows M-x compile to do fancy +;; things like infer `default-directory' from 'cd's in the string. +(defun counsel-compile--update-history (_proc) + "Update `counsel-compile-history' from the compilation state." + (let* ((srcdir (counsel--compile-root)) + (blddir default-directory) + (bldenv compilation-environment) + (cmd (concat + (propertize (car compilation-arguments) 'cmd t) + (unless (file-equal-p blddir srcdir) + (counsel-compile--pretty-propertize "in" blddir + 'dired-directory)) + (when bldenv + (counsel-compile--pretty-propertize "with" + (mapconcat #'identity bldenv " ") + 'font-lock-variable-name-face))))) + (add-text-properties 0 (length cmd) + `(srcdir ,srcdir blddir ,blddir bldenv ,bldenv) cmd) + (add-to-history 'counsel-compile-history cmd))) + +(defvar counsel-compile--current-build-dir nil + "Tracks the last directory `counsel-compile' was called with. + +This state allows us to set it correctly if the user has manually +edited the command, thus losing our embedded state.") + +(defun counsel-compile--action (cmd) + "Process CMD to call `compile'. + +If CMD has the `recursive' property set we call `counsel-compile' +again to further refine the compile options in the directory +specified by the `blddir' property." + (let ((blddir (get-text-property 0 'blddir cmd)) + (bldenv (get-text-property 0 'bldenv cmd))) + (if (get-text-property 0 'recursive cmd) + (counsel-compile blddir) + (when (get-char-property 0 'cmd cmd) + (setq cmd (substring-no-properties + cmd 0 (next-single-property-change 0 'cmd cmd)))) + (let ((default-directory (or blddir + counsel-compile--current-build-dir + default-directory)) + (compilation-environment bldenv)) + ;; No need to specify `:history' because of this hook. + (add-hook 'compilation-start-hook #'counsel-compile--update-history) + (unwind-protect + (compile cmd) + (remove-hook 'compilation-start-hook #'counsel-compile--update-history)))))) + +;;;###autoload +(defun counsel-compile (&optional dir) + "Call `compile' completing with smart suggestions, optionally for DIR." + (interactive) + (setq counsel-compile--current-build-dir (or dir + (counsel--compile-root) + default-directory)) + (ivy-read "Compile command: " + (delete-dups (counsel--get-compile-candidates dir)) + :action #'counsel-compile--action + :caller 'counsel-compile)) + +(ivy-add-actions + 'counsel-compile + '(("d" counsel-compile-forget-command "delete"))) + +(defun counsel-compile-forget-command (cmd) + "Delete CMD from `counsel-compile-history'." + (setq counsel-compile-history + (delete cmd counsel-compile-history))) + +(defun counsel-compile-env--format-hint (cands) + "Return a formatter for compile-env CANDS." + (let ((rmstr + (propertize "remove" 'face 'font-lock-warning-face)) + (addstr + (propertize "add" 'face 'font-lock-variable-name-face))) + (ivy--format-function-generic + (lambda (selected) + (format "%s %s" + (if (member selected counsel-compile-env) rmstr addstr) + selected)) + #'identity + cands + "\n"))) + +(defun counsel-compile-env--update (var) + "Update `counsel-compile-env' either adding or removing VAR." + (cond ((member var counsel-compile-env) + (setq counsel-compile-env (delete var counsel-compile-env))) + ((string-match-p counsel-compile-env-pattern var) + (push var counsel-compile-env)) + (t (user-error "Ignoring malformed variable: '%s'" var)))) + +;;;###autoload +(defun counsel-compile-env () + "Update `counsel-compile-env' interactively." + (interactive) + (ivy-read "Compile environment variable: " + (delete-dups (append + counsel-compile-env counsel-compile-env-history)) + :action #'counsel-compile-env--update + :predicate (lambda (cand) + (string-match-p counsel-compile-env-pattern + cand)) + :history 'counsel-compile-env-history + :caller 'counsel-compile-env)) + +(ivy-configure 'counsel-compile-env + :format-fn #'counsel-compile-env--format-hint) + +;;** `counsel-minor' +(defvar counsel-minor-history nil + "History for `counsel-minor'.") + +(defun counsel--minor-candidates () + "Return completion alist for `counsel-minor'. + +The alist element is cons of minor mode string with its lighter +and minor mode symbol." + (delq nil + (mapcar + (lambda (mode) + (when (and (boundp mode) (commandp mode)) + (let ((lighter (cdr (assq mode minor-mode-alist)))) + (cons (concat + (if (symbol-value mode) "-" "+") + (symbol-name mode) + (propertize + (if lighter + (format " \"%s\"" + (format-mode-line (cons t lighter))) + "") + 'face font-lock-string-face)) + mode)))) + minor-mode-list))) + +;;;###autoload +(defun counsel-minor () + "Enable or disable minor mode. + +Disabled minor modes are prefixed with \"+\", and +selecting one of these will enable it. +Enabled minor modes are prefixed with \"-\", and +selecting one of these will enable it. + +Additional actions:\\ + + \\[ivy-dispatching-done] d: Go to minor mode definition + \\[ivy-dispatching-done] h: Describe minor mode" + + (interactive) + (ivy-read "Minor modes (enable +mode or disable -mode): " + (counsel--minor-candidates) + :require-match t + :history 'counsel-minor-history + :action (lambda (x) + (call-interactively (cdr x))))) + +(ivy-configure 'counsel-minor + :initial-input "^+" + :sort-fn #'ivy-string<) + +(ivy-set-actions + 'counsel-minor + `(("d" ,(lambda (x) (find-function (cdr x))) "definition") + ("h" ,(lambda (x) (describe-function (cdr x))) "help"))) + +;;;###autoload +(defun counsel-major () + (interactive) + (ivy-read "Major modes: " obarray + :predicate (lambda (f) + (and (commandp f) (string-match "-mode$" (symbol-name f)) + (or (and (autoloadp (symbol-function f)) + (let ((doc-split (help-split-fundoc (documentation f) f))) + ;; major mode starters have no arguments + (and doc-split (null (cdr (read (car doc-split))))))) + (null (help-function-arglist f))))) + :action #'counsel-M-x-action + :caller 'counsel-major)) + +;;** `counsel-search' +(declare-function request "ext:request") + +(defcustom counsel-search-engine 'ddg + "The search engine choice in `counsel-search-engines-alist'." + :type '(choice + (const ddg) + (const google))) + +(defcustom counsel-search-engines-alist + '((google + "http://suggestqueries.google.com/complete/search" + "https://www.google.com/search?q=" + counsel--search-request-data-google) + (ddg + "https://duckduckgo.com/ac/" + "https://duckduckgo.com/html/?q=" + counsel--search-request-data-ddg)) + "Search engine parameters for `counsel-search'." + :type '(list)) + +(defun counsel--search-request-data-google (data) + (mapcar #'identity (aref data 1))) + +(defun counsel--search-request-data-ddg (data) + (mapcar #'cdar data)) + +(defun counsel-search-function (input) + "Create a request to a search engine with INPUT. +Return 0 tells `ivy--exhibit' not to update the minibuffer. +We update it in the callback with `ivy-update-candidates'." + (or + (ivy-more-chars) + (let ((engine (cdr (assoc counsel-search-engine counsel-search-engines-alist)))) + (request + (nth 0 engine) + :type "GET" + :params (list + (cons "client" "firefox") + (cons "q" input)) + :parser 'json-read + :success (cl-function + (lambda (&key data &allow-other-keys) + (ivy-update-candidates + (funcall (nth 2 engine) data))))) + 0))) + +(defun counsel-search-action (x) + "Search for X." + (browse-url + (concat + (nth 2 (assoc counsel-search-engine counsel-search-engines-alist)) + x))) + +(defun counsel-search () + "Ivy interface for dynamically querying a search engine." + (interactive) + (require 'request) + (require 'json) + (ivy-read "search: " #'counsel-search-function + :action #'counsel-search-action + :dynamic-collection t + :caller 'counsel-search)) + +(define-obsolete-function-alias 'counsel-google + 'counsel-search "<2019-10-17 Thu>") + +;;** `counsel-compilation-errors' +(defun counsel--compilation-errors-buffer (buf) + (with-current-buffer buf + (let ((res nil) + (pt (point-min))) + (save-excursion + (while (setq pt (compilation-next-single-property-change + pt 'compilation-message)) + (let ((loc (get-text-property pt 'compilation-message))) + (when (and loc (setq loc (compilation--message->loc loc))) + (goto-char pt) + (push + (propertize + (buffer-substring-no-properties pt (line-end-position)) + 'pt pt + 'buffer buf) + res))))) + (nreverse res)))) + +(defun counsel-compilation-errors-cands () + (cl-loop + for buf in (buffer-list) + when (compilation-buffer-p buf) + nconc (counsel--compilation-errors-buffer buf))) + +(defun counsel-compilation-errors-action (x) + (pop-to-buffer (get-text-property 0 'buffer x)) + (goto-char (get-text-property 0 'pt x)) + (compile-goto-error)) + +;;;###autoload +(defun counsel-compilation-errors () + "Compilation errors." + (interactive) + (ivy-read "compilation errors: " (counsel-compilation-errors-cands) + :require-match t + :action #'counsel-compilation-errors-action + :history 'counsel-compilation-errors-history)) + +;;** `counsel-flycheck' +(defvar flycheck-current-errors) +(declare-function flycheck-error-filename "ext:flycheck") +(declare-function flycheck-error-line "ext:flycheck") +(declare-function flycheck-error-message "ext:flycheck") +(declare-function flycheck-jump-to-error "ext:flycheck") + +(defun counsel-flycheck-errors-cands () + (mapcar + (lambda (err) + (propertize + (format "%s:%d:%s" + (file-name-base (flycheck-error-filename err)) + (flycheck-error-line err) + (flycheck-error-message err)) 'error err)) + flycheck-current-errors)) + +(defun counsel-flycheck-occur (cands) + "Generate a custom occur buffer for `counsel-flycheck'." + (unless (eq major-mode 'ivy-occur-grep-mode) + (ivy-occur-grep-mode) + (setq default-directory (ivy-state-directory ivy-last))) + (swiper--occur-insert-lines + (mapcar + (lambda (cand) + (let ((err (get-text-property 0 'error cand))) + (propertize + (format + "%s:%d:%s" + (flycheck-error-filename err) + (flycheck-error-line err) + cand) + 'error err))) + cands))) + +(defun counsel-flycheck-errors-action (err) + (flycheck-jump-to-error (get-text-property 0 'error err))) + +(ivy-configure 'counsel-flycheck + :occur #'counsel-flycheck-occur) + +;;;###autoload +(defun counsel-flycheck () + "Flycheck errors." + (interactive) + (require 'flycheck) + (ivy-read "flycheck errors: " (counsel-flycheck-errors-cands) + :require-match t + :action #'counsel-flycheck-errors-action + :history 'counsel-flycheck-errors-history)) + + +;;* `counsel-mode' +(defvar counsel-mode-map + (let ((map (make-sparse-keymap))) + (dolist (binding + '((execute-extended-command . counsel-M-x) + (describe-bindings . counsel-descbinds) + (describe-function . counsel-describe-function) + (describe-variable . counsel-describe-variable) + (describe-symbol . counsel-describe-symbol) + (apropos-command . counsel-apropos) + (describe-face . counsel-describe-face) + (list-faces-display . counsel-faces) + (find-file . counsel-find-file) + (find-library . counsel-find-library) + (imenu . counsel-imenu) + (load-library . counsel-load-library) + (load-theme . counsel-load-theme) + (yank-pop . counsel-yank-pop) + (info-lookup-symbol . counsel-info-lookup-symbol) + (pop-to-mark-command . counsel-mark-ring) + (geiser-doc-look-up-manual . counsel-geiser-doc-look-up-manual) + (bookmark-jump . counsel-bookmark))) + (define-key map (vector 'remap (car binding)) (cdr binding))) + map) + "Map for `counsel-mode'. +Remaps built-in functions to counsel replacements.") + +(defcustom counsel-mode-override-describe-bindings nil + "Whether to override `describe-bindings' when `counsel-mode' is active." + :type 'boolean) + +;;;###autoload +(define-minor-mode counsel-mode + "Toggle Counsel mode on or off. +Turn Counsel mode on if ARG is positive, off otherwise. Counsel +mode remaps built-in emacs functions that have counsel +replacements. + +Local bindings (`counsel-mode-map'): +\\{counsel-mode-map}" + :global t + :keymap counsel-mode-map + :lighter " counsel" + (if counsel-mode + (progn + (when counsel-mode-override-describe-bindings + (advice-add #'describe-bindings :override #'counsel-descbinds)) + (define-key minibuffer-local-map (kbd "C-r") + 'counsel-minibuffer-history)) + (advice-remove #'describe-bindings #'counsel-descbinds))) + +(provide 'counsel) + +;;; counsel.el ends here diff --git a/lisp/crdt.el b/lisp/crdt.el new file mode 100644 index 00000000..50fde7fe --- /dev/null +++ b/lisp/crdt.el @@ -0,0 +1,1871 @@ +;;; crdt.el --- collaborative editing using Conflict-free Replicated Data Types -*- lexical-binding: t; -*- +;; +;; Copyright (C) 2020 Qiantan Hong +;; +;; Author: Qiantan Hong +;; Maintainer: Qiantan Hong +;; Keywords: collaboration crdt +;; Version: 0.0.0 +;; +;; crdt.el 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. +;; +;; crdt.el 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 crdt.el. If not, see . + +;;; Commentary: +;; This package provides a collaborative editing environment for Emacs. + +;;; Code: + +;;; Customs + +(defgroup crdt nil + "Collaborative editing using Conflict-free Replicated Data Types." + :prefix "crdt-" + :group 'applications) + +(defcustom crdt-ask-for-name t + "Ask for display name everytime a CRDT session is to be started or connected." + :type 'boolean) + +(defcustom crdt-default-name (user-full-name) + "Default display name." + :type 'string) + +(defcustom crdt-ask-for-password t + "Ask for server password everytime a CRDT server is to be started." + :type 'boolean) + +(defcustom crdt-confirm-stop-session t + "Ask for confirmation when a CRDT server with some client connected is to be stopped." + :type 'boolean) + +(defvar crdt--log-network-traffic nil + "Debug switch to log network traffic to *Messages*.") + +(require 'files) + +(defcustom crdt-tuntox-executable (executable-find "tuntox") + "Path to the tuntox binary." + :type 'file) + +(defcustom crdt-tuntox-key-path (expand-file-name "~") + "Path to save tuntox's private key." + :type 'directory) + +(defcustom crdt-use-tuntox nil + "Start tuntox proxy for CRDT servers." + :type '(choice boolean (const confirm))) + +(require 'cl-lib) +(require 'subr-x) +(require 'url) + +;;; Pseudo cursor/region utils + +(require 'color) + +(defvar crdt-cursor-region-colors + (let ((n 10)) + (cl-loop for i below n + for hue by (/ 1.0 n) + collect (cons + (apply #'color-rgb-to-hex + (color-hsl-to-rgb hue 0.5 0.5)) + (apply #'color-rgb-to-hex + (color-hsl-to-rgb hue 0.2 0.5)))))) + +(defun crdt--get-cursor-color (site-id) + "Get cursor color for SITE-ID." + (car (nth (mod site-id (length crdt-cursor-region-colors)) crdt-cursor-region-colors))) + +(defun crdt--get-region-color (site-id) + "Get region color for SITE-ID." + (cdr (nth (mod site-id (length crdt-cursor-region-colors)) crdt-cursor-region-colors))) + +(defun crdt--move-cursor (ov pos) + "Move pseudo cursor overlay OV to POS." + ;; Hax! + (let* ((eof (eq pos (point-max))) + (end (if eof pos (1+ pos))) + (display-string + (when eof + (unless (or (eq (point) (point-max)) + (cl-some (lambda (ov) + (and (eq (overlay-get ov 'category) 'crdt-pseudo-cursor) + (overlay-get ov 'before-string))) + (overlays-in (point-max) (point-max)))) + (propertize " " 'face (overlay-get ov 'face)))))) + (move-overlay ov pos end) + (overlay-put ov 'before-string display-string))) + +(defun crdt--move-region (ov pos mark) + "Move pseudo marked region overlay OV to mark between POS and MARK." + (move-overlay ov (min pos mark) (max pos mark))) + + +;; CRDT ID utils +;; CRDT IDs are represented by unibyte strings (for efficient comparison) +;; Every two bytes represent a big endian encoded integer +;; For base IDs, last two bytes are always representing site ID +;; Stored strings are BASE-ID:OFFSETs. So the last two bytes represent offset, +;; and second last two bytes represent site ID +(defconst crdt--max-value (lsh 1 16)) +;; (defconst crdt--max-value 16) +;; for debug +(defconst crdt--low-byte-mask 255) + +(defsubst crdt--get-two-bytes (string index) + "Get the big-endian encoded integer from STRING starting from INDEX. +INDEX is counted by bytes." + (logior (lsh (elt string index) 8) + (elt string (1+ index)))) + +(defsubst crdt--get-two-bytes-with-offset (string offset index default) + "Helper function for CRDT--GENERATE-ID. +Get the big-endian encoded integer from STRING starting from INDEX, +but with last two-bytes of STRING (the offset portion) replaced by OFFSET, +and padded infintely by DEFAULT to the right." + (cond ((= index (- (string-bytes string) 2)) + offset) + ((< (1+ index) (string-bytes string)) + (logior (lsh (elt string index) 8) + (elt string (1+ index)))) + (t default))) + +(defsubst crdt--id-offset (id) + "Get the literal offset integer from ID. +Note that it might deviate from real offset for a character +in the middle of a block." + (crdt--get-two-bytes id (- (string-bytes id) 2))) + +(defsubst crdt--set-id-offset (id offset) + "Set the OFFSET portion of ID destructively." + (let ((length (string-bytes id))) + (aset id (- length 2) (lsh offset -8)) + (aset id (- length 1) (logand offset crdt--low-byte-mask)))) + +(defsubst crdt--id-replace-offset (id offset) + "Create and return a new id string by replacing the OFFSET portion from ID." + (let ((new-id (substring id))) + (crdt--set-id-offset new-id offset) + new-id)) + +(defsubst crdt--id-site (id) + "Get the site id from ID." + (crdt--get-two-bytes id (- (string-bytes id) 4))) + +(defsubst crdt--generate-id (low-id low-offset high-id high-offset site-id) + "Generate a new ID between LOW-ID and HIGH-ID. +The generating site is marked as SITE-ID. +Offset parts of LOW-ID and HIGH-ID are overriden by LOW-OFFSET +and HIGH-OFFSET. (to save two copying from using CRDT--ID-REPLACE-OFFSET)" + (let* ((l (crdt--get-two-bytes-with-offset low-id low-offset 0 0)) + (h (crdt--get-two-bytes-with-offset high-id high-offset 0 crdt--max-value)) + (bytes (cl-loop for pos from 2 by 2 + while (< (- h l) 2) + append (list (lsh l -8) + (logand l crdt--low-byte-mask)) + do (setq l (crdt--get-two-bytes-with-offset low-id low-offset pos 0)) + do (setq h (crdt--get-two-bytes-with-offset high-id high-offset pos crdt--max-value)))) + (m (+ l 1 (random (- h l 1))))) + (apply #'unibyte-string + (append bytes (list (lsh m -8) + (logand m crdt--low-byte-mask) + (lsh site-id -8) + (logand site-id crdt--low-byte-mask) + 0 + 0))))) + +;; CRDT-ID text property actually stores a cons of (ID-STRING . END-OF-BLOCK-P) +(defsubst crdt--get-crdt-id-pair (pos &optional obj) + "Get the (CRDT-ID . END-OF-BLOCK-P) pair at POS in OBJ." + (get-text-property pos 'crdt-id obj)) + +(defsubst crdt--get-starting-id (pos &optional obj) + "Get the CRDT-ID at POS in OBJ." + (car (crdt--get-crdt-id-pair pos obj))) + +(defsubst crdt--end-of-block-p (pos &optional obj) + "Get the END-OF-BLOCK-P at POS in OBJ." + (cdr (crdt--get-crdt-id-pair pos obj))) + +(defsubst crdt--get-starting-id-maybe (pos &optional obj limit) + "Get the CRDT-ID at POS in OBJ if POS is no smaller than LIMIT. +Return NIL otherwise." + (unless (< pos (or limit (point-min))) + (car (get-text-property pos 'crdt-id obj)))) + +(defsubst crdt--get-id-offset (starting-id pos &optional obj limit) + "Get the real offset integer for a character at POS. +Assume the stored literal ID is STARTING-ID." + (let* ((start-pos (previous-single-property-change (1+ pos) 'crdt-id obj (or limit (point-min))))) + (+ (- pos start-pos) (crdt--id-offset starting-id)))) + +;;; CRDT ID and text property utils + +(defsubst crdt--get-id (pos &optional obj left-limit right-limit) + "Get the real CRDT ID at POS in OBJ. +The search for start and end of CRDT ID block is limited by LEFT-LIMIT and RIGHT-LIMIT." + (let ((right-limit (or right-limit (point-max))) + (left-limit (or left-limit (point-min)))) + (cond ((>= pos right-limit) "") + ((< pos left-limit) nil) + (t + (let* ((starting-id (crdt--get-starting-id pos obj)) + (left-offset (crdt--get-id-offset starting-id pos obj left-limit))) + (crdt--id-replace-offset starting-id left-offset)))))) + +(defsubst crdt--set-id (pos id &optional end-of-block-p obj limit) + "Set the crdt ID and END-OF-BLOCK-P at POS in OBJ. +Any characters after POS but before LIMIT that used to +have the same (CRDT-ID . END-OF-BLOCK-P) pair are also updated +with ID and END-OF-BLOCK-P." + (put-text-property pos (next-single-property-change pos 'crdt-id obj (or limit (point-max))) 'crdt-id (cons id end-of-block-p) obj)) + +(cl-defmacro crdt--with-insertion-information + ((beg end &optional beg-obj end-obj beg-limit end-limit) &body body) + "Setup some useful variables relevant to an insertion and evaluate BODY. +The insert happens between BEG in BEG-OBJ and END in END-OBJ, +if BEG-OBJ or END-OBJ is NIL, it is treated as current buffer. +The search for start and end of CRDT ID block is limited by BEG-LIMIT and END-LIMIT." + `(let* ((not-begin (> ,beg ,(or beg-limit '(point-min)))) ; if it's nil, we're at the beginning of buffer + (left-pos (1- ,beg)) + (starting-id-pair (when not-begin (crdt--get-crdt-id-pair left-pos ,beg-obj))) + (starting-id (if not-begin (car starting-id-pair) "")) + (left-offset (if not-begin (crdt--get-id-offset starting-id left-pos ,beg-obj ,beg-limit) 0)) + (not-end (< ,end ,(or end-limit '(point-max)))) + ;; (beg ,beg) ; it happens that no function relies on this particular binding + (end ,end) + (beg-obj ,beg-obj) + (end-obj ,end-obj) + ;; (beg-limit ,beg-limit) ; it happens that no function uses it right now. + (end-limit ,end-limit)) + ,@body)) + +(defmacro crdt--split-maybe () + "Split the block if current insertion lies in some CRDT ID block. +Must be used inside CRDT--WITH-INSERTION-INFORMATION." + '(when (and not-end (eq starting-id (crdt--get-starting-id end end-obj))) + ;; need to split id block + (crdt--set-id end (crdt--id-replace-offset starting-id (1+ left-offset)) + (crdt--end-of-block-p left-pos beg-obj) end-obj end-limit) + (rplacd (get-text-property left-pos 'crdt-id beg-obj) nil) ;; clear end-of-block flag + t)) + +;;; Buffer local variables + +(defmacro crdt--defvar-permanent-local (name &optional initial-value docstring) + "Define a permanent local variable with NAME with INITIAL-VALUE and DOCSTRING." + `(progn + (defvar-local ,name ,initial-value ,docstring) + (put ',name 'permanent-local t))) + +(crdt--defvar-permanent-local crdt--session) + +(defsubst crdt--assimilate-session (buffer) + "Set CRDT--SESSION of BUFFER to be the same as current CRDT--SESSION." + (let ((session crdt--session)) + (with-current-buffer buffer + (setq crdt--session session)))) + +(cl-defstruct (crdt--session (:constructor crdt--make-session)) + local-id ; Local site-id + local-clock ; Local logical clock + contact-table ; A hash table that maps SITE-ID to CRDT--CONTACT-METADATAs + local-name + name + focused-buffer-name + user-menu-buffer + buffer-menu-buffer + network-process + network-clients + next-client-id + buffer-table) + +(defvar crdt--inhibit-update nil "When set, don't call CRDT--LOCAL-* on change. +This is useful for functions that apply remote change to local buffer, +to avoid recusive calling of CRDT synchronization functions.") + +(crdt--defvar-permanent-local crdt--changed-string nil) + +(crdt--defvar-permanent-local crdt--last-point nil) + +(crdt--defvar-permanent-local crdt--last-mark nil) + +(crdt--defvar-permanent-local crdt--pseudo-cursor-table nil + "A hash table that maps SITE-ID to CONSes of the form (CURSOR-OVERLAY . REGION-OVERLAY).") + +(cl-defstruct (crdt--contact-metadata + (:constructor crdt--make-contact-metadata (display-name focused-buffer-name host service))) + display-name host service focused-buffer-name) + +(cl-defstruct (crdt--overlay-metadata + (:constructor crdt--make-overlay-metadata + (lamport-timestamp species front-advance rear-advance plist)) + (:copier crdt--copy-overlay-metadata)) + "" + lamport-timestamp species front-advance rear-advance plist) + +(crdt--defvar-permanent-local crdt--overlay-table nil + "A hash table that maps CONSes of the form (SITE-ID . LOGICAL-CLOCK) to overlays.") + +(defvar crdt--track-overlay-species nil) + +(crdt--defvar-permanent-local crdt--enabled-overlay-species nil) + +(crdt--defvar-permanent-local crdt--buffer-network-name) + +(crdt--defvar-permanent-local crdt--buffer-sync-callback) + +;;; Global variables + +(defvar crdt--session-list nil) + +(defvar crdt--session-menu-buffer nil) + +;;; crdt-mode + +(defun crdt--install-hooks () + "Install the hooks used by CRDT-MODE." + (add-hook 'after-change-functions #'crdt--after-change nil t) + (add-hook 'before-change-functions #'crdt--before-change nil t) + (add-hook 'post-command-hook #'crdt--post-command nil t) + (add-hook 'deactivate-mark-hook #'crdt--post-command nil t) + (add-hook 'kill-buffer-hook #'crdt--kill-buffer-hook nil t)) + +(defun crdt--uninstall-hooks () + "Uninstall the hooks used by CRDT-MODE." + (remove-hook 'after-change-functions #'crdt--after-change t) + (remove-hook 'before-change-functions #'crdt--before-change t) + (remove-hook 'post-command-hook #'crdt--post-command t) + (remove-hook 'deactivate-mark-hook #'crdt--post-command t) + (remove-hook 'kill-buffer-hook #'crdt--kill-buffer-hook t)) + +(defsubst crdt--clear-pseudo-cursor-table () + "Remove all overlays in CRDT--PSEUDO-CURSOR-TABLE. +Also set CRDT--PSEUDO-CURSOR-TABLE to NIL." + (when crdt--pseudo-cursor-table + (maphash (lambda (_ pair) + (delete-overlay (car pair)) + (delete-overlay (cdr pair))) + crdt--pseudo-cursor-table) + (setq crdt--pseudo-cursor-table nil))) + +(define-minor-mode crdt-mode + "CRDT mode" nil " CRDT" nil + (if crdt-mode + (progn + (setq crdt--pseudo-cursor-table (make-hash-table)) + (setq crdt--overlay-table (make-hash-table :test 'equal)) + (crdt--install-hooks)) + (crdt--uninstall-hooks) + (crdt--clear-pseudo-cursor-table) + (setq crdt--overlay-table nil))) + +;;; Shared buffer utils + +(defsubst crdt--server-p (&optional session) + "Tell if SESSION is running as a server. +If SESSION is nil, use current CRDT--SESSION." + (process-contact + (crdt--session-network-process + (or session crdt--session)) + :server)) + +(defmacro crdt--with-buffer-name (name &rest body) + "Find CRDT shared buffer associated with NAME and evaluate BODY in it. +Must be called when CURRENT-BUFFER is a CRDT status buffer. +If such buffer doesn't exist yet, do nothing." + `(let (crdt-buffer) + (setq crdt-buffer (gethash ,name (crdt--session-buffer-table crdt--session))) + (when (and crdt-buffer (buffer-live-p crdt-buffer)) + (with-current-buffer crdt-buffer + ,@body)))) + +(defmacro crdt--with-buffer-name-pull (name &rest body) + "Find CRDT shared buffer associated with NAME and evaluate BODY in it. +Must be called when CURRENT-BUFFER is a CRDT status buffer. +If such buffer doesn't exist yet, request it from the server, +and store the body in CRDT--BUFFER-SYNC-CALLBACK to evaluate it +after synchronization is completed." + `(let (crdt-buffer) + (setq crdt-buffer (gethash ,name (crdt--session-buffer-table crdt--session))) + (if (and crdt-buffer (buffer-live-p crdt-buffer)) + (with-current-buffer crdt-buffer + ,@body) + (unless (process-contact (crdt--session-network-process crdt--session) :server) + (setq crdt-buffer (generate-new-buffer (format "crdt - %s" ,name))) + (puthash ,name crdt-buffer (crdt--session-buffer-table crdt--session)) + (let ((session crdt--session)) + (with-current-buffer crdt-buffer + (setq crdt--buffer-network-name ,name) + (setq crdt--session session) + (crdt-mode) + (crdt--broadcast-maybe (crdt--format-message `(get ,,name))) + (let ((crdt--inhibit-update t)) + (insert "Synchronizing with server...")) + (setq crdt--buffer-sync-callback + (lambda () + ,@body)))))))) + +;;; Session menu + +(defun crdt--session-menu-goto () + "Open the buffer menu for the session under point in CRDT session menu." + (interactive) + (let ((crdt--session (tabulated-list-get-id))) + (crdt-list-buffers))) + +(defun crdt--session-menu-kill () + "Kill the session under point in CRDT session menu." + (interactive) + (crdt--stop-session (tabulated-list-get-id))) + +(defvar crdt-session-menu-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") #'crdt--session-menu-goto) + (define-key map (kbd "k") #'crdt--session-menu-kill) + map)) + +(define-derived-mode crdt-session-menu-mode tabulated-list-mode + "CRDT User List" + (setq tabulated-list-format [("Session Name" 15 t) + ("Role" 7 t) + ("My Name" 15 t) + ("Buffers" 30 t) + ("Users" 15 t)])) + +(defun crdt-list-sessions (&optional display-buffer) + "Display a list of active CRDT sessions. +If DISPLAY-BUFFER is provided, display the output there." + (interactive) + (unless display-buffer + (unless (and crdt--session-menu-buffer (buffer-live-p crdt--session-menu-buffer)) + (setf crdt--session-menu-buffer + (generate-new-buffer "*CRDT Sessions*"))) + (setq display-buffer crdt--session-menu-buffer)) + (crdt-refresh-sessions display-buffer) + (switch-to-buffer-other-window display-buffer)) + +(defun crdt-refresh-sessions (display-buffer) + "Refresh the CRDT session menu in DISPLAY-BUFFER." + (with-current-buffer display-buffer + (crdt-session-menu-mode) + (setq tabulated-list-entries nil) + (mapc (lambda (session) + (push + (list session (vector (crdt--session-name session) + (if (crdt--server-p session) "Server" "Client") + (crdt--session-local-name session) + (mapconcat (lambda (v) (format "%s" v)) + (hash-table-keys (crdt--session-buffer-table session)) + ", ") + (mapconcat (lambda (v) (format "%s" v)) + (let (users) + (maphash (lambda (_ v) + (push (crdt--contact-metadata-display-name v) users)) + (crdt--session-contact-table session)) + (cons (crdt--session-local-name session) users)) + ", "))) + tabulated-list-entries)) + crdt--session-list) + (tabulated-list-init-header) + (tabulated-list-print))) + +(defsubst crdt--refresh-sessions-maybe () + "Refresh the session menu buffer, if there's any." + (when (and crdt--session-menu-buffer (buffer-live-p crdt--session-menu-buffer)) + (crdt-refresh-sessions crdt--session-menu-buffer))) + +;;; Buffer menu + +(defun crdt--buffer-menu-goto () + "Open the buffer under point in CRDT buffer menu." + (interactive) + (let ((name (tabulated-list-get-id))) + (crdt--with-buffer-name-pull name + (switch-to-buffer-other-window (current-buffer))))) + +(defun crdt--buffer-menu-kill () + "Stop sharing the buffer under point in CRDT buffer menu. +Only server can perform this action." + (interactive) + (if (crdt--server-p) + (let ((name (tabulated-list-get-id))) + (crdt--with-buffer-name name + (crdt-stop-share-buffer))) + (message "Only server can stop sharing a buffer."))) + +(defvar crdt-buffer-menu-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") #'crdt--buffer-menu-goto) + (define-key map (kbd "k") #'crdt--buffer-menu-kill) + map)) + +(define-derived-mode crdt-buffer-menu-mode tabulated-list-mode + "CRDT User List" + (setq tabulated-list-format [("Local Buffer" 15 t) + ("Network Name" 30 t) + ("Users" 15 t)])) + +(defun crdt-list-buffers (&optional crdt-buffer display-buffer) + "Display a list of buffers shared in the current CRDT session. +If DISPLAY-BUFFER is provided, display the output there. +Otherwise use a dedicated buffer for displaying active users on CRDT-BUFFER." + (interactive) + (with-current-buffer (or crdt-buffer (current-buffer)) + (unless crdt--session + (error "Not a CRDT shared buffer")) + (unless display-buffer + (unless (and (crdt--session-buffer-menu-buffer crdt--session) (buffer-live-p (crdt--session-buffer-menu-buffer crdt--session))) + (setf (crdt--session-buffer-menu-buffer crdt--session) + (generate-new-buffer (concat (crdt--session-name crdt--session) + " buffers"))) + (crdt--assimilate-session (crdt--session-buffer-menu-buffer crdt--session))) + (setq display-buffer (crdt--session-buffer-menu-buffer crdt--session))) + (crdt-refresh-buffers display-buffer) + (if (crdt--session-network-process crdt--session) + (switch-to-buffer display-buffer) + (switch-to-buffer-other-window display-buffer)))) + +(defun crdt-refresh-buffers (display-buffer) + "Refresh the CRDT buffer menu in DISPLAY-BUFFER." + (with-current-buffer display-buffer + (crdt-buffer-menu-mode) + (setq tabulated-list-entries nil) + (let ((tmp-hashtable (make-hash-table :test 'equal))) + (maphash (lambda (_ v) + (push (crdt--contact-metadata-display-name v) + (gethash (crdt--contact-metadata-focused-buffer-name v) + tmp-hashtable))) + (crdt--session-contact-table crdt--session)) + (push (crdt--session-local-name crdt--session) + (gethash (crdt--session-focused-buffer-name crdt--session) + tmp-hashtable)) + (maphash (lambda (k v) + (push (list k (vector (if (and v (buffer-live-p v)) + (buffer-name v) + "--") + k (mapconcat #'identity (gethash k tmp-hashtable) ", "))) + tabulated-list-entries)) + (crdt--session-buffer-table crdt--session))) + (tabulated-list-init-header) + (tabulated-list-print))) + +(defsubst crdt--refresh-buffers-maybe () + "Refresh the buffer menu buffer for current session, if there's any." + (when (and (crdt--session-buffer-menu-buffer crdt--session) (buffer-live-p (crdt--session-buffer-menu-buffer crdt--session))) + (crdt-refresh-buffers (crdt--session-buffer-menu-buffer crdt--session))) + (crdt--refresh-sessions-maybe)) + +;;; User menu + +(defun crdt--user-menu-goto () + "Goto the cursor location of the user under point in CRDT user menu." + (interactive) + (let ((site-id (tabulated-list-get-id))) + (if (eq site-id (crdt--session-local-id crdt--session)) + (switch-to-buffer-other-window + (gethash (crdt--session-focused-buffer-name crdt--session) (crdt--session-buffer-table crdt--session))) + (unless + (cl-block nil + (let* ((metadata (or (gethash site-id (crdt--session-contact-table crdt--session)) (cl-return))) + (buffer-name (or (crdt--contact-metadata-focused-buffer-name metadata) (cl-return)))) + (crdt--with-buffer-name-pull + buffer-name + (switch-to-buffer-other-window (current-buffer)) + (ignore-errors (goto-char (overlay-start (car (gethash site-id crdt--pseudo-cursor-table))))) + t))) + (message "Doesn't have position information for this user yet."))))) + +(defvar crdt-user-menu-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") #'crdt--user-menu-goto) + map)) + +(define-derived-mode crdt-user-menu-mode tabulated-list-mode + "CRDT User List" + (setq tabulated-list-format [("Display Name" 15 t) + ("Focused Buffer" 30 t) + ("Address" 15 t)])) + +(defun crdt-list-users (&optional crdt-buffer display-buffer) + "Display a list of active users working on a CRDT-shared buffer CRDT-BUFFER. +If DISPLAY-BUFFER is provided, display the output there. +Otherwise use a dedicated buffer for displaying active users on CRDT-BUFFER." + (interactive) + (with-current-buffer (or crdt-buffer (current-buffer)) + (unless crdt--session + (error "Not a CRDT shared buffer")) + (unless display-buffer + (unless (and (crdt--session-user-menu-buffer crdt--session) (buffer-live-p (crdt--session-user-menu-buffer crdt--session))) + (setf (crdt--session-user-menu-buffer crdt--session) + (generate-new-buffer (concat (crdt--session-name crdt--session) " users"))) + (crdt--assimilate-session (crdt--session-user-menu-buffer crdt--session))) + (setq display-buffer (crdt--session-user-menu-buffer crdt--session))) + (crdt-refresh-users display-buffer) + (switch-to-buffer-other-window display-buffer))) + +(defun crdt-refresh-users (display-buffer) + "Refresh the CRDT user menu in DISPLAY-BUFFER." + (with-current-buffer display-buffer + (crdt-user-menu-mode) + (setq tabulated-list-entries nil) + (push (list (crdt--session-local-id crdt--session) + (vector (crdt--session-local-name crdt--session) + (or (crdt--session-focused-buffer-name crdt--session) "--") + "*myself*")) + tabulated-list-entries) + (maphash (lambda (k v) + (push (list k (let ((name (crdt--contact-metadata-display-name v)) + (host (crdt--contact-metadata-host v)) + (service (crdt--contact-metadata-service v)) + (focused-buffer-name (or (crdt--contact-metadata-focused-buffer-name v) "--"))) + (let ((colored-name (concat name " "))) + (put-text-property 0 (1- (length colored-name)) + 'face `(:background ,(crdt--get-region-color k)) + colored-name) + (put-text-property (1- (length colored-name)) (length colored-name) + 'face `(:background ,(crdt--get-cursor-color k)) + colored-name) + (vector colored-name focused-buffer-name (format "%s:%s" host service))))) + tabulated-list-entries)) + (crdt--session-contact-table crdt--session)) + (tabulated-list-init-header) + (tabulated-list-print))) + +(defsubst crdt--refresh-users-maybe () + "Refresh the user menu buffer for current session, if there's any." + (when (and (crdt--session-user-menu-buffer crdt--session) (buffer-live-p (crdt--session-user-menu-buffer crdt--session))) + (crdt-refresh-users (crdt--session-user-menu-buffer crdt--session))) + (crdt--refresh-buffers-maybe)) + +(defun crdt--kill-buffer-hook () + "Kill buffer hook for CRDT shared buffers. +It informs other peers that the buffer is killed." + (when crdt--buffer-network-name + (puthash crdt--buffer-network-name nil (crdt--session-buffer-table crdt--session)) + (crdt--broadcast-maybe (crdt--format-message + `(cursor ,crdt--buffer-network-name + ,(crdt--session-local-id crdt--session) nil nil nil nil))) + (when (eq (crdt--session-focused-buffer-name crdt--session) crdt--buffer-network-name) + (crdt--broadcast-maybe (crdt--format-message + `(focus ,(crdt--session-local-id crdt--session) nil))) + (setf (crdt--session-focused-buffer-name crdt--session) nil)) + (crdt--refresh-users-maybe))) + +;;; CRDT insert/delete + +(defsubst crdt--base64-encode-maybe (str) + "Base64 encode STR if it's a string, or return NIL if STR is NIL." + (when str (base64-encode-string str))) + +(defun crdt--local-insert (beg end) + "To be called after a local insert happened in current buffer from BEG to END. +Returns a list of (insert type) messages to be sent." + (let (resulting-commands) + (crdt--with-insertion-information + (beg end) + (unless (crdt--split-maybe) + (when (and not-begin + (eq (crdt--id-site starting-id) (crdt--session-local-id crdt--session)) + (crdt--end-of-block-p left-pos)) + ;; merge crdt id block + (let* ((max-offset crdt--max-value) + (merge-end (min end (+ (- max-offset left-offset 1) beg)))) + (unless (= merge-end beg) + (put-text-property beg merge-end 'crdt-id starting-id-pair) + (let ((virtual-id (substring starting-id))) + (crdt--set-id-offset virtual-id (1+ left-offset)) + (push `(insert ,crdt--buffer-network-name + ,(base64-encode-string virtual-id) ,beg + ,(buffer-substring-no-properties beg merge-end)) + resulting-commands)) + (cl-incf left-offset (- merge-end beg)) + (setq beg merge-end))))) + (while (< beg end) + (let ((block-end (min end (+ crdt--max-value beg)))) + (let* ((ending-id (if not-end (crdt--get-starting-id end) "")) + (new-id (crdt--generate-id starting-id left-offset + ending-id (if not-end (crdt--id-offset ending-id) 0) + (crdt--session-local-id crdt--session)))) + (put-text-property beg block-end 'crdt-id (cons new-id t)) + (push `(insert ,crdt--buffer-network-name + ,(base64-encode-string new-id) ,beg + ,(buffer-substring-no-properties beg block-end)) + resulting-commands) + (setq beg block-end) + (setq left-offset (1- crdt--max-value)) ; this is always true when we need to continue + (setq starting-id new-id))))) + ;; (crdt--verify-buffer) + (nreverse resulting-commands))) + +(defun crdt--find-id (id pos &optional before) + "Find the first position *after* ID if BEFORE is NIL or *before* ID otherwise. +Start the search from POS." + (let* ((left-pos (previous-single-property-change (min (1+ pos) (point-max)) + 'crdt-id nil (point-min))) + (left-id (crdt--get-starting-id left-pos)) + (right-pos (next-single-property-change pos 'crdt-id nil (point-max))) + (right-id (crdt--get-starting-id right-pos)) + (moving-forward nil)) + (cl-macrolet ((move-forward () + '(progn + (setq moving-forward t) + (setq left-pos right-pos) + (setq left-id right-id) + (setq right-pos (next-single-property-change right-pos 'crdt-id nil (point-max))) + (setq right-id (crdt--get-starting-id right-pos)))) + (move-backward () + '(progn + (setq moving-forward nil) + (setq right-pos left-pos) + (setq right-id left-id) + (setq left-pos (previous-single-property-change left-pos 'crdt-id nil (point-min))) + (setq left-id (crdt--get-starting-id left-pos))))) + (cl-block nil + (while t + (cond ((<= right-pos (point-min)) + (cl-return (point-min))) + ((>= left-pos (point-max)) + (cl-return (point-max))) + ((and right-id (not (string< id right-id))) + (move-forward)) + ((not left-id) + (if moving-forward + (move-forward) + (move-backward))) + ((string< id left-id) + (move-backward)) + (t + ;; will unibyte to multibyte conversion cause any problem? + (cl-return + (if (eq t (compare-strings left-id 0 (- (string-bytes left-id) 2) + id 0 (- (string-bytes left-id) 2))) + (min right-pos (+ left-pos (if before 0 1) + (- (crdt--get-two-bytes id (- (string-bytes left-id) 2)) + (crdt--id-offset left-id)))) + right-pos))))))))) + +(defun crdt--remote-insert (id position-hint content) + "Handle remote insert message that CONTENT should be insert. +The first character of CONTENT has CRDT ID. +Start the search around POSITION-HINT." + (let* ((beg (crdt--find-id id position-hint)) end) + (save-excursion + (goto-char beg) + (insert content) + (setq end (point)) + ;; work around for input method overlays + (cl-loop for ov in (overlays-at beg) + do (unless (overlay-get ov 'crdt-meta) + (when (eq (overlay-start ov) beg) + (move-overlay ov end (overlay-end ov))))) + (with-silent-modifications + (let ((real-end end)) + (unless (get-text-property end 'crdt-id) + (setq end (next-single-property-change end 'crdt-id nil (point-max)))) + (crdt--with-insertion-information + (beg end) + (let ((base-length (- (string-bytes starting-id) 2))) + (if (and (eq (string-bytes id) (string-bytes starting-id)) + (eq t (compare-strings starting-id 0 base-length + id 0 base-length)) + (eq (1+ left-offset) (crdt--id-offset id))) + (put-text-property beg real-end 'crdt-id starting-id-pair) + (put-text-property beg real-end 'crdt-id (cons id t)))) + (crdt--split-maybe)))))) + ;; (crdt--verify-buffer) + ) + +(defun crdt--local-delete (beg end) + "Handle local deletion event and return a message to be sent to other peers. +The deletion happens between BEG and END." + (let ((outer-end end)) + (crdt--with-insertion-information + (beg 0 nil crdt--changed-string nil (length crdt--changed-string)) + (when (crdt--split-maybe) + (let* ((not-end (< outer-end (point-max))) + (ending-id (when not-end (crdt--get-starting-id outer-end)))) + (when (and not-end (eq starting-id (crdt--get-starting-id outer-end))) + (crdt--set-id outer-end + (crdt--id-replace-offset ending-id (+ 1 left-offset (length crdt--changed-string)))))))) + (crdt--with-insertion-information + ((length crdt--changed-string) outer-end crdt--changed-string nil 0 nil) + (crdt--split-maybe))) + ;; (crdt--verify-buffer) + `(delete ,crdt--buffer-network-name + ,beg ,@ (crdt--dump-ids 0 (length crdt--changed-string) crdt--changed-string t))) + +(defun crdt--remote-delete (position-hint id-items) + "Handle remote deletion message of ID-ITEMS. +ID-ITEMS should be a list of CONSes of the form (LENGTH . STARTING-ID). +Start the search for those ID-ITEMs around POSITION-HINT." + (save-excursion + (dolist (id-item id-items) + (cl-destructuring-bind (length id) id-item + (while (> length 0) + (goto-char (crdt--find-id id position-hint t)) + (let* ((end-of-block (next-single-property-change (point) 'crdt-id nil (point-max))) + (block-length (- end-of-block (point)))) + (cl-case (cl-signum (- length block-length)) + ((1) (delete-char block-length) + (cl-decf length block-length) + (crdt--set-id-offset id (+ (crdt--id-offset id) block-length))) + ((0) (delete-char length) + (setq length 0)) + ((-1) + (let* ((starting-id (crdt--get-starting-id (point))) + (eob (crdt--end-of-block-p (point))) + (left-offset (crdt--get-id-offset starting-id (point)))) + (delete-char length) + (crdt--set-id (point) (crdt--id-replace-offset starting-id (+ left-offset length)) eob)) + (setq length 0))))) + ;; (crdt--verify-buffer) + )))) + +(defun crdt--before-change (beg end) + "Before change hook used by CRDT-MODE. +It saves the content to be changed (between BEG and END) into CRDT--CHANGED-STRING." + (unless crdt--inhibit-update + (setq crdt--changed-string (buffer-substring beg end)))) + +(defsubst crdt--crdt-id-assimilate (template beg &optional object) + "Make the CRDT-ID property after BEG in OBJECT the same as TEMPLATE. +TEMPLATE should be a string. If OBJECT is NIL, use current buffer." + (let (next-pos + (pos 0) + (limit (length template))) + (while (< pos limit) + (setq next-pos (next-single-property-change pos 'crdt-id template limit)) + (put-text-property (+ beg pos) (+ beg next-pos) 'crdt-id + (get-text-property pos 'crdt-id template) + object) + (setq pos next-pos)))) + +(defun crdt--after-change (beg end length) + "After change hook used by CRDT-MODE. +It examine CRDT--CHANGED-STRING (should be saved by +CRDT--BEFORE-STRING and whose length shall equal to LENGTH) +and current content between BEG and END, +update the CRDT-ID for any newly inserted text, +and send message to other peers if needed." + (when (markerp beg) + (setq beg (marker-position beg))) + (when (markerp end) + (setq end (marker-position end))) + (mapc (lambda (ov) + (when (eq (overlay-get ov 'category) 'crdt-pseudo-cursor) + (crdt--move-cursor ov beg))) + (overlays-in beg (min (point-max) (1+ beg)))) + (when (crdt--session-local-id crdt--session) ; LOCAL-ID is NIL when a client haven't received the first sync message + (unless crdt--inhibit-update + (let ((crdt--inhibit-update t)) + ;; we're only interested in text change + ;; ignore property only changes + (save-excursion + (goto-char beg) + (if (and (= length (- end beg)) + (string-equal crdt--changed-string + (buffer-substring-no-properties beg end))) + (crdt--crdt-id-assimilate crdt--changed-string beg) + (widen) + (with-silent-modifications + (unless (= length 0) + (crdt--broadcast-maybe + (crdt--format-message (crdt--local-delete beg end)))) + (unless (= beg end) + (dolist (message (crdt--local-insert beg end)) + (crdt--broadcast-maybe + (crdt--format-message message))))))))))) + +;;; CRDT point/mark synchronization + +(defsubst crdt--id-to-pos (id hint) + "Convert CRDT-ID ID to a position in current buffer with best effort. +Start the search around HINT." + (if (> (string-bytes id) 0) + (crdt--find-id id hint t) + (point-max))) + +(defun crdt--remote-cursor (site-id point-position-hint point-crdt-id mark-position-hint mark-crdt-id) + "Handle remote cursor/mark movement message at SITE-ID. +The cursor for that site is at POINT-CRDT-ID, +whose search starts around POINT-POSITION-HINT. +If POINT-CRDT-ID is NIL, remove the pseudo cursor and region +overlays for this site. +The mark for that site is at MARK-CRDT-ID, +whose search starts around MARK-POSITION-HINT. +If MARK-CRDT-ID, deactivate the pseudo region overlay." + (when (and site-id (not (eq site-id (crdt--session-local-id crdt--session)))) + (let ((ov-pair (gethash site-id crdt--pseudo-cursor-table))) + (if point-crdt-id + (let* ((point (crdt--id-to-pos point-crdt-id point-position-hint)) + (mark (if mark-crdt-id + (crdt--id-to-pos mark-crdt-id mark-position-hint) + point))) + (unless ov-pair + (let ((new-cursor (make-overlay 1 1)) + (new-region (make-overlay 1 1))) + (overlay-put new-cursor 'face `(:background ,(crdt--get-cursor-color site-id))) + (overlay-put new-cursor 'category 'crdt-pseudo-cursor) + (overlay-put new-region 'face `(:background ,(crdt--get-region-color site-id) :extend t)) + (setq ov-pair (puthash site-id (cons new-cursor new-region) + crdt--pseudo-cursor-table)))) + (crdt--move-cursor (car ov-pair) point) + (crdt--move-region (cdr ov-pair) point mark)) + (when ov-pair + (remhash site-id crdt--pseudo-cursor-table) + (delete-overlay (car ov-pair)) + (delete-overlay (cdr ov-pair))))))) + +(cl-defun crdt--local-cursor (&optional (lazy t)) + "Handle local cursor/mark movement event. +If LAZY if T, return NIL if cursor/mark doesn't move +since last call of this function. +Always return a message otherwise." + (let ((point (point)) + (mark (when (use-region-p) (mark)))) + (unless (and lazy + (eq point crdt--last-point) + (eq mark crdt--last-mark)) + (when (or (eq point (point-max)) (eq crdt--last-point (point-max))) + (mapc (lambda (ov) + (when (eq (overlay-get ov 'category) 'crdt-pseudo-cursor) + (crdt--move-cursor ov (point-max)))) + (overlays-in (point-max) (point-max)))) + (setq crdt--last-point point) + (setq crdt--last-mark mark) + (let ((point-id-base64 (base64-encode-string (crdt--get-id point))) + (mark-id-base64 (when mark (base64-encode-string (crdt--get-id mark))))) + `(cursor ,crdt--buffer-network-name ,(crdt--session-local-id crdt--session) + ,point ,point-id-base64 ,mark ,mark-id-base64))))) + +(defun crdt--post-command () + "Post command hook used by CRDT-MODE. +Check if focused buffer and cursor/mark position are changed. +Send message to other peers about any changes." + (unless (eq crdt--buffer-network-name (crdt--session-focused-buffer-name crdt--session)) + (crdt--broadcast-maybe + (crdt--format-message `(focus ,(crdt--session-local-id crdt--session) ,crdt--buffer-network-name))) + (setf (crdt--session-focused-buffer-name crdt--session) crdt--buffer-network-name)) + (let ((cursor-message (crdt--local-cursor))) + (when cursor-message + (crdt--broadcast-maybe (crdt--format-message cursor-message))))) + + +;;; CRDT ID (de)serialization + +(defun crdt--dump-ids (beg end object &optional omit-end-of-block-p include-content) + "Serialize all CRDT IDs in OBJECT from BEG to END into a list. +The list contains CONSes of the form (LENGTH CRDT-ID-BASE64 END-OF-BLOCK-P), +or (LENGTH CRDT-ID-BASE64) if OMIT-END-OF-BLOCK-P is non-NIL, +in the order that they appears in the document. +If INCLUDE-CONTENT is non-NIL, the list contains STRING instead of LENGTH." + (let (ids (pos end)) + (while (> pos beg) + (let ((prev-pos (previous-single-property-change pos 'crdt-id object beg))) + (when (crdt--get-crdt-id-pair prev-pos object) + (push (cons (if include-content + (cond ((not object) (buffer-substring-no-properties prev-pos pos)) + ((bufferp object) + (with-current-buffer object + (buffer-substring-no-properties prev-pos pos))) + (t (substring object prev-pos pos))) + (- pos prev-pos)) + (cl-destructuring-bind (id . eob) (crdt--get-crdt-id-pair prev-pos object) + (let ((id-base64 (base64-encode-string id))) + (if omit-end-of-block-p (list id-base64) (list id-base64 eob))))) + ids)) + (setq pos prev-pos))) + ids)) + +(defun crdt--load-ids (ids) + "Load the CRDT ids in IDS (generated by CRDT--DUMP-IDS) +into current buffer." + (goto-char (point-min)) + (dolist (id-item ids) + (cl-destructuring-bind (content id-base64 eob) id-item + (insert (propertize content 'crdt-id + (cons (base64-decode-string id-base64) eob)))))) + +(defun crdt--verify-buffer () + "Debug helper function. +Verify that CRDT IDs in a document follows ascending order." + (let* ((pos (point-min)) + (id (crdt--get-starting-id pos))) + (cl-block nil + (while t + (let* ((next-pos (next-single-property-change pos 'crdt-id)) + (next-id (if (< next-pos (point-max)) + (crdt--get-starting-id next-pos) + (cl-return))) + (prev-id (substring id))) + (crdt--set-id-offset id (+ (- next-pos pos) (crdt--id-offset id))) + (unless (string< prev-id next-id) + (error "Not monotonic!")) + (setq pos next-pos) + (setq id next-id)))))) + +;;; Network protocol + +(defun crdt--format-message (args) + "Serialize ARGS (which should be a list) into a string. +Return the string." + (let ((print-level nil) + (print-length nil)) + (prin1-to-string args))) + +(cl-defun crdt--broadcast-maybe (message-string &optional (without t)) + "Broadcast or send MESSAGE-STRING. +If (CRDT--SESSION-NETWORK-PROCESS CRDT--SESSION) is a server process, +broadcast MESSAGE-STRING to clients except the one of which CLIENT-ID +property is EQ to WITHOUT. +If (CRDT--SESSION-NETWORK-PROCESS CRDT--SESSION) is a client process, +send MESSAGE-STRING to server when WITHOUT is T." + (when crdt--log-network-traffic + (message "Send %s" message-string)) + (if (process-contact (crdt--session-network-process crdt--session) :server) + (dolist (client (crdt--session-network-clients crdt--session)) + (when (and (eq (process-status client) 'open) + (not (eq (process-get client 'client-id) without))) + (process-send-string client message-string) + ;; (run-at-time 1 nil #'process-send-string client message-string) + ;; ^ quick dirty way to simulate network latency, for debugging + )) + (when without + (process-send-string (crdt--session-network-process crdt--session) message-string) + ;; (run-at-time 1 nil #'process-send-string (crdt--session-network-process crdt--session) message-string) + ))) + +(defsubst crdt--overlay-add-message (id clock species front-advance rear-advance beg end) + "Create an overlay-add message to be sent to peers. +The overlay is generated at site with ID and logical CLOCK. +The overlay is categorized as SPECIES. +The overlay is FRONT-ADVANCE and REAR-ADVANCE, and lies between BEG and END." + `(overlay-add ,crdt--buffer-network-name ,id ,clock + ,species ,front-advance ,rear-advance + ,beg ,(if front-advance + (base64-encode-string (crdt--get-id beg)) + (crdt--base64-encode-maybe (crdt--get-id (1- beg)))) + ,end ,(if rear-advance + (base64-encode-string (crdt--get-id end)) + (crdt--base64-encode-maybe (crdt--get-id (1- end)))))) + +(defun crdt--generate-challenge () + "Generate a challenge string for authentication." + (apply #'unibyte-string (cl-loop for i below 32 collect (random 256)))) + +(defsubst crdt--sync-buffer-to-client (buffer process) + "Send messages to a client about the full state of BUFFER. +The network process for the client connection is PROCESS." + (with-current-buffer buffer + (process-send-string process (crdt--format-message `(sync + ,crdt--buffer-network-name + ,@ (crdt--dump-ids (point-min) (point-max) nil nil t)))) + ;; synchronize cursor + (maphash (lambda (site-id ov-pair) + (cl-destructuring-bind (cursor-ov . region-ov) ov-pair + (let* ((point (overlay-start cursor-ov)) + (region-beg (overlay-start region-ov)) + (region-end (overlay-end region-ov)) + (mark (if (eq point region-beg) + (unless (eq point region-end) region-end) + region-beg)) + (point-id-base64 (base64-encode-string (crdt--get-id point))) + (mark-id-base64 (when mark (base64-encode-string (crdt--get-id mark))))) + (process-send-string process + (crdt--format-message + `(cursor ,crdt--buffer-network-name ,site-id + ,point ,point-id-base64 ,mark ,mark-id-base64)))))) + crdt--pseudo-cursor-table) + (process-send-string process (crdt--format-message (crdt--local-cursor nil))) + + ;; synchronize tracked overlay + (maphash (lambda (k ov) + (let ((meta (overlay-get ov 'crdt-meta))) + (process-send-string + process + (crdt--format-message (crdt--overlay-add-message + (car k) (cdr k) + (crdt--overlay-metadata-species meta) + (crdt--overlay-metadata-front-advance meta) + (crdt--overlay-metadata-rear-advance meta) + (overlay-start ov) + (overlay-end ov)))) + (cl-loop for (prop value) on (crdt--overlay-metadata-plist meta) by #'cddr + do (process-send-string + process + (crdt--format-message `(overlay-put ,crdt--buffer-network-name + ,(car k) ,(cdr k) ,prop ,value)))))) + crdt--overlay-table) + + (process-send-string process (crdt--format-message `(ready ,crdt--buffer-network-name ,major-mode))))) + +(defun crdt--greet-client (process) + "Send initial information when a client connects. +Those information include the assigned SITE-ID, buffer list, +and contact data of other users. +The network process for the client connection is PROCESS." + (let ((crdt--session (process-get process 'crdt-session))) + (cl-pushnew process (crdt--session-network-clients crdt--session)) + (let ((client-id (process-get process 'client-id))) + (unless client-id + (unless (< (crdt--session-next-client-id crdt--session) crdt--max-value) + (error "Used up client IDs. Need to implement allocation algorithm")) + (process-put process 'client-id (crdt--session-next-client-id crdt--session)) + (setq client-id (crdt--session-next-client-id crdt--session)) + (process-send-string process (crdt--format-message + `(login ,client-id + ,(crdt--session-name crdt--session)))) + (cl-incf (crdt--session-next-client-id crdt--session))) + (process-send-string process (crdt--format-message + (cons 'add (hash-table-keys (crdt--session-buffer-table crdt--session))))) + ;; synchronize contact + (maphash (lambda (k v) + (process-send-string + process (crdt--format-message `(contact ,k ,(crdt--contact-metadata-display-name v) + ,(crdt--contact-metadata-host v) + ,(crdt--contact-metadata-service v)))) + (process-send-string + process (crdt--format-message `(focus ,k ,(crdt--contact-metadata-focused-buffer-name v))))) + (crdt--session-contact-table crdt--session)) + (process-send-string process + (crdt--format-message `(contact ,(crdt--session-local-id crdt--session) + ,(crdt--session-local-name crdt--session)))) + (process-send-string process + (crdt--format-message `(focus ,(crdt--session-local-id crdt--session) + ,(crdt--session-focused-buffer-name crdt--session)))) + (let ((contact-message `(contact ,client-id ,(process-get process 'client-name) + ,(process-contact process :host) + ,(process-contact process :service)))) + (crdt-process-message contact-message process))))) + +(cl-defgeneric crdt-process-message (message process) "Handle MESSAGE received from PROCESS.") + +(cl-defmethod crdt-process-message (message process) + (message "Unrecognized message %S from %s:%s." + message (process-contact process :host) (process-contact process :service))) + +(cl-defmethod crdt-process-message ((message (head insert)) process) + (cl-destructuring-bind (buffer-name crdt-id position-hint content) (cdr message) + (crdt--with-buffer-name + buffer-name + (crdt--remote-insert (base64-decode-string crdt-id) position-hint content))) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) + +(cl-defmethod crdt-process-message ((message (head delete)) process) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id)) + (cl-destructuring-bind (buffer-name position-hint . id-base64-pairs) (cdr message) + (mapc (lambda (p) (rplaca (cdr p) (base64-decode-string (cadr p)))) id-base64-pairs) + (crdt--with-buffer-name + buffer-name + (crdt--remote-delete position-hint id-base64-pairs)))) + +(cl-defmethod crdt-process-message ((message (head cursor)) process) + (cl-destructuring-bind (buffer-name site-id point-position-hint point-crdt-id + mark-position-hint mark-crdt-id) + (cdr message) + (crdt--with-buffer-name + buffer-name + (crdt--remote-cursor site-id point-position-hint + (and point-crdt-id (base64-decode-string point-crdt-id)) + mark-position-hint + (and mark-crdt-id (base64-decode-string mark-crdt-id))))) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) + +(cl-defmethod crdt-process-message ((message (head get)) process) + (cl-destructuring-bind (buffer-name) (cdr message) + (let ((buffer (gethash buffer-name (crdt--session-buffer-table crdt--session)))) + (if (and buffer (buffer-live-p buffer)) + (crdt--sync-buffer-to-client buffer process) + (process-send-string process (crdt--format-message `(remove ,buffer-name))))))) + +(cl-defmethod crdt-process-message ((message (head sync)) _process) + (unless (crdt--server-p) ; server shouldn't receive this + (cl-destructuring-bind (buffer-name . ids) (cdr message) + (crdt--with-buffer-name + buffer-name + (let ((crdt--inhibit-update t)) + (unless crdt--buffer-sync-callback + ;; try to get to the same position after sync, + ;; if crdt--buffer-sync-callback is not set yet + (let ((pos (point))) + (setq crdt--buffer-sync-callback + (lambda () + (goto-char + (max (min pos (point-max)) + (point-max))))))) + (erase-buffer) + (crdt--load-ids ids)))) + (crdt--refresh-buffers-maybe))) + +(cl-defmethod crdt-process-message ((message (head ready)) _process) + (unless (crdt--server-p) ; server shouldn't receive this + (cl-destructuring-bind (buffer-name mode) (cdr message) + (crdt--with-buffer-name + buffer-name + (if (fboundp mode) + (unless (eq major-mode mode) + (funcall mode) ; trust your server... + (crdt-mode)) + (message "Server uses %s, but not available locally." mode)) + (when crdt--buffer-sync-callback + (funcall crdt--buffer-sync-callback) + (setq crdt--buffer-sync-callback nil)))))) + +(cl-defmethod crdt-process-message ((message (head add)) _process) + (dolist (buffer-name (cdr message)) + (unless (gethash buffer-name (crdt--session-buffer-table crdt--session)) + (puthash buffer-name nil (crdt--session-buffer-table crdt--session))) + (crdt--refresh-buffers-maybe))) + +(cl-defmethod crdt-process-message ((message (head remove)) process) + (let ((saved-session crdt--session)) + (dolist (buffer-name (cdr message)) + (let ((buffer (gethash buffer-name (crdt--session-buffer-table crdt--session)))) + (remhash buffer-name (crdt--session-buffer-table crdt--session)) + (when buffer + (when (buffer-live-p buffer) + (with-current-buffer buffer + (crdt-mode 0) + (setq crdt--session nil)))))) + (message "Server stopped sharing %s." + (mapconcat #'identity (cdr message) ", ")) + (let ((crdt--session saved-session)) + (crdt--broadcast-maybe (crdt--format-message message) + (when process (process-get process 'client-id))) + (crdt--refresh-buffers-maybe)))) + +(cl-defmethod crdt-process-message ((message (head login)) process) + (cl-destructuring-bind (id session-name) (cdr message) + (puthash 0 (crdt--make-contact-metadata nil nil + (process-contact process :host) + (process-contact process :service)) + (crdt--session-contact-table crdt--session)) + (setf (crdt--session-name crdt--session) (concat session-name "@" (crdt--session-name crdt--session))) + (setf (crdt--session-local-id crdt--session) id) + (crdt--refresh-sessions-maybe))) + +(cl-defmethod crdt-process-message ((_message (head leave)) process) + (delete-process process)) + +(cl-defmethod crdt-process-message ((message (head challenge)) _process) + (unless (crdt--server-p) ; server shouldn't receive this + (message nil) + (let ((password (read-passwd + (format "Password for %s:%s: " + (process-contact (crdt--session-network-process crdt--session) :host) + (process-contact (crdt--session-network-process crdt--session) :service))))) + (crdt--broadcast-maybe (crdt--format-message + `(hello ,(crdt--session-local-name crdt--session) + ,(gnutls-hash-mac 'SHA1 password (cadr message)))))))) + +(cl-defmethod crdt-process-message ((message (head contact)) process) + (cl-destructuring-bind + (site-id display-name &optional host service) (cdr message) + (if display-name + (if host + (puthash site-id (crdt--make-contact-metadata + display-name nil host service) + (crdt--session-contact-table crdt--session)) + (let ((existing-item (gethash site-id (crdt--session-contact-table crdt--session)))) + (setf (crdt--contact-metadata-display-name existing-item) display-name))) + (remhash site-id (crdt--session-contact-table crdt--session))) + (crdt--refresh-users-maybe)) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) + +(cl-defmethod crdt-process-message ((message (head focus)) process) + (cl-destructuring-bind + (site-id buffer-name) (cdr message) + (let ((existing-item (gethash site-id (crdt--session-contact-table crdt--session)))) + (setf (crdt--contact-metadata-focused-buffer-name existing-item) buffer-name)) + ;; (when (and (= site-id 0) (not crdt--focused-buffer-name)) + ;; (setq crdt--focused-buffer-name buffer-name) + ;; (switch-to-buffer (gethash buffer-name (crdt--session-buffer-table crdt--session)))) + (crdt--refresh-users-maybe)) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) + +(defun crdt--network-filter (process string) + "Network filter function for CRDT network processes. +Handle received STRING from PROCESS." + (unless (and (process-buffer process) + (buffer-live-p (process-buffer process))) + (set-process-buffer process (generate-new-buffer "*crdt-server*")) + (set-marker (process-mark process) 1)) + (with-current-buffer (process-buffer process) + (unless crdt--session + (setq crdt--session (process-get process 'crdt-session))) + (save-excursion + (goto-char (process-mark process)) + (insert string) + (set-marker (process-mark process) (point)) + (goto-char (point-min)) + (let (message) + (while (setq message (ignore-errors (read (current-buffer)))) + (when crdt--log-network-traffic + (print message)) + (cl-macrolet ((body () + '(if (or (not (crdt--server-p)) (process-get process 'authenticated)) + (let ((crdt--inhibit-update t)) + (crdt-process-message message process)) + (cl-block nil + (when (eq (car message) 'hello) + (cl-destructuring-bind (name &optional response) (cdr message) + (when (or (not (process-get process 'password)) ; server password is empty + (and response (string-equal response (process-get process 'challenge)))) + (process-put process 'authenticated t) + (process-put process 'client-name name) + (crdt--greet-client process) + (cl-return)))) + (let ((challenge (crdt--generate-challenge))) + (process-put process 'challenge + (gnutls-hash-mac 'SHA1 (substring (process-get process 'password)) challenge)) + (process-send-string process (crdt--format-message `(challenge ,challenge)))))))) + (if debug-on-error (body) + (condition-case err (body) + (error (message "%s error when processing message from %s:%s, disconnecting." err + (process-contact process :host) (process-contact process :service)) + (if (crdt--server-p) + (delete-process process) + (crdt--stop-session crdt--session)))))) + (delete-region (point-min) (point)) + (goto-char (point-min))))))) + +(defun crdt--server-process-sentinel (client _message) + (let ((crdt--session (process-get client 'crdt-session))) + (unless (or (process-contact client :server) ; it's actually server itself + (eq (process-status client) 'open)) + ;; client disconnected + (setf (crdt--session-network-clients crdt--session) + (delq client (crdt--session-network-clients crdt--session))) + (when (process-buffer client) (kill-buffer (process-buffer client))) + ;; generate a clear cursor message and a clear contact message + (let* ((client-id (process-get client 'client-id)) + (clear-contact-message `(contact ,client-id nil))) + (crdt-process-message clear-contact-message client) + (maphash + (lambda (k _) + (crdt-process-message + `(cursor ,k ,client-id 1 nil 1 nil) + client)) + (crdt--session-buffer-table crdt--session)) + (crdt--refresh-users-maybe))))) + +(defun crdt--client-process-sentinel (process _message) + (unless (eq (process-status process) 'open) + (when (process-get process 'tuntox-process) + (process-send-string process (crdt--format-message '(leave)))) + (crdt--stop-session (process-get process 'crdt-session)))) + +;;; UI commands + +(defun crdt--read-name (&optional session-name) + "Read display name from minibuffer or use the default display name. +The behavior is controlled by CRDT-ASK-FOR-NAME. +SESSION-NAME if provided is used in the prompt." + (if crdt-ask-for-name + (let ((input (read-from-minibuffer + (format "Display name%s (default %S): " + (if session-name (concat " for " session-name) "") + crdt-default-name)))) + (if (> (length input) 0) input crdt-default-name)) + crdt-default-name)) + +(defun crdt--share-buffer (buffer session) + "Add BUFFER to CRDT SESSION." + (if (process-contact (crdt--session-network-process session) :server) + (with-current-buffer buffer + (setq crdt--session session) + (puthash (buffer-name buffer) buffer (crdt--session-buffer-table crdt--session)) + (setq crdt--buffer-network-name (buffer-name buffer)) + (crdt-mode) + (save-excursion + (widen) + (let ((crdt--inhibit-update t)) + (with-silent-modifications + (crdt--local-insert (point-min) (point-max)))) + (crdt--broadcast-maybe + (crdt--format-message `(add + ,crdt--buffer-network-name)))) + (add-hook 'kill-buffer-hook #'crdt-stop-share-buffer nil t) + (crdt--refresh-buffers-maybe) + (crdt--refresh-sessions-maybe)) + (error "Only server can add new buffer"))) + +(defsubst crdt--get-session-names (server) + "Get session names for CRDT sessions (as in CRDT--SESSION-LIST). +If SERVER is non-NIL, return the list of names for server sessions. +Otherwise, return the list of names for client sessions." + (let (session-names) + (dolist (session crdt--session-list) + (when (eq (crdt--server-p session) server) + (push (crdt--session-name session) session-names))) + (nreverse session-names))) + +(defsubst crdt--get-session (name) + "Get the CRDT session object with NAME." + (cl-find name crdt--session-list + :test 'equal :key #'crdt--session-name)) + +(defun crdt-share-buffer (session-name) + "Share the current buffer in the CRDT session with name SESSION-NAME. +Create a new one if such a CRDT session doesn't exist. +If SESSION-NAME is empty, use the buffer name of the current buffer." + (interactive + (progn + (when (and crdt-mode crdt--session) + (error "Current buffer is already shared in a CRDT session")) + (list (let* ((session-names (crdt--get-session-names t)) + (default-name (concat crdt-default-name ":" (buffer-name (current-buffer)))) + (session-name (if session-names + (completing-read "Choose a server session (create if not exist): " + session-names) + (read-from-minibuffer + (format "New session name (default %s): " default-name))))) + (unless (and session-name (> (length session-name) 0)) + (setq session-name default-name)) + session-name)))) + (let ((session (crdt--get-session session-name))) + (if session + (crdt--share-buffer (current-buffer) session) + (let ((port (read-from-minibuffer "Create new session on port (default 6530): " nil nil t nil "6530"))) + (when (not (numberp port)) + (error "Port must be a number")) + (crdt--share-buffer (current-buffer) (crdt-new-session port session-name)))))) + +(defun crdt-stop-share-buffer () + "Stop sharing the current buffer." + (interactive) + (if crdt--session + (if (crdt--server-p) + (let ((buffer-name crdt--buffer-network-name)) + (let ((remove-message `(remove ,buffer-name))) + (crdt-process-message remove-message nil))) + (message "Only server can stop sharing a buffer.")) + (message "Not a CRDT shared buffer."))) + +(defun crdt-new-session (port session-name &optional password display-name) + "Start a new CRDT session on PORT with SESSION-NAME. +Setup up the server with PASSWORD and assign this Emacs DISPLAY-NAME." + (let* ((network-process (make-network-process + :name "CRDT Server" + :server t + :family 'ipv4 + :host "0.0.0.0" + :service port + :filter #'crdt--network-filter + :sentinel #'crdt--server-process-sentinel)) + (new-session + (crdt--make-session :local-id 0 + :local-clock 0 + :next-client-id 1 + :local-name (or display-name (crdt--read-name)) + :contact-table (make-hash-table :test 'equal) + :buffer-table (make-hash-table :test 'equal) + :name session-name + :network-process network-process)) + (tuntox-p (or (eq crdt-use-tuntox t) + (and (eq crdt-use-tuntox 'confirm) + (yes-or-no-p "Start a tuntox proxy for this session? "))))) + (process-put network-process 'crdt-session new-session) + (push new-session crdt--session-list) + (unless password + (setq password + (when crdt-ask-for-password + (read-from-minibuffer "Set password (empty for no authentication): ")))) + (if tuntox-p + (let ((proxy-process + (make-process :name "Tuntox Proxy" + :buffer (generate-new-buffer "*Tuntox Proxy*") + :command + `(,crdt-tuntox-executable + "-C" ,crdt-tuntox-key-path + "-f" "/dev/stdin" ; do the filtering for safety sake + ,@ (when (and password (> (length password) 0)) + `("-s" ,password)))))) + (process-put network-process 'tuntox-process proxy-process) + (process-send-string proxy-process (format "127.0.0.1:%s\n" port)) ; only allow connection to our port + (process-send-eof proxy-process) + (switch-to-buffer-other-window (process-buffer proxy-process))) + (when (and password (> (length password) 0)) + (process-put network-process 'password password))) + new-session)) + +(defun crdt--stop-session (session) + "Kill the CRDT SESSION. +Disconnect if it's a client session, or stop serving if it's a server session." + (when (if (and crdt-confirm-stop-session + (crdt--server-p session) + (crdt--session-network-clients session)) + (yes-or-no-p "There are yet connected clients. Stop session? ") + t) + (dolist (client (crdt--session-network-clients session)) + (when (process-live-p client) + (delete-process client)) + (when (process-buffer client) + (kill-buffer (process-buffer client)))) + (when (crdt--session-user-menu-buffer session) + (kill-buffer (crdt--session-user-menu-buffer session))) + (when (crdt--session-buffer-menu-buffer session) + (kill-buffer (crdt--session-buffer-menu-buffer session))) + (maphash + (lambda (_ v) + (when (and v (buffer-live-p v)) + (with-current-buffer v + (setq crdt--session nil) + (crdt-mode 0)))) + (crdt--session-buffer-table session)) + (setq crdt--session-list + (delq session crdt--session-list)) + (crdt--refresh-sessions-maybe) + (let ((proxy-process (process-get (crdt--session-network-process session) 'tuntox-process))) + (when (and proxy-process (process-live-p proxy-process)) + (interrupt-process proxy-process))) + (delete-process (crdt--session-network-process session)) + (message "Disconnected."))) + +(defun crdt-stop-session (&optional session-name) + "Stop sharing the session with SESSION-NAME. +If SESSION-NAME is nil, stop sharing the current session." + (interactive + (list (completing-read "Choose a server session: " + (crdt--get-session-names t) nil t + (when (and crdt--session (crdt--server-p)) + (crdt--session-name crdt--session))))) + (let ((session (if session-name + (crdt--get-session session-name) + crdt--session))) + (crdt--stop-session session))) + +(defun crdt-copy-url (&optional session-name) + "Copy the url for the session with SESSION-NAME. +Currently this only work if a tuntox proxy is used." + (interactive + (list (completing-read "Choose a server session: " + (crdt--get-session-names t) nil t + (when (and crdt--session (crdt--server-p)) + (crdt--session-name crdt--session))))) + (let* ((session (if session-name + (crdt--get-session session-name) + crdt--session)) + (network-process (crdt--session-network-process session)) + (tuntox-process (process-get network-process 'tuntox-process))) + (if tuntox-process + (progn + (kill-new (format "tuntox://%s:%s" + (with-current-buffer (process-buffer tuntox-process) + (save-excursion + (goto-char (point-min)) + (search-forward "Using Tox ID: ") + (let ((start (point))) + (end-of-line) + (buffer-substring-no-properties start (point))))) + (process-contact network-process :service))) + (message "URL copied.")) + (message "No known URL to copy, find out your public IP address yourself!")))) + +(defun crdt-disconnect (&optional session-name) + "Disconnect from the session with SESSION-NAME. +If SESSION-NAME is nil, disconnect from the current session." + (interactive + (list (completing-read "Choose a client session: " + (crdt--get-session-names nil) nil t + (when (and crdt--session (not (crdt--server-p crdt--session))) + (crdt--session-name crdt--session))))) + (let ((session (if session-name + (crdt--get-session session-name) + crdt--session))) + (crdt--stop-session session))) + +(defvar crdt-connect-url-history nil) + +(defun crdt-connect (url &optional display-name) + "Connect to a CRDT server running at URL. +Open a new buffer to display the shared content. +Join with DISPLAY-NAME." + (interactive + (list + (let (parsed-url + (url (read-from-minibuffer "URL: " nil nil nil 'crdt-connect-url-history))) + (when (eq (length url) 0) + (error "Please input a valid URL")) + (setq parsed-url (url-generic-parse-url url)) + (unless (url-type parsed-url) + (setq parsed-url (url-generic-parse-url (concat "tcp://" url)))) + (when (and (not (url-portspec parsed-url)) (member (url-type parsed-url) '("tcp" "tuntox"))) + (let ((port (read-from-minibuffer "Server port (default 6530): " nil nil t nil "6530"))) + (when (not (numberp port)) + (error "Port must be a number")) + (setf (url-portspec parsed-url) port))) + parsed-url))) + (let ((url-type (url-type url)) + address port) + (cl-macrolet ((start-session (&body body) + `(let* ((network-process (make-network-process + :name "CRDT Client" + :buffer (generate-new-buffer "*crdt-client*") + :host address + :family 'ipv4 + :service port + :filter #'crdt--network-filter + :sentinel #'crdt--client-process-sentinel)) + (name-placeholder (format "%s:%s" address port)) + (new-session + (crdt--make-session :local-clock 0 + :local-name (or display-name (crdt--read-name name-placeholder)) + :contact-table (make-hash-table :test 'equal) + :buffer-table (make-hash-table :test 'equal) + :name name-placeholder + :network-process network-process))) + (process-put network-process 'crdt-session new-session) + (push new-session crdt--session-list) + ,@body + (process-send-string network-process + (crdt--format-message `(hello ,(crdt--session-local-name new-session)))) + (let ((crdt--session new-session)) + (crdt-list-buffers))))) + (cond ((equal url-type "tcp") + (setq address (url-host url)) + (setq port (url-portspec url)) + (start-session)) + ((equal url-type "tuntox") + (setq address "127.0.0.1") + (setq port (read-from-minibuffer (format "tuntox proxy port (default %s): " (1+ (url-portspec url))) + nil nil t nil (format "%s" (1+ (url-portspec url))))) + (let ((password (read-passwd "tuntox password (empty for no password): "))) + (switch-to-buffer-other-window + (process-buffer + (make-process + :name "Tuntox Proxy" + :buffer (generate-new-buffer "*Tuntox Proxy*") + :command + `(,crdt-tuntox-executable + "-i" ,(url-host url) + "-L" ,(format "%s:127.0.0.1:%s" port (url-portspec url)) + ,@ (when (> (length password) 0) + `("-s" ,password))) + :filter + (let (initialized) + (lambda (proc string) + (when (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (let ((moving (= (point) (process-mark proc)))) + (save-excursion + (goto-char (process-mark proc)) + (insert string) + (set-marker (process-mark proc) (point)) + (unless initialized + (when (ignore-errors (search-backward "Friend request accepted")) + (setq initialized t) + (start-session (process-put network-process 'tuntox-process proc))))) + (if moving (goto-char (process-mark proc))))))))))))) + (t (error "Unknown protocol \"%s\"" url-type)))))) + +;;; overlay tracking + +(defvar crdt--inhibit-overlay-advices nil) + +(defvar crdt--modifying-overlay-metadata nil) + +(defun crdt--enable-overlay-species (species) + (push species crdt--enabled-overlay-species) + (when crdt-mode + (let ((crdt--inhibit-overlay-advices t)) + (maphash (lambda (_ ov) + (let ((meta (overlay-get ov 'crdt-meta))) + (when (eq species (crdt--overlay-metadata-species meta)) + (cl-loop for (prop value) on (crdt--overlay-metadata-plist meta) by #'cddr + do (overlay-put ov prop value))))) + crdt--overlay-table)))) + +(defun crdt--disable-overlay-species (species) + (setq crdt--enabled-overlay-species (delq species crdt--enabled-overlay-species)) + (when crdt-mode + (let ((crdt--inhibit-overlay-advices t)) + (maphash (lambda (_ ov) + (let ((meta (overlay-get ov 'crdt-meta))) + (when (eq species (crdt--overlay-metadata-species meta)) + (cl-loop for (prop _value) on (crdt--overlay-metadata-plist meta) by #'cddr + do (overlay-put ov prop nil))))) + crdt--overlay-table)))) + +(defun crdt--make-overlay-advice (orig-fun beg end &optional buffer front-advance rear-advance) + (let ((new-overlay (funcall orig-fun beg end buffer front-advance rear-advance))) + ;; should we check if we are in the current buffer? + (when crdt-mode + (when crdt--track-overlay-species + (crdt--broadcast-maybe + (crdt--format-message + (crdt--overlay-add-message (crdt--session-local-id crdt--session) + (crdt--session-local-clock crdt--session) + crdt--track-overlay-species front-advance rear-advance + beg end))) + (let* ((key (cons (crdt--session-local-id crdt--session) + (crdt--session-local-clock crdt--session))) + (meta (crdt--make-overlay-metadata key crdt--track-overlay-species + front-advance rear-advance nil))) + (puthash key new-overlay crdt--overlay-table) + (let ((crdt--inhibit-overlay-advices t) + (crdt--modifying-overlay-metadata t)) + (overlay-put new-overlay 'crdt-meta meta))) + (cl-incf (crdt--session-local-clock crdt--session)))) + new-overlay)) + +(cl-defmethod crdt-process-message ((message (head overlay-add)) process) + (cl-destructuring-bind + (buffer-name site-id logical-clock species + front-advance rear-advance start-hint start-id-base64 end-hint end-id-base64) + (cdr message) + (crdt--with-buffer-name + buffer-name + (let* ((crdt--track-overlay-species nil) + (start (crdt--find-id (base64-decode-string start-id-base64) start-hint front-advance)) + (end (crdt--find-id (base64-decode-string end-id-base64) end-hint rear-advance)) + (new-overlay + (make-overlay start end nil front-advance rear-advance)) + (key (cons site-id logical-clock)) + (meta (crdt--make-overlay-metadata key species + front-advance rear-advance nil))) + (puthash key new-overlay crdt--overlay-table) + (let ((crdt--inhibit-overlay-advices t) + (crdt--modifying-overlay-metadata t)) + (overlay-put new-overlay 'crdt-meta meta))))) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) + +(defun crdt--move-overlay-advice (orig-fun ov beg end &rest args) + (when crdt-mode + (unless crdt--inhibit-overlay-advices + (let ((meta (overlay-get ov 'crdt-meta))) + (when meta ;; to be fixed + (let ((key (crdt--overlay-metadata-lamport-timestamp meta)) + (front-advance (crdt--overlay-metadata-front-advance meta)) + (rear-advance (crdt--overlay-metadata-rear-advance meta))) + (crdt--broadcast-maybe + (crdt--format-message + `(overlay-move ,crdt--buffer-network-name ,(car key) ,(cdr key) + ,beg ,(if front-advance + (base64-encode-string (crdt--get-id beg)) + (crdt--base64-encode-maybe (crdt--get-id (1- beg)))) + ,end ,(if rear-advance + (base64-encode-string (crdt--get-id end)) + (crdt--base64-encode-maybe (crdt--get-id (1- end)))))))))))) + (apply orig-fun ov beg end args)) + +(cl-defmethod crdt-process-message ((message (head overlay-move)) process) + (cl-destructuring-bind (buffer-name site-id logical-clock + start-hint start-id-base64 end-hint end-id-base64) + (cdr message) + (crdt--with-buffer-name + buffer-name + (let* ((key (cons site-id logical-clock)) + (ov (gethash key crdt--overlay-table))) + (when ov + (let* ((meta (overlay-get ov 'crdt-meta)) + (front-advance (crdt--overlay-metadata-front-advance meta)) + (rear-advance (crdt--overlay-metadata-rear-advance meta)) + (start (crdt--find-id (base64-decode-string start-id-base64) start-hint front-advance)) + (end (crdt--find-id (base64-decode-string end-id-base64) end-hint rear-advance))) + (let ((crdt--inhibit-overlay-advices t)) + (move-overlay ov start end))))))) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) + +(defun crdt--delete-overlay-advice (orig-fun ov) + (unless crdt--inhibit-overlay-advices + (when crdt-mode + (let ((meta (overlay-get ov 'crdt-meta))) + (when meta + (let ((key (crdt--overlay-metadata-lamport-timestamp meta))) + (remhash key crdt--overlay-table) + (crdt--broadcast-maybe (crdt--format-message + `(overlay-remove ,crdt--buffer-network-name ,(car key) ,(cdr key))))))))) + (funcall orig-fun ov)) + +(cl-defmethod crdt-process-message ((message (head overlay-remove)) process) + (cl-destructuring-bind (buffer-name site-id logical-clock) (cdr message) + (crdt--with-buffer-name + buffer-name + (let* ((key (cons site-id logical-clock)) + (ov (gethash key crdt--overlay-table))) + (when ov + (remhash key crdt--overlay-table) + (let ((crdt--inhibit-overlay-advices t)) + (delete-overlay ov)))))) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) + +(defun crdt--overlay-put-advice (orig-fun ov prop value) + (unless (and (eq prop 'crdt-meta) + (not crdt--modifying-overlay-metadata)) + (when crdt-mode + (unless crdt--inhibit-overlay-advices + (let ((meta (overlay-get ov 'crdt-meta))) + (when meta + (setf (crdt--overlay-metadata-plist meta) (plist-put (crdt--overlay-metadata-plist meta) prop value)) + (let* ((key (crdt--overlay-metadata-lamport-timestamp meta)) + (message (crdt--format-message `(overlay-put ,crdt--buffer-network-name + ,(car key) ,(cdr key) ,prop ,value)))) + (condition-case nil + (progn ; filter non-readable object + (read-from-string message) + (crdt--broadcast-maybe message)) + (invalid-read-syntax))))))) + (funcall orig-fun ov prop value))) + +(cl-defmethod crdt-process-message ((message (head overlay-put)) process) + (cl-destructuring-bind (buffer-name site-id logical-clock prop value) (cdr message) + (crdt--with-buffer-name + buffer-name + (let ((ov (gethash (cons site-id logical-clock) crdt--overlay-table))) + (when ov + (let ((meta (overlay-get ov 'crdt-meta))) + (setf (crdt--overlay-metadata-plist meta) + (plist-put (crdt--overlay-metadata-plist meta) prop value)) + (when (memq (crdt--overlay-metadata-species meta) crdt--enabled-overlay-species) + (let ((crdt--inhibit-overlay-advices t)) + (overlay-put ov prop value)))))))) + (crdt--broadcast-maybe (crdt--format-message message) (process-get process 'client-id))) + +(advice-add 'make-overlay :around #'crdt--make-overlay-advice) + +(advice-add 'move-overlay :around #'crdt--move-overlay-advice) + +(advice-add 'delete-overlay :around #'crdt--delete-overlay-advice) + +(advice-add 'overlay-put :around #'crdt--overlay-put-advice) + +;;; Org integration + +(define-minor-mode crdt-org-sync-overlay-mode "" + nil " Sync Org Overlay" nil + (if crdt-org-sync-overlay-mode + (progn + (save-excursion + (widen) + ;; heuristic to remove existing org overlays + (cl-loop for ov in (overlays-in (point-min) (point-max)) + do (when (memq (overlay-get ov 'invisible) + '(outline org-hide-block)) + (delete-overlay ov)))) + (crdt--enable-overlay-species 'org)) + (crdt--disable-overlay-species 'org))) + +(defun crdt--org-overlay-advice (orig-fun &rest args) + (if crdt-org-sync-overlay-mode + (let ((crdt--track-overlay-species 'org)) + (apply orig-fun args)) + (apply orig-fun args))) + +(cl-loop for command in '(org-cycle org-shifttab) + do (advice-add command :around #'crdt--org-overlay-advice)) + +(provide 'crdt) +;;; crdt.el ends here diff --git a/lisp/ctable.el b/lisp/ctable.el new file mode 100644 index 00000000..e97924b4 --- /dev/null +++ b/lisp/ctable.el @@ -0,0 +1,1925 @@ +;;; ctable.el --- Table component for Emacs Lisp + +;; Copyright (C) 2011, 2012, 2013, 2014 SAKURAI Masashi + +;; Author: SAKURAI Masashi +;; URL: https://github.com/kiwanami/emacs-ctable +;; Package-Version: 20171006.11 +;; Version: 0.1.2 +;; Keywords: table + +;; 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 . + +;;; Commentary: + +;; This program is a table component for Emacs Lisp. +;; Other programs can use this table component for the application UI. + +;;; Installation: + +;; Place this program in your load path and add following code. + +;; (require 'ctable) + +;;; Usage: + +;; Executing the command `ctbl:open-table-buffer', switch to the table buffer. + +;; Table data which are shown in the table view, are collected +;; by the `ctbl:model' objects. See the function `ctbl:demo' for example. +;; See the README document for the details. + +;;; Code: + +(require 'cl) + +(declare-function popup-tip "popup") +(declare-function pos-tip-show "pos-tip") + + +;;; Models and Parameters + +(defstruct ctbl:model + "Table model structure + +data : Table data as a list of rows. A row contains a list of columns. + If an instance of `ctbl:async-model' is given, the model is built up asynchronously. +column-model : A list of column models. +sort-state : The current sort order as a list of column indexes. + The index number of the first column is 1. + If the index is negative, the sort order is reversed." + data column-model sort-state) + + +(defstruct ctbl:async-model + "Asynchronous data model + +request : Data request function which receives 4 arguments (begin-num length fn(row-list) fe(errmsg)). + This function should return the next data which begins with `begin-num' and has the length + as `length', evaluating the continuation function `fn' with the data. + If the function `fn' is given `nil', it means no more data. + If the error function `fe' is evaluated with `errmsg', the message is displayed for the user. +init-num : Initial row number. (Default 20) +more-num : Increase row number. (Default 20) +reset : Reset function which is called when user executes update command. (Can be nil) +cancel : Cancel function of data requesting. (Can be nil) + +For forward compatibility, these callback functions should have a `&rest' keyword at the end of argument list. +" + request (init-num 20) (more-num 20) reset cancel) + + +(defstruct ctbl:cmodel + "Table column model structure + +title : title string. +sorter : sorting function which transforms a cell value into sort value. + It should return -1, 0 and 1. If nil, `ctbl:sort-string-lessp' is used. +align : text alignment: 'left, 'right and 'center. (default: right) +max-width : maximum width of the column. if nil, no constraint. (default: nil) +min-width : minimum width of the column. if nil, no constraint. (default: nil) +click-hooks : a list of functions for header clicking with two arguments + the `ctbl:component' object and the `ctbl:cmodel' one. + (default: '(`ctbl:cmodel-sort-action'))" + title sorter align max-width min-width + (click-hooks '(ctbl:cmodel-sort-action))) + + +(defstruct ctbl:param + "Rendering parameters + +display-header : if t, display the header row with column models. +fixed-header : if t, display the header row in the header-line area. +bg-colors : '(((row-id . col-id) . colorstr) (t . default-color) ... ) or (lambda (model row-id col-id) colorstr or nil) +vline-colors : \"#RRGGBB\" or '((0 . colorstr) (t . default-color)) or (lambda (model col-index) colorstr or nil) +hline-colors : \"#RRGGBB\" or '((0 . colorstr) (t . default-color)) or (lambda (model row-index) colorstr or nil) +draw-vlines : 'all or '(0 1 2 .. -1) or (lambda (model col-index) t or nil ) +draw-hlines : 'all or '(0 1 2 .. -1) or (lambda (model row-index) t or nil ) +vertical-line horizontal-line : | - +left-top-corner right-top-corner left-bottom-corner right-bottom-corner : + +top-junction bottom-junction left-junction right-junction cross-junction : +" + display-header fixed-header + bg-colors vline-colors hline-colors draw-vlines draw-hlines vertical-line horizontal-line + left-top-corner right-top-corner left-bottom-corner right-bottom-corner + top-junction bottom-junction left-junction right-junction cross-junction) + +(defvar ctbl:completing-read 'completing-read + "Customize for completing-read function. + +To use `ido-completing-read', put the following sexp into your +Emacs init file: + +(eval-after-load 'ido + '(progn + (setq ctbl:completing-read 'ido-completing-read)))") + + +(defvar ctbl:default-rendering-param + (make-ctbl:param + :display-header t + :fixed-header nil + :bg-colors nil + :vline-colors "DarkGray" + :hline-colors "DarkGray" + :draw-vlines 'all + :draw-hlines '(1) + :vertical-line ?| + :horizontal-line ?- + :left-top-corner ?+ + :right-top-corner ?+ + :left-bottom-corner ?+ + :right-bottom-corner ?+ + :top-junction ?+ + :bottom-junction ?+ + :left-junction ?+ + :right-junction ?+ + :cross-junction ?+ + ) + "Default rendering parameters.") + +(defvar ctbl:tooltip-method '(pos-tip popup minibuffer) + "Preferred tooltip methods in order.") + +(defvar ctbl:component) +(defvar ctbl:header-text) + +;;; Faces + +(defface ctbl:face-row-select + '((((class color) (background light)) + :background "WhiteSmoke") + (((class color) (background dark)) + :background "Blue4")) + "Face for row selection" :group 'ctable) + +(defface ctbl:face-cell-select + '((((class color) (background light)) + :background "Mistyrose1") + (((class color) (background dark)) + :background "Blue2")) + "Face for cell selection" :group 'ctable) + +(defface ctbl:face-continue-bar + '((((class color) (background light)) + :background "OldLace") + (((class color) (background dark)) + :background "Gray26")) + "Face for continue bar" :group 'ctable) + +;;; Utilities + +(defun ctbl:define-keymap (keymap-list &optional prefix) + "[internal] Keymap utility." + (let ((map (make-sparse-keymap))) + (mapc + (lambda (i) + (define-key map + (if (stringp (car i)) + (read-kbd-macro + (if prefix + (replace-regexp-in-string "prefix" prefix (car i)) + (car i))) + (car i)) + (cdr i))) + keymap-list) + map)) + +(defun ctbl:cell-id (row-id col-id) + "[internal] Create a cell-id object" + (cons row-id col-id)) + +(defun ctbl:tp (text prop value) + "[internal] Put a text property to the entire text string." + (if (< 0 (length text)) + (put-text-property 0 (length text) prop value text)) + text) + +(defvar ctbl:uid 1) + +(defun ctbl:uid () + "[internal] Generate an unique number." + (incf ctbl:uid)) + +(defun ctbl:fill-keymap-property (begin end keymap) + "[internal] Put the given text property to the region between BEGIN and END. +If the text already has some keymap property, the text is skipped." + (save-excursion + (goto-char begin) + (loop with pos = begin with nxt = nil + until (or (null pos) (<= end pos)) + when (get-text-property pos 'keymap) do + (setq pos (next-single-property-change pos 'keymap)) + else do + (setq nxt (next-single-property-change pos 'keymap)) + (when (null nxt) (setq nxt end)) + (put-text-property pos (min nxt end) 'keymap keymap)))) + +;; Model functions + +(defun ctbl:model-column-length (model) + "[internal] Return the column number." + (length (ctbl:model-column-model model))) + +(defun ctbl:model-row-length (model) + "[internal] Return the row number." + (length (ctbl:model-data model))) + +(defun ctbl:model-modify-sort-key (model col-index) + "Modify the list of sort keys for the column headers." + (let* ((sort-keys (ctbl:model-sort-state model)) + (col-key (1+ col-index))) + (cond + ((eq (car sort-keys) col-key) + (setf (ctbl:model-sort-state model) + (cons (- col-key) (cdr sort-keys)))) + ((eq (car sort-keys) (- col-key)) + (setf (ctbl:model-sort-state model) + (cons col-key (cdr sort-keys)))) + (t + (setf (ctbl:model-sort-state model) + (cons col-key (delete (- col-key) + (delete col-key sort-keys)))))) + (ctbl:model-sort-state model))) + +(defun ctbl:cmodel-sort-action (cp col-index) + "Sorting action for click on the column headers. +If data is an instance of `ctbl:async-model', this function do nothing." + (let* ((model (ctbl:cp-get-model cp))) + (unless (ctbl:async-model-p (ctbl:model-data model)) + (ctbl:model-modify-sort-key model col-index) + (ctbl:cp-update cp)))) + + +;;; ctable framework + +;; Component + +(defstruct ctbl:component + "Component + +This structure defines attributes of the table component. +These attributes are internal use. Other programs should access +through the functions of the component interface. + +dest : an object of `ctbl:dest' +model : an object of the table model +selected : selected cell-id: (row index . col index) +param : rendering parameter object +sorted-data : sorted data to display the table view. + see `ctbl:cp-get-selected-data-row' and `ctbl:cp-get-selected-data-cell'. +update-hooks : a list of hook functions for update event +selection-change-hooks : a list of hook functions for selection change event +click-hooks : a list of hook functions for click event +states : alist of arbitrary data for internal use" + dest model param selected sorted-data + update-hooks selection-change-hooks click-hooks states) + + +;; Rendering Destination + +(defstruct ctbl:dest + "Rendering Destination + +This structure object is the abstraction of the rendering +destinations, such as buffers, regions and so on. + +type : identify symbol for destination type. (buffer, region, text) +buffer : a buffer object of rendering destination. +min-func : a function that returns upper limit of rendering destination. +max-func : a function that returns lower limit of rendering destination. +width : width of the reference size. (number, nil or full) +height : height of the reference size. (number, nil or full) +clear-func : a function that clears the rendering destination. +before-update-func : a function that is called at the beginning of rendering routine. +after-update-func : a function that is called at the end of rendering routine. +select-ol : a list of overlays for selection" + type buffer min-func max-func width height + clear-func before-update-func after-update-func select-ol) + +(eval-when-compile + (defmacro ctbl:dest-with-region (dest &rest body) + (declare (debug (form &rest form))) + (let (($dest (gensym))) + `(let ((,$dest ,dest)) + (with-current-buffer (ctbl:dest-buffer ,$dest) + (save-restriction + (narrow-to-region + (ctbl:dest-point-min ,$dest) (ctbl:dest-point-max ,$dest)) + ,@body)))))) +(put 'ctbl:dest-with-region 'lisp-indent-function 1) + +(defun ctbl:dest-point-min (c) + (funcall (ctbl:dest-min-func c))) + +(defun ctbl:dest-point-max (c) + (funcall (ctbl:dest-max-func c))) + +(defun ctbl:dest-clear (c) + (funcall (ctbl:dest-clear-func c))) + +(defun ctbl:dest-before-update (c) + (when (ctbl:dest-before-update-func c) + (funcall (ctbl:dest-before-update-func c)))) + +(defun ctbl:dest-after-update (c) + (when (ctbl:dest-after-update-func c) + (funcall (ctbl:dest-after-update-func c)))) + + +;; Buffer + +(defconst ctbl:table-buffer-name "*ctbl-table*" "[internal] Default buffer name for the table view.") + +(defun ctbl:dest-init-buffer (&optional buf width height custom-map) + "Create a buffer destination. +This destination uses an entire buffer and set up the major-mode +`ctbl:table-mode' and the key map `ctbl:table-mode-map'. BUF is +a buffer name to render the table view. If BUF is nil, the +default buffer name is used. WIDTH and HEIGHT are reference size +of the table view. If those are nil, the size of table is +calculated from the window that shows BUF or the selected window. +The component object is stored at the buffer local variable +`ctbl:component'. CUSTOM-MAP is the additional keymap that is +added to default keymap `ctbl:table-mode-map'." + (lexical-let + ((buffer (or buf (get-buffer-create (format "*Table: %d*" (ctbl:uid))))) + (window (or (and buf (get-buffer-window buf)) (selected-window))) + dest) + (setq dest + (make-ctbl:dest + :type 'buffer + :min-func 'point-min + :max-func 'point-max + :buffer buffer + :width width + :height height + :clear-func (lambda () + (with-current-buffer buffer + (erase-buffer))))) + (with-current-buffer buffer + (unless (eq major-mode 'ctbl:table-mode) + (ctbl:table-mode custom-map))) + dest)) + +;; Region + +(defun ctbl:dest-init-region (buf mark-begin mark-end &optional width height) + "Create a region destination. The table is drew between +MARK-BEGIN and MARK-END in the buffer BUF. MARK-BEGIN and +MARK-END are separated by more than one character, such as a +space. This destination is employed to be embedded in the some +application buffer. Because this destination does not set up +any modes and key maps for the buffer, the application that uses +the ctable is responsible to manage the buffer and key maps." + (lexical-let + ((mark-begin mark-begin) (mark-end mark-end) + (window (or (get-buffer-window buf) (selected-window)))) + (make-ctbl:dest + :type 'region + :min-func (lambda () (marker-position mark-begin)) + :max-func (lambda () (marker-position mark-end)) + :buffer buf + :width width + :height height + :clear-func + (lambda () + (ctbl:dest-region-clear (marker-position mark-begin) + (marker-position mark-end)))))) + +(defun ctbl:dest-region-clear (begin end) + "[internal] Clear the content text." + (when (< 2 (- end begin)) + (delete-region begin (1- end))) + (goto-char begin)) + +;; Inline text + +(defconst ctbl:dest-background-buffer " *ctbl:dest-background*") + +(defun ctbl:dest-init-inline (width height) + "Create a text destination." + (lexical-let + ((buffer (get-buffer-create ctbl:dest-background-buffer)) + (window (selected-window)) + dest) + (setq dest + (make-ctbl:dest + :type 'text + :min-func 'point-min + :max-func 'point-max + :buffer buffer + :width width + :height height + :clear-func (lambda () + (with-current-buffer buffer + (erase-buffer))))) + dest)) + +;; private functions + +(defun ctbl:dest-ol-selection-clear (dest) + "[internal] Clear the selection overlays on the current table view." + (loop for i in (ctbl:dest-select-ol dest) + do (delete-overlay i)) + (setf (ctbl:dest-select-ol dest) nil)) + +(defun ctbl:dest-ol-selection-set (dest cell-id) + "[internal] Put a selection overlay on CELL-ID. The selection overlay can be + put on some cells, calling this function many times. This + function does not manage the selections, just put the overlay." + (lexical-let (ols (row-id (car cell-id)) (col-id (cdr cell-id))) + (ctbl:dest-with-region dest + (ctbl:find-all-by-row-id + dest row-id + (lambda (tcell-id begin end) + (let ((overlay (make-overlay begin end))) + (overlay-put overlay 'face + (if (= (cdr tcell-id) col-id) + 'ctbl:face-cell-select + 'ctbl:face-row-select)) + (push overlay ols))))) + (setf (ctbl:dest-select-ol dest) ols))) + + +;; Component implementation + +(defun ctbl:cp-new (dest model param) + "[internal] Create a new component object. +DEST is a ctbl:dest object. MODEL is a model object. PARAM is a +rendering parameter object. This function is called by the +initialization functions, `ctbl:create-table-component-buffer', +`ctbl:create-table-component-region' and `ctbl:get-table-text'." + (let ((cp (make-ctbl:component + :selected '(0 . 0) + :dest dest + :model model + :param (or param ctbl:default-rendering-param)))) + (ctbl:cp-update cp) + cp)) + +(defun ctbl:cp-get-component () + "Return the component object on the current cursor position. +Firstly, getting a text property `ctbl:component' on the current +position. If no object is found in the text property, the buffer +local variable `ctbl:component' is tried to get. If no object is +found at the variable, return nil." + (let ((component (get-text-property (point) 'ctbl:component))) + (unless component + (unless (local-variable-p 'ctbl:component (current-buffer)) + (error "Not found ctbl:component attribute...")) + (setq component (buffer-local-value 'ctbl:component (current-buffer)))) + component)) + +;; Component : getters + +(defun ctbl:cp-get-selected (component) + "Return the selected cell-id of the component." + (ctbl:component-selected component)) + +(defun ctbl:cp-get-selected-data-row (component) + "Return the selected row data. If no cell is selected, return nil." + (let* ((rows (ctbl:component-sorted-data component)) + (cell-id (ctbl:component-selected component)) + (row-id (car cell-id)) (col-id (cdr cell-id))) + (if row-id (nth row-id rows) nil))) + +(defun ctbl:cp-get-selected-data-cell (component) + "Return the selected cell data. If no cell is selected, return nil." + (let* ((rows (ctbl:component-sorted-data component)) + (cell-id (ctbl:component-selected component)) + (row-id (car cell-id)) (col-id (cdr cell-id))) + (if row-id + (nth col-id (nth row-id rows)) + nil))) + +(defun ctbl:cp-get-model (component) + "Return the model object." + (ctbl:component-model component)) + +(defun ctbl:cp-set-model (component model) + "Replace the model object and update the destination." + (setf (ctbl:component-model component) model) + (ctbl:cp-update component)) + +(defun ctbl:cp-get-param (component) + "Return a rendering parameter object." + (ctbl:component-param component)) + +(defun ctbl:cp-get-buffer (component) + "Return a buffer object on which the component draws the content." + (ctbl:dest-buffer (ctbl:component-dest component))) + +;; Component : setters + +(defun ctbl:cp-move-cursor (dest cell-id) + "[internal] Just move the cursor onto the CELL-ID. +If CELL-ID is not found, return nil. This function +is called by `ctbl:cp-set-selected-cell'." + (let ((pos (ctbl:find-by-cell-id dest cell-id))) + (cond + (pos + (goto-char pos) + (unless (eql (selected-window) (get-buffer-window (current-buffer))) + (set-window-point (get-buffer-window (current-buffer)) pos)) + t) + (t nil)))) + +(defun ctbl:cp-set-selected-cell (component cell-id) + "Select the cell on the component. If the current view doesn't contain the cell, +this function updates the view to display the cell." + (let ((last (ctbl:component-selected component)) + (dest (ctbl:component-dest component)) + (model (ctbl:component-model component))) + (when (ctbl:cp-move-cursor dest cell-id) + (setf (ctbl:component-selected component) cell-id) + (ctbl:dest-before-update dest) + (ctbl:dest-ol-selection-clear dest) + (ctbl:dest-ol-selection-set dest cell-id) + (ctbl:dest-after-update dest) + (unless (equal last cell-id) + (ctbl:cp-fire-selection-change-hooks component))))) + +;; Hook + +(defun ctbl:cp-add-update-hook (component hook) + "Add the update hook function to the component. +HOOK is a function that has no argument." + (push hook (ctbl:component-update-hooks component))) + +(defun ctbl:cp-add-selection-change-hook (component hook) + "Add the selection change hook function to the component. +HOOK is a function that has no argument." + (push hook (ctbl:component-selection-change-hooks component))) + +(defun ctbl:cp-add-click-hook (component hook) + "Add the click hook function to the component. +HOOK is a function that has no argument." + (push hook (ctbl:component-click-hooks component))) + +;; update + +(defun ctbl:cp-update (component) + "Clear and re-draw the component content." + (let* ((buf (ctbl:cp-get-buffer component)) + (dest (ctbl:component-dest component))) + (with-current-buffer buf + (ctbl:dest-before-update dest) + (ctbl:dest-ol-selection-clear dest) + (let (buffer-read-only) + (ctbl:dest-with-region dest + (ctbl:dest-clear dest) + (cond + ;; asynchronous model + ((ctbl:async-model-p + (ctbl:model-data (ctbl:component-model component))) + (lexical-let ((cp component)) + (ctbl:async-state-on-update cp) + (ctbl:render-async-main + dest + (ctbl:component-model component) + (ctbl:component-param component) + (lambda (rows &optional astate) + (setf (ctbl:component-sorted-data cp) rows) + (when astate + (ctbl:cp-states-set cp 'async-state astate)))))) + ;; synchronous model + (t + (setf (ctbl:component-sorted-data component) + (ctbl:render-main + dest + (ctbl:component-model component) + (ctbl:component-param component))))))) + (ctbl:cp-set-selected-cell + component (ctbl:component-selected component)) + (ctbl:dest-after-update dest) + (ctbl:cp-fire-update-hooks component)))) + +;; Component : privates + +(defun ctbl:cp-states-get (component key) + "[internal] Get a value from COMPONENT with KEY." + (cdr (assq key (ctbl:component-states component)))) + +(defun ctbl:cp-states-set (component key value) + "[internal] Set a value with KEY." + (let ((pair (assq key (ctbl:component-states component)))) + (cond + ((null pair) + (push (cons key value) (ctbl:component-states component))) + (t + (setf (cdr pair) value))))) + +(defun ctbl:cp-fire-click-hooks (component) + "[internal] Call click hook functions of the component with no arguments." + (loop for f in (ctbl:component-click-hooks component) + do (condition-case err + (funcall f) + (error (message "CTable: Click / Hook error %S [%s]" f err))))) + +(defun ctbl:cp-fire-selection-change-hooks (component) + "[internal] Call selection change hook functions of the component with no arguments." + (loop for f in (ctbl:component-selection-change-hooks component) + do (condition-case err + (funcall f) + (error (message "CTable: Selection change / Hook error %S [%s]" f err))))) + +(defun ctbl:cp-fire-update-hooks (component) + "[internal] Call update hook functions of the component with no arguments." + (loop for f in (ctbl:component-update-hooks component) + do (condition-case err + (funcall f) + (error (message "Ctable: Update / Hook error %S [%s]" f err))))) + +(defun ctbl:find-position-fast (dest cell-id) + "[internal] Find the cell-id position using bi-section search." + (let* ((row-id (car cell-id)) + (row-id-lim (max (- row-id 10) 0)) + (min (ctbl:dest-point-min dest)) + (max (ctbl:dest-point-max dest)) + (mid (/ (+ min max) 2))) + (save-excursion + (loop for next = (next-single-property-change mid 'ctbl:cell-id nil max) + for cur-row-id = (and next (car (ctbl:cursor-to-cell next))) + do + (cond + ((>= next max) (return (point))) + ((null cur-row-id) (setq mid next)) + ((= cur-row-id row-id) + (goto-char mid) (beginning-of-line) + (return (point))) + ((and (< row-id-lim cur-row-id) (< cur-row-id row-id)) + (goto-char mid) (beginning-of-line) (forward-line) + (return (point))) + ((< cur-row-id row-id) + (setq min mid) + (setq mid (/ (+ min max) 2))) + ((< row-id cur-row-id) + (setq max mid) + (setq mid (/ (+ min max) 2)))))))) + +(defun ctbl:find-by-cell-id (dest cell-id) + "[internal] Return a point where the text property `ctbl:cell-id' +is equal to cell-id in the current table view. If CELL-ID is not +found in the current view, return nil." + (loop with pos = (ctbl:find-position-fast dest cell-id) + with end = (ctbl:dest-point-max dest) + for next = (next-single-property-change pos 'ctbl:cell-id nil end) + for text-cell = (and next (ctbl:cursor-to-cell next)) + while (and next (< next end)) do + (if (and text-cell (equal cell-id text-cell)) + (return next)) + (setq pos next))) + +(defun ctbl:find-all-by-cell-id (dest cell-id func) + "[internal] Call the function FUNC in each regions where the +text-property `ctbl:cell-id' is equal to CELL-ID. The argument function FUNC +receives two arguments, begin position and end one. This function is +mainly used at functions for putting overlays." + (loop with pos = (ctbl:find-position-fast dest cell-id) + with end = (ctbl:dest-point-max dest) + for next = (next-single-property-change pos 'ctbl:cell-id nil end) + for text-id = (and next (ctbl:cursor-to-cell next)) + while (and next (< next end)) do + (if (and text-id (equal cell-id text-id)) + (let ((cend (next-single-property-change + next 'ctbl:cell-id nil end))) + (return (funcall func next cend)))) + (setq pos next))) + +(defun ctbl:find-all-by-row-id (dest row-id func) + "[internal] Call the function FUNC in each regions where the +row-id of the text-property `ctbl:cell-id' is equal to +ROW-ID. The argument function FUNC receives three arguments, +cell-id, begin position and end one. This function is mainly used +at functions for putting overlays." + (loop with pos = (ctbl:find-position-fast dest (cons row-id nil)) + with end = (ctbl:dest-point-max dest) + for next = (next-single-property-change pos 'ctbl:cell-id nil end) + for text-id = (and next (ctbl:cursor-to-cell next)) + while (and next (< next end)) do + (when text-id + (cond + ((equal row-id (car text-id)) + (let ((cend (next-single-property-change + next 'ctbl:cell-id nil end))) + (funcall func text-id next cend))) + ((< row-id (car text-id)) + (return nil)))) + (setq pos next))) + +(defun ctbl:find-first-cell (dest) + "[internal] Return the first cell in the current buffer." + (let ((pos (next-single-property-change + (ctbl:dest-point-min dest) 'ctbl:cell-id))) + (and pos (ctbl:cursor-to-cell pos)))) + +(defun ctbl:find-last-cell (dest) + "[internal] Return the last cell in the current buffer." + (let ((pos (previous-single-property-change + (ctbl:dest-point-max dest) 'ctbl:cell-id))) + (and pos (ctbl:cursor-to-cell (1- pos))))) + +(defun ctbl:cursor-to-cell (&optional pos) + "[internal] Return the cell-id at the cursor. If the text does not +have the text-property `ctbl:cell-id', return nil." + (get-text-property (or pos (point)) 'ctbl:cell-id)) + +(defun ctbl:cursor-to-nearest-cell () + "Return the cell-id at the cursor. If the point of cursor does +not have the cell-id, search the cell-id around the cursor +position. If the current buffer is not table view (it may be +bug), this function may return nil." + (or (ctbl:cursor-to-cell) + (let* ((r (lambda () (when (not (eolp)) (forward-char)))) + (l (lambda () (when (not (bolp)) (backward-char)))) + (u (lambda () (when (not (bobp)) (line-move 1)))) + (d (lambda () (when (not (eobp)) (line-move -1)))) + (dest (ctbl:component-dest (ctbl:cp-get-component))) + get) + (setq get (lambda (cmds) + (save-excursion + (if (null cmds) (ctbl:cursor-to-cell) + (ignore-errors + (funcall (car cmds)) (funcall get (cdr cmds))))))) + (or (loop for i in `((,d) (,r) (,u) (,l) + (,d ,r) (,d ,l) (,u ,r) (,u ,l) + (,d ,d) (,r ,r) (,u ,u) (,l ,l)) + for id = (funcall get i) + if id return id) + (cond + ((> (/ (point-max) 2) (point)) + (ctbl:find-first-cell dest)) + (t (ctbl:find-last-cell dest))))))) + + +;; Commands + +(defun ctbl:navi-move-gen (drow dcol) + "[internal] Move to the cell with the abstract position." + (let* ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell)) + (row-id (car cell-id)) (col-id (cdr cell-id))) + (when (and cp cell-id) + (ctbl:navi-goto-cell (ctbl:cell-id (+ drow row-id) + (+ dcol col-id)))))) + +(defun ctbl:navi-move-up (&optional num) + "Move to the up neighbor cell." + (interactive "p") + (unless num (setq num 1)) + (ctbl:navi-move-gen (- num) 0)) + +(defun ctbl:navi-move-down (&optional num) + "Move to the down neighbor cell." + (interactive "p") + (unless num (setq num 1)) + (ctbl:navi-move-gen num 0)) + +(defun ctbl:navi-move-right (&optional num) + "Move to the right neighbor cell." + (interactive "p") + (unless num (setq num 1)) + (ctbl:navi-move-gen 0 num)) + +(defun ctbl:navi-move-left (&optional num) + "Move to the left neighbor cell." + (interactive "p") + (unless num (setq num 1)) + (ctbl:navi-move-gen 0 (- num))) + +(defun ctbl:navi-move-left-most () + "Move to the left most cell." + (interactive) + (let* ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell)) + (row-id (car cell-id))) + (when (and cp cell-id) + (ctbl:navi-goto-cell (ctbl:cell-id row-id 0))))) + +(defun ctbl:navi-move-right-most () + "Move to the right most cell." + (interactive) + (let* ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell)) + (row-id (car cell-id)) + (model (ctbl:cp-get-model cp)) + (cols (ctbl:model-column-length model))) + (when (and cp cell-id) + (ctbl:navi-goto-cell (ctbl:cell-id row-id (1- cols)))))) + +(defun ctbl:navi-goto-cell (cell-id) + "Move the cursor to CELL-ID and put selection." + (let ((cp (ctbl:cp-get-component))) + (when cp + (ctbl:cp-set-selected-cell cp cell-id)))) + +(defun ctbl:navi-on-click () + "Action handler on the cells." + (interactive) + (let ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell))) + (when (and cp cell-id) + (ctbl:cp-set-selected-cell cp cell-id) + (ctbl:cp-fire-click-hooks cp)))) + +(defun ctbl:navi-jump-to-column () + "Jump to a specified column of the current row." + (interactive) + (let* ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell)) + (row-id (car cell-id)) + (model (ctbl:cp-get-model cp)) + (cols (ctbl:model-column-length model)) + (col-names (mapcar 'ctbl:cmodel-title + (ctbl:model-column-model model))) + (completion-ignore-case t) + (col-name (funcall ctbl:completing-read "Column name: " col-names))) + (when (and cp cell-id) + (ctbl:navi-goto-cell + (ctbl:cell-id + row-id + (position col-name col-names :test 'equal)))))) + +(defun ctbl:action-update-buffer () + "Update action for the latest table model." + (interactive) + (let ((cp (ctbl:cp-get-component))) + (when cp + (ctbl:cp-update cp)))) + +(defun ctbl:action-column-header () + "Action handler on the header columns. (for normal key events)" + (interactive) + (ctbl:fire-column-header-action + (ctbl:cp-get-component) + (get-text-property (point) 'ctbl:col-id))) + +(defun ctbl:fire-column-header-action (cp col-id) + "[internal] Execute action handlers on the header columns." + (when (and cp col-id) + (loop with cmodel = (nth col-id (ctbl:model-column-model (ctbl:cp-get-model cp))) + for f in (ctbl:cmodel-click-hooks cmodel) + do (condition-case err + (funcall f cp col-id) + (error (message "Ctable: Header Click / Hook error %S [%s]" + f err)))))) + +(defun ctbl:render-column-header-keymap (col-id) + "[internal] Generate action handler on the header columns. (for header-line-format)" + (lexical-let ((col-id col-id)) + (let ((keymap (copy-keymap ctbl:column-header-keymap))) + (define-key keymap [header-line mouse-1] + (lambda () + (interactive) + (ctbl:fire-column-header-action (ctbl:cp-get-component) col-id))) + keymap))) + +(defvar ctbl:column-header-keymap + (ctbl:define-keymap + '(([mouse-1] . ctbl:action-column-header) + ("C-m" . ctbl:action-column-header) + ("RET" . ctbl:action-column-header) + )) + "Keymap for the header columns.") + +(defvar ctbl:table-mode-map + (ctbl:define-keymap + '( + ("k" . ctbl:navi-move-up) + ("j" . ctbl:navi-move-down) + ("h" . ctbl:navi-move-left) + ("l" . ctbl:navi-move-right) + + ("p" . ctbl:navi-move-up) + ("n" . ctbl:navi-move-down) + ("b" . ctbl:navi-move-left) + ("f" . ctbl:navi-move-right) + + ("c" . ctbl:navi-jump-to-column) + + ("e" . ctbl:navi-move-right-most) + ("a" . ctbl:navi-move-left-most) + + ("g" . ctbl:action-update-buffer) + + ("?" . ctbl:describe-bindings) + + ([mouse-1] . ctbl:navi-on-click) + ("C-m" . ctbl:navi-on-click) + ("RET" . ctbl:navi-on-click) + + )) "Keymap for the table-mode buffer.") + +(defun ctbl:table-mode-map (&optional custom-map) + "[internal] Return a keymap object for the table buffer." + (cond + (custom-map + (set-keymap-parent custom-map ctbl:table-mode-map) + custom-map) + (t ctbl:table-mode-map))) + +(defvar ctbl:table-mode-hook nil + "This hook is called at end of setting up major mode `ctbl:table-mode'.") + +(defun ctbl:table-mode (&optional custom-map) + "Set up major mode `ctbl:table-mode'. + +\\{ctbl:table-mode-map}" + (kill-all-local-variables) + (setq truncate-lines t) + (use-local-map (ctbl:table-mode-map custom-map)) + (setq major-mode 'ctbl:table-mode + mode-name "Table Mode") + (setq buffer-undo-list t + buffer-read-only t) + (add-hook 'post-command-hook 'ctbl:start-tooltip-timer nil t) + (run-hooks 'ctbl:table-mode-hook)) + + +;; Rendering + +(defun ctbl:render-check-cell-width (rows cmodels column-widths) + "[internal] Return a list of rows. This function makes side effects: +cell widths are stored at COLUMN-WIDTHS, longer cell strings are truncated by +maximum width of the column models." + (loop for row in rows collect + (loop for c in row + for cm in cmodels + for cwmax = (ctbl:cmodel-max-width cm) + for i from 0 + for cw = (nth i column-widths) + for val = (format "%s" c) + collect + (progn + (when (and cwmax (< cwmax (string-width val))) + (setq val (truncate-string-to-width val cwmax))) + (when (< cw (string-width val)) + (setf (nth i column-widths) (string-width val))) + val)))) + +(defun ctbl:render-adjust-cell-width (cmodels column-widths total-width) + "[internal] Adjust column widths and return a list of column widths. +If TOTAL-WIDTH is nil, this function just returns COLUMN-WIDTHS. +If TOTAL-WIDTHS is shorter than sum of COLUMN-WIDTHS, this +function expands columns. The residual width is distributed over +the columns. If TOTAL-WIDTHS is longer than sum of +COLUMN-WIDTHS, this function shrinks columns to reduce the +surplus width." + (let ((init-total (loop for i in column-widths sum i))) + (cond + ((or (null total-width) + (= total-width init-total)) column-widths) + ((< total-width init-total) + (ctbl:render-adjust-cell-width-shrink + cmodels column-widths total-width init-total)) + (t + (ctbl:render-adjust-cell-width-expand + cmodels column-widths total-width init-total))))) + +(defun ctbl:render-adjust-cell-width-shrink (cmodels column-widths total-width init-total ) + "[internal] shrink column widths." + (let* ((column-widths (copy-sequence column-widths)) + (column-indexes (loop for i from 0 below (length cmodels) collect i)) + (residual (- init-total total-width))) + (loop for cnum = (length column-indexes) + until (or (= 0 cnum) (= 0 residual)) + do + (loop with ave-shrink = (max 1 (/ residual cnum)) + for idx in column-indexes + for cmodel = (nth idx cmodels) + for cwidth = (nth idx column-widths) + for min-width = (or (ctbl:cmodel-min-width cmodel) 1) + do + (cond + ((<= residual 0) (return)) ; complete + ((<= cwidth min-width) ; reject + (setq column-indexes (delete idx column-indexes))) + (t ; reduce + (let ((next-width (max 1 (- cwidth ave-shrink)))) + (incf residual (- next-width cwidth)) + (setf (nth idx column-widths) next-width)))))) + column-widths)) + +(defun ctbl:render-adjust-cell-width-expand (cmodels column-widths total-width init-total ) + "[internal] expand column widths." + (let* ((column-widths (copy-sequence column-widths)) + (column-indexes (loop for i from 0 below (length cmodels) collect i)) + (residual (- total-width init-total))) + (loop for cnum = (length column-indexes) + until (or (= 0 cnum) (= 0 residual)) + do + (loop with ave-expand = (max 1 (/ residual cnum)) + for idx in column-indexes + for cmodel = (nth idx cmodels) + for cwidth = (nth idx column-widths) + for max-width = (or (ctbl:cmodel-max-width cmodel) total-width) + do + (cond + ((<= residual 0) (return)) ; complete + ((<= max-width cwidth) ; reject + (setq column-indexes (delete idx column-indexes))) + (t ; expand + (let ((next-width (min max-width (+ cwidth ave-expand)))) + (incf residual (- cwidth next-width)) + (setf (nth idx column-widths) next-width)))))) + column-widths)) + +(defun ctbl:render-get-formats (cmodels column-widths) + "[internal] Return a list of the format functions." + (loop for cw in column-widths + for cm in cmodels + for al = (ctbl:cmodel-align cm) + collect + (lexical-let ((cw cw)) + (cond + ((eq al 'left) + (lambda (s) (ctbl:format-left cw s))) + ((eq al 'center) + (lambda (s) (ctbl:format-center cw s))) + (t + (lambda (s) (ctbl:format-right cw s))))))) + +(defun ctbl:render-choose-color (model param index) + "[internal] Choose rendering color." + (cond + ((null param) nil) + ((stringp param) param) + ((functionp param) + (funcall param model index)) + (t (let ((val (or (assq index param) + (assq t param)))) + (if val (cdr val) nil))))) + +(defun ctbl:render-bg-color (str row-id col-id model param) + "[internal] Return nil or the color string at the cell (row-id . cell-id)." + (let ((bgc-param (ctbl:param-bg-colors param))) + (cond + ((null bgc-param) nil) + ((functionp bgc-param) + (funcall bgc-param model row-id col-id str)) + (t + (let ((pair (or (assoc (cons row-id col-id) bgc-param) + (assoc t bgc-param)))) + (if pair (cdr pair) nil)))))) + +(defun ctbl:render-bg-color-put (str row-id col-id model param) + "[internal] Return the string with the background face." + (let ((bgcolor (ctbl:render-bg-color str row-id col-id model param))) + (if bgcolor + (let ((org-face (get-text-property 0 'face str))) + (propertize + (copy-sequence str) + 'face (if org-face + (append org-face (list ':background bgcolor)) + (list ':background bgcolor)))) + str))) + +(defun ctbl:render-line-color (str model param index) + "[internal] Return the propertize string." + (propertize (copy-sequence str) + 'face (list + ':foreground + (ctbl:render-choose-color model param index)))) + +(defun ctbl:render-vline-color (str model param index) + "[internal] Return the propertize string for vertical lines." + (ctbl:render-line-color str model (ctbl:param-vline-colors param) index)) + +(defun ctbl:render-hline-color (str model param index) + "[internal] Return the propertize string for horizontal lines." + (ctbl:render-line-color str model (ctbl:param-hline-colors param) index)) + +(defun ctbl:render-draw-vline-p (model param index) + "[internal] If a vertical line is needed at the column index, return t." + (cond + ((null param) nil) + ((eq 'all param) t) + ((functionp param) (funcall param model index)) + (t (and (consp param) (memq index param))))) + +(defun ctbl:render-draw-hline-p (model param index) + "[internal] If a horizontal line is needed at the row index, return t." + (cond + ((null param) nil) + ((eq 'all param) t) + ((functionp param) (funcall param model index)) + (t (memq index param)))) + +(defun ctbl:render-make-hline (column-widths model param index) + "[internal] " + (let ((vparam (ctbl:param-draw-vlines param)) + (hline (ctbl:param-horizontal-line param)) + left joint right) + (if (not (ctbl:render-draw-hline-p + model (ctbl:param-draw-hlines param) index)) + "" + (cond + ((eq 0 index) + (setq left (char-to-string (ctbl:param-left-top-corner param)) + joint (char-to-string (ctbl:param-top-junction param)) + right (char-to-string (ctbl:param-right-top-corner param)))) + ((eq -1 index) + (setq left (char-to-string (ctbl:param-left-bottom-corner param)) + joint (char-to-string (ctbl:param-bottom-junction param)) + right (char-to-string (ctbl:param-right-bottom-corner param)))) + (t + (setq left (char-to-string (ctbl:param-left-junction param)) + joint (char-to-string (ctbl:param-cross-junction param)) + right (char-to-string (ctbl:param-right-junction param))))) + (ctbl:render-hline-color + (concat + (if (ctbl:render-draw-vline-p model vparam 0) left) + (loop with ret = nil with endi = (length column-widths) + for cw in column-widths + for ci from 1 + for endp = (equal ci endi) + do + (push (make-string cw hline) ret) + (when (and (ctbl:render-draw-vline-p model vparam ci) + (not endp)) + (push joint ret)) + finally return (apply 'concat (reverse ret))) + (if (ctbl:render-draw-vline-p model vparam -1) right) + "\n") + model param index)))) + +(defun ctbl:render-join-columns (columns model param) + "[internal] Join a list of column strings with vertical lines." + (let (ret (V (char-to-string (ctbl:param-vertical-line param)))) + ;; left border line + (setq ret (if (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) 0) + (list (ctbl:render-vline-color V model param 0)) + nil)) + ;; content line + (loop with param-vl = (ctbl:param-draw-vlines param) + with param-vc = (ctbl:param-vline-colors param) + with endi = (length columns) + for i from 1 for endp = (equal i endi) + for cv in columns + for color = (ctbl:render-choose-color model param-vc i) + do + (push cv ret) + (when (and (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) i) + (not endp)) + (push (ctbl:render-vline-color V model param i) ret))) + ;; right border line + (when (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) -1) + (push (ctbl:render-vline-color V model param -1) ret)) + ;; join them + (mapconcat 'identity (reverse ret) ""))) + +(defun ctbl:render-sum-vline-widths (cmodels model param) + "[internal] Return a sum of the widths of vertical lines." + (let ((sum 0)) + ;; left border line + (when (ctbl:render-draw-vline-p model (ctbl:param-draw-vlines param) 0) + (incf sum)) + ;; content line + (loop with param-vl = (ctbl:param-draw-vlines param) + with endi = (length cmodels) + for i from 1 upto (length cmodels) + for endp = (equal i endi) do + (when (and (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) i) + (not endp)) + (incf sum))) + ;; right border line + (when (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) -1) + (incf sum)) + sum)) + +(defun ctbl:dest-width-get (dest) + "[internal] Return the column number to draw the table view. +Return nil, if the width is not given. Then, the renderer draws freely." + (let ((dwidth (ctbl:dest-width dest)) + (dwin (get-buffer-window))) + (cond + ((numberp dwidth) dwidth) + ((eq 'full dwidth) (window-width dwin)) + (t nil)))) + +(defun ctbl:dest-height-get (dest) + "[internal] Return the row number to draw the table view. +Return nil, if the height is not given. Then, the renderer draws freely." + (let ((dheight (ctbl:dest-height dest)) + (dwin (get-buffer-window))) + (cond + ((numberp dheight) dheight) + ((eq 'full dheight) (1- (window-height dwin))) + (t nil)))) + +(defun ctbl:render-main (dest model param) + "[internal] Rendering the table view. +This function assumes that the current buffer is the destination buffer." + (let* ((EOL "\n") drows + (cmodels (ctbl:model-column-model model)) + (rows (ctbl:sort + (copy-sequence (ctbl:model-data model)) cmodels + (ctbl:model-sort-state model))) + (column-widths + (loop for c in cmodels + for title = (ctbl:cmodel-title c) + collect (max (or (ctbl:cmodel-min-width c) 0) + (or (and title (length title)) 0)))) + column-formats) + ;; check cell widths + (setq drows (ctbl:render-check-cell-width rows cmodels column-widths)) + ;; adjust cell widths for ctbl:dest width + (when (ctbl:dest-width-get dest) + (setq column-widths + (ctbl:render-adjust-cell-width + cmodels column-widths + (- (ctbl:dest-width-get dest) + (ctbl:render-sum-vline-widths + cmodels model param))))) + (setq column-formats (ctbl:render-get-formats cmodels column-widths)) + (catch 'ctbl:insert-break + (when (ctbl:param-display-header param) + (ctbl:render-main-header dest model param + cmodels column-widths)) + (ctbl:render-main-content dest model param + cmodels drows column-widths column-formats)) + ;; return the sorted list + rows)) + +(defun ctbl:render-main-header (dest model param cmodels column-widths) + "[internal] Render the table header." + (let ((EOL "\n") + (header-string + (ctbl:render-join-columns + (loop for cm in cmodels + for i from 0 + for cw in column-widths + collect + (propertize + (ctbl:format-center cw (ctbl:cmodel-title cm)) + 'ctbl:col-id i + 'local-map (ctbl:render-column-header-keymap i) + 'mouse-face 'highlight)) + model param))) + (cond + ((and (eq 'buffer (ctbl:dest-type dest)) + (ctbl:param-fixed-header param)) + ;; buffer header-line + (let* ((fcol (/ (car (window-fringes)) + (frame-char-width))) + (header-text (concat (make-string fcol ? ) header-string))) + (setq header-line-format header-text) + ;; save header-text for hscroll updating + (set (make-local-variable 'ctbl:header-text) header-text))) + (t + ;; content area + (insert ; border line + (ctbl:render-make-hline column-widths model param 0)) + (insert header-string EOL) ; header columns + )))) + +(defun ctbl:render-main-content (dest model param cmodels rows + column-widths column-formats + &optional begin-index) + "[internal] Render the table content." + (unless begin-index + (setq begin-index 0)) + (let ((EOL "\n") (row-num (length rows))) + (loop for cols in rows + for row-index from begin-index + do + (insert + (ctbl:render-make-hline + column-widths model param (1+ row-index))) + (insert + (ctbl:render-join-columns + (loop for i in cols + for s = (if (stringp i) i (format "%s" i)) + for fmt in column-formats + for cw in column-widths + for col-index from 0 + for str = (ctbl:render-bg-color-put + (funcall fmt s) row-index col-index + model param) + collect + (propertize str + 'ctbl:cell-id (cons row-index col-index) + 'ctbl:cell-width cw)) + model param) EOL)) + ;; bottom border line + (insert + (ctbl:render-make-hline column-widths model param -1)))) + + +;; async data model + +(defvar ctbl:continue-button-keymap + (ctbl:define-keymap + '(([mouse-1] . ctbl:action-continue-async-clicked) + ("C-m" . ctbl:action-continue-async-clicked) + ("RET" . ctbl:action-continue-async-clicked) + )) + "Keymap for the continue button.") + +;; async data / internal state + +(defstruct ctbl:async-state + "Rendering State [internal] + +status : symbol -> + normal : data still remains. this is the start state. + requested : requested data and waiting for response. + done : no data remains. this is the final state. +actual-width : actual width +column-widths : width of each columns +column-formats : format of each columns +next-index : row index number for next request +panel-begin : begin mark object for status panel +panel-end : end mark object for status panel +" + status actual-width column-widths column-formats + next-index panel-begin panel-end) + +(defun ctbl:async-state-on-update (component) + "[internal] Reset async data model." + (let* ((cp component) + (amodel (ctbl:model-data (ctbl:cp-get-model cp))) + (astate (ctbl:cp-states-get cp 'async-state))) + (when (and astate (ctbl:async-model-reset amodel)) + (funcall (ctbl:async-model-reset amodel))))) + +(defun ctbl:async-state-on-click-panel (component) + "[internal] This function is called when the user clicks the status panel." + (let* ((cp component) + (amodel (ctbl:model-data (ctbl:cp-get-model cp))) + (astate (ctbl:cp-states-get cp 'async-state))) + (when cp + (case (ctbl:async-state-status astate) + ('normal + (ctbl:render-async-continue cp)) + ('requested + (when (ctbl:async-model-cancel amodel) + (funcall (ctbl:async-model-cancel amodel)) + (ctbl:async-state-update-status (ctbl:component-dest cp) 'normal))))))) + +(defun ctbl:async-state-update-status (component next-status) + "[internal] Update internal status of async-state and update the status panel." + (let* ((cp component) + (dest (ctbl:component-dest cp)) + (amodel (ctbl:model-data (ctbl:cp-get-model cp))) + (astate (ctbl:cp-states-get cp 'async-state))) + (with-current-buffer (ctbl:dest-buffer dest) + (setf (ctbl:async-state-status astate) next-status) + (ctbl:async-state-update-status-panel dest astate amodel)))) + +(defun ctbl:async-state-update-status-panel (dest astate amodel) + "[internal] Rendering data model status panel with current state." + (let ((begin (ctbl:async-state-panel-begin astate)) + (end (ctbl:async-state-panel-end astate)) + (width (ctbl:async-state-actual-width astate))) + (save-excursion + (let (buffer-read-only) + (when (< 2 (- end begin)) + (delete-region begin (1- end))) + (goto-char begin) + (insert + (propertize + (case (ctbl:async-state-status astate) + ('done + (ctbl:format-center width "No more data.")) + ('requested + (cond + ((ctbl:async-model-cancel amodel) + (ctbl:format-center width "(Waiting for data. [Click to Cancel])")) + (t + (ctbl:format-center width "(Waiting for data...)")))) + ('normal + (ctbl:format-center width "[Click to retrieve more data.]")) + (t + (ctbl:format-center + width (format "(Error : %s)" (ctbl:async-state-status astate))))) + 'keymap ctbl:continue-button-keymap + 'face 'ctbl:face-continue-bar + 'mouse-face 'highlight) + "\n"))))) + +(defun ctbl:async-state-on-post-command-hook (component) + "[internal] Try auto requesting for asynchronous data." + (let* ((astate (ctbl:cp-states-get component 'async-state)) + (panel-begin-pos (marker-position + (ctbl:async-state-panel-begin astate)))) + (when (and (eq 'normal (ctbl:async-state-status astate)) + (< panel-begin-pos (window-end))) + (ctbl:action-continue-async-clicked)))) + +;; rendering async data + +(defun ctbl:render-async-main (dest model param rows-setter) + "[internal] Rendering the table view for async data model. +This function assumes that the current buffer is the destination buffer." + (lexical-let* + ((dest dest) (model model) (param param) (rows-setter rows-setter) + (amodel (ctbl:model-data model)) (buf (current-buffer)) + (cmodels (ctbl:model-column-model model))) + (funcall + (ctbl:async-model-request amodel) + 0 (ctbl:async-model-init-num amodel) + (lambda (rows) ; >> request succeeded + (with-current-buffer buf + (let (buffer-read-only drows column-formats + (column-widths + (loop for c in cmodels + for title = (ctbl:cmodel-title c) + collect (max (or (ctbl:cmodel-min-width c) 0) + (or (and title (length title)) 0)))) + (EOL "\n")) + ;; check cell widths + (setq drows (ctbl:render-check-cell-width rows cmodels column-widths)) + ;; adjust cell widths for ctbl:dest width + (when (ctbl:dest-width-get dest) + (setq column-widths + (ctbl:render-adjust-cell-width + cmodels column-widths + (- (ctbl:dest-width-get dest) + (ctbl:render-sum-vline-widths + cmodels model param))))) + (setq column-formats (ctbl:render-get-formats cmodels column-widths)) + (ctbl:render-main-header dest model param cmodels column-widths) + (ctbl:render-main-content dest model param cmodels drows column-widths column-formats) + (add-hook 'post-command-hook 'ctbl:post-command-hook-for-auto-request t t) + (let (mark-panel-begin mark-panel-end astate) + (setq mark-panel-begin (point-marker)) + (insert "\n") + (setq mark-panel-end (point-marker)) + (setq astate + (make-ctbl:async-state + :status 'normal + :actual-width (+ (ctbl:render-sum-vline-widths cmodels model param) + (loop for i in column-widths sum i)) + :column-widths column-widths :column-formats column-formats + :next-index (length rows) + :panel-begin mark-panel-begin :panel-end mark-panel-end)) + (ctbl:async-state-update-status-panel dest astate amodel) + (funcall rows-setter rows astate)) + (goto-char (ctbl:dest-point-min dest))))) + (lambda (errsym) ; >> request failed + (message "ctable : error -> %S" errsym))))) + +(defun ctbl:render-async-continue (component) + "[internal] Rendering subsequent data asynchronously." + (lexical-let* + ((cp component) (dest (ctbl:component-dest cp)) (buf (current-buffer)) + (model (ctbl:cp-get-model cp)) + (amodel (ctbl:model-data model)) + (astate (ctbl:cp-states-get cp 'async-state)) + (begin-index (ctbl:async-state-next-index astate))) + ;; status update + (ctbl:async-state-update-status cp 'requested) + (condition-case err + (funcall ; request async data + (ctbl:async-model-request amodel) + begin-index (ctbl:async-model-more-num amodel) + (lambda (rows) ; >> request succeeded + (with-current-buffer buf + (save-excursion + (let (buffer-read-only) + (cond + ((null rows) + ;; no more data + (ctbl:async-state-update-status cp 'done)) + (t + ;; continue data + (goto-char (1- (marker-position (ctbl:async-state-panel-begin astate)))) + (insert "\n") + (ctbl:render-main-content + dest model (ctbl:cp-get-param cp) (ctbl:model-column-model model) + rows (ctbl:async-state-column-widths astate) + (ctbl:async-state-column-formats astate) begin-index) + (backward-delete-char 1) + (ctbl:async-state-update-status cp 'normal) + ;; append row data (side effect!) + (setf (ctbl:component-sorted-data cp) + (append (ctbl:component-sorted-data cp) rows)) + (setf (ctbl:async-state-next-index astate) + (+ (length rows) begin-index)))))))) + (lambda (errsym) ; >> request failed + (ctbl:async-state-update-status cp errsym))) + (error ; >> request synchronously failed + (ctbl:async-state-update-status cp (cadr err)) + (message "ctable : error -> %S" err))))) + +;; async data actions + +(defun ctbl:action-continue-async-clicked () + "Action for clicking the continue button." + (interactive) + (let ((cp (ctbl:cp-get-component))) + (when cp + (ctbl:async-state-on-click-panel cp)))) + +(defun ctbl:post-command-hook-for-auto-request () + "[internal] This hook watches the buffer position of displayed window +to urge async data model to request next data chunk." + (let ((cp (ctbl:cp-get-component))) + (when (and cp (not (window-minibuffer-p))) + (ctbl:async-state-on-post-command-hook cp)))) + +(defun ctbl:async-model-wrapper (rows &optional init-num more-num) + "This function wraps a list of row data in an asynchronous data +model so as to avoid Emacs freezing with a large number of rows." + (lexical-let ((rows rows) (rest-rows rows) + (init-num (or init-num 100)) + (more-num (or more-num 100))) + (make-ctbl:async-model + :request + (lambda (row-num len responsef errorf &rest ignored) + (funcall + responsef + (cond + ((null rest-rows) nil) + (t + (nreverse + (loop with pos = rest-rows + with ret = nil + for i from 0 below len + do + (push (car pos) ret) + (setq pos (cdr pos)) + (unless pos (return ret)) + finally return ret))))) + (when rest-rows + (setq rest-rows (nthcdr len rest-rows)))) + :reset + (lambda (&rest ignored) (setq rest-rows rows)) + :init-num init-num :more-num more-num))) + + +;; tooltip + +(defun ctbl:pop-tooltip (string) + "[internal] Show STRING in tooltip." + (cond + ((and (memq 'pos-tip ctbl:tooltip-method) window-system (featurep 'pos-tip)) + (pos-tip-show (ctbl:string-fill-paragraph string) + 'popup-tip-face nil nil 0)) + ((and (memq 'popup ctbl:tooltip-method) (featurep 'popup)) + (popup-tip string)) + ((memq 'minibuffer ctbl:tooltip-method) + (let ((message-log-max nil)) + (message string))))) + +(defun ctbl:show-cell-in-tooltip (&optional unless-visible) + "Show cell at point in tooltip. +When UNLESS-VISIBLE is non-nil, show tooltip only when data in +cell is truncated." + (interactive) + (let* ((cp (ctbl:cp-get-component)) + (data (when cp (ctbl:cp-get-selected-data-cell cp)))) + (when data + (let ((string (if (stringp data) data (format "%S" data))) + (width (get-text-property (point) 'ctbl:cell-width))) + (when (or (not unless-visible) + (and (integerp width) (>= (length string) width))) + (ctbl:pop-tooltip string)))))) + +(defvar ctbl:tooltip-delay 1) + +(defvar ctbl:tooltip-timer nil) + +(defun ctbl:start-tooltip-timer () + (unless ctbl:tooltip-timer + (setq ctbl:tooltip-timer + (run-with-idle-timer ctbl:tooltip-delay nil + (lambda () + (ctbl:show-cell-in-tooltip t) + (setq ctbl:tooltip-timer nil)))))) + + +;; help output + +(defun ctbl:describe-bindings () + "Display a buffer showing a list of keys defined in the table." + (interactive) + (let ((keymap (get-text-property (point) 'keymap))) + (when keymap + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (map-keymap (lambda (key value) + (when (characterp key) + (insert (format "%s %s\n" (key-description (vector key)) value)))) + keymap)))))) + + +;; Rendering utilities + +(defun ctbl:format-truncate (org limit-width &optional ellipsis) + "[internal] Truncate a string ORG with LIMIT-WIDTH, like `truncate-string-to-width'." + (setq org (replace-regexp-in-string "\n" " " org)) + (if (< limit-width (string-width org)) + (let ((str (truncate-string-to-width + (substring org 0) limit-width 0 nil ellipsis))) + (when (< limit-width (string-width str)) + (setq str (truncate-string-to-width (substring org 0) + limit-width))) + (setq str (propertize str 'mouse-face 'highlight)) + (unless (get-text-property 0 'help-echo str) + (setq str (propertize str 'help-echo org))) + str) + org)) + +(defun ctbl:format-right (width string &optional padding) + "[internal] Format STRING, padding on the left with the character PADDING." + (let* ((padding (or padding ?\ )) + (cnt (or (and string + (ctbl:format-truncate string width t)) + "")) + (len (string-width cnt)) + (margin (max 0 (- width len)))) + (concat (make-string margin padding) cnt))) + +(defun ctbl:format-center (width string &optional padding) + "[internal] Format STRING in the center, padding on the both +sides with the character PADDING." + (let* ((padding (or padding ?\ )) + (cnt (or (and string + (ctbl:format-truncate string width t)) + "")) + (len (string-width cnt)) + (margin (max 0 (/ (- width len) 2)))) + (concat + (make-string margin padding) cnt + (make-string (max 0 (- width len margin)) padding)))) + +(defun ctbl:format-left (width string &optional padding) + "[internal] Format STRING, padding on the right with the character PADDING." + (let* ((padding (or padding ?\ )) + (cnt (or (and string + (ctbl:format-truncate string width t)) + "")) + (len (string-width cnt)) + (margin (max 0 (- width len)))) + (concat cnt (make-string margin padding)))) + +(defun ctbl:sort-string-lessp (i j) + "[internal] String comparator." + (cond + ((string= i j) 0) + ((string< i j) -1) + (t 1))) + +(defun ctbl:sort-number-lessp (i j) + "[internal] Number comparator." + (cond + ((= i j) 0) + ((< i j) -1) + (t 1))) + +(defun ctbl:sort (rows cmodels orders) + "[internal] Sort rows according to order indexes and column models." + (let* + ((comparator + (lambda (ref) + (lexical-let + ((ref ref) + (f (or (ctbl:cmodel-sorter (nth ref cmodels)) + 'ctbl:sort-string-lessp))) + (lambda (i j) + (funcall f (nth ref i) (nth ref j)))))) + (negative-comparator + (lambda (ref) + (lexical-let ((cp (funcall comparator ref))) + (lambda (i j) (- (funcall cp i j)))))) + (to-bool + (lambda (f) + (lexical-let ((f f)) + (lambda (i j) + (< (funcall f i j) 0))))) + (chain + (lambda (fs) + (lexical-let ((fs fs)) + (lambda (i j) + (loop for f in fs + for v = (funcall f i j) + unless (eq 0 v) + return v + finally return 0)))))) + (sort rows + (loop with fs = nil + for o in (reverse (copy-sequence orders)) + for gen = (if (< 0 o) comparator negative-comparator) + for f = (funcall gen (1- (abs o))) + do (push f fs) + finally return (funcall to-bool (funcall chain fs)))))) + +(defun ctbl:string-fill-paragraph (string &optional justify) + "[internal] `fill-paragraph' against STRING." + (with-temp-buffer + (erase-buffer) + (insert string) + (goto-char (point-min)) + (fill-paragraph justify) + (buffer-string))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; CTable API + +;; buffer + +(defun* ctbl:open-table-buffer(&key buffer width height custom-map model param) + "Open a table buffer simply. +This function uses the function +`ctbl:create-table-component-buffer' internally." + (let ((cp (ctbl:create-table-component-buffer + :buffer buffer :width width :height height + :custom-map custom-map :model model :param param))) + (switch-to-buffer (ctbl:cp-get-buffer cp)))) + +(defun* ctbl:create-table-component-buffer(&key buffer width height custom-map model param) + "Return a table buffer with some customize parameters. + +This function binds the component object at the +buffer local variable `ctbl:component'. + +The size of table is calculated from the window that shows BUFFER or the selected window. +BUFFER is the buffer to be rendered. If BUFFER is nil, this function creates a new buffer. +CUSTOM-MAP is the additional keymap that is added to default keymap `ctbl:table-mode-map'." + (let* ((dest (ctbl:dest-init-buffer buffer width height custom-map)) + (cp (ctbl:cp-new dest model param))) + (setf (ctbl:dest-after-update-func dest) + (lambda () + (ctbl:dest-buffer-update-header))) + (with-current-buffer (ctbl:dest-buffer dest) + (set (make-local-variable 'ctbl:component) cp)) + cp)) + +(defun ctbl:dest-buffer-update-header () + "[internal] After auto hscrolling, update the horizontal position of the header line." + (run-at-time 0.01 nil 'ctbl:dest-buffer-update-header--deferred)) + +(defun ctbl:dest-buffer-update-header--deferred () + "[internal] Adjust header line position." + (when (boundp 'ctbl:header-text) + (let* ((left (window-hscroll)) + (text (substring ctbl:header-text left))) + (setq header-line-format text)) + (force-window-update (current-buffer)))) + + +(defun ctbl:popup-table-buffer-easy (rows &optional header-row) + "Popup a table buffer from a list of rows." + (pop-to-buffer (ctbl:create-table-buffer-easy rows header-row))) + +(defun ctbl:open-table-buffer-easy (rows &optional header-row) + "Open a table buffer from a list of rows." + (switch-to-buffer (ctbl:create-table-buffer-easy rows header-row))) + +(defun ctbl:create-table-buffer-easy (rows &optional header-row) + "Return a table buffer from a list of rows." + (ctbl:cp-get-buffer + (ctbl:create-table-component-buffer + :model (ctbl:make-model-from-list rows header-row)))) + +(defun ctbl:make-model-from-list (rows &optional header-row) + "Make a `ctbl:model' instance from a list of rows." + (let* ((col-num (or (and header-row (length header-row)) + (and (car rows) (length (car rows))))) + (column-models + (if header-row + (loop for i in header-row + collect (make-ctbl:cmodel :title (format "%s" i) :min-width 5)) + (loop for i from 0 below col-num + for ch = (char-to-string (+ ?A i)) + collect (make-ctbl:cmodel :title ch :min-width 5))))) + (make-ctbl:model + :column-model column-models :data rows))) + +;; region + +(defun* ctbl:create-table-component-region(&key width height keymap model param) + "Insert markers of the rendering destination at current point and display the table view. + +This function returns a component object and stores it at the text property `ctbl:component'. + +WIDTH and HEIGHT are reference size of the table view. If those are nil, the size is calculated from the selected window. +KEYMAP is the keymap that is put to the text property `keymap'. If KEYMAP is nil, `ctbl:table-mode-map' is used." + (let (mark-begin mark-end) + (setq mark-begin (point-marker)) + (insert " ") + (setq mark-end (point-marker)) + (save-excursion + (let* ((dest (ctbl:dest-init-region (current-buffer) mark-begin mark-end width height)) + (cp (ctbl:cp-new dest model param)) + (after-update-func + (lexical-let ((keymap keymap) (cp cp)) + (lambda () + (ctbl:dest-with-region (ctbl:component-dest cp) + (let (buffer-read-only) + (put-text-property (point-min) (1- (point-max)) + 'ctbl:component cp) + (ctbl:fill-keymap-property + (point-min) (1- (point-max)) + (or keymap ctbl:table-mode-map)))))))) + (setf (ctbl:dest-after-update-func dest) after-update-func) + (funcall after-update-func) + cp)))) + + +;; inline + +(defun* ctbl:get-table-text(&key width height model param) + "Return a text that is drew the table view. + +In this case, the rendering destination object is disposable. So, +one can not modify the obtained text with `ctbl:xxx' functions. + +WIDTH and HEIGHT are reference size of the table view." + (let* ((dest (ctbl:dest-init-inline width height)) + (cp (ctbl:cp-new dest model param)) + text) + (setq text + (with-current-buffer (ctbl:cp-get-buffer cp) + (buffer-substring (point-min) (point-max)))) + (kill-buffer (ctbl:cp-get-buffer cp)) + text)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Demo + +(defun ctbl:demo () + "Sample code for implementation for the table model." + (interactive) + (let ((param (copy-ctbl:param ctbl:default-rendering-param))) + ;; rendering parameters + ;;(setf (ctbl:param-display-header param) nil) + (setf (ctbl:param-fixed-header param) t) + (setf (ctbl:param-hline-colors param) + '((0 . "#00000") (1 . "#909090") (-1 . "#ff0000") (t . "#00ff00"))) + (setf (ctbl:param-draw-hlines param) + (lambda (model row-index) + (cond ((memq row-index '(0 1 -1)) t) + (t (= 0 (% (1- row-index) 5)))))) + (setf (ctbl:param-bg-colors param) + (lambda (model row-id col-id str) + (cond ((string-match "CoCo" str) "LightPink") + ((= 0 (% (1- row-id) 2)) "Darkseagreen1") + (t nil)))) + (let ((cp + (ctbl:create-table-component-buffer + :width nil :height nil + :model + (make-ctbl:model + :column-model + (list (make-ctbl:cmodel + :title "A" :sorter 'ctbl:sort-number-lessp + :min-width 5 :align 'right) + (make-ctbl:cmodel + :title "Title" :align 'center + :sorter (lambda (a b) (ctbl:sort-number-lessp (length a) (length b)))) + (make-ctbl:cmodel + :title "Comment" :align 'left)) + :data + '((1 "Bon Tanaka" "8 Year Curry." 'a) + (2 "Bon Tanaka" "Nan-ban Curry." 'b) + (3 "Bon Tanaka" "Half Curry." 'c) + (4 "Bon Tanaka" "Katsu Curry." 'd) + (5 "Bon Tanaka" "Gyu-don." 'e) + (6 "CoCo Ichi" "Beaf Curry." 'f) + (7 "CoCo Ichi" "Poke Curry." 'g) + (8 "CoCo Ichi" "Yasai Curry." 'h) + (9 "Berkley" "Hamburger Curry." 'i) + (10 "Berkley" "Lunch set." 'j) + (11 "Berkley" "Coffee." k)) + :sort-state + '(2 1) + ) + :param param))) + (ctbl:cp-add-click-hook + cp (lambda () (message "CTable : Click Hook [%S]" + (ctbl:cp-get-selected-data-row cp)))) + (ctbl:cp-add-selection-change-hook cp (lambda () (message "CTable : Select Hook"))) + (ctbl:cp-add-update-hook cp (lambda () (message "CTable : Update Hook"))) + (switch-to-buffer (ctbl:cp-get-buffer cp))))) + +;; (progn (eval-current-buffer) (ctbl:demo)) + +(provide 'ctable) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; indent-tabs-mode: nil +;; End: + +;;; ctable.el ends here diff --git a/lisp/deft.el b/lisp/deft.el new file mode 100644 index 00000000..e07435e5 --- /dev/null +++ b/lisp/deft.el @@ -0,0 +1,1866 @@ +;;; deft.el --- quickly browse, filter, and edit plain text notes + +;;; Copyright (C) 2011-2017 Jason R. Blevins +;; All rights reserved. + +;; 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. Neither the names of the copyright holders nor the names of any +;; contributors may be used to endorse or promote products derived from +;; this software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT HOLDER OR CONTRIBUTORS 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. + +;;; Version: 0.8 +;; Package-Version: 20200515.1513 +;; Package-Commit: fca9ea05ef4fdac825e2ad3921baa7042f6b82c8 +;;; Author: Jason R. Blevins +;;; Keywords: plain text, notes, Simplenote, Notational Velocity +;;; URL: https://jblevins.org/projects/deft/ + +;; This file is not part of GNU Emacs. + +;;; Commentary: + +;; Deft is an Emacs mode for quickly browsing, filtering, and editing +;; directories of plain text notes, inspired by Notational Velocity. +;; It was designed for increased productivity when writing and taking +;; notes by making it fast and simple to find the right file at the +;; right time and by automating many of the usual tasks such as +;; creating new files and saving files. + +;; ![Deft Screencast](https://jblevins.org/projects/deft/deft-v0.6.gif) + +;; Obtaining Deft +;; -------------- + +;; Deft is open source software and may be freely distributed and +;; modified under the BSD license. The latest stable release is +;; version 0.8, released on January 12, 2018. + +;; **Installation via MELPA Stable** + +;; The recommended way to install Deft is to obtain the stable version +;; from [MELPA Stable](https://stable.melpa.org/#/deft) using +;; `package.el'. First, configure `package.el' and the MELPA Stable +;; repository by adding the following to your `.emacs', `init.el', or +;; equivalent startup file: + +;; (require 'package) +;; (add-to-list 'package-archives +;; '("melpa-stable" . "https://stable.melpa.org/packages/")) +;; (package-initialize) + +;; Then, after restarting Emacs or evaluating the above statements, issue +;; the following command: `M-x package-install RET deft RET`. + +;; [MELPA Stable]: http://stable.melpa.org/ + +;; **Direct Download** + +;; Alternatively you can manually download and install Deft. +;; First, download the latest stable version of and save the file +;; where Emacs can find it---a directory in your `load-path': + +;; * [deft.el](https://jblevins.org/projects/deft/deft.el) + +;; Then, add the following line to your startup file: + +;; (require 'deft) + +;; **Development Version** + +;; To follow or contribute to Deft development, you can browse or +;; clone the Git repository [on GitHub](https://github.com/jrblevin/deft): + +;; git clone https://github.com/jrblevin/deft.git + +;; If you prefer to install and use the development version, which may +;; become unstable at some times, you can either clone the Git +;; repository as above or install Deft from +;; [MELPA](https://melpa.org/#/deft). + +;; If you clone the repository directly, then make sure that Emacs can +;; find it by adding the following line to your startup file: + +;; (add-to-list 'load-path "/path/to/deft/repository") + +;; Overview +;; -------- + +;; The Deft buffer is simply a file browser which lists the titles of +;; all text files in the Deft directory followed by short summaries +;; and last modified times. The title is taken to be the first line +;; of the file and the summary is extracted from the text that +;; follows. Files are, by default, sorted in terms of the last +;; modified date, from newest to oldest. + +;; All Deft files or notes are simple plain text files where the first +;; line contains a title. As an example, the following directory +;; structure generated the screenshot above. +;; +;; % ls ~/.deft +;; about.txt browser.txt directory.txt operations.txt +;; ack.txt completion.txt extensions.org +;; binding.txt creation.txt filtering.txt +;; +;; % cat ~/.deft/about.txt +;; # About +;; +;; An Emacs mode for slicing and dicing plain text files. + +;; Deft's primary operation is searching and filtering. The list of +;; files can be limited or filtered using a search string, which will +;; match both the title and the body text. To initiate a filter, +;; simply start typing. Filtering happens on the fly. As you type, +;; the file browser is updated to include only files that match the +;; current string. + +;; To open the first matching file, simply press `RET`. If no files +;; match your search string, pressing `RET` will create a new file +;; using the string as the title. This is a very fast way to start +;; writing new notes. The filename will be generated automatically. +;; If you prefer to provide a specific filename, use `C-RET` instead. + +;; To open files other than the first match, navigate up and down +;; using `C-p` and `C-n` and press `RET` on the file you want to open. +;; When opening a file, Deft searches forward and leaves the point +;; at the end of the first match of the filter string. + +;; You can also press `C-o` to open a file in another window, without +;; switching to the other window. Issue the same command with a prefix +;; argument, `C-u C-o`, to open the file in another window and switch +;; to that window. + +;; To edit the filter string, press `DEL` (backspace) to remove the +;; last character or `M-DEL` to remove the last "word". To yank +;; (paste) the most recently killed (cut or copied) text into the +;; filter string, press `C-y`. Press `C-c C-c` to clear the filter +;; string and display all files and `C-c C-g` to refresh the file +;; browser using the current filter string. + +;; For more advanced editing operations, you can also edit the filter +;; string in the minibuffer by pressing `C-c C-l`. While in the +;; minibuffer, the history of previous edits can be cycled through by +;; pressing `M-p` and `M-n`. This form of static, one-time filtering +;; (as opposed to incremental, on-the-fly filtering) may be preferable +;; in some situations, such as over slow connections or on systems +;; where interactive filtering performance is poor. + +;; By default, Deft filters files in incremental string search mode, +;; where "search string" will match all files containing both "search" +;; and "string" in any order. Alternatively, Deft supports direct +;; regexp filtering, where the filter string is interpreted as a +;; formal regular expression. For example, `^\(foo\|bar\)` matches +;; foo or bar at the beginning of a line. Pressing `C-c C-t` will +;; toggle between incremental and regexp search modes. Regexp +;; search mode is indicated by an "R" in the mode line. + +;; Common file operations can also be carried out from within Deft. +;; Files can be renamed using `C-c C-r` or deleted using `C-c C-d`. +;; New files can also be created using `C-c C-n` for quick creation or +;; `C-c C-m` for a filename prompt. You can leave Deft at any time +;; with `C-c C-q`. + +;; Unused files can be archived by pressing `C-c C-a`. Files will be +;; moved to `deft-archive-directory', which is a directory named +;; `archive` within your `deft-directory' by default. + +;; Files opened with deft are automatically saved after Emacs has been +;; idle for a customizable number of seconds. This value is a floating +;; point number given by `deft-auto-save-interval' (default: 1.0). + +;; Getting Started +;; --------------- + +;; Once you have installed Deft following one of the above methods, +;; you can simply run `M-x deft` to start Deft. It is useful +;; to create a global keybinding for the `deft' function (e.g., a +;; function key) to start it quickly (see below for details). + +;; When you first run Deft, it will complain that it cannot find the +;; `~/.deft` directory. You can either create a symbolic link to +;; another directory where you keep your notes or run `M-x deft-setup` +;; to create the `~/.deft` directory automatically. + +;; One useful way to use Deft is to keep a directory of notes in a +;; Dropbox folder. This can be used with other applications and +;; mobile devices, for example, [nvALT][], [Notational Velocity][], or +;; [Simplenote][] on OS X or [Editorial][], [Byword][], or [1Writer][] +;; on iOS. + +;; [nvALT]: http://brettterpstra.com/projects/nvalt/ +;; [Notational Velocity]: http://notational.net/ +;; [Simplenote]: http://simplenote.com/ +;; [Editorial]: https://geo.itunes.apple.com/us/app/editorial/id673907758?mt=8&uo=6&at=11l5Vs&ct=deft +;; [Byword]: https://geo.itunes.apple.com/us/app/byword/id482063361?mt=8&uo=6&at=11l5Vs&ct=deft +;; [1Writer]: https://geo.itunes.apple.com/us/app/1writer-note-taking-writing/id680469088?mt=8&uo=6&at=11l5Vs&ct=deft + +;; Basic Customization +;; ------------------- + +;; You can customize items in the `deft` group to change the default +;; functionality. + +;; By default, Deft looks for notes by searching for files with the +;; extensions `.txt`, `.text`, `.md`, `.markdown`, or `.org` in the +;; `~/.deft` directory. You can customize both the file extension and +;; the Deft directory by running `M-x customize-group` and typing +;; `deft`. Alternatively, you can configure them in your `.emacs` +;; file: + +;; (setq deft-extensions '("txt" "tex" "org")) +;; (setq deft-directory "~/Dropbox/notes") + +;; The first element of `deft-extensions' (or in Lisp parlance, the +;; car) is the default extension used to create new files. + +;; By default, Deft only searches for files in `deft-directory' but +;; not in any subdirectories. All files in `deft-directory' with one +;; of the specified extensions will be included except for those +;; matching `deft-ignore-file-regexp'. Set `deft-recursive' to a +;; non-nil value to enable searching for files in subdirectories +;; (those not matching `deft-recursive-ignore-dir-regexp'): + +;; (setq deft-recursive t) + +;; You can easily set up a global keyboard binding for Deft. For +;; example, to bind it to F8, add the following code to your `.emacs` +;; file: + +;; (global-set-key [f8] 'deft) + +;; If you manage loading packages with [use-package][], then you can +;; configure by adding a declaration such as this one to your init +;; file: + +;; (use-package deft +;; :bind ("" . deft) +;; :commands (deft) +;; :config (setq deft-directory "~/Dropbox/notes" +;; deft-extensions '("md" "org"))) + +;; [use-package]: https://github.com/jwiegley/use-package + +;; Reading Files +;; ------------- + +;; The displayed title of each file is taken to be the first line of +;; the file, with certain characters removed from the beginning. Hash +;; characters, as used in Markdown headers, and asterisks, as in Org +;; Mode headers, are removed. Additionally, Org mode `#+TITLE:` tags, +;; MultiMarkdown `Title:` tags, LaTeX comment markers, and +;; Emacs mode-line declarations (e.g., `-*-mode-*-`) are stripped from +;; displayed titles. This can be customized by changing +;; `deft-strip-title-regexp'. + +;; More generally, the title post-processing function itself can be +;; customized by setting `deft-parse-title-function', which accepts +;; the first line of the file as an argument and returns the parsed +;; title to display in the file browser. The default function is +;; `deft-strip-title', which removes all occurrences of +;; `deft-strip-title-regexp' as described above. + +;; For compatibility with other applications which use the filename as +;; the title of a note (rather than the first line of the file), set the +;; `deft-use-filename-as-title' flag to a non-`nil' value. Deft will then +;; use note filenames to generate the displayed titles in the Deft +;; file browser. To enable this, add the following to your `.emacs` file: + +;; (setq deft-use-filename-as-title t) + +;; Finally, the short summary that is displayed following the file +;; title can be customized by changing `deft-strip-summary-regexp'. By +;; default, this is set to remove certain org-mode metadata statements +;; such as `#+OPTIONS:` and `#+AUTHOR:'. + +;; Creating Files +;; -------------- + +;; Filenames for newly created files are generated by Deft automatically. +;; The process for doing so is determined by the variables +;; `deft-use-filename-as-title' and `deft-use-filter-string-for-filename' +;; as well as the rules in the `deft-file-naming-rules' alist. +;; The possible cases are as follows: + +;; 1. **Default** (`deft-use-filename-as-title' and +;; `deft-use-filter-string-for-filename' are both `nil'): +;; +;; The filename will be automatically generated using an short, +;; ISO-like timestamp as in `2016-05-12T09:00.txt'. The format +;; can be customized by setting the variable +;; `deft-new-file-format'. The filter string will be inserted as +;; the first line of the file (which is also used as the display +;; title). In case of file name conflicts, an underscore and a +;; numerical suffix (e.g., `_2') will be appended before the +;; extension. + +;; 2. **Filenames as titles** (`deft-use-filename-as-title' is non-`nil'): + +;; When `deft-use-filename-as-title' is non-`nil', the filter string +;; will be used as the filename for new files (with the appropriate +;; file extension appended to the end). An example of new file creation +;; in this case: + +;; * Filter string: "My New Project" +;; * File name: "My New Project.txt" +;; * File contents: [empty] + +;; 3. **Readable filenames** (`deft-use-filename-as-title' is +;; `nil' but `deft-use-filter-string-for-filename' is non-`nil'): + +;; In this case you can choose to display the title as parsed from +;; the first line of the file while also generating readable +;; filenames for new files based on the filter string. The +;; variable `deft-use-filter-string-for-filename' controls this +;; behavior and decouples the title display +;; (`deft-use-filename-as-title') from the actual filename. New +;; filenames will be generated from the filter string and +;; processed according to the rules defined in the +;; `deft-file-naming-rules' alist. By default, slashes are removed +;; and replaced by hyphens, but many other options are possible +;; (camel case, replacing spaces by hyphens, and so on). See the +;; documentation for `deft-file-naming-rules' for additional +;; details. + +;; As an example, with the following value for +;; `deft-file-naming-rules', Deft will replace all slashes and +;; spaces with hyphens and will convert the file name to +;; lowercase: + +;; (setq deft-file-naming-rules +;; '((noslash . "-") +;; (nospace . "-") +;; (case-fn . downcase))) + +;; Below is an example in this case, with the above file naming +;; rules. Notice that the filter string is inserted as the first +;; line of the file but it is also used to generate a "readable" +;; file name. + +;; * Filter string: "My New Project" +;; * File name: "my-new-project.txt" +;; * File contents: "My New Project" + +;; Titles inserted into files from the filter string can also be +;; customized for two common modes, `markdown-mode' and `org-mode', by +;; setting the following variables: + +;; * `deft-markdown-mode-title-level' - When set to a positive +;; integer, determines how many hash marks will be added to titles +;; in new Markdown files. In other words, setting +;; `deft-markdown-mode-title-level' to `2` will result in new files +;; being created with level-2 headings of the form `## Title`. + +;; * `deft-org-mode-title-prefix' - When non-nil, automatically +;; generated titles in new `org-mode' files will be prefixed with +;; `#+TITLE:`. + +;; Other Customizations +;; -------------------- + +;; Deft, by default, lists files from newest to oldest. You can set +;; `deft-current-sort-method' to 'title to sort by file titles, case +;; ignored. Or, you can toggle sorting method using +;; `deft-toggle-sort-method'. + +;; Incremental string search is the default method of filtering on +;; startup, but you can set `deft-incremental-search' to nil to make +;; regexp search the default. + +;; Deft also provides a function for opening files without using the +;; Deft buffer directly. Calling `deft-find-file' will prompt for a +;; file to open, much like `find-file', but limits consideration to +;; files in `deft-directory' that are known to Deft (i.e., those files +;; matching `deft-extensions`). Unlike `find-file`, a list of all +;; such files is provided and the desired file name can be completed +;; using `completing-read' (and, as a result, `deft-find-file` will +;; read/complete filenames using ido, helm, etc. when enabled). If +;; the selected file is in `deft-directory', it is opened with the +;; usual Deft features (automatic saving, automatic updating of the +;; Deft buffer, etc.). Otherwise, the file will be opened by +;; `find-file' as usual. Therefore, you can set up a global +;; keybinding for this function to open Deft files anywhere. For +;; example, to use `C-x C-g`, a neighbor of `C-x C-f`, use the +;; following: + +;; (global-set-key (kbd "C-x C-g") 'deft-find-file) + +;; The faces used for highlighting various parts of the screen can +;; also be customized. By default, these faces inherit their +;; properties from the standard font-lock faces defined by your current +;; color theme. + +;; If you are experiencing slow performance with a large number of +;; files, you can limit the number of files displayed in the buffer by +;; seting `deft-file-limit' to a positive integer value. This limits +;; the number of file widgets that need to be rendered, making each +;; update faster. + +;; Deft also provides several hooks: `deft-mode-hook', +;; `deft-filter-hook', and `deft-open-file-hook'. See the +;; documentation for these variables for further details. + +;; Acknowledgments +;; --------------- + +;; Thanks to Konstantinos Efstathiou for writing simplenote.el, from +;; which I borrowed liberally, and to Zachary Schneirov for writing +;; Notational Velocity, whose functionality and spirit I wanted to +;; bring to Emacs. + +;; History +;; ------- + +;; Version 0.8 (2018-01-12): + +;; * Limit `deft-find-file' to files known to Deft and support +;; completing-read. +;; * Keep subdirectory portion when displaying filenames. +;; * New variable `deft-width-offset' for custom summary line width +;; offset. +;; * Attempt to restore point after refreshing browser and preserve +;; position while filtering. +;; * Add hooks: `deft-filter-hook' for filter string changes and +;; `deft-open-file-hook' which runs after opening a file. +;; * Prevent spurious Deft browser refreshes, which fixes an issue +;; with `sublimity-mode'. +;; * More reliable browser updates when window size changes. +;; * Only update width when buffer is visible. +;; * Lazily update the Deft buffer after saving files. +;; * Close open buffer when deleting a file. +;; * Initialize width even when started in background. +;; * Omit files generated from org or markdown. +;; * Custom format string `deft-new-file-format' for new file names. +;; * Reduce summary line width when there is no fringe. +;; * Support Org links. +;; * Option `deft-filter-only-filenames' to filter only on file names. + +;; Version 0.7 (2015-12-21): + +;; * Add custom regular expression `deft-strip-summary-regexp' for +;; stripping extraneous text for generating the summary line. Strip +;; all `org-mode' metadata by default. +;; * New customizable regular expressions for ignoring files and +;; directories. See `deft-recursive-ignore-dir-regexp' and +;; `deft-ignore-file-regexp'. +;; * Bug fix: Prevent lines from wrapping in console mode. +;; * Bug fix: Setup `deft-extensions` and `deft-default-extension` at +;; load time. +;; * Bug fix: Try to prevent false title matches in org-mode notes +;; where the string `#+TITLE:` might also appear in the body. +;; * Bug fix: Use `with-current-buffer` instead of `save-excursion` +;; while auto-saving files since we do not want to save the point. +;; * Bug fix: Don't escape quotes in `deft-file-naming-rules'. + +;; Version 0.6 (2015-06-26): + +;; * Recursive search in subdirectories (optional). Set +;; `deft-recursive' to a non-nil value to enable. +;; * Support for multiple extensions via the `deft-extensions' list. +;; As such, `deft-extension' is now deprecated. +;; * New variable `deft-create-file-from-filter-string' can enable +;; generation of new filenames based on the filter string. This decouples +;; the title display (`deft-use-filename-as-title') from the actual filename +;; generation. +;; * New variable `deft-file-naming-rules' allows customizing generation +;; of filenames with regard to letter case and handling of spaces. +;; * New variables `deft-markdown-mode-title-level' and +;; `deft-org-mode-title-prefix' for automatic insertion of title markup. +;; * Archiving of files in `deft-archive-directory'. +;; * Ability to sort by either title or modification time via +;; `deft-current-sort-method'. +;; * Update default `deft-strip-title-regexp' to remove the following: +;; - org-mode `#+TITLE:` tags +;; - MultiMarkdown `Title:` tags +;; - LaTeX comment markers +;; - Emacs mode-line declarations (e.g., `-*-mode-*-`) +;; * Remove leading and trailing whitespace from titles. +;; * Disable visual line mode to prevent lines from wrapping. +;; * Enable line truncation to avoid displaying truncation characters. +;; * Show the old filename as the default prompt when renaming a file. +;; * Call `hack-local-variables' to read file-local variables when +;; opening files. +;; * Fixed several byte-compilation warnings. +;; * Bug fix: more robust handling of relative and absolute filenames. +;; * Bug fix: use width instead of length of strings for calculations. +;; * Bug fix: fix `string-width' error with empty file. + +;; Version 0.5.1 (2013-01-28): + +;; * Bug fix: creating files with `C-c C-n` when both the filter string and +;; `deft-use-filename-as-title' are non-nil resulted in an invalid path. +;; * Bug fix: killed buffers would persist in `deft-auto-save-buffers'. + +;; Version 0.5 (2013-01-25): + +;; * Implement incremental string search (default) and regexp search. +;; These search modes can be toggled by pressing `C-c C-t`. +;; * Default search method can be changed by setting `deft-incremental-search'. +;; * Support custom `deft-parse-title-function' for post-processing titles. +;; * The default `deft-parse-title-function' simply strips occurrences of +;; `deft-strip-title-regexp', which removes Markdown and Org headings. +;; * Open files in another window with `C-o`. Prefix it with `C-u` to +;; switch to the other window. +;; * For symbolic links, use modification time of taget for sorting. +;; * When opening files, move point to the end of the first match of +;; the filter string. +;; * Improved filter editing: delete (`DEL`), delete word (`M-DEL`), +;; and yank (`C-y`). +;; * Advanced filter editing in minibuffer (`C-c C-l`). + +;; Version 0.4 (2011-12-11): + +;; * Improved filtering performance. +;; * Optionally take title from filename instead of first line of the +;; contents (see `deft-use-filename-as-title'). +;; * Dynamically resize width to fit the entire window. +;; * Customizable time format (see `deft-time-format'). +;; * Handle `deft-directory' properly with or without a trailing slash. + +;; Version 0.3 (2011-09-11): + +;; * Internationalization: support filtering with multibyte characters. + +;; Version 0.2 (2011-08-22): + +;; * Match filenames when filtering. +;; * Automatically save opened files (optional). +;; * Address some byte-compilation warnings. + +;; Deft was originally written by [Jason Blevins](https://jblevins.org/). +;; The initial version, 0.1, was released on August 6, 2011. + +;;; Code: + +(require 'cl) +(require 'widget) +(require 'wid-edit) + +;; Customization + +(defgroup deft nil + "Emacs Deft mode." + :group 'local) + +(defcustom deft-directory (expand-file-name "~/.deft/") + "Deft directory." + :type 'directory + :safe 'stringp + :group 'deft) + +(make-obsolete-variable 'deft-extension 'deft-extensions "v0.6") + +(defcustom deft-extensions + (if (boundp 'deft-extension) + (cons deft-extension '()) + '("txt" "text" "md" "markdown" "org")) + "Files with these extensions will be listed. +The first element of the list is used as the default file +extension of newly created files, if `deft-default-extension' is +not set." + :type '(repeat string) + :group 'deft) + +(defcustom deft-auto-save-interval 1.0 + "Idle time in seconds before automatically saving buffers opened by Deft. +Set to zero to disable." + :type 'float + :group 'deft) + +(defcustom deft-time-format " %Y-%m-%d %H:%M" + "Format string for modification times in the Deft browser. +Set to nil to hide." + :type '(choice (string :tag "Time format") + (const :tag "Hide" nil)) + :group 'deft) + +(defcustom deft-new-file-format "%Y-%m-%dT%H%M" + "Format string for new file names. +The default value yields a short ISO-like timestamp, as in +\"2016-05-12T0900\". To use a full ISO 8601 time stamp, for +example, set this variable to \"%FT%T%z\". See +`format-time-string' for possible format controls." + :type 'string + :group 'deft) + +(defcustom deft-use-filename-as-title nil + "Use filename as title in the *Deft* buffer." + :type 'boolean + :group 'deft) + +(defcustom deft-use-filter-string-for-filename nil + "Use the filter string to generate name for the new file." + :type 'boolean + :group 'deft) + +(defcustom deft-markdown-mode-title-level 0 + "Prefix titles in new Markdown files with required number of hash marks." + :type 'integer + :group 'deft) + +(defcustom deft-org-mode-title-prefix t + "Prefix the generated title in new `org-mode' files with #+TITLE:." + :type 'boolean + :group 'deft) + +(defcustom deft-incremental-search t + "Use incremental string search when non-nil and regexp search when nil. +During incremental string search, substrings separated by spaces are +treated as subfilters, each of which must match a file. They need +not be adjacent and may appear in any order. During regexp search, the +entire filter string is interpreted as a single regular expression." + :type 'boolean + :group 'deft) + +(defcustom deft-recursive nil + "Recursively search for files in subdirectories when non-nil." + :type 'boolean + :group 'deft) + +(defcustom deft-recursive-ignore-dir-regexp + (concat "\\(?:" + "\\." + "\\|\\.\\." + "\\)$") + "Regular expression for subdirectories to be ignored. +This variable is only effective when searching for files +recursively, that is, when `deft-recursive' is non-nil." + :type 'regexp + :safe 'stringp + :group 'deft) + +(defcustom deft-ignore-file-regexp + (concat "\\(?:" + "^$" + "\\)") + "Regular expression for files to be ignored." + :type 'regexp + :safe 'stringp + :group 'deft) + +(defcustom deft-parse-title-function 'deft-strip-title + "Function for post-processing file titles." + :type 'function + :group 'deft) + +(defcustom deft-strip-title-regexp + (concat "\\(?:" + "^%+" ; line beg with % + "\\|^#\\+TITLE: *" ; org-mode title + "\\|^[#* ]+" ; line beg with #, * and/or space + "\\|-\\*-[[:alpha:]]+-\\*-" ; -*- .. -*- lines + "\\|^Title:[\t ]*" ; MultiMarkdown metadata + "\\|#+" ; line with just # chars + "$\\)") + "Regular expression to remove from file titles. +Presently, it removes leading LaTeX comment delimiters, leading +and trailing hash marks from Markdown ATX headings, leading +astersisks from Org Mode headings, and Emacs mode lines of the +form -*-mode-*-." + :type 'regexp + :safe 'stringp + :group 'deft) + +(defcustom deft-strip-summary-regexp + (concat "\\(" + "[\n\t]" ;; blank + "\\|^#\\+[[:upper:]_]+:.*$" ;; org-mode metadata + "\\)") + "Regular expression to remove file contents displayed in summary. +Presently removes blank lines and `org-mode' metadata statements." + :type 'regexp + :safe 'stringp + :group 'deft) + +(defcustom deft-archive-directory "archive/" + "Deft archive directory. +This may be a relative path from `deft-directory', or an absolute path." + :type 'directory + :safe 'stringp + :group 'deft) + +(defcustom deft-file-naming-rules '( (noslash . "-") ) + "Alist of cons cells (SYMBOL . VALUE) for `deft-absolute-filename'. + +Supported cons car values: `noslash', `nospace', `case-fn'. + +Value of `slash' is a string which should replace the forward +slash characters in the file name. The default behavior is to +replace slashes with hyphens in the file name. To change the +replacement charcter to an underscore, one could use: + + (setq deft-file-naming-rules '((noslash . \"_\"))) + +Value of `nospace' is a string which should replace the space +characters in the file name. Below example replaces spaces with +underscores in the file names: + + (setq deft-file-naming-rules '((nospace . \"_\"))) + +Value of `case-fn' is a function name that takes a string as +input that has to be applied on the file name. Below example +makes the file name all lower case: + + (setq deft-file-naming-rules '((case-fn . downcase))) + +It is also possible to use a combination of the above cons cells +to get file name in various case styles like, + +snake_case: + + (setq deft-file-naming-rules '((noslash . \"_\") + (nospace . \"_\") + (case-fn . downcase))) + +or CamelCase + + (setq deft-file-naming-rules '((noslash . \"\") + (nospace . \"\") + (case-fn . capitalize))) + +or kebab-case + + (setq deft-file-naming-rules '((noslash . \"-\") + (nospace . \"-\") + (case-fn . downcase)))" + :type '(alist :key-type symbol :value-type sexp) + :group 'deft) + +(defcustom deft-generation-rules '(("org" . "tex") ("md" . "tex")) + "Rules for omitting automatically generated files. +For example, .tex files may be generated from `org-mode' or Pandoc." + :type '(repeat (cons string string)) + :group 'deft) + +(defcustom deft-filter-only-filenames nil + "Filter on file names only." + :type 'boolean + :group 'deft) + +(defcustom deft-file-limit nil + "Maximum number of files to list in the Deft browser. +Set this to an integer value if you have a large number of files +and are experiencing performance degradation. This is the +maximum number of files to display in the Deft buffer. When +set to nil, there is no limit." + :type '(choice (integer :tag "Limit number of files displayed") + (const :tag "No limit" nil)) + :group 'deft + :package-version '(deft . "0.9")) + +;; Faces + +(defgroup deft-faces nil + "Faces used in Deft mode" + :group 'deft + :group 'faces) + +(defface deft-header-face + '((t :inherit font-lock-keyword-face :bold t)) + "Face for Deft header." + :group 'deft-faces) + +(defface deft-filter-string-face + '((t :inherit font-lock-string-face)) + "Face for Deft filter string." + :group 'deft-faces) + +(defface deft-filter-string-error-face + '((t :inherit font-lock-warning-face)) + "Face for Deft filter string when regexp is invalid." + :group 'deft-faces) + +(defface deft-title-face + '((t :inherit font-lock-function-name-face :bold t)) + "Face for Deft file titles." + :group 'deft-faces) + +(defface deft-separator-face + '((t :inherit font-lock-comment-delimiter-face)) + "Face for Deft separator string." + :group 'deft-faces) + +(defface deft-summary-face + '((t :inherit font-lock-comment-face)) + "Face for Deft file summary strings." + :group 'deft-faces) + +(defface deft-time-face + '((t :inherit font-lock-variable-name-face)) + "Face for Deft last modified times." + :group 'deft-faces) + +;; Constants + +(defconst deft-version "0.8") + +(defconst deft-buffer "*Deft*" + "Deft buffer name.") + +(defconst deft-separator " --- " + "Text used to separate file titles and summaries.") + +(defconst deft-empty-file-title "[Empty file]" + "Text to use as title for empty files.") + +;; Global variables + +(defvar deft-mode-hook nil + "Hook run when entering Deft mode.") + +(defvar deft-filter-hook nil + "Hook run when the Deft filter string changes.") + +(defvar deft-open-file-hook nil + "Hook run after Deft opens a file.") + +(defvar deft-filter-regexp nil + "A list of string representing the current filter used by Deft. + +In incremental search mode, when `deft-incremental-search' is +non-nil, the elements of this list are the individual words of +the filter string, in reverse order. That is, the car of the +list is the last word in the filter string. + +In regexp search mode, when `deft-incremental-search' is nil, +this list has a single element containing the entire filter +regexp.") + +(defvar deft-current-files nil + "List of files matching current filter.") + +(defvar deft-current-sort-method 'mtime + "Current file soft method. +Available methods are 'mtime and 'title.") + +(defvar deft-all-files nil + "List of all files in `deft-directory'.") + +(defvar deft-hash-contents nil + "Hash containing complete cached file contents, keyed by filename.") + +(defvar deft-hash-mtimes nil + "Hash containing cached file modification times, keyed by filename.") + +(defvar deft-hash-titles nil + "Hash containing cached file titles, keyed by filename.") + +(defvar deft-hash-summaries nil + "Hash containing cached file summaries, keyed by filename.") + +(defvar deft-auto-save-buffers nil + "List of buffers that will be automatically saved.") + +(defvar deft-window-width nil + "Width of Deft buffer.") + +(defvar deft-filter-history nil + "History of interactive filter strings.") + +(defvar deft-regexp-error nil + "Flag for indicating invalid regexp errors.") + +(defvar deft-default-extension (copy-sequence (car deft-extensions)) + "Default file extension of newly created files.") + +(defvar deft-pending-updates nil + "Indicator of pending updates due to automatic saves, etc.") + +(make-obsolete-variable 'deft-width-offset nil "v0.8") + +;; Keymap definition + +(defvar deft-mode-map + (let ((i 0) + (map (make-keymap))) + ;; Make multibyte characters extend the filter string. + (set-char-table-range (nth 1 map) (cons #x100 (max-char)) + 'deft-filter-increment) + ;; Extend the filter string by default. + (setq i ?\s) + (while (< i 256) + (define-key map (vector i) 'deft-filter-increment) + (setq i (1+ i))) + ;; Handle backspace and delete + (define-key map (kbd "DEL") 'deft-filter-decrement) + (define-key map (kbd "M-DEL") 'deft-filter-decrement-word) + ;; Handle return via completion or opening file + (define-key map (kbd "RET") 'deft-complete) + ;; Filtering + (define-key map (kbd "C-c C-l") 'deft-filter) + (define-key map (kbd "C-c C-c") 'deft-filter-clear) + (define-key map (kbd "C-y") 'deft-filter-yank) + ;; File creation + (define-key map (kbd "C-c C-n") 'deft-new-file) + (define-key map (kbd "C-c C-m") 'deft-new-file-named) + (define-key map (kbd "") 'deft-new-file-named) + ;; File management + (define-key map (kbd "C-c C-d") 'deft-delete-file) + (define-key map (kbd "C-c C-r") 'deft-rename-file) + (define-key map (kbd "C-c C-f") 'deft-find-file) + (define-key map (kbd "C-c C-a") 'deft-archive-file) + ;; Settings + (define-key map (kbd "C-c C-t") 'deft-toggle-incremental-search) + (define-key map (kbd "C-c C-s") 'deft-toggle-sort-method) + ;; Miscellaneous + (define-key map (kbd "C-c C-g") 'deft-refresh) + (define-key map (kbd "C-c C-q") 'quit-window) + ;; Widgets + (define-key map [down-mouse-1] 'widget-button-click) + (define-key map [down-mouse-2] 'widget-button-click) + (define-key map (kbd "") 'widget-forward) + (define-key map (kbd "") 'widget-backward) + (define-key map (kbd "") 'widget-backward) + (define-key map (kbd "C-o") 'deft-open-file-other-window) + map) + "Keymap for Deft mode.") + +;; Helpers + +(defun deft-whole-filter-regexp () + "Join incremental filters into one." + (mapconcat 'identity (reverse deft-filter-regexp) " ")) + +(defun deft-search-forward (str) + "Function to use when matching files against filter strings STR. +This function calls `search-forward' when `deft-incremental-search' +is non-nil and `re-search-forward' otherwise." + (if deft-incremental-search + (search-forward str nil t) + (re-search-forward str nil t))) + +(defun deft-set-mode-name () + "Set the mode line text based on search mode." + (if deft-incremental-search + (setq mode-name "Deft") + (setq mode-name "Deft/R"))) + +(defun deft-toggle-incremental-search () + "Toggle the `deft-incremental-search' setting." + (interactive) + (cond + (deft-incremental-search + (setq deft-incremental-search nil) + (message "Regexp search")) + (t + (setq deft-incremental-search t) + (message "Incremental string search"))) + (deft-filter (deft-whole-filter-regexp) t) + (deft-set-mode-name)) + +(defun deft-toggle-sort-method () + "Toggle file sorting method defined in `deft-current-sort-method'." + (interactive) + (setq deft-current-sort-method + (if (eq deft-current-sort-method 'mtime) 'title 'mtime)) + (deft-refresh)) + +(defun deft-filter-regexp-as-regexp () + "Return a regular expression corresponding to the current filter string. +When `deft-incremental-search' is non-nil, we must combine each individual +whitespace separated string. Otherwise, the `car' of `deft-filter-regexp' +is the complete regexp." + (if deft-incremental-search + (mapconcat 'regexp-quote (reverse deft-filter-regexp) "\\|") + (car deft-filter-regexp))) + +;; File processing + +(defun deft-chomp (str) + "Trim leading and trailing whitespace from STR." + (replace-regexp-in-string "\\(^[[:space:]\n]*\\|[[:space:]\n]*$\\)" "" str)) + +(defun deft-base-filename (file) + "Strip `deft-directory' and `deft-extension' from filename FILE." + (let* ((deft-dir (file-name-as-directory (expand-file-name deft-directory))) + (len (length deft-dir)) + (file (substring file len))) + (file-name-sans-extension file))) + +(defun deft-find-all-files () + "Return a list of all files in the Deft directory. + +See `deft-find-files'." + (deft-find-files deft-directory)) + +(defun deft-find-all-files-no-prefix () + "List files in Deft directory with the Deft directory prefix removed. +See `deft-find-files' and `deft-find-all-files'." + (let* ((dir (expand-file-name deft-directory)) + (files (mapcar (lambda (f) (replace-regexp-in-string dir "" f)) + (deft-find-all-files)))) + files)) + +(defun deft-find-files (dir) + "Return a list of all files in the directory DIR. + +It is important to note that the return value is a list of +absolute filenames. These absolute filenames are used as keys +for the various hash tables used for storing file metadata and +contents. So, any functions looking up values in these hash +tables should use `expand-file-name' on filenames first. + +If `deft-recursive' is non-nil, then search recursively in +subdirectories of `deft-directory' (with the exception of +`deft-archive-directory'). + +See `deft-find-all-files'." + (if (file-exists-p dir) + (let ((archive-dir (expand-file-name (concat deft-directory "/" + deft-archive-directory "/"))) + (files (directory-files dir t "." t)) + result) + (dolist (file files) + (cond + ;; Recurse into subdirectory if `deft-recursive' is non-nil + ;; and the directory is not ".", "..", or `deft-archive-directory'. + ((file-directory-p file) + (when (and deft-recursive + (not (string-match deft-recursive-ignore-dir-regexp file)) + (not (string-prefix-p archive-dir + (expand-file-name (concat file "/"))))) + (setq result (append (deft-find-files file) result)))) + ;; Collect names of readable files ending in `deft-extension' + ((and (file-readable-p file) + (not (string-match deft-ignore-file-regexp file)) + (not (backup-file-name-p file)) + (member (file-name-extension file) deft-extensions)) + (setq result (cons file result))))) + (deft-apply-generation-rules result)))) + +(defun deft-apply-generation-rules (lst) + "Apply `deft-generation-rules' to each file in LST. +Remove files which were likely automatically generated from others." + (if deft-generation-rules + (let ((result nil)) + (dolist (file lst) + (when (not (deft-generated-file? file lst)) + (setq result (cons file result)))) + result) + lst)) + +(defun deft-generated-file? (file-name files) + "Determine whether FILE-NAME was likely generated from another in LST. +See `deft-generation-rules'." + (let ((val nil)) + (dolist (rule deft-generation-rules) + (let* ((orig-file-ext (file-name-extension file-name))) + (when (equal (cdr rule) orig-file-ext) + (let* ((new-file-ext (car rule)) + (new-file-name (concat (file-name-sans-extension file-name) + "." new-file-ext))) + (when (not val) + (when (member new-file-name files) + (setq val t))))))) + val)) + +(defun deft-strip-title (title) + "Remove all strings matching `deft-strip-title-regexp' from TITLE." + (deft-chomp (replace-regexp-in-string deft-strip-title-regexp "" title))) + +(defun deft-parse-title (file contents) + "Parse the given FILE and CONTENTS and determine the title. +If `deft-use-filename-as-title' is nil, the title is taken to +be the first non-empty line of the FILE. Else the base name of the FILE is +used as title." + (if deft-use-filename-as-title + (deft-base-filename file) + (let ((begin (string-match "^.+$" contents))) + (if begin + (funcall deft-parse-title-function + (substring contents begin (match-end 0))))))) + +(defun deft-parse-summary (contents title) + "Parse the file CONTENTS, given the TITLE, and extract a summary. +The summary is a string extracted from the contents following the +title." + (let ((summary (let ((case-fold-search nil)) + (replace-regexp-in-string deft-strip-summary-regexp " " contents)))) + (deft-chomp + (if (and title + (not deft-use-filename-as-title) + (string-match (regexp-quote + (if deft-org-mode-title-prefix + (concat "^#+TITLE: " title) + title)) + summary)) + (substring summary (match-end 0) nil) + summary)))) + +(defun deft-cache-file (file) + "Update file cache if FILE exists." + (when (file-exists-p file) + (add-to-list 'deft-all-files file) + (let ((mtime-cache (deft-file-mtime file)) + (mtime-file (nth 5 (file-attributes (file-truename file))))) + (if (or (not mtime-cache) + (time-less-p mtime-cache mtime-file)) + (deft-cache-newer-file file mtime-file))))) + +(defun deft-cache-newer-file (file mtime) + "Update cached information for FILE with given MTIME." + ;; Modification time + (puthash file mtime deft-hash-mtimes) + (let (contents title) + ;; Contents + (with-current-buffer (get-buffer-create "*Deft temp*") + (insert-file-contents file nil nil nil t) + (setq contents (concat (buffer-string)))) + (puthash file contents deft-hash-contents) + ;; Title + (setq title (deft-parse-title file contents)) + (puthash file title deft-hash-titles) + ;; Summary + (puthash file (deft-parse-summary contents title) deft-hash-summaries)) + (kill-buffer "*Deft temp*")) + +(defun deft-file-newer-p (file1 file2) + "Return non-nil if FILE1 was modified since FILE2 and nil otherwise." + (let (time1 time2) + (setq time1 (deft-file-mtime file1)) + (setq time2 (deft-file-mtime file2)) + (time-less-p time2 time1))) + +(defun deft-file-title-lessp (file1 file2) + "Return non-nil if FILE1 title is lexicographically less than FILE2's. +Case is ignored." + (let ((t1 (deft-file-title file1)) + (t2 (deft-file-title file2))) + (string-lessp (and t1 (downcase t1)) + (and t2 (downcase t2))))) + +(defun deft-cache-initialize () + "Initialize hash tables for caching files." + (setq deft-hash-contents (make-hash-table :test 'equal)) + (setq deft-hash-mtimes (make-hash-table :test 'equal)) + (setq deft-hash-titles (make-hash-table :test 'equal)) + (setq deft-hash-summaries (make-hash-table :test 'equal))) + +(defun deft-cache-update-all () + "Update file list and update cached information for each file." + (setq deft-all-files (deft-find-all-files)) ; List all files + (mapc 'deft-cache-file deft-all-files) ; Cache contents + (setq deft-all-files (deft-sort-files deft-all-files))) ; Sort by mtime + +(defun deft-cache-update-file (file) + "Update cached information for a single file named FILE." + (deft-cache-file file) ; Cache contents + (setq deft-all-files (deft-sort-files deft-all-files))) ; Sort by mtime + +(defun deft-current-files () + "Return list `deft-current-files', possibly truncated. +Whether the list is truncated depends on the value of +the variable `deft-file-limit'." + (let ((len (length deft-current-files))) + (if (and (integerp deft-file-limit) + (> len 0) + (< deft-file-limit len)) + (reverse (nthcdr (- len deft-file-limit) + (reverse deft-current-files))) + deft-current-files))) + +;; Cache access + +(defun deft-file-contents (file) + "Retrieve complete contents of FILE from cache." + (gethash file deft-hash-contents)) + +(defun deft-file-mtime (file) + "Retrieve modified time of FILE from cache." + (gethash file deft-hash-mtimes)) + +(defun deft-file-title (file) + "Retrieve title of FILE from cache." + (gethash file deft-hash-titles)) + +(defun deft-file-summary (file) + "Retrieve summary of FILE from cache." + (gethash file deft-hash-summaries)) + +;; File list display + +(defun deft-print-header () + "Prints the *Deft* buffer header." + (if deft-filter-regexp + (progn + (widget-insert + (propertize "Deft: " 'face 'deft-header-face)) + (widget-insert + (propertize (deft-whole-filter-regexp) 'face + (if (and (not deft-incremental-search) deft-regexp-error) + 'deft-filter-string-error-face + 'deft-filter-string-face)))) + (widget-insert + (propertize "Deft" 'face 'deft-header-face))) + (widget-insert "\n\n")) + +(defun deft-current-window-width () + "Return current width of window displaying `deft-buffer'. +If the frame has a fringe, it will absorb the newline. +Otherwise, we reduce the line length by a one-character offset." + (let* ((window (get-buffer-window deft-buffer)) + (fringe-right (ceiling (or (cadr (window-fringes)) 0))) + (offset (if (> fringe-right 0) 0 1))) + (when window + (- (window-text-width window) offset)))) + +(defun deft-buffer-setup (&optional refresh) + "Render the file browser in the *Deft* buffer. +When REFRESH is true, attempt to restore the point afterwards." + (let ((orig-line (line-number-at-pos)) + (orig-col (current-column))) + (when (deft-buffer-visible-p) + (setq deft-window-width (deft-current-window-width))) + (let ((inhibit-read-only t)) + (erase-buffer)) + (remove-overlays) + (deft-print-header) + + ;; Print the files list + (if (not (file-exists-p deft-directory)) + (widget-insert (deft-no-directory-message)) + (if deft-current-files + (progn + (mapc 'deft-file-widget (deft-current-files))) + (widget-insert (deft-no-files-message)))) + + (use-local-map deft-mode-map) + (widget-setup) + (setq deft-pending-updates nil) + + ;; Position or reposition point + (goto-char (point-min)) + (forward-line (if refresh (1- orig-line) 2)) + (forward-char (if refresh orig-col 0)))) + +(defun deft-string-width (str) + "Return 0 if STR is nil and call `string-width` otherwise. +This is simply a wrapper function for `string-width' which +handles nil values gracefully." + (if str (string-width str) 0)) + +(defun deft-file-widget (file) + "Add a line to the file browser for the given FILE." + (when file + (let* ((key (file-name-nondirectory file)) + (text (deft-file-contents file)) + (title (deft-file-title file)) + (summary (deft-file-summary file)) + (mtime (when deft-time-format + (format-time-string deft-time-format (deft-file-mtime file)))) + (mtime-width (deft-string-width mtime)) + (line-width (- deft-window-width mtime-width)) + (title-width (min line-width (deft-string-width title))) + (summary-width (min (deft-string-width summary) + (- line-width + title-width + (length deft-separator))))) + (widget-create 'link + :button-prefix "" + :button-suffix "" + :button-face 'deft-title-face + :format "%[%v%]" + :tag file + :help-echo "Edit this file" + :notify (lambda (widget &rest ignore) + (deft-open-file (widget-get widget :tag))) + (if title (truncate-string-to-width title title-width) + deft-empty-file-title)) + (when (> summary-width 0) + (widget-insert (propertize deft-separator 'face 'deft-separator-face)) + (widget-insert (propertize (truncate-string-to-width summary summary-width) + 'face 'deft-summary-face))) + (when mtime + (while (< (current-column) line-width) + (widget-insert " ")) + (widget-insert (propertize mtime 'face 'deft-time-face))) + (widget-insert "\n")))) + +(defun deft-buffer-visible-p () + "Return non-nil if a window is displaying `deft-buffer'." + (get-buffer-window deft-buffer)) + +(defun deft-window-size-change-function (frame) + "Possibly refresh Deft buffer when size of a window in FRAME is changed. +If there are pending updates, refresh the filtered files list and +update the Deft browser. Otherwise, if the window width changed, +only update the Deft browser." + (when (deft-buffer-visible-p) + (cond (deft-pending-updates (deft-refresh-filter)) + ((/= deft-window-width (deft-current-window-width)) + (deft-refresh-browser))))) + +(defun deft-window-configuration-change-function () + "Possibly refresh Deft browser when window configuration is changed." + (deft-window-size-change-function nil)) + +(defun deft-refresh () + "Update the file cache, reapply the filter, and refresh the *Deft* buffer." + (interactive) + (deft-cache-update-all) + (deft-refresh-filter)) + +(defun deft-refresh-filter () + "Reapply the filter and refresh the *Deft* buffer. +Call this after any actions which update the cache." + (interactive) + (deft-filter-update) + (deft-refresh-browser)) + +(defun deft-refresh-browser () + "Refresh the *Deft* buffer in the background. +Call this function after any actions which update the filter and file list." + (when (get-buffer deft-buffer) + (with-current-buffer deft-buffer + (deft-buffer-setup t)))) + +(defun deft-no-directory-message () + "Return a short message to display when the Deft directory does not exist." + (concat "Directory " deft-directory " does not exist.\n")) + +(defun deft-no-files-message () + "Return a short message to display if no files are found." + (if deft-filter-regexp + "No files match the current filter string.\n" + "No files found.")) + +;; File list file management actions + +(defun deft-absolute-filename (slug &optional extension) + "Return an absolute filename to file named SLUG with optional EXTENSION. +If EXTENSION is not given, `deft-default-extension' is assumed. + +Refer to `deft-file-naming-rules' for setting rules for formatting the file +name." + (let* ((slug (deft-chomp slug)) ; remove leading/trailing spaces + (slash-replacement (cdr (assq 'noslash deft-file-naming-rules))) + (space-replacement (cdr (assq 'nospace deft-file-naming-rules))) + (case-fn (cdr (assq 'case-fn deft-file-naming-rules)))) + (when slash-replacement + (setq slug (replace-regexp-in-string "\/" slash-replacement slug))) + (when space-replacement + (setq slug (replace-regexp-in-string " " space-replacement slug))) + (when case-fn + (setq slug (funcall case-fn slug))) + (concat (file-name-as-directory (expand-file-name deft-directory)) + slug "." (or extension deft-default-extension)))) + +(defun deft-unused-slug () + "Return an unused filename slug (short name) in `deft-directory'." + (let* ((slug (format-time-string deft-new-file-format)) + (fmt (concat slug "_%d")) + (counter 1) + (file (deft-absolute-filename slug))) + (while (or (file-exists-p file) (get-file-buffer file)) + (setq counter (1+ counter)) + (setq slug (format fmt counter)) + (setq file (deft-absolute-filename slug))) + slug)) + +(defun deft-update-visiting-buffers (old new) + "Rename visited file of buffers visiting file OLD to NEW." + (let ((buffer (get-file-buffer old))) + (when buffer + (with-current-buffer (get-file-buffer old) + (set-visited-file-name new nil t) + (hack-local-variables))))) + +(defun deft-open-file (file &optional other switch) + "Open FILE in a new buffer and setting its mode. +When OTHER is non-nil, open the file in another window. When +OTHER and SWITCH are both non-nil, switch to the other window. +FILE must be a relative or absolute path, with extension." + (let ((buffer (find-file-noselect file))) + (with-current-buffer buffer + (hack-local-variables) + (when deft-filter-regexp + (goto-char (point-min)) + (re-search-forward (deft-filter-regexp-as-regexp) nil t)) + ;; Ensure that Deft has been initialized + (when (not (get-buffer deft-buffer)) + (with-current-buffer (get-buffer-create deft-buffer) + (deft-mode))) + ;; Set up auto save hooks + (add-to-list 'deft-auto-save-buffers buffer) + (add-hook 'after-save-hook + (lambda () (save-excursion + (deft-cache-update-file buffer-file-name) + (if (deft-buffer-visible-p) + (deft-refresh-filter) + (setq deft-pending-updates t)))) + nil t) + (run-hooks 'deft-open-file-hook)) + (if other + (if switch + (switch-to-buffer-other-window buffer) + (display-buffer buffer other)) + (switch-to-buffer buffer)))) + +;;;###autoload +(defun deft-find-file (file) + "Find FILE interactively using the minibuffer. +FILE must exist and be a relative or absolute path, with extension. +If FILE is not inside `deft-directory', fall back to using `find-file'." + (interactive + (list (completing-read "Deft find file: " (deft-find-all-files-no-prefix)))) + (let* ((dir (expand-file-name deft-directory))) + ;; If missing, add full deft-directory prefix back + (unless (string-match (concat "^" dir) file) + (setq file (concat dir "/" file))) + (deft-open-file file))) + +(defun deft-auto-populate-title-maybe (file) + "Possibly populate title line for FILE using filter string. +If the filter string is non-nil and `deft-use-filename-as-title' +is nil, then use the filter string to populate the title line in +the newly created FILE." + (when (and deft-filter-regexp (not deft-use-filename-as-title)) + (write-region + (concat + (cond + ((and (> deft-markdown-mode-title-level 0) + (string-match "^\\(txt\\|text\\|md\\|mdown\\|markdown\\)" + deft-default-extension)) + (concat (make-string deft-markdown-mode-title-level ?#) " ")) + ((and deft-org-mode-title-prefix + (string-equal deft-default-extension "org")) + "#+TITLE: ")) + (deft-whole-filter-regexp) + "\n\n") + nil file nil))) + +(defun deft-new-file-named (slug) + "Create a new file named SLUG. +SLUG is the short file name, without a path or a file extension." + (interactive "sNew filename (without extension): ") + (let ((file (deft-absolute-filename slug))) + (if (file-exists-p file) + (message "Aborting, file already exists: %s" file) + (deft-auto-populate-title-maybe file) + (deft-cache-update-file file) + (deft-refresh-filter) + (deft-open-file file) + (with-current-buffer (get-file-buffer file) + (goto-char (point-max)))))) + +;;;###autoload +(defun deft-new-file () + "Create a new file quickly. +Use either an automatically generated filename or the filter string if non-nil +and `deft-use-filter-string-for-filename' is set. If the filter string is +non-nil and title is not from filename, use it as the title." + (interactive) + (let (slug) + (if (and deft-filter-regexp deft-use-filter-string-for-filename) + ;; If the filter string is non-emtpy and titles are taken from + ;; filenames is set, construct filename from filter string. + (setq slug (deft-whole-filter-regexp)) + ;; If the filter string is empty, or titles are taken from file + ;; contents, then use an automatically generated unique filename. + (setq slug (deft-unused-slug))) + (deft-new-file-named slug))) + +(defun deft-filename-at-point () + "Return the name of the file represented by the widget at the point. +Return nil if the point is not on a file widget." + (widget-get (widget-at) :tag)) + +(defun deft-open-file-other-window (&optional arg) + "When the point is at a widget, open the file in the other window. +The argument ARG is passed to `deft-open-file'." + (interactive "P") + (let ((file (deft-filename-at-point))) + (when file + (deft-open-file file t arg)))) + +(defun deft-delete-file () + "Delete the file represented by the widget at the point. +If the point is not on a file widget, do nothing. Prompts before +proceeding." + (interactive) + (let ((filename (deft-filename-at-point))) + (when filename + (when (y-or-n-p + (concat "Delete file " (file-name-nondirectory filename) "? ")) + (let ((buffer (get-file-buffer filename))) + (when buffer (kill-buffer buffer))) + (delete-file filename) + (delq filename deft-current-files) + (delq filename deft-all-files) + (deft-refresh))))) + +(defun deft-rename-file () + "Rename the file represented by the widget at the point. +If the point is not on a file widget, do nothing." + (interactive) + (let ((old-filename (deft-filename-at-point)) + (deft-dir (file-name-as-directory deft-directory)) + new-filename old-name new-name) + (when old-filename + (setq old-name (deft-base-filename old-filename)) + (setq new-name (read-string + (concat "Rename " old-name " to (without extension): ") + old-name)) + (setq new-filename + (concat deft-dir new-name "." deft-default-extension)) + (rename-file old-filename new-filename) + (deft-update-visiting-buffers old-filename new-filename) + (deft-refresh)))) + +(defun deft-archive-file () + "Archive the file represented by the widget at the point. +If the point is not on a file widget, do nothing." + (interactive) + (let (old new name-ext) + (setq old (deft-filename-at-point)) + (when old + (setq name-ext (file-name-nondirectory old)) + (setq new (concat deft-archive-directory name-ext)) + (when (y-or-n-p (concat "Archive file " name-ext "? ")) + ;; if the filename already exists ask for a new name + (while (file-exists-p new) + (setq name-ext (read-string "File exists, choose a new name: " name-ext)) + (setq new (concat deft-archive-directory name-ext))) + (when (not (file-exists-p deft-archive-directory)) + (make-directory deft-archive-directory t)) + (rename-file old new) + (deft-update-visiting-buffers old new) + (deft-refresh))))) + +;; File list filtering + +(defun deft-sort-files-by-mtime (files) + "Sort FILES in reverse order by modified time." + (sort files (lambda (f1 f2) (deft-file-newer-p f1 f2)))) + +(defun deft-sort-files-by-title (files) + "Sort FILES by title, ignoring case." + (sort files (lambda (f1 f2) (deft-file-title-lessp f1 f2)))) + +(defun deft-sort-files (files) + "Sort FILES using method specified in `deft-current-sort-method'." + (funcall (if (eq deft-current-sort-method 'title) + 'deft-sort-files-by-title + 'deft-sort-files-by-mtime) files)) + +(defun deft-filter-initialize () + "Initialize the filter string (nil) and files list (all files)." + (interactive) + (setq deft-filter-regexp nil) + (setq deft-current-files deft-all-files)) + +(defun deft-filter-match-file (file &optional batch) + "Return FILE if it is a match against the current filter regexp. +If BATCH is non-nil, treat `deft-filter-regexp' as a list and match +all elements." + (with-temp-buffer + (insert file) + (let ((title (deft-file-title file)) + (contents (if deft-filter-only-filenames "" (deft-file-contents file)))) + (when title (insert title)) + (when contents (insert contents))) + (if batch + (if (every (lambda (filter) + (goto-char (point-min)) + (deft-search-forward filter)) + deft-filter-regexp) + file) + (goto-char (point-min)) + (if (deft-search-forward (car deft-filter-regexp)) + file)))) + +(defun deft-filter-files (files) + "Update `deft-current-files' given a list of paths, FILES. +Apply `deft-filter-match-file' to `deft-all-files', handling +any errors that occur." + (delq nil + (condition-case nil + ;; Map `deft-filter-match-file' onto FILES. Return + ;; filtered files list and clear error flag if no error. + (progn + (setq deft-regexp-error nil) + (mapcar (lambda (file) (deft-filter-match-file file t)) files)) + ;; Upon an error (`invalid-regexp'), set an error flag + (error + (progn + (setq deft-regexp-error t) + files))))) + +(defun deft-filter-update () + "Update the filtered files list using the current filter regexp. +Starts from scratch using `deft-all-files'. Does not refresh the +Deft buffer." + (if (not deft-filter-regexp) + (setq deft-current-files deft-all-files) + (setq deft-current-files + (deft-filter-files deft-all-files)))) + +;; Filters that cause a refresh + +(defun deft-filter-clear () + "Clear the current filter string and refresh the file browser." + (interactive) + (when deft-filter-regexp + (setq deft-filter-regexp nil) + (setq deft-current-files deft-all-files) + (deft-refresh) + (run-hooks 'deft-filter-hook)) + (message "Filter cleared.")) + +(defun deft-filter (str &optional reset) + "Update the filter with STR and update the file browser. + +In incremental search mode, the car of `deft-filter-regexp' will +be replaced with STR. If STR has zero length and the length of +the list is greater than one, the empty string will be retained +to simulate whitespace. However, if STR has zero length and the +list is of length one, then the filter will be cleared. If STR +is nil, then the car is removed from the list. + +In regexp search mode, the current filter string will be replaced +with STR. + +When called interactively, or when RESET is non-nil, always +replace the entire filter string." + (interactive + (list (read-from-minibuffer "Filter: " (deft-whole-filter-regexp) + nil nil 'deft-filter-history))) + (if deft-incremental-search + ;; Incremental search mode + (if (or (called-interactively-p 'any) reset) + ;; Called interactively or RESET non-nil + (if (= (length str) 0) + (setq deft-filter-regexp nil) + (setq deft-filter-regexp (reverse (split-string str " ")))) + ;; Called noninteractively + (if (not str) + ;; If str is nil, remove it and filter with the cdr + (setq deft-filter-regexp (cdr deft-filter-regexp)) + ;; Use STR it as the new car, even when empty (to simulate + ;; whitespace), unless this is the only element in the list. + (if (and (= (length deft-filter-regexp) 1) + (= (length str) 0)) + (setq deft-filter-regexp nil) + (setcar deft-filter-regexp str)))) + ;; Regexp search mode + (if (> (length str) 0) + (setq deft-filter-regexp (list str)) + (setq deft-filter-regexp nil))) + (deft-filter-update) + (deft-refresh-browser) + (run-hooks 'deft-filter-hook)) + +(defun deft-filter-increment () + "Append character to the filter regexp and update `deft-current-files'." + (interactive) + (let ((char last-command-event)) + (if (= char ?\S-\ ) + (setq char ?\s)) + (setq char (char-to-string char)) + (if (and deft-incremental-search (string= char " ")) + (setq deft-filter-regexp (cons "" deft-filter-regexp)) + (progn + (if (car deft-filter-regexp) + (setcar deft-filter-regexp (concat (car deft-filter-regexp) char)) + (setq deft-filter-regexp (list char))) + (setq deft-current-files (deft-filter-files deft-current-files)) + (setq deft-current-files (delq nil deft-current-files)) + (deft-refresh-browser) + (run-hooks 'deft-filter-hook))))) + +(defun deft-filter-decrement () + "Remove last character from the filter, if possible, and update. + +In incremental search mode, the elements of `deft-filter-regexp' +are the words of the filter string in reverse order. In regexp +search mode, the list is a single element containing the entire +filter regexp. Therefore, in both cases, only the car of +`deft-filter-regexp' is modified." + (interactive) + (let ((str (car deft-filter-regexp))) + (deft-filter + (if (> (length str) 0) + ;; If the last string element has at least one character, + ;; simply remove the last character. + (substring str 0 -1) + ;; Otherwise, return nil + nil)))) + +(defun deft-filter-decrement-word () + "Remove last word from the filter, if possible, and update." + (interactive) + (deft-filter + (if deft-incremental-search + ;; In incremental search mode, remove the car + nil + ;; In regexp search mode, remove last "word" component + ;; (replace-regexp-in-string "[[:space:]\n]*$" "" s) + (let ((str (car deft-filter-regexp))) + (if (> (length str) 0) + (with-temp-buffer + (insert (concat "\"" str "\"")) + (lisp-interaction-mode) + (goto-char (- (point-max) 1)) + (backward-word 1) + (buffer-substring 2 (point))) + nil))))) + +(defun deft-filter-yank () + "Append the most recently killed or yanked text to the filter." + (interactive) + (deft-filter + (concat (deft-whole-filter-regexp) (current-kill 0 t)) t)) + +(defun deft-complete () + "Complete the current action. +If there is a widget at the point, press it. If a filter is +applied and there is at least one match, open the first matching +file. If there is an active filter but there are no matches, +quick create a new file using the filter string as the title. +Otherwise, quick create a new file." + (interactive) + (cond + ;; Activate widget + ((widget-at) + (widget-button-press (point))) + ;; Active filter string with match + ((and deft-filter-regexp deft-current-files) + (deft-open-file (car deft-current-files))) + ;; Default + (t + (deft-new-file)))) + +;;; Automatic File Saving + +(defun deft-auto-save () + "Save any modified files in the list of auto-save files." + (dolist (buf deft-auto-save-buffers) + (if (buffer-name buf) + ;; Save open buffers that have been modified. + (with-current-buffer buf + (when (buffer-modified-p) + (basic-save-buffer))) + ;; If a buffer is no longer open, remove it from auto save list. + (delq buf deft-auto-save-buffers)))) + +;;; Org-link + +(declare-function org-store-link-props "org") +(declare-function org-add-link-type "org") +(declare-function org-open-file-with-emacs "org") + +(defun org-deft-store-link () + "Store the Deft widget at point as an org-mode link." + (when (equal major-mode 'deft-mode) + (let ((link (concat "deft:" (file-name-nondirectory (deft-filename-at-point)))) + (title (deft-file-title (deft-filename-at-point)))) + (org-store-link-props + :type "deft" + :link link + :description title)))) + +(with-eval-after-load 'org + (if (fboundp 'org-link-set-parameters) + (org-link-set-parameters + "deft" :follow 'deft--org-follow-link :store 'org-deft-store-link + :complete 'deft--org-complete) + (org-add-link-type + "Deft" + (lambda (handle) + (org-open-file-with-emacs + (expand-file-name handle deft-directory)))) + (add-hook 'org-store-link-functions 'org-deft-store-link))) + +(defun deft--org-follow-link (handle) + (org-open-file-with-emacs + (expand-file-name handle deft-directory))) + +(defun deft--org-complete () + (let ((file (completing-read "file" (deft-find-all-files-no-prefix)))) + (concat "deft:" (substring file 1)))) + +;;; Mode definition + +(defun deft-show-version () + "Show the version number in the minibuffer." + (interactive) + (message "Deft %s" deft-version)) + +(defun deft-setup () + "Prepare environment by creating the Deft notes directory." + (interactive) + (when (not (file-exists-p deft-directory)) + (make-directory deft-directory t)) + (deft-refresh)) + +;; Deft mode is suitable only for specially-prepared text +(put 'deft-mode 'mode-class 'special) + +(defun deft-mode () + "Major mode for quickly browsing, filtering, and editing plain text notes. +Turning on `deft-mode' runs the hook `deft-mode-hook'. + +\\{deft-mode-map}." + (message "Deft initializing...") + (kill-all-local-variables) + (setq truncate-lines t) + (setq buffer-read-only t) + (setq default-directory (expand-file-name deft-directory)) + (setq deft-window-width (if (deft-buffer-visible-p) + (deft-current-window-width) + (frame-text-cols))) + + ;; Visual line mode causes lines to wrap, so turn it off. + (when (fboundp 'visual-line-mode) + (visual-line-mode 0)) + + (use-local-map deft-mode-map) + (deft-cache-initialize) + (deft-cache-update-all) + (deft-filter-initialize) + (setq major-mode 'deft-mode) + (deft-set-mode-name) + (deft-buffer-setup) + (add-hook 'window-size-change-functions + 'deft-window-size-change-function t) + (add-hook 'window-configuration-change-hook + 'deft-window-configuration-change-function t) + (when (> deft-auto-save-interval 0) + (run-with-idle-timer deft-auto-save-interval t 'deft-auto-save)) + (run-mode-hooks 'deft-mode-hook) + (message "Deft loaded %d files." (length deft-all-files))) + +(put 'deft-mode 'mode-class 'special) + +;;;###autoload +(defun deft () + "Switch to *Deft* buffer and load files." + (interactive) + (switch-to-buffer deft-buffer) + (if (not (eq major-mode 'deft-mode)) + (deft-mode))) + +(provide 'deft) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; indent-tabs-mode: nil +;; End: + +;;; deft.el ends here diff --git a/lisp/delight.el b/lisp/delight.el new file mode 100644 index 00000000..54eb01f8 --- /dev/null +++ b/lisp/delight.el @@ -0,0 +1,495 @@ +;;; delight.el --- A dimmer switch for your lighter text -*- lexical-binding:t -*- +;; +;; Copyright (C) 2013-2020 Free Software Foundation, Inc. + +;; Author: Phil Sainty +;; Maintainer: Phil Sainty +;; URL: https://savannah.nongnu.org/projects/delight +;; Package-Requires: ((cl-lib "0.5") (nadvice "0.3")) +;; Keywords: convenience +;; Created: 25 Jun 2013 +;; Version: 1.7 + +;; 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 . + +;;; Commentary: +;; +;; Enables you to customise the mode names displayed in the mode line. +;; +;; For major modes, the buffer-local `mode-name' variable is modified. +;; For minor modes, the associated value in `minor-mode-alist' is set. +;; +;; Example usage: +;; +;; ;; Delighting a single mode at a time: +;; (require 'delight) +;; (delight 'abbrev-mode " Abv" "abbrev") +;; (delight 'rainbow-mode) +;; +;; ;; Delighting multiple modes together: +;; (require 'delight) +;; (delight '((abbrev-mode " Abv" "abbrev") +;; (smart-tab-mode " \\t" "smart-tab") +;; (eldoc-mode nil "eldoc") +;; (rainbow-mode) +;; (overwrite-mode " Ov" t) +;; (emacs-lisp-mode "Elisp" :major))) +;; +;; The first argument is the mode symbol. +;; +;; The second argument is the replacement name to use in the mode line +;; (or nil to hide it). +;; +;; The third argument is either the keyword :major for major modes or, +;; for minor modes, the library which defines the mode. This is passed +;; to `eval-after-load' and so should be either the name (as a string) +;; of the library file which defines the mode, or the feature (symbol) +;; provided by that library. If this argument is nil, the mode symbol +;; will be passed as the feature. If this argument is either t or 'emacs +;; then it is assumed that the mode is already loaded (you can use this +;; with standard minor modes that are pre-loaded by default when Emacs +;; starts). +;; +;; In the above example, `rainbow-mode' is the symbol for both the minor +;; mode and the feature which provides it, and its lighter text will be +;; hidden from the mode line. +;; +;; To determine which library defines a mode, use e.g.: C-h f eldoc-mode. +;; The name of the library is displayed in the first paragraph, with an +;; ".el" suffix (in this example it displays "eldoc.el", and therefore we +;; could use the value "eldoc" for the library). +;; +;; If you simply cannot figure out which library to specify, an +;; alternative approach is to evaluate (delight 'something-mode nil t) +;; once you know for sure that the mode has already been loaded, perhaps +;; by using the mode hook for that mode. +;; +;; If all else fails, it's worth looking at C-h v minor-mode-alist +;; (after enabling the minor mode in question). There are rare cases +;; where the entry in `minor-mode-alist' has a different symbol to the +;; minor mode with which it is associated, and in these situations you +;; will need to specify the name in the alist, rather than the name of +;; the mode itself. Known examples (and how to delight them) are: +;; +;; `auto-fill-mode': (delight 'auto-fill-function " AF" t) +;; `server-mode': (delight 'server-buffer-clients " SV" 'server) +;; +;; * Important notes: +;; +;; Although strings are common, any mode line construct is permitted as +;; the value (for both minor and major modes); so before you override a +;; value you should check the existing one, as you may want to replicate +;; any structural elements in your replacement if it turns out not to be +;; a simple string. +;; +;; For major modes, M-: mode-name +;; For minor modes, M-: (cadr (assq 'MODE minor-mode-alist)) +;; for the minor MODE in question. +;; +;; Conversely, you may incorporate additional mode line constructs in +;; your replacement values, if you so wish. e.g.: +;; +;; (delight 'emacs-lisp-mode +;; '("Elisp" (lexical-binding ":Lex" ":Dyn")) +;; :major) +;; +;; See `mode-line-format' for information about mode line constructs, and +;; M-: (info "(elisp) Mode Line Format") for further details. +;; +;; Settings for minor modes are held in a global variable and tend to take +;; immediate effect upon calling ‘delight’. Major mode names are held in +;; buffer-local variables, however, so changes to these will not take +;; effect in a given buffer unless the major mode is called again, or the +;; buffer is reverted. Calling M-x normal-mode is sufficient in most +;; cases. +;; +;; Also bear in mind that some modes may dynamically update these values +;; themselves (for instance dired-mode updates mode-name if you change the +;; sorting criteria) in which cases this library may prove inadequate. +;; +;; Some modes also implement direct support for customizing these values; +;; so if delight is not sufficient for a particular mode, be sure to check +;; whether the library in question provides its own way of doing this. +;; +;; * Conflict with `c-mode' and related major modes: +;; +;; Major modes based on cc-mode.el (including ‘c-mode’, ‘c++-mode’, and +;; derivatives such as ‘php-mode’) cannot be delighted, due to Emacs bug +;; #2034: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=2034 +;; +;; cc-mode.el assumes that ‘mode-name’ is always a string (which was true +;; in Emacs 22 and earlier), while delight.el makes use of the fact that +;; ‘mode-name’ can (since Emacs 23) contain any mode line construct. The +;; two are therefore incompatible. +;; +;; The symptom of this conflict is the following error (where the "..." +;; varies): +;; +;; (wrong-type-argument stringp (delight-mode-name-inhibit ...)) +;; +;; The conflicting function is ‘c-update-modeline’ which adds the various +;; suffix characters documented at M-: (info "(ccmode) Minor Modes"). +;; (E.g. In the mode line of a ‘c-mode’ buffer, the name C might be +;; changed to "C/*l" or similar, depending on the minor modes.) +;; +;; If you are willing (or indeed wishing) to eliminate those suffixes +;; entirely for all relevant major modes, then you can work around this +;; conflict between the two libraries by disabling ‘c-update-modeline’ +;; entirely, like so: +;; +;; (advice-add 'c-update-modeline :override #'ignore) +;; +;; * Integration with mode line replacement libraries: +;; +;; Libraries which replace the standard mode line are liable to conflict +;; with delight's treatment of major modes, as such libraries invariably +;; need to call `format-mode-line', which otherwise happens only in +;; circumstances in which delight wishes to show the original mode-name. +;; +;; These libraries (or custom advice) can prevent this by let-binding +;; `delight-mode-name-inhibit' to nil around calls to `format-mode-line' +;; which will ensure that the delighted `mode-name' is displayed. +;; +;; * Configuration via use-package: +;; +;; The popular `use-package' macro supports delight.el so you can also +;; delight modes as part of your package configurations. See its README +;; file for details. + +;;; Change Log: +;; +;; 1.7 (2020-07-11) +;; - Add `delight-version'. +;; - Support loading newer versions over the top of older versions. +;; - Support `unload-feature'. +;; - Rename `delighted-modes' to `delight-delighted-modes'. +;; - Rename `delight--inhibit' to `delight-mode-name-inhibit', and +;; document its uses. +;; 1.6 (2019-07-23) +;; - Use cl-lib, nadvice, and lexical-binding. +;; - Rename `inhibit-mode-name-delight' to `delight--inhibit'. +;; 1.5 (2016-03-01) +;; - Support FILE value t, meaning that the minor MODE in question +;; is guaranteed to already be loaded. +;; 1.4 (2016-02-28) +;; - Respect `inhibit-mode-name-delight' when already set. +;; 1.3 (2014-05-30) +;; - Add support for `mode-line-mode-menu'. +;; 1.2 (2014-05-04) +;; - Bug fix for missing 'cl requirement for destructuring-bind macro. +;; 1.1 (2014-05-04) +;; - Allow the keyword :major as the FILE argument for major modes, +;; to avoid also processing them as minor modes. +;; 1.0 (2013-06-25) +;; - Initial release. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'nadvice) + +(defconst delight--latest-version "1.7") + +;; Check whether a newer version is being loaded over an older one. +;; +;; If `delight-version' has an existing value which is less than +;; `delight--latest-version', then an earlier version was already loaded, +;; and we must perform any necessary updates (see "Live upgrades" below). +;; +;; If `delight-version' is unbound then most likely there was no older +;; version loaded; however, prior to version 1.7 `delight-version' was not +;; defined at all, and so we need to detect that scenario too. +(defvar delight-version + (if (not (featurep 'delight)) + ;; The normal case: delight was not already loaded. + delight--latest-version + ;; Otherwise delight was loaded. However, as this initial value code is + ;; being evaluated, the loaded version had not defined `delight-version'. + (cond + ;; In 1.5 and earlier, `delight--format-mode-line' didn't exist. + ;; (Earlier versions can be treated as 1.5 for upgrade purposes.) + ((not (fboundp 'delight--format-mode-line)) + "1.5") + ;; In 1.6 `delight--inhibit' wasn't an alias. + ((eq (indirect-variable 'delight--inhibit) 'delight--inhibit) + "1.6") + ;; If we get to here, we've probably used `eval-defun' on this defvar. + (t delight--latest-version))) + "The loaded version of delight.el.") + +(define-obsolete-variable-alias 'delighted-modes + 'delight-delighted-modes "delight-1.7") + +(defvar delight-delighted-modes nil + "List of specs for modifying the display of mode names in the mode line. + +See `delight'.") + +;;;###autoload +(defun delight (spec &optional value file) + "Modify the lighter value displayed in the mode line for the given mode SPEC +if and when the mode is loaded. + +SPEC can be either a mode symbol, or a list containing multiple elements of +the form (MODE VALUE FILE). In the latter case the two optional arguments are +omitted, as they are instead specified for each element of the list. + +For minor modes, VALUE is the replacement lighter value (or nil to disable) +to set in the `minor-mode-alist' variable. For major modes VALUE is the +replacement buffer-local `mode-name' value to use when a buffer changes to +that mode. + +In both cases VALUE is commonly a string, but may in fact contain any valid +mode line construct. For details see the `mode-line-format' variable, and +Info node `(elisp) Mode Line Format'. + +The FILE argument is passed through to `eval-after-load'. If FILE is nil then +the mode symbol is passed as the required feature. If FILE is t then it is +assumed that the mode is already loaded. (Note that you can also use \\='emacs +for this purpose). These FILE options are relevant to minor modes only. + +For major modes you should specify the keyword :major as the value of FILE, +to prevent the mode being treated as a minor mode." + (let ((glum (if (consp spec) spec (list (list spec value file))))) + (while glum + (cl-destructuring-bind (mode &optional value file) (pop glum) + (assq-delete-all mode delight-delighted-modes) + (add-to-list 'delight-delighted-modes (list mode value file)) + ;; Major modes are handled in `after-change-major-mode-hook'. + ;; Minor modes are handled at load time: + (unless (eq file :major) + (eval-after-load (if (eq file t) 'emacs (or file mode)) + `(when (featurep 'delight) + (let ((minor-delight (assq ',mode minor-mode-alist))) + (when minor-delight + (setcar (cdr minor-delight) ',value) + (delight-mode-line-mode-menu ',mode ',value)))))))))) + +(defun delight-mode-line-mode-menu (mode value) + "Delight `mode-line-mode-menu' (the \"Toggle minor modes\" menu) +so that the Lighter text displayed in the menu matches that displayed in +the mode line (when such menu items exist). + +The expected naming scheme for the menu items is: \"Friendly name (Lighter)\" +e.g.: \"Highlight changes (Chg)\". + +We replace the \"Lighter\" portion of that with our delighted VALUE, for the +specified MODE, unless VALUE is empty/nil, in which case we remove the text +and parentheses altogether. + +If the delighted VALUE is not a string and not nil, we do nothing." + (when (string-or-null-p value) + (let* ((menu-keymap mode-line-mode-menu) + (menu-item (assq mode (cdr menu-keymap)))) + (when menu-item + ;; Lighter text is typically prefixed with a space to separate + ;; it from the preceding lighter. We need to trim that space. + (let* ((trimmed-value (if (and value (string-match "\\`\\s-+" value)) + (replace-match "" t t value) + value)) + (wrapped-value (if (> (length trimmed-value) 0) + (concat " (" trimmed-value ")") + "")) + (menu-def (cdr menu-item)) + (label (cadr menu-def)) + (new-label (and (stringp label) + (or (string-match "\\s-+(.+?)\\s-*\\'" label) + (string-match "\\s-*\\'" label)) + (replace-match wrapped-value t t label)))) + (when new-label + ;; Pure storage is used for the default menu items, so we + ;; cannot modify those objects directly. + (setq menu-def (copy-sequence menu-def)) + (setf (cadr menu-def) new-label) + (define-key menu-keymap (vector mode) menu-def))))))) + +;; Handle major modes at call time. +(add-hook 'after-change-major-mode-hook #'delight-major-mode) + +(defun delight-major-mode () + "Delight the 'pretty name' of the current buffer's major mode +when displayed in the mode line. + +When `mode-name' is displayed in other contexts (such as in the +`describe-mode' help buffer), its original value will be used, +unless `delight-mode-name-inhibit' is bound and nil." + (let ((major-delight (assq major-mode delight-delighted-modes))) + (when major-delight + (setq mode-name `(delight-mode-name-inhibit + ,mode-name ;; glum + ,(cadr major-delight)))))) ;; delighted + +(define-obsolete-variable-alias 'inhibit-mode-name-delight + 'delight-mode-name-inhibit "delight-1.6") +(define-obsolete-variable-alias 'delight--inhibit + 'delight-mode-name-inhibit "delight-1.7") + +(makunbound 'delight-mode-name-inhibit) +;; We explicitly call `makunbound' first because our `delight-unload-function' +;; workaround for dealing with any remaining delighted `mode-name' values is +;; simply to redefine `delight-mode-name-inhibit' with a non-nil default value. + +(defvar delight-mode-name-inhibit) +;; This variable determines whether the `mode-name' set by `delight-major-mode' +;; will render as the original name or the delighted name. For the purposes of +;; mode line formatting, void and nil are equivalent. It is void by default so +;; that we are able to respect any binding made by external code, and only +;; let-bind it ourselves if no such external binding exists. +;; +;; Note that if this were bound to nil by default, `delight--format-mode-line' +;; would be unable to recognise a nil binding made by some other library; and +;; if it were bound to a non-nil value by default, then we would render the +;; wrong value in the mode line. + +(put 'delight-mode-name-inhibit 'variable-documentation + "Whether to display the original `mode-name' of a delighted major mode. + +A non-nil value means that the original mode name will be displayed +instead of the delighted name. + +If nil or void, then the delighted mode name will be displayed. + +With the exception of Emacs' standard mode line rendering, anything +rendering a mode line construct (for instance the `describe-mode' help +buffer) will call `format-mode-line'. Normally we want to display +delighted major mode names only in the mode line itself, and not in +other contexts, and so this variable is used to inhibit the delighted +names during `format-mode-line' calls. + +However, certain libraries may call `format-mode-line' for the purpose +of replacing the standard mode line entirely, in which case we DO want +to see the delighted major mode names during those particular +`format-mode-line' calls. + +This variable is normally void, and bound to t during calls to +`format-mode-line'. If, however, it is already bound, then its value +will be respected; therefore binding `delight-mode-name-inhibit' to +nil around a call to `format-mode-line' will allow the delighted name +to be rendered. + +See also `delight--format-mode-line'.") + +(defun delight--format-mode-line (orig-fun &rest args) + "Advice for `format-mode-line'. + +Delighted major modes should exhibit their original `mode-name' when +`format-mode-line' is called. See `delight-major-mode' as well as +`delight-mode-name-inhibit'." + (let ((delight-mode-name-inhibit (if (boundp 'delight-mode-name-inhibit) + delight-mode-name-inhibit + t))) + (apply orig-fun args))) + +(advice-add 'format-mode-line :around #'delight--format-mode-line) + +(defun delight-unload-function () + "Handler for `unload-feature'." + (condition-case err + (progn + (defvar unload-function-defs-list) + ;; Remove hook. + (remove-hook 'after-change-major-mode-hook #'delight-major-mode) + ;; Remove advice. + (advice-remove 'format-mode-line #'delight--format-mode-line) + ;; Revert the `mode-name' changes (for the normal/expected cases). + ;; We're not concerned with reversing ALL changes made, but we make + ;; the effort for `mode-name' as it might prevent conflicts with + ;; code which wasn't expecting a non-string mode line construct as + ;; a value (e.g. Emacs bug 2034). + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (and (consp mode-name) + (symbolp (car mode-name)) + (eq (indirect-variable (car mode-name)) + 'delight-mode-name-inhibit)) + (setq mode-name (cadr mode-name))))) + ;; We keep `delight-mode-name-inhibit' around (with delighted values + ;; permanently inhibited) for any unexpected cases (e.g. where our + ;; modified `mode-name' was further manipulated by something else, + ;; and no longer matched the format expected above). + (defconst delight-mode-name-inhibit t) + (dolist (var '(delight-mode-name-inhibit ;; and its aliases + delight--inhibit + inhibit-mode-name-delight)) + (setq unload-function-defs-list + (delq var unload-function-defs-list))) + ;; Return nil if unloading was successful. Refer to `unload-feature'. + nil) + ;; If any error occurred, return non-nil. + (error (progn + (message "Error unloading delight: %S %S" (car err) (cdr err)) + t)))) + +;; Live upgrades, for when a newer version is loaded over an older one. +(when (version< delight-version delight--latest-version) + ;; Perform each update in sequence, as necessary. + ;; Update to version 1.6 from earlier versions: + (when (version< delight-version "1.6") + ;; Old advice was replaced by nadvice. + (eval-and-compile (require 'advice)) ;; Both macros and functions. + (declare-function ad-find-advice "advice") + (declare-function ad-remove-advice "advice") + (declare-function ad-activate "advice") + (when (ad-find-advice 'format-mode-line 'around 'delighted-modes-are-glum) + (ad-remove-advice 'format-mode-line 'around 'delighted-modes-are-glum) + (ad-activate 'format-mode-line))) + ;; Update to version 1.N: + ;; (when (version< delight-version "1.N") ...) + ;; + ;; All updates completed. + (setq delight-version delight--latest-version)) + + +;; Local Variables: +;; indent-tabs-mode: nil +;; ispell-check-comments: exclusive +;; End: + +;;;; ChangeLog: + +;; 2020-07-11 Phil Sainty +;; +;; Merge commit '5a0cd5ccb650d7bba1c1ea02cf67b71d7cfa6e9a' from delight +;; +;; 2019-07-23 Stefan Monnier +;; +;; * packages/delight/delight.el: Use cl-lib and nadvice. +;; +;; (delight--inhibit): Rename from inhibit-mode-name-delight to clean up +;; namespace use. +;; (delight--format-mode-line): New function, extracted from the old +;; defadvice. +;; (format-mode-line): Replace defadvice with advice-add. +;; +;; 2016-07-14 Phil Sainty +;; +;; Use GNU ELPA version number formatting +;; +;; 2016-07-13 Stefan Monnier +;; +;; * delight.el: Fix copyright +;; +;; 2016-07-14 Phil Sainty +;; +;; Add 'packages/delight/' from commit +;; 'cd037ed41ae29dda89e36ff2ac8637aea96acded' +;; +;; git-subtree-dir: packages/delight git-subtree-mainline: +;; a1cdea05e8cbfe15ba075c64417db20b814e48e8 git-subtree-split: +;; cd037ed41ae29dda89e36ff2ac8637aea96acded +;; + + +(provide 'delight) +;;; delight.el ends here diff --git a/lisp/dialog.el b/lisp/dialog.el new file mode 100644 index 00000000..208b2590 --- /dev/null +++ b/lisp/dialog.el @@ -0,0 +1,3039 @@ +;;; dialog.el --- dialog box interface using widgets, frames and windows + +;; Copyright (C) 2008-2019 Vinicius Jose Latorre + +;; Time-stamp: <2019/10/10 01:16:31 vinicius> +;; Author: Vinicius Jose Latorre +;; Maintainer: Vinicius Jose Latorre +;; Keywords: convenience, extensions, hypermedia +;; Version: 0.2 +;; X-URL: https://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre + +;; This file is *NOT* (yet?) 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, 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Introduction +;; ------------ +;; +;; This package implements a dialog box interface using widgets, +;; frames and windows. +;; +;; `dialog' package uses the widget package which handle all low level +;; stuff for deal with buttons, fields, etc. The buttons, fields, +;; etc. are created in a buffer. +;; +;; `dialog' package simplifies the use of the widget package, as the +;; easymenu package simplifies the menu creation/management. +;; +;; `dialog' package provides a mechanism to navigate through dialogs. +;; +;; This package was tested on Emacs 22 and 23. +;; +;; +;; Using dialog +;; ------------ +;; +;; As an example, here is a very simple dialog specification: +;; +;; (require 'dialog) +;; +;; (dialog-define hello1 +;; '(:style window +;; [navigation 1 1 :tag "Navigation"] +;; [text 3 1 "Hello World 1!!"] +;; [button-quit 5 1] +;; [button-previous 5 10 :tag "Hello :("]) +;; "This is a Hello World example.") +;; +;; (dialog-define hello2 +;; '(:style window +;; [navigation 1 1 :tag "Navigation"] +;; [text 3 1 "Hello World 2!!"] +;; [button-quit 5 1] +;; [button-next 5 10 hello1 :tag "Hello :)"]) +;; "This is another Hello World example.") +;; +;; (hello2) ; or (dialog-run 'hello2) run dialog hello2 +;; +;; The following screen is displayed when hello2 executes: +;; +;; ------------------------------------------------------------ hello2 +;; Navigation: hello2 +;; +;; Hello World 2!! +;; +;; [Quit] [Hello :)] +;; ------------------------------------------------------------ hello2 +;; +;; If [Quit] button is pressed (by mouse ou keyboard), the dialog box +;; quits. If [Hello :)] button is pressed, the dialog hello executes +;; as seen below. +;; +;; ------------------------------------------------------------- hello +;; Navigation: [hello2] :: hello +;; +;; Hello World 1!! +;; +;; [Quit] [Hello :(] +;; ------------------------------------------------------------- hello +;; +;; If [Hello :(] or [hello2] button is pressed, the dialog hello2 +;; executes as seen above. +;; +;; +;; Interface Functions +;; ------------------- +;; +;; -- Macro: dialog-define dialog spec doc +;; Declare a dialog called DIALOG with items described in SPEC. +;; DIALOG does not need to be quoted. +;; +;; Second argument SPEC is the dialog specification. +;; +;; Third argument DOC is the dialog documentation. +;; +;; See _Defining a Dialog Box_ section for SPEC documentation. +;; See also _Dialog Derivation_ section. +;; +;; -- Function: dialog-doc-string dialog +;; -- Function: dialog-documentation dialog +;; Get the documentation string for DIALOG. +;; +;; -- Function: dialog-make-empty dialog +;; Define a new, empty dialog with name DIALOG. +;; If the dialog already exists, it is left unmodified. +;; Return DIALOG. +;; +;; -- Function: dialog-run dialog +;; Execute DIALOG. See `dialog-define'. +;; +;; -- Function: dialog-spec dialog +;; Get the DIALOG specification. See `dialog-define'. +;; +;; -- Function: dialog-update-text sym +;; Update text field associated with symbol SYM. +;; See `dialog-define'. +;; +;; -- Function: dialogp object +;; Return t if OBJECT is a dialog object. +;; +;; -- Function: set-dialog-doc-string dialog doc +;; -- Function: set-dialog-documentation dialog doc +;; Set the documentation string for DIALOG to DOC. +;; +;; -- Function: set-dialog-spec dialog spec +;; Set the DIALOG specification. See `dialog-define'. +;; +;; +;; Defining a Dialog Box +;; --------------------- +;; +;; A dialog box is defined by a list which has the following form: +;; +;; (STYLE FIELD...) +;; +;; Where STYLE specifies how dialog will be opened and dialog +;; derivation (more about this below), and FIELD is a vector which +;; specifies a dialog field. +;; +;; Valid values for STYLE are: +;; +;; :style window +;; Use the current frame with only one window. +;; +;; :style split-window-horizontally +;; :style (split-window-horizontally . ARG) +;; Split current window horizontally and select the window at +;; left. ARG is optional; if specified, it is passed as argument +;; to `split-window-horizontally' function (which see). +;; ARG must be an integer. +;; +;; :style split-window-vertically +;; :style (split-window-vertically . ARG) +;; Split current window vertically and select the window above. +;; ARG is optional; if specified, it is passed as argument for +;; `split-window-vertically' function (which see). +;; ARG must be an integer. +;; +;; :style frame +;; :style (frame . POSITION) +;; Make a new frame. POSITION is optional; it specifies the +;; position of the upper left corner of the new frame. +;; POSITION can have the following values: +;; +;; (X . Y) the position in pixels. +;; +;; point the current point position. +;; +;; mouse the current mouse position. +;; +;; center the new frame is centralized in the selected frame. +;; +;; frame the upper left corner of the selected frame. +;; +;; If POSITION is omitted, the frame position is given by the +;; system where Emacs is running. +;; +;; If there isn't a windowing system, it behaves as `window'. +;; +;; :parent DIALOG +;; :parent (DIALOG . DECORATION) +;; This dialog derives from dialog DIALOG (the parent dialog). +;; DECORATION specifies what to do with decorations (box, hline +;; and vline fields). DECORATION can have the following values: +;; +;; keep keep all parent decoration. +;; +;; kill kill all parent decoration. +;; +;; kill-overlap kill parent decoration only when overlaps with +;; some derived dialog field (decoration or not). +;; +;; The DECORATION default value is keep. +;; +;; See _Dialog Derivation_ section. +;; +;; STYLE can be omitted, the default value is `:style window'. +;; +;; The window configuration is saved just before the dialog box +;; activation and it is restored just after dialog box termination. +;; +;; There exist the following FIELD types: +;; +;; box +;; button +;; button-cancel +;; button-next +;; button-ok +;; button-previous +;; button-quit +;; button-reset +;; checkbox +;; editable +;; hline +;; menu +;; navigation +;; radio +;; text +;; vline +;; +;; FIELD has the following forms: +;; +;; [box LINE COLUMN LINE2 COLUMN2 +;; :tag TAG] +;; +;; Draw a box which diagonal vertices are at LINE and COLUMN, and +;; at LINE2 and COLUMN2. +;; LINE(2) starts from 1. COLUMN(2) starts from 0. +;; TAG contains the characters used to draw the box border. +;; If TAG is omitted, the default value is ".-|++++". +;; The TAG string specifies: +;; +;; ".-|++++" +;; ::::::: +;; ::::::+--- bottom left corner +;; :::::+---- bottom right corner +;; ::::+----- top left corner +;; :::+------ top right corner +;; ::+------- vertical +;; :+-------- horizontal +;; +--------- null box (LINE = LINE2 and COLUMN = COLUMN2) +;; +;; [button LINE COLUMN +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a button at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; If TAG is omitted, "Button" is used. +;; When pressed, it executes FUNCTION, if FUNCTION is +;; specified. If FUNCTION is omitted, nothing happens. +;; See _Field Keywords_ section below. +;; +;; [button-cancel LINE COLUMN +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a cancel button at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; If TAG is omitted, "Cancel" is used. +;; When pressed, it takes the following steps: +;; 1. Discard all temporary dialog values; +;; 2. Execute FUNCTION, if FUNCTION is specified; +;; 3. Finish the current dialog, that is, return to previous +;; dialog, if exists one. +;; See _Field Keywords_ section below. +;; +;; [button-next LINE COLUMN DIALOG +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a next button at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; If TAG is omitted, "Next" is used. +;; If DIALOG is not a dialog, nothing happens. +;; If DIALOG is a dialog, when pressed, it takes the following +;; steps: +;; 1. Execute FUNCTION, if FUNCTION is specified; +;; 2. Go to next DIALOG. +;; See _Field Keywords_ section below. +;; +;; [button-ok LINE COLUMN +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify an ok button at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; If TAG is omitted, "Ok" is used. +;; When pressed, it takes the following steps: +;; 1. All temporary dialog values are saved into +;; corresponding variables; +;; 2. Execute FUNCTION, if FUNCTION is specified; +;; 3. Finish the current dialog, that is, return to previous +;; dialog, if exists one. +;; See _Field Keywords_ section below. +;; +;; [button-previous LINE COLUMN +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a previous button at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; If TAG is omitted, "Previous" is used. +;; If there isn't a previous dialog, nothing happens. +;; If there isn a previous dialog, when pressed, it takes the +;; following steps: +;; 1. Execute FUNCTION, if FUNCTION is specified; +;; 2. Go to previous dialog. +;; See _Field Keywords_ section below. +;; +;; [button-quit LINE COLUMN +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a quit button at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; If TAG is omitted, "Quit" is used. +;; When pressed, it takes the following steps: +;; 1. Discard all temporary dialog values; +;; 2. Execute FUNCTION, if FUNCTION is specified; +;; 3. Finish all dialog chain. +;; See _Field Keywords_ section below. +;; +;; [button-reset LINE COLUMN +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a reset button at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; If TAG is omitted, "Reset" is used. +;; When pressed, it takes the following steps: +;; 1. Reset all temporary dialog values, that is, restore the +;; original value for each temporary dialog variable; +;; 2. Execute FUNCTION, if FUNCTION is specified. +;; See _Field Keywords_ section below. +;; +;; [checkbox LINE COLUMN VAR +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a checkbox at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; VAR is a symbol variable which will hold the checkbox value. +;; If TAG is omitted, it is created only the checkbox. +;; If TAG is specified, the first character indicates if the TAG +;; is positioned at left or right of the checkbox. If the first +;; character is `?-', the TAG is positioned at left of the +;; checkbox, that is: +;; +;; TAG [] +;; +;; If the first character is not `?-', the TAG is positioned at +;; right of the checkbox, that is: +;; +;; [] TAG +;; +;; The first character of the TAG is discarded, so, the minimum +;; TAG length is 2. +;; When pressed, it takes the following steps: +;; 1. Store VALUE into a temporary dialog variable; +;; 2. Execute FUNCTION passing VALUE as argument, if +;; FUNCTION is specified. +;; See _Field Keywords_ section below. +;; +;; [editable LINE COLUMN KIND VAR +;; :tag TAG :notify FUNCTION :help-echo HELP +;; :size SIZE :action FUNCTION :secret CHAR] +;; +;; Specify an editable field at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; VAR is a symbol variable which will hold the editable value. +;; KIND specifies the kind of editable field, it can have the +;; following values: +;; +;; character a character field. +;; +;; coding-system a MULE coding-system field. +;; +;; color choose a color name (with sample). +;; +;; directory a directory name field. +;; +;; file a file name field. +;; +;; float a floating point number field. +;; +;; integer an integer number field. +;; +;; key-sequence a key sequence field. +;; +;; number a number (floating point or integer) field. +;; +;; regexp a regular expression field. +;; +;; sexp an arbitrary Lisp expression field. +;; +;; string a string field. +;; +;; symbol a Lisp symbol field. +;; +;; text a multiline text area field. +;; +;; variable a Lisp variable field. +;; +;; See _Field Keywords_ section below. +;; +;; [hline LINE COLUMN LENGTH +;; :tag TAG] +;; +;; Draw a horizontal line starting at LINE and COLUMN until LINE +;; and (COLUMN + LENGTH - 1). +;; LINE starts from 1. COLUMN starts from 0. +;; TAG is a string which the very first character is used to draw +;; the line. If TAG is omitted, the default value is "-". +;; +;; [menu LINE COLUMN VAR ALIST +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a menu at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; VAR is a symbol variable which will hold the menu value. +;; ALIST is an association list which has the following form: +;; +;; (VALUE . MENU-ITEM) +;; +;; Where VALUE is the value which will be stored in VAR when this +;; menu item is selected; MENU-ITEM is a string shown as the menu +;; item. VALUE can be a symbol or a string. +;; When a menu item is selected, it takes the following steps: +;; 1. Store VALUE into a temporary dialog variable; +;; 2. Execute FUNCTION passing VALUE as argument, if FUNCTION is +;; specified. +;; See _Field Keywords_ section below. +;; +;; [navigation LINE COLUMN +;; :tag TAG :help-echo HELP] +;; +;; Specify a navigation field bar at LINE and COLUMN which shows +;; all dialogs before the current one. +;; LINE starts from 1. COLUMN starts from 0. +;; It has the following generic form: +;; +;; TAG: [dialog1] :: [dialog2] :: ... :: [dialogN-1] :: dialogN +;; +;; Where TAG, if specified, is given by :tag keyword; [dialog1], +;; [dialog2] until [dialogN-1] are buttons which go to dialog +;; correspondent when the button is pressed. +;; See _Field Keywords_ section below. +;; +;; [radio LINE COLUMN VAR VALUE +;; :tag TAG :notify FUNCTION :help-echo HELP] +;; +;; Specify a radio at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; VAR is a symbol variable which will hold the radio value. +;; VALUE is the value used when this radio is selected. +;; If TAG is omitted, it is created only the radio. +;; If TAG is specified, the first character indicates if the TAG +;; is positioned at left or right of the radio. If the first +;; character is `?-', the TAG is positioned at left of the +;; radio, that is: +;; +;; TAG ( ) +;; +;; If the first character is not `?-', the TAG is positioned at +;; right of the radio, that is: +;; +;; ( ) TAG +;; +;; The first character of the TAG is discarded, so, the minimum +;; TAG length is 2. +;; When pressed, it takes the following steps: +;; 1. Store VALUE into a temporary dialog variable; +;; 2. Update all radio which share the same VAR; +;; 3. Execute FUNCTION passing VALUE as argument, if +;; FUNCTION is specified. +;; See _Field Keywords_ section below. +;; +;; [text LINE COLUMN TEXT +;; :size SIZE] +;; +;; Specify a TEXT string to be inserted at LINE and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; TEXT can be a string, a symbol or a list. If TEXT is a symbol +;; variable, the variable value must be a string. If TEXT is a +;; symbol function or a function, the function will be evaluated +;; without parameters and should returns a string. If TEXT is a +;; list, the list header should be a function, this function will +;; be evaluated and the list tail will be the parameters for this +;; function; this function should return a string. +;; If TEXT is a symbol, `dialog-update-text' can be used by a +;; function updates this field. +;; See _Field Keywords_ section below. +;; +;; [vline LINE COLUMN LENGTH +;; :tag TAG] +;; +;; Draw a vertical line starting at LINE and COLUMN until (LINE + +;; LENGTH - 1) and COLUMN. +;; LINE starts from 1. COLUMN starts from 0. +;; TAG is a string which the very first character is used to draw +;; the line. If TAG is omitted, the default value is "|". +;; +;; +;; Field Keywords +;; -------------- +;; +;; The keywords specified in a field are optionals. +;; Below is the keyword documentation. +;; +;; :action FUNCTION +;; Specify a function FUNCTION which is activated when RET key is +;; pressed. It is passed as argument the value of the editable +;; field. FUNCTION must return a value. +;; If the returned value is nil, it means that something goes +;; wrong, so the point stays in the current editable field. +;; If the returned value is not nil, the point goes to the next +;; field. +;; +;; :help-echo HELP +;; Specifies how to display a message whenever you move to the +;; field via keyboard or move the mouse over it. HELP is either +;; a string to display, a function of one argument, the field +;; widget, which should return a string to display, or a form +;; that evaluates to such a string. +;; +;; :notify FUNCTION +;; Specify a function FUNCTION which is activated at each change +;; of the editable field. It is passed as argument the value of +;; the field. +;; +;; :secret CHAR +;; Character used to display the value. You can set this to +;; e.g. `?*' if the field contains a password or other secret +;; information. By default, this is `nil', and the value is not +;; secret. +;; +;; :size SIZE +;; Specify the SIZE of string to be displayed. +;; It can have the following values: +;; +;; integer the size of string. +;; +;; (COLUMNS . LINES) rectangular text area, both values +;; are integers greater than zero. +;; +;; :tag TAG +;; Usually, specify a field label. +;; Some fields use TAG differently, see the field documentation +;; above. +;; +;; +;; Dialog Derivation +;; ----------------- +;; +;; Sometimes you need to create a dialog B which is almost the same as +;; another dialog A, but it should add some extra fields in A, or it +;; should remove some fields from A. This is what the dialog +;; derivation do, that is, a way to add/remove some fields from a +;; dialog in order to create a new one. +;; +;; To derive a dialog from another one, just specify the :parent in a +;; dialog definition. For example: +;; +;; (dialog-define example2 +;; '(:style window +;; [navigation 1 1 :tag "Navigation"] +;; [text 3 1 "Hello World 1!!"] +;; [button-quit 5 1] +;; [button-previous 5 10 :tag "Hello :("]) +;; "This is the parent dialog.") +;; +;; (dialog-define example1 +;; '(:style (frame . mouse) :parent example2 +;; ;; this is a new button +;; [button-quit 7 1 :tag "New Quit Button"] +;; ;; this text field removes the "Hello :(" button +;; [text 5 10 " "]) +;; "This is the derived dialog.") +;; +;; So, if the new dialog element overlaps one of parent dialog +;; elements, the parent dialog element is removed. +;; +;; The :parent specification have the following values: +;; +;; :parent DIALOG +;; :parent (DIALOG . DECORATION) +;; +;; Where DIALOG is the parent dialog and DECORATION specifies what to do +;; with decoration fields, that is, box, hline and vline fields. +;; +;; DECORATION can have the following values: +;; +;; keep keep all parent decoration. +;; +;; kill kill all parent decoration. +;; +;; kill-overlap kill parent decoration only when overlaps with +;; some derived dialog field (decoration or not). +;; +;; The DECORATION default value is keep. +;; +;; +;; Options +;; ------- +;; +;; Below it's shown a brief description of `dialog' options, please, +;; see the options declaration in the code for a long documentation. +;; +;; `dialog-frame-min-width' Specify frame minimum width, measured +;; in characters. +;; +;; `dialog-frame-min-height' Specify frame minimum height, measured +;; in lines. +;; +;; `dialog-extra-columns' Specify extra number of columns, +;; measured in characters. +;; +;; `dialog-extra-lines' Specify extra number of lines, +;; measured in lines. +;; +;; To set the above options you may: +;; +;; a) insert the code in your ~/.emacs, like: +;; +;; (setq dialog-frame-min-width 50) +;; +;; This way always keep your default settings when you enter a new +;; Emacs session. +;; +;; b) or use `set-variable' in your Emacs session, like: +;; +;; M-x set-variable RET dialog-frame-min-width RET 50 RET +;; +;; This way keep your settings only during the current Emacs +;; session. +;; +;; c) or use customization, for example: +;; click on menu-bar *Options* option, +;; then click on *Customize Emacs*, +;; then click on *Browse Customization Groups*, +;; expand *Convenience* group, +;; expand *Dialog* group +;; and then customize `dialog' options. +;; Through this way, you may choose if the settings are kept or not +;; when you leave out the current Emacs session. +;; +;; d) or see the option value: +;; +;; C-h v dialog-frame-min-width RET +;; +;; and click the *customize* hypertext button. +;; Through this way, you may choose if the settings are kept or not +;; when you leave out the current Emacs session. +;; +;; +;; Todo List +;; --------- +;; +;; - output a rectangular text area +;; - edit a rectangular text area +;; - hints and tips section +;; - scrolling list/vector (probably like a button which opens another +;; frame/window) +;; +;; +;; Acknowledgements +;; ---------------- +;; +;; Thanks to Christoph Conrad for dialog +;; derivation suggestion. +;; +;; Thanks to Per Abrahamsen (and to all people +;; who contributed with him) for developing widget and custom +;; packages. +;; +;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; code: + + +(eval-when-compile + (require 'cus-edit) + (require 'wid-edit) + (require 'widget)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Interface + + +(defgroup dialog nil + "Dialog group." + :tag "Dialog" + :link '(emacs-library-link :tag "Source Lisp File" "dialog.el") + :version "23" + :group 'convenience + :group 'extensions + :group 'hypermedia) + + +(defcustom dialog-extra-columns 6 + "*Specify extra number of columns, measured in characters. + +Used to adjust point position and frame centralisation." + :type 'integer + :group 'dialog) + + +(defcustom dialog-extra-lines 0 + "*Specify extra number of lines, measured in lines. + +Used to adjust point position and frame centralisation." + :type 'integer + :group 'dialog) + + +;; I got these values by trial and error in my system. +;; If you got different values, please, send me an email. +(defcustom dialog-frame-min-width 27 + "*Specify frame minimum width, measured in characters." + :type 'integer + :group 'dialog) + + +(defcustom dialog-frame-min-height 3 + "*Specify frame minimum height, measured in lines." + :type 'integer + :group 'dialog) + + +;;;###autoload +(put 'dialog-define 'lisp-indent-function 'defun) +;;;###autoload +(defmacro dialog-define (dialog spec doc) + "Declare a dialog called DIALOG with items described in SPEC. +DIALOG does not need to be quoted. + +Second argument SPEC is the dialog specification. + +Third argument DOC is the dialog documentation. + +The SPEC argument value should have the following form: + + (STYLE FIELD...) + +Where STYLE specifies how dialog will be opened and FIELD is a +vector which specifies a dialog field. + +Valid values for STYLE are: + + :style window + Use the current frame with only one window. + + :style split-window-horizontally + :style (split-window-horizontally . ARG) + Split current window horizontally and select the window + at left. ARG is optional; if specified, it is passed as + argument to `split-window-horizontally' function (which + see). ARG must be an integer. + + :style split-window-vertically + :style (split-window-vertically . ARG) + Split current window vertically and select the window + above. ARG is optional; if specified, it is passed as + argument for `split-window-vertically' function (which + see). ARG must be an integer. + + :style frame + :style (frame . POSITION) + Make a new frame. POSITION is optional; it specifies the + position of the upper left corner of the new frame. + POSITION can have the following values: + + (X . Y) the position in pixels. + + point the current point position. + + mouse the current mouse position. + + center the new frame is centralized in the selected frame. + + frame the upper left corner of the selected frame. + + If POSITION is omitted, the frame position is given by + the system where Emacs is running. + + If there isn't a windowing system, it behaves as `window'. + + :parent DIALOG + :parent (DIALOG . DECORATION) + This dialog derives from dialog DIALOG (the parent + dialog). DECORATION specifies what to do with + decorations (box, hline and vline fields). + DECORATION can have the following values: + + keep keep all parent decoration. + + kill kill all parent decoration. + + kill-overlap kill parent decoration only when overlaps with + some derived dialog field (decoration or not). + + The DECORATION default value is keep. + + See _Dialog Derivation_ section. + +STYLE can be omitted, the default value is `window'. + +The window configuration is saved just before the dialog box +activation and it is restored just after dialog box termination. + +There exist the following FIELD types: + + box + button + button-cancel + button-next + button-ok + button-previous + button-quit + button-reset + checkbox + editable + hline + menu + navigation + radio + text + vline + +FIELD has the following forms: + + [box LINE COLUMN LINE2 COLUMN2 + :tag TAG] + + Draw a box which diagonal vertices are at LINE and + COLUMN, and at LINE2 and COLUMN2. + LINE(2) starts from 1. COLUMN(2) starts from 0. + TAG contains the characters used to draw the box border. + If TAG is omitted, the default value is \".-|++++\". + The TAG string specifies: + + \".-|++++\" + ::::::: + ::::::+--- bottom left corner + :::::+---- bottom right corner + ::::+----- top left corner + :::+------ top right corner + ::+------- vertical + :+-------- horizontal + +--------- null box (LINE = LINE2 and COLUMN = COLUMN2) + + [button LINE COLUMN + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a button at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + If TAG is omitted, \"Button\" is used. + When pressed, it executes FUNCTION, if FUNCTION is + specified. If FUNCTION is omitted, nothing happens. + See _Field Keywords_ section below. + + [button-cancel LINE COLUMN + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a cancel button at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + If TAG is omitted, \"Cancel\" is used. + When pressed, it takes the following steps: + 1. Discard all temporary dialog values; + 2. Execute FUNCTION, if FUNCTION is specified; + 3. Finish the current dialog, that is, return to previous + dialog, if exists one. + See _Field Keywords_ section below. + + [button-next LINE COLUMN DIALOG + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a next button at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + If TAG is omitted, \"Next\" is used. + If DIALOG is not a dialog, nothing happens. + If DIALOG is a dialog, when pressed, it takes the + following steps: + 1. Execute FUNCTION, if FUNCTION is specified; + 2. Go to next DIALOG. + See _Field Keywords_ section below. + + [button-ok LINE COLUMN + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify an ok button at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + If TAG is omitted, \"Ok\" is used. + When pressed, it takes the following steps: + 1. All temporary dialog values are saved into + corresponding variables; + 2. Execute FUNCTION, if FUNCTION is specified; + 3. Finish the current dialog, that is, return to previous + dialog, if exists one. + See _Field Keywords_ section below. + + [button-previous LINE COLUMN + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a previous button at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + If TAG is omitted, \"Previous\" is used. + If there isn't a previous dialog, nothing happens. + If there isn a previous dialog, when pressed, it takes + the following steps: + 1. Execute FUNCTION, if FUNCTION is specified; + 2. Go to previous dialog. + See _Field Keywords_ section below. + + [button-quit LINE COLUMN + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a quit button at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + If TAG is omitted, \"Quit\" is used. + When pressed, it takes the following steps: + 1. Discard all temporary dialog values; + 2. Execute FUNCTION, if FUNCTION is specified; + 3. Finish all dialog chain. + See _Field Keywords_ section below. + + [button-reset LINE COLUMN + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a reset button at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + If TAG is omitted, \"Reset\" is used. + When pressed, it takes the following steps: + 1. Reset all temporary dialog values, that is, restore + the original value for each temporary dialog variable; + 2. Execute FUNCTION, if FUNCTION is specified. + See _Field Keywords_ section below. + + [checkbox LINE COLUMN VAR + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a checkbox at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + VAR is a symbol variable which will hold the checkbox value. + If TAG is omitted, it is created only the checkbox. + If TAG is specified, the first character indicates if the TAG + is positioned at left or right of the checkbox. If the first + character is `?-', the TAG is positioned at left of the + checkbox, that is: + + TAG [] + + If the first character is not `?-', the TAG is positioned at + right of the checkbox, that is: + + [] TAG + + The first character of the TAG is discarded, so, the minimum + TAG length is 2. + When pressed, it takes the following steps: + 1. Store VALUE into a temporary dialog variable; + 2. Execute FUNCTION passing VALUE as argument, if + FUNCTION is specified. + See _Field Keywords_ section below. + + [editable LINE COLUMN KIND VAR + :tag TAG :notify FUNCTION :help-echo HELP + :size SIZE :action FUNCTION :secret BOOL] + + Specify an editable field at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + VAR is a symbol variable which will hold the editable value. + KIND specifies the kind of editable field, it can have the + following values: + + character a character field. + + coding-system a MULE coding-system field. + + color choose a color name (with sample). + + directory a directory name field. + + file a file name field. + + float a floating point number field. + + integer an integer number field. + + key-sequence a key sequence field. + + number a number (floating point or integer) field. + + regexp a regular expression field. + + sexp an arbitrary Lisp expression field. + + string a string field. + + symbol a Lisp symbol field. + + text a multiline text area field. + + variable a Lisp variable field. + + See _Field Keywords_ section below. + + [hline LINE COLUMN LENGTH + :tag TAG] + + Draw a horizontal line starting at LINE and COLUMN until + LINE and (COLUMN + LENGTH - 1). + LINE starts from 1. COLUMN starts from 0. + TAG is a string which the very first character is used to + draw the line. If TAG is omitted, the default value is + \"-\". + + [menu LINE COLUMN VAR ALIST + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a menu at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + VAR is a symbol variable which will hold the menu value. + ALIST is an association list which has the following form: + + (VALUE . MENU-ITEM) + + Where VALUE is the value which will be stored in VAR when + this menu item is selected; MENU-ITEM is a string shown + as the menu item. VALUE can be a symbol or a string. + When a menu item is selected, it takes the following + steps: + 1. Store VALUE into a temporary dialog variable; + 2. Execute FUNCTION passing VALUE as argument, if + FUNCTION is specified. + See _Field Keywords_ section below. + + [navigation LINE COLUMN + :tag TAG :help-echo HELP] + + Specify a navigation field bar at LINE and COLUMN which + shows all dialogs before the current one. + LINE starts from 1. COLUMN starts from 0. + It has the following generic form: + + TAG: [dialog1] :: [dialog2] :: ... :: [dialogN-1] :: dialogN + + Where TAG, if specified, is given by :tag keyword; + [dialog1], [dialog2] until [dialogN-1] are buttons which + go to the dialog correspondent when the button is pressed. + See _Field Keywords_ section below. + + [radio LINE COLUMN VAR VALUE + :tag TAG :notify FUNCTION :help-echo HELP] + + Specify a radio at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + VAR is a symbol variable which will hold the radio value. + VALUE is the value used when this radio is selected. + If TAG is omitted, it is created only the radio. + If TAG is specified, the first character indicates if the TAG + is positioned at left or right of the radio. If the first + character is `?-', the TAG is positioned at left of the + radio, that is: + + TAG ( ) + + If the first character is not `?-', the TAG is positioned at + right of the radio, that is: + + ( ) TAG + + The first character of the TAG is discarded, so, the minimum + TAG length is 2. + When pressed, it takes the following steps: + 1. Store VALUE into a temporary dialog variable; + 2. Update all radio which share the same VAR; + 3. Execute FUNCTION passing VALUE as argument, if + FUNCTION is specified. + See _Field Keywords_ section below. + + [text LINE COLUMN TEXT + :size SIZE] + + Specify a TEXT string to be inserted at LINE and COLUMN. + LINE starts from 1. COLUMN starts from 0. + TEXT can be a string, a symbol or a list. If TEXT is a + symbol variable, the variable value must be a string. If + TEXT is a symbol function or a function, the function + will be evaluated without parameters and should returns a + string. If TEXT is a list, the list header should be a + function, this function will be evaluated and the list + tail will be the parameters for this function; this + function should return a string. + If TEXT is a symbol, `dialog-update-text' can be used by a + function updates this field. + See _Field Keywords_ section below. + + [vline LINE COLUMN LENGTH + :tag TAG] + + Draw a vertical line starting at LINE and COLUMN until + (LINE + LENGTH - 1) and COLUMN. + LINE starts from 1. COLUMN starts from 0. + TAG is a string which the very first character is used to + draw the line. If TAG is omitted, the default value is + \"|\". + + +Field Keywords +-------------- + +The keywords specified in a field are optionals. +Below is the keyword documentation. + + :action FUNCTION + Specify a function FUNCTION which is activated when RET + key is pressed. It is passed as argument the value of + the editable field. FUNCTION must return a value. + If the returned value is nil, it means that something + goes wrong, so the point stays in the current editable + field. If the returned value is not nil, the point goes + to the next field. + + :help-echo HELP + Specifies how to display a message whenever you move to + the field via keyboard or move the mouse over it. HELP + is either a string to display, a function of one + argument, the field widget, which should return a string + to display, or a form that evaluates to such a string. + + :notify FUNCTION + Specify a function FUNCTION which is activated at each + change of the editable field. It is passed as argument + the value of the field. + + :secret CHAR + Character used to display the value. You can set this to + e.g. `?*' if the field contains a password or other + secret information. By default, this is `nil', and the + value is not secret. + + :size SIZE + Specify the SIZE of string to be displayed. + It can have the following values: + + integer the size of string. + + (COLUMNS . LINES) rectangular text area, both values + are integers greater than zero. + + :tag TAG + Usually, specify a field label. + Some fields use TAG differently, see the field + documentation above. + + +Dialog Derivation +----------------- + +Sometimes you need to create a dialog B which is almost the same +as another dialog A, but it should add some extra fields in A, or +it should remove some fields from A. This is what the dialog +derivation do, that is, a way to add/remove some fields from a +dialog in order to create a new one. + +To derive a dialog from another one, just specify the :parent in a +dialog definition. For example: + + (dialog-define example2 + '(:style window + [navigation 1 1 :tag \"Navigation\"] + [text 3 1 \"Hello World 1!!\"] + [button-quit 5 1] + [button-previous 5 10 :tag \"Hello :(\"]) + \"This is the parent dialog.\") + + (dialog-define example1 + '(:style (frame . mouse) :parent example2 + ;; this is a new button + [button-quit 7 1 :tag \"New Quit Button\"] + ;; this text field removes the \"Hello :(\" button + [text 5 10 \" \"]) + \"This is the derived dialog.\") + +So, if the new dialog element overlaps one of parent dialog elements, +the parent dialog element is removed. + +The :parent specification have the following values: + + :parent DIALOG + :parent (DIALOG . DECORATION) + +Where DIALOG is the parent dialog and DECORATION specifies what to do +with decoration fields, that is, box, hline and vline fields. + +DECORATION can have the following values: + + keep keep all parent decoration. + + kill kill all parent decoration. + + kill-overlap kill parent decoration only when overlaps with some + derived dialog field (decoration or not). + +The DECORATION default value is keep. + + +Example +------- + +As an example, here is a very simple dialog specification: + + (require 'dialog) + + (dialog-define hello1 + '(:style window + [navigation 1 1 :tag \"Navigation\"] + [text 3 1 \"Hello World 1!!\"] + [button-quit 5 1] + [button-previous 5 10 :tag \"Hello :(\"]) + \"This is a Hello World example.\") + + (dialog-define hello2 + '(:style window + [navigation 1 1 :tag \"Navigation\"] + [text 3 1 \"Hello World 2 !!\"] + [button-quit 5 1] + [button-next 5 10 hello1 :tag \"Hello :)\"]) + \"This is another Hello World example.\") + + (hello2) ; or (dialog-run 'hello2) run dialog hello2" + (list 'dialog-do-define (list 'quote dialog) spec doc)) + + +;;;###autoload +(defun dialog-run (dialog) + "Execute DIALOG. See `dialog-define'." + (when (dialogp dialog) + (funcall dialog))) + + +;;;###autoload +(defun dialog-make-empty (dialog) + "Define a new, empty dialog with name DIALOG. +If the dialog already exists, it is left unmodified. +Return DIALOG." + (unless (dialogp dialog) + (dialog-set dialog t t 'ignore nil)) + dialog) + + +;;;###autoload +(defun dialogp (object) + "Return t if OBJECT is a dialog object." + (and (symbolp object) ; it is a symbol... + (boundp object) ; and symbol's value is not void... + (fboundp object) ; and symbol's function is not void... + (get object 'dialog-spec) ; and symbol's property has `dialog-spec' + (get object 'dialog-documentation) ; and also `dialog-documentation'. + t)) + + +(defun dialog-documentation (dialog) + "Get the documentation string for DIALOG." + (when (dialogp dialog) + (get dialog 'dialog-documentation))) + + +(defun set-dialog-documentation (dialog doc) + "Set the documentation string for DIALOG to DOC." + (when (dialogp dialog) + (put dialog 'dialog-documentation + (if (stringp doc) (purecopy doc) "")))) + + +(defalias 'dialog-doc-string 'dialog-documentation) +(defalias 'set-dialog-doc-string 'set-dialog-documentation) + + +(defun dialog-spec (dialog) + "Get the DIALOG specification. See `dialog-define'." + (when (dialogp dialog) + (get dialog 'dialog-spec))) + + +(defun set-dialog-spec (dialog spec) + "Set the DIALOG specification. See `dialog-define'." + (when (dialogp dialog) + (dialog-do-define1 dialog spec (dialog-documentation dialog)))) + + +(defvar dialog-internal-sym-text-alist) ; forward declaration + +(defun dialog-update-text (sym) + "Update text field associated with symbol SYM. +See `dialog-define'." + (dolist (field (cdr (assq sym dialog-internal-sym-text-alist))) + (dialog-insert-text field))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Internal functions --- Dialog definition + + +;; Global var +(defvar dialog-frame-alist nil) + + +;; Local vars +(defvar dialog-internal-window-config nil) +(defvar dialog-internal-style nil) +(defvar dialog-internal-style-arg nil) +(defvar dialog-internal-max-line 0) +(defvar dialog-internal-max-column 0) +(defvar dialog-internal-previous-dialog nil) +(defvar dialog-internal-next-dialog nil) +(defvar dialog-internal-dialog nil) +;; ALIST: (var tmp wid) or (var tmp (wid . val)) +(defvar dialog-internal-variable-alist nil) +(defvar dialog-internal-variable-count 0) +;; ALIST: (sym field...) +(defvar dialog-internal-sym-text-alist nil) + +;; this var is a work around due to a `set-frame-position' problem, +;; that is, when current frame has menu-bar-mode and/or tool-bar-mode +;; on, and the new frame has both of them off, the new frame is +;; positioned higher (relative to y axis) than it should. +(defvar dialog-internal-y-offset 0) ; HACK + + +;; Style vector index +(defconst dialog-style-type 0) +(defconst dialog-style-arg 1) +(defconst dialog-style-parent 2) +(defconst dialog-style-decoration 3) + + +;; Field vector index +(defconst dialog-field-type 0) +(defconst dialog-field-create 1) +(defconst dialog-field-line 2) +(defconst dialog-field-column 3) +(defconst dialog-field-line-end 4) +(defconst dialog-field-line2 4) +(defconst dialog-field-column-end 5) +(defconst dialog-field-column2 5) +(defconst dialog-field-arg 6) +(defconst dialog-field-notify 7) +(defconst dialog-field-tag 8) +(defconst dialog-field-help 9) +(defconst dialog-field-size 10) +(defconst dialog-field-action 11) +(defconst dialog-field-secret 12) + + +(defun dialog-buffer-name (dialog) + (format "*Dialog %s*" dialog)) + + +(defun dialog-set (dialog spec parsed fun doc) + "Set unconditionally DIALOG symbol. + +SPEC is the dialog specification. + +PARSED is the dialog specification parsed. + +FUN is the dialog activation function. + +DOC is the dialog documentation. + +See `dialog-define'." + (set dialog parsed) + (fset dialog fun) + (put dialog 'dialog-spec spec) + (put dialog 'dialog-documentation + (if (stringp doc) (purecopy doc) "")) + (put dialog 'dialog-derived-fields nil) + dialog) + + +(defun dialog-do-define (dialog spec doc) + "Like `dialog-define', but DIALOG is evaluated as a normal argument." + (unless (dialogp dialog) + (dialog-do-define1 dialog spec doc)) + dialog) + + +(defun dialog-do-define1 (dialog spec doc) + "Like `dialog-do-define', but don't test if DIALOG is a dialog object." + (dialog-set dialog + spec + (dialog-overlap-between-fields + dialog + (dialog-parse-spec dialog spec)) + (list 'lambda () + (list 'dialog-do-execute + (list 'quote dialog))) + doc)) + + +(defun dialog-do-execute (dialog) + "Execute DIALOG." + (let ((window-config (current-window-configuration)) + (frame-y-offset ; HACK + (* (frame-char-height) + (+ (if (and menu-bar-mode + (frame-parameter nil 'menu-bar-lines)) + (* 2 (frame-parameter nil 'menu-bar-lines)) + 0) + (if (and tool-bar-mode + (frame-parameter nil 'tool-bar-lines)) + (1+ (* 2 (frame-parameter nil 'tool-bar-lines))) + 0)))) + (frame-char (cons (frame-char-width) (frame-char-height))) + (frame-size (cons (frame-pixel-width) (frame-pixel-height))) + (frame-pos (cons (frame-parameter nil 'left) + (frame-parameter nil 'top))) + (mouse-pos (cdr (mouse-pixel-position))) + (point-pos (cons (+ dialog-extra-columns + (car (window-edges)) + (current-column)) + (+ dialog-extra-lines + (cadr (window-edges)) + (count-lines (window-start) (point)) + (if (= (current-column) 0) 1 0)))) + (buffer (get-buffer-create (dialog-buffer-name dialog))) + (style (aref (car (symbol-value dialog)) dialog-style-type)) + (arg (aref (car (symbol-value dialog)) dialog-style-arg)) + (previous-dialog dialog-internal-dialog) + (previous-style dialog-internal-style)) + ;; initialize buffer + (set-buffer buffer) + (kill-all-local-variables) + (let ((inhibit-read-only t) + (ol (overlay-lists))) + ;; delete all the overlays. + (mapc 'delete-overlay (car ol)) + (mapc 'delete-overlay (cdr ol)) + (erase-buffer)) + ;; initialize local vars + (set (make-local-variable 'dialog-internal-window-config) window-config) + (set (make-local-variable 'dialog-internal-style) style) + (set (make-local-variable 'dialog-internal-style-arg) arg) + (set (make-local-variable 'dialog-internal-max-line) 1) + (set (make-local-variable 'dialog-internal-max-column) 0) + (set (make-local-variable 'dialog-internal-previous-dialog) previous-dialog) + (set (make-local-variable 'dialog-internal-next-dialog) nil) + (set (make-local-variable 'dialog-internal-dialog) dialog) + (set (make-local-variable 'dialog-internal-variable-alist) nil) + (set (make-local-variable 'dialog-internal-variable-count) 0) + (set (make-local-variable 'dialog-internal-sym-text-alist) nil) + ;; HACK + (set (make-local-variable 'dialog-internal-y-offset) frame-y-offset) + ;; hooks + (dialog-add-hooks) + ;; create fields + (dolist (field (dialog-derive-fields dialog)) + (dialog-goto-line-column (aref field dialog-field-line) + (aref field dialog-field-column)) + (funcall (aref field dialog-field-create) + field dialog previous-dialog)) + ;; adjust window/frame + (dialog-pop-to-buffer dialog style arg buffer + t previous-style + frame-char frame-size frame-pos + point-pos mouse-pos) + ;; start widget + (use-local-map widget-keymap) + (widget-setup))) + + +(defun dialog-pop-to-buffer (dialog style style-arg buffer + &optional create-p previous-style + frame-char frame-size frame-pos + point-pos mouse-pos) + "Create dialog window and then display dialog buffer in it. + +DIALOG is the dialog. + +STYLE is the dialog style. + +STYLE-ARG is the dialog style argument. + +BUFFER is the dialog buffer. + +PREVIOUS-STYLE is the previous dialog style. + +CREATE-P indicates if buffer is being created now; +otherwise, the buffer already exists and will be used now. + +See `dialog-make-frame' for documentation about FRAME-CHAR, +FRAME-SIZE, FRAME-POS, POINT-POS and MOUSE-POS arguments." + ;; handle dialog style + (cond + ;; split-window-horizontally + ((eq style 'split-window-horizontally) + (when (eq previous-style 'split-window-horizontally) + (delete-windows-on (current-buffer))) + (split-window-horizontally style-arg)) + ;; split-window-vertically + ((eq style 'split-window-vertically) + (when (eq previous-style 'split-window-vertically) + (delete-windows-on (current-buffer))) + (split-window-vertically style-arg)) + ;; window-system and frame + ((and create-p window-system (eq style 'frame)) + (dialog-make-frame dialog buffer style-arg + frame-char frame-size frame-pos + point-pos mouse-pos)) + ;; window or (frame and not (create-p and window-system)) + (t + (delete-other-windows))) + ;; display buffer in recent window + (let (pop-up-windows) + (pop-to-buffer buffer)) + ;; eventually, fit window to buffer + (when (and (eq style 'split-window-vertically) + (null style-arg)) ; honor user setting + (fit-window-to-buffer))) + + +(defun dialog-make-frame (dialog buffer position + frame-char frame-size frame-pos + point-pos mouse-pos) + "Make a DIALOG frame displaying BUFFER. + +POSITION is the kind of frame position. It can be: + (X . Y) the position in pixels. + point the current point position. + mouse the current mouse position. + center the new frame is centralized in the selected frame. + frame the upper left corner of the selected frame. + +FRAME-CHAR is the frame char dimensions in pixel. It has the form: + (frame-char-width . frame-char-height) + +FRAME-SIZE is the frame size in pixel. It has the form: + (frame-width . frame-height) + +FRAME-POS is the frame position in pixel. It has the form: + (left . top) + +POINT-POS is the point position in characters. It has the form: + (column . line) + +MOUSE-POS is the mouse position in pixel. It has the form: + (left . top)" + (goto-char (point-min)) + (let* ( ;; frame width + (col (max dialog-frame-min-width + dialog-internal-max-column)) + ;; frame height + (lin (+ 2 + (max dialog-frame-min-height + dialog-internal-max-line))) + ;; frame left + (left (cond ((consp position) + (car position)) + ((eq position 'point) + (+ (car frame-pos) + (* (car frame-char) + (car point-pos)))) + ((eq position 'mouse) + (+ (or (car mouse-pos) 0) + (car frame-pos))) + ((eq position 'frame) + (car frame-pos)) + ((eq position 'center) + (+ (car frame-pos) + (/ (- (car frame-size) + (* (+ col + dialog-extra-columns) + (car frame-char))) + 2))) + (t 0))) + ;; frame top + (top (+ dialog-internal-y-offset ; HACK + (cond ((consp position) + (cdr position)) + ((eq position 'point) + (+ (cdr frame-pos) + (* (cdr frame-char) + (cdr point-pos)))) + ((eq position 'mouse) + (+ (or (cdr mouse-pos) 0) + (cdr frame-pos))) + ((eq position 'frame) + (cdr frame-pos)) + ((eq position 'center) + (+ (cdr frame-pos) + (/ (- (cdr frame-size) + (* (+ lin + dialog-extra-lines) + (cdr frame-char))) + 2))) + (t 0)))) + ;; frame name + (name (format " .: %s :. " (symbol-name dialog))) + ;; The frame + (frame (select-frame + (make-frame + (list (cons 'title name) + (cons 'name name) + (cons 'width col) + (cons 'height lin) + (cons 'left left) + (cons 'top top) + '(user-size . t) + '(user-position . t) + '(menu-bar-lines . nil) + '(tool-bar-lines . nil) + '(minibuffer . nil)))))) + (dialog-add-frame-alist frame buffer))) + + +(defun dialog-create-text (field dialog previous-dialog) + "Create a text FIELD." + (dialog-add-symbol-alist field) + (dialog-insert-text field)) + + +(defun dialog-insert-text (field) + "Insert the text of the text FIELD." + (dialog-goto-line-column (aref field dialog-field-line) + (aref field dialog-field-column)) + (dialog-insert (aref field dialog-field-size) + (dialog-text-eval (aref field dialog-field-arg)))) + + +(defun dialog-create-button-text (field default) + "Create a text button FIELD. + +DEFAULT is the default tag." + (dialog-insert nil "[" (or (aref field dialog-field-tag) default) "]")) + + +(defun dialog-create-hline (field dialog previous-dialog) + "Create a horizontal line FIELD." + (dialog-create-hline1 (aref field dialog-field-line) + (aref field dialog-field-column) + (aref field dialog-field-arg) + (aref (aref field dialog-field-tag) 0))) + + +(defun dialog-create-hline1 (line column length hchar) + "Create horizontal line at LINE and COLUMN with LENGTH characters HCHAR." + (dialog-goto-line-column line column) + (dialog-insert nil (make-string length hchar))) + + +(defun dialog-create-vline (field dialog previous-dialog) + "Create a vertical line FIELD." + (dialog-create-vline1 (aref field dialog-field-line) + (aref field dialog-field-column) + (aref field dialog-field-arg) + (aref (aref field dialog-field-tag) 0))) + + +(defun dialog-create-vline1 (line column length vchar) + "Create vertical line at LINE and COLUMN with LENGTH characters VCHAR." + (let ((vstr (char-to-string vchar))) + (dotimes (i length) + (dialog-goto-line-column (+ line i) column) + (dialog-insert nil vstr)))) + + +(defun dialog-create-box (field dialog previous-dialog) + "Create a box FIELD." + (let ((lower-lin (min (aref field dialog-field-line) + (aref field dialog-field-line2))) + (upper-lin (1- (max (aref field dialog-field-line) + (aref field dialog-field-line2)))) + (lower-col (min (aref field dialog-field-column) + (aref field dialog-field-column2))) + (upper-col (1- (max (aref field dialog-field-column) + (aref field dialog-field-column2)))) + (border (aref field dialog-field-tag))) + (dialog-goto-line-column upper-lin upper-col) + (cond + ;; null box + ((and (= lower-lin upper-lin) (= lower-col upper-col)) + (dialog-insert nil (char-to-string (aref border 0)))) + ;; horizontal line + ((= lower-lin upper-lin) + (dialog-create-hline1 lower-lin lower-col + (- upper-col lower-col) + (aref border 1))) + ;; vertical line + ((= lower-col upper-col) + (dialog-create-vline1 lower-lin lower-col + (- upper-lin lower-lin) + (aref border 2))) + ;; box + (t + (let ((hlen (1+ (- upper-col lower-col))) + (hstr (make-string (- upper-col lower-col 1) + (aref border 1))) + (vstr (char-to-string (aref border 2))) + (llin (1+ lower-lin))) + ;; top border + (dialog-goto-line-column lower-lin lower-col) + (dialog-insert nil (char-to-string (aref border 3)) + hstr + (char-to-string (aref border 4))) + ;; bottom border + (dialog-goto-line-column upper-lin lower-col) + (dialog-insert nil (char-to-string (aref border 6)) + hstr + (char-to-string (aref border 5))) + ;; vertical borders + (dotimes (i (- upper-lin lower-lin 1)) + (dialog-goto-line-column (+ llin i) lower-col) + (dialog-insert nil vstr) + (dialog-goto-line-column (+ llin i) upper-col) + (dialog-insert nil vstr))))))) + + +(defun dialog-create-navigation (field dialog previous-dialog) + (let ((beg (current-column)) + dlist previous) + ;; get previous dialogs + (save-excursion + (while dialog-internal-previous-dialog + (setq previous dialog-internal-previous-dialog) + (when (dialog-set-buffer previous) + (setq dlist (cons previous dlist))))) + ;; insert tag, if exists + (when (aref field dialog-field-tag) + (dialog-insert nil (aref field dialog-field-tag) ": ")) + ;; insert buttons to previous dialogs + (dolist (dlg (nreverse dlist)) + (dialog-delete-region (+ (length (symbol-name dlg)) 6)) + (widget-create 'push-button + :notify (dialog-create-goto-function dlg) + :help-echo (aref field dialog-field-help) + (symbol-name dlg)) + (widget-insert " :: ")) + ;; insert current dialog + (dialog-insert nil (symbol-name dialog)))) + + +(defun dialog-create-button-if (condition field dfun dtag) + "Create a button FIELD, depending on CONDITION. + +If CONDITION is non-nil, create a button FIELD; +otherwise, create a text button. + +DFUN is the button action. It should be a function or nil. + +DTAG is the button tag. It should be a string." + (if condition + (dialog-create-button1 field dfun dtag) + (dialog-create-button-text field dtag))) + + +(defun dialog-create-button (field dialog previous-dialog) + "Create a button FIELD." + (dialog-create-button1 field 'dialog-action-quit "Button")) + + +(defun dialog-create-button-cancel (field dialog previous-dialog) + "Create a cancel button FIELD." + (dialog-create-button1 field 'dialog-action-cancel "Cancel")) + + +(defun dialog-create-button-next (field dialog previous-dialog) + "Create a next button FIELD." + (let ((dialog (aref field dialog-field-arg))) + (dialog-create-button-if + (dialogp dialog) + field + (dialog-create-goto-function dialog) "Next"))) + + +(defun dialog-create-button-ok (field dialog previous-dialog) + "Create an ok button FIELD." + (dialog-create-button1 field 'dialog-action-save-and-cancel "Ok")) + + +(defun dialog-create-button-previous (field dialog previous-dialog) + "Create a previous button FIELD." + (dialog-create-button-if + previous-dialog + field + 'dialog-action-goto-previous "Previous")) + + +(defun dialog-create-button-quit (field dialog previous-dialog) + "Create a quit button FIELD." + (dialog-create-button1 field 'dialog-action-quit "Quit")) + + +(defun dialog-create-button-reset (field dialog previous-dialog) + "Create a reset button FIELD." + (dialog-create-button1 field 'dialog-action-reset "Reset")) + + +(defun dialog-create-button1 (field dfun dtag) + "Create a button FIELD. + +DFUN is the button action. It should be a function or nil. + +DTAG is the button tag. It should be a string." + (let ((tag (or (aref field dialog-field-tag) dtag))) + (dialog-delete-region (+ (length tag) 2)) + (widget-create 'push-button + :notify (let ((fun + (aref field dialog-field-notify))) + (if fun + (list 'lambda '(&rest ignore) + (list 'funcall fun) + (list dfun)) + dfun)) + :help-echo (aref field dialog-field-help) + tag))) + + +(defun dialog-create-menu (field dialog previous-dialog) + "Create a menu FIELD." + (let* ((var (car (aref field dialog-field-arg))) + (tmp (dialog-make-temp-var var)) + (alist (cdr (aref field dialog-field-arg))) + (tag (aref field dialog-field-tag)) + (fun (aref field dialog-field-notify)) + (max 0)) + (mapc #'(lambda (item) + (setq max (max max (length (cdr item))))) + alist) + (dialog-delete-region (+ (length tag) 2 (max max 20))) + (dialog-add-variable-alist + var tmp + (apply 'widget-create 'menu-choice + :tag tag + :format (if tag "%[%t%]: %v" "%v") + :value (symbol-value tmp) + :help-echo (aref field dialog-field-help) + :notify (dialog-create-function + 'dialog-internal-function-notify + 'widget + (list 'quote tmp) + (dialog-arg-function fun)) + :void '(choice-item :format "%[%t%]" + :tag "Can't display value!") + ;; menu items + (mapcar #'(lambda (item) + (list 'choice-item + :format "%[%t%]" + :value (car item) + :tag (concat + (cdr item) + (make-string + (- max (length (cdr item))) + ?\ )))) + alist))))) + + +(defun dialog-create-checkbox (field dialog previous-dialog) + "Create a checkbox FIELD." + (let* ((var (aref field dialog-field-arg)) + (tmp (dialog-make-temp-var var)) + (fun (aref field dialog-field-notify)) + (tag (aref field dialog-field-tag))) + (when (and tag (= (aref tag 0) ?-)) + (dialog-insert nil (substring tag 1) " ")) + (dialog-delete-region 1) + (dialog-add-variable-alist + var tmp + (widget-create 'checkbox + :help-echo (aref field dialog-field-help) + :notify (dialog-create-function + 'dialog-internal-function-notify-value + (list 'not tmp) + (list 'quote tmp) + (dialog-arg-function fun)) + (symbol-value tmp))) + (when (and tag (/= (aref tag 0) ?-)) + (dialog-insert nil " " (substring tag 1))))) + + +(defun dialog-create-radio (field dialog previous-dialog) + "Create a radio FIELD." + (let* ((var (car (aref field dialog-field-arg))) + (val (cdr (aref field dialog-field-arg))) + (tmp (dialog-make-temp-var var)) + (fun (aref field dialog-field-notify)) + (tag (aref field dialog-field-tag))) + (when (and tag (= (aref tag 0) ?-)) + (dialog-insert nil (substring tag 1) " ")) + (dialog-delete-region 1) + (dialog-add-variable-alist + var tmp + (widget-create 'radio-button + :help-echo (aref field dialog-field-help) + :value (eq (symbol-value tmp) val) + :notify (dialog-create-function + 'dialog-update-radio + (list 'quote var) + (list 'quote val) + (dialog-arg-function fun))) + val t) + (when (and tag (/= (aref tag 0) ?-)) + (dialog-insert nil " " (substring tag 1))))) + + +(defun dialog-create-editable (field dialog previous-dialog) + "Create an editable FIELD." + (let* ((kind (car (aref field dialog-field-arg))) + (var (cdr (aref field dialog-field-arg))) + (number-p (and (memq kind '(number integer float)) t)) + (tmp (dialog-make-temp-var var)) + (notify (aref field dialog-field-notify)) + (action (aref field dialog-field-action)) + (size (aref field dialog-field-size)) + (tag (or (aref field dialog-field-tag) + (capitalize (symbol-name kind)))) + (waction (if action + (dialog-create-action-function + kind action number-p) + (dialog-default-action-function kind))) + (wnotify (dialog-create-function + 'dialog-internal-function-notify + 'widget + (list 'quote tmp) + (dialog-arg-function notify) + number-p))) + (dialog-delete-region (+ (length tag) (or size 1) 2)) + (dialog-add-variable-alist + var tmp + (widget-create kind + :help-echo (aref field dialog-field-help) + :tag tag + :size size + :secret (aref field dialog-field-secret) + :action waction + :notify wnotify) + (symbol-value var) t) + (when size + (dialog-insert nil " ")))) + + +(defun dialog-create-goto-function (dialog) + "Create a widget function which goes to dialog DIALOG." + (dialog-create-function + 'dialog-action-goto-dialog (list 'quote dialog))) + + +(defun dialog-create-function (fun &rest args) + "Create a widget function which calls FUN with arguments ARGS." + (list 'lambda '(widget &rest args) + (apply 'list fun args))) + + +(defun dialog-create-action-function (kind action number-p) + "Create an `:action' widget function." + (list 'lambda '(widget &optional event) + (list 'when + (list 'funcall (dialog-arg-function action) + (list 'dialog-widget-value 'widget number-p)) + (list (dialog-default-action-function kind) + 'widget 'event)))) + + +(defun dialog-default-action-function (kind) + "Return the default `:action' widget function. + +KIND is the widget kind." + (cond ((eq kind 'coding-system) 'widget-coding-system-action) + ((eq kind 'color) 'widget-color-action) + (t 'widget-field-action))) + + +(defun dialog-arg-function (fun) + "Return function FUN as an argument." + (cond ((null fun) nil) ; no function + ((symbolp fun) (list 'quote fun)) ; symbol function + ((functionp fun) fun) ; lambda function + (t nil))) ; no function + + +(defun dialog-internal-function-notify (widget sym-var fun + &optional numberp) + (dialog-internal-function-notify-value + (dialog-widget-value widget numberp) + sym-var fun)) + + +(defun dialog-widget-value (widget &optional numberp) + "Return the WIDGET value. + +NUMBERP indicates if WIDGET is a numeric widget." + (if (string= (widget-apply widget :value-get) "") + (if numberp 0 "") + (widget-value widget))) + + +(defun dialog-internal-function-notify-value (value sym-var fun) + (set sym-var value) + (when fun + (funcall fun value))) + + +(defun dialog-text-eval (arg) + "Evaluate ARG to string. + +If ARG is a string, return the string. +If ARG is a symbol variable, get the variable value. +If ARG is a symbol function or a function, the function is +evaluated without argument. +If ARG is a list and the list header is a function, the function +is evaluated with list tail as the arguments. +Any other value, return an empty string. +If the result of the variable or function evaluation is not a +string, it evaluates recursively until a string is returned." + (let ((val (cond + ((symbolp arg) ; symbol + (cond + ((boundp arg) (symbol-value arg)) + ((fboundp arg) (funcall arg)) + (t ""))) + ((functionp arg) ; function + (funcall arg)) + ((and (listp arg) ; list + (functionp (car arg))) + (apply (car arg) (cdr arg))) + ((stringp arg) ; string + arg) + (t ; anything else + "")))) + (if (stringp val) + val + (dialog-text-eval val)))) + + +(defun dialog-insert (size &rest args) + "Insert strings in ARGS until SIZE characters. +If SIZE is nil, all strings in ARGS are inserted. +If SIZE is lesser than or equal to zero, nothing happens." + (when (or (null size) (> size 0)) + (if size + ;; limit the length of all strings in ARGS to SIZE + (let ((alist args) + (nchar size) + len last) + (while alist + (setq len (length (car alist))) + (cond ((> nchar len) + (setq nchar (- nchar len))) + ((< nchar len) + (setcar alist + (if (> nchar 1) + (substring (car alist) 0 (1- nchar)) + (char-to-string ?\x8BB))) + (setcdr alist + (if (> nchar 1) + (cons (char-to-string ?\x8BB) nil) + nil)) + (setq nchar 0) + (setq alist nil)) + (t + (setq nchar 0) + (setcdr alist nil))) + (setq last alist + alist (cdr alist))) + (when (> nchar 0) + (setcdr last (cons (make-string nchar ?\s) nil)))) + ;; calculate the lenght of all strings in ARGS + (setq size 0) + (dolist (arg args) + (setq size (+ size (length arg))))) + ;; insert ARGS in SIZE columns + (dialog-delete-region size) + (apply 'widget-insert args))) + + +(defun dialog-goto-line-column (line column) + "Goto line LINE and then move point to column COLUMN. +See `dialog-goto-line' and `dialog-move-to-column'." + (dialog-goto-line line) + (dialog-move-to-column column)) + + +(defun dialog-goto-line (line) + "Like `goto-line', but LINE can go beyond end of buffer." + (if (<= line dialog-internal-max-line) + (goto-line line) + (goto-char (point-max)) + (widget-insert (make-string (- line dialog-internal-max-line) ?\n)) + (setq dialog-internal-max-line line))) + + +(defun dialog-move-to-column (column) + "Like `move-to-column'." + (move-to-column column t) + (dialog-internal-max-column)) + + +(defun dialog-delete-region (length) + "Delete text between point and LENGTH characters forward." + (delete-region (save-excursion + (move-to-column (+ (current-column) length) t) + (dialog-internal-max-column) + (point)) + (point))) + + +(defun dialog-internal-max-column () + "Set the maximum column number into `dialog-internal-max-column'." + (setq dialog-internal-max-column (max dialog-internal-max-column + (current-column)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Internal functions --- Parsing + + +(defconst dialog-style-values + '( + split-window-horizontally + split-window-vertically + window + frame + ) + "List of valid dialog style.") + + +(defconst dialog-style-frame-values + '( + point + mouse + center + frame + ) + "List of valid :position values for :style frame.") + + +(defconst dialog-editable-field-list + '( + character + coding-system + color + directory + file + float + integer + key-sequence + number + regexp + sexp + string + symbol + text + variable + ) + "List of valid editable fields.") + + +(defconst dialog-parent-decor-values + '( + keep + kill + kill-overlap + ) + "List of valid :parent decoration values.") + + +(defconst dialog-create-field-alist + '( + (box . dialog-create-box) + (button . dialog-create-button) + (button-cancel . dialog-create-button-cancel) + (button-next . dialog-create-button-next) + (button-ok . dialog-create-button-ok) + (button-previous . dialog-create-button-previous) + (button-quit . dialog-create-button-quit) + (button-reset . dialog-create-button-reset) + (checkbox . dialog-create-checkbox) + (editable . dialog-create-editable) + (hline . dialog-create-hline) + (menu . dialog-create-menu) + (navigation . dialog-create-navigation) + (radio . dialog-create-radio) + (text . dialog-create-text) + (vline . dialog-create-vline) + ) + "Alist which associates dialog type field with a field creation function.") + + +(defun dialog-parse-spec (dialog spec) + "Parse SPEC for DIALOG and return a parsed structure." + (let ( ;; Parse dialog keywords + (keywords (dialog-parse-spec-keywords dialog spec))) + (cons (car keywords) + ;; Parse dialog fields + (dialog-parse-spec-fields dialog (cdr keywords))))) + + +(defun dialog-parse-spec-keywords (dialog spec) + "Parse SPEC for DIALOG keywords." + (let (keyword arg style value parent decoration) + (while (and spec + (cdr spec) + (keywordp (setq keyword (car spec)))) + (setq arg (cadr spec) + spec (cddr spec)) + (cond + ;; :parent DIALOG + ;; :parent (DIALOG . DECORATION) + ((eq keyword :parent) + (if (consp arg) + (setq parent (car arg) + decoration (cdr arg)) + (setq parent arg + decoration 'keep)) + (unless (and parent (symbolp parent) + (memq decoration dialog-parent-decor-values)) + (dialog-error + dialog ":parent keyword value `%s' is not valid" + arg))) + ;; :style window + ;; :style split-window-vertically + ;; :style (split-window-vertically . ARG) + ;; :style split-window-horizontally + ;; :style (split-window-horizontally . ARG) + ;; :style frame + ;; :style (frame . (X . Y)) + ;; :style (frame . point) + ;; :style (frame . mouse) + ;; :style (frame . center) + ;; :style (frame . frame) + ((eq keyword :style) + (if (consp arg) + (setq style (car arg) + value (cdr arg)) + (setq style arg + value nil)) + ;; check style + (unless (memq style dialog-style-values) + (dialog-error + dialog ":style keyword value `%s' is not a valid style" + style)) + ;; check value + (cond + ((null value)) + ((eq style 'window) + (dialog-error + dialog ":style window does not have any argument")) + ((memq style '(split-window-horizontally + split-window-vertically)) + (unless (integerp value) + (dialog-error + dialog ":style %s argument value `%s' is not an integer" + style value))) + ((eq style 'frame) + (unless (or (memq value dialog-style-frame-values) + (and (consp value) + (integerp (car value)) + (integerp (cdr value)))) + (dialog-error + dialog ":style frame argument value `%s' is not a valid position" + value))))) + ;; otherwise, error!!! + (t + (dialog-error + dialog "`%s' is not a valid keyword" + keyword)))) + (when (or + ;; if :style is omitted... + (null style) + ;; or if it's not a windowing manager and style is frame... + (and (not window-system) (eq style 'frame))) + ;; ...force `window' instead of `frame' + (setq style 'window + value nil)) + ;; return dialog style structure + (cons (vector style value parent decoration) spec))) + + +(defun dialog-parse-spec-fields (dialog spec) + "Parse DIALOG for SPEC fields." + (let (parsed) + ;; Parse dialog fields + (when (null spec) + (dialog-error + dialog "specification must have at least one field")) + (dolist (field spec) + ;; A field must be a vector... + (unless (vectorp field) + (dialog-error + dialog "field specification must be a vector")) + ;; ...and it must have a minimum length. + (unless (>= (length field) 3) + (dialog-error + dialog "invalid vector field specification")) + (setq parsed (cons (dialog-parse-field field dialog) parsed))) + (nreverse parsed))) + + +(defun dialog-parse-field (field dialog) + "Parse one FIELD of DIALOG." + (let ((type (aref field 0)) + (line-end 0) + (column-end 0) + arg keywords) + ;; parse LINE and COLUMN first + (dialog-parse-field-line-column field dialog) + (cond + ;; [text LINE COLUMN TEXT :size SIZE] + ((eq type 'text) + (dialog-index-is-inside 3 field dialog) + (let ((text (aref field 3))) + (unless (and text + (or (stringp text) + (symbolp text) + (listp text))) + (dialog-error-field + dialog field "TEXT must be string, symbol or list")) + (setq arg (copy-sequence text))) + (setq keywords (dialog-parse-field-keywords + '(:size) 4 field dialog)) + ;; set field boundary + (let ((size (nth 3 keywords))) + (setq line-end (+ (aref field 1) + (if (consp size) + (car size) + 1)) + column-end (+ (aref field 2) + (cond ((null size) + (if (stringp arg) + (length arg) + 100)) ; occupy rest of line + ((consp size) + (cdr size)) + (t + size)))))) + ;; [navigation LINE COLUMN :tag TAG :help-echo HELP] + ((eq type 'navigation) + (dialog-parse-field-line-column field dialog) + (setq keywords (dialog-parse-field-keywords + '(:tag :help-echo) 3 field dialog)) + ;; set field boundary + (setq line-end (1+ (aref field 1)) + column-end (+ (aref field 2) 100))) ; occupy rest of line + ;; [button LINE COLUMN :tag TAG :notify FUNCTION :help-echo HELP] + ;; [button-ok LINE COLUMN :tag TAG :notify FUNCTION :help-echo HELP] + ;; [button-cancel LINE COLUMN :tag TAG :notify FUNCTION :help-echo HELP] + ;; [button-reset LINE COLUMN :tag TAG :notify FUNCTION :help-echo HELP] + ;; [button-quit LINE COLUMN :tag TAG :notify FUNCTION :help-echo HELP] + ;; [button-previous LINE COLUMN :tag TAG :notify FUNCTION :help-echo HELP] + ((memq type '(button button-ok button-cancel button-reset + button-quit button-previous)) + (setq keywords (dialog-parse-field-keywords + '(:tag :notify :help-echo) 3 field dialog)) + ;; set field boundary + (setq line-end (1+ (aref field 1)) + column-end (+ (aref field 2) 2 + (cond ((nth 1 keywords) + (length (nth 1 keywords))) + ((eq type 'button) 6) + ((eq type 'button-ok) 2) + ((eq type 'button-cancel) 6) + ((eq type 'button-reset) 5) + ((eq type 'button-quit) 4) + ((eq type 'button-previous) 8))))) + ;; [button-next LINE COLUMN DIALOG + ;; :tag TAG :notify FUNCTION :help-echo HELP + ((eq type 'button-next) + (dialog-index-is-inside 3 field dialog) + (setq arg (aref field 3)) + (unless (and arg (symbolp arg)) + (dialog-error-field + dialog field "`%s' is not a DIALOG symbol" arg)) + (setq keywords (dialog-parse-field-keywords + '(:tag :notify :help-echo) 4 field dialog)) + ;; set field boundary + (setq line-end (1+ (aref field 1)) + column-end (+ (aref field 2) 2 + (if (nth 1 keywords) + (length (nth 1 keywords)) + 4)))) + ;; [hline LINE COLUMN LENGTH :tag TAG] + ;; [vline LINE COLUMN LENGTH :tag TAG] + ((memq type '(hline vline)) + (dialog-index-is-inside 3 field dialog) + (setq arg (aref field 3)) + (unless (and arg (integerp arg) (> arg 0)) + (dialog-error-field + dialog field "LENGTH must be an integer greater than zero")) + (setq keywords (dialog-parse-field-keywords + '(:tag) 4 field dialog)) + (unless (nth 1 keywords) ; TAG default value + (setcar (cdr keywords) (if (eq type 'hline) "-" "|"))) + (unless (> (length (nth 1 keywords)) 0) + (dialog-error-field + dialog field "TAG can't be an empty string")) + ;; set field boundary + (setq line-end (if (eq type 'hline) + (1+ (aref field 1)) + (+ (aref field 1) arg)) + column-end (if (eq type 'hline) + (+ (aref field 2) arg) + (1+ (aref field 2))))) + ;; [box LINE COLUMN LINE2 COLUMN2 :tag TAG] + ((eq type 'box) + (dialog-parse-field-line-column field dialog 3) + (setq keywords (dialog-parse-field-keywords + '(:tag) 5 field dialog)) + (unless (nth 1 keywords) ; TAG default value + (setcar (cdr keywords) ".-|++++")) + (unless (>= (length (nth 1 keywords)) 7) + (dialog-error-field + dialog field "TAG length must be equal or greater than 7")) + ;; adjust boundary values + (setq line-end (1+ (max (aref field 1) (aref field 3))) + column-end (1+ (max (aref field 2) (aref field 4)))) + (aset field 1 (min (aref field 1) (aref field 3))) + (aset field 2 (min (aref field 2) (aref field 4)))) + ;; [menu LINE COLUMN VAR ALIST + ;; :tag TAG :notify FUNCTION :help-echo HELP + ;; ALIST: (atom . string) + ((eq type 'menu) + (dialog-index-is-inside 4 field dialog) + (setq arg (aref field 3)) + (unless (and arg (symbolp arg) (boundp arg)) + (dialog-error-field + dialog field "VARIABLE must be a symbol variable")) + ;; (VAR ALIST) + (setq arg (cons arg (aref field 4))) + (unless (and (cdr arg) + (let ((is-alist t)) + (mapc #'(lambda (item) + (setq is-alist + (and is-alist + (consp item) + ;; option value + (or (symbolp (car item)) + (stringp (car item))) + ;; option tag + (and (stringp (cdr item)) + ;; get max option len + (setq column-end + (max column-end + (length + (cdr item)))))))) + (cdr arg)) + is-alist)) + (dialog-error-field + dialog field + "ALIST must be an alist of (symbol . string) or (string . string)")) + (setq keywords (dialog-parse-field-keywords + '(:tag :notify :help-echo) 5 field dialog)) + ;; set field boundary + (setq line-end (1+ (aref field 1)) + column-end (+ column-end (aref field 2) + (if (nth 1 keywords) + (+ (length (nth 1 keywords)) 2) + 0)))) + ;; [checkbox LINE COLUMN VAR + ;; :tag TAG :notify FUNCTION :help-echo HELP + ((eq type 'checkbox) + (dialog-index-is-inside 3 field dialog) + (setq arg (aref field 3)) + (unless (and arg (symbolp arg) (boundp arg)) + (dialog-error-field + dialog field "VARIABLE must be a symbol variable")) + (setq keywords (dialog-parse-field-keywords + '(:tag :notify :help-echo) 4 field dialog)) + ;; set field boundary + (setq line-end (1+ (aref field 1)) + column-end (+ (aref field 2) 1 + (if (nth 1 keywords) + (length (nth 1 keywords)) + 0)))) + ;; [radio LINE COLUMN VAR VALUE + ;; :tag TAG :notify FUNCTION :help-echo HELP] + ((eq type 'radio) + (dialog-index-is-inside 4 field dialog) + (setq arg (aref field 3)) + (unless (and arg (symbolp arg) (boundp arg)) + (dialog-error-field + dialog field "VARIABLE must be a symbol variable")) + ;; (VAR . VALUE) + (setq arg (cons arg (aref field 4))) + (setq keywords (dialog-parse-field-keywords + '(:tag :notify :help-echo) 5 field dialog)) + ;; set field boundary + (setq line-end (1+ (aref field 1)) + column-end (+ (aref field 2) 3 + (if (nth 1 keywords) + (length (nth 1 keywords)) + 0)))) + ;; [editable LINE COLUMN KIND VAR + ;; :tag TAG :notify FUNCTION :help-echo HELP + ;; :size SIZE :action FUNCTION :secret CHAR] + ((eq type 'editable) + (dialog-index-is-inside 4 field dialog) + (let ((var (aref field 4)) + (kind (aref field 3))) + (unless (and (symbolp kind) + (memq kind dialog-editable-field-list)) + (dialog-error-field + dialog field + "KIND must be a symbol which is contained in `dialog-editable-field-list'")) + (unless (and var (symbolp var) (boundp var)) + (dialog-error-field + dialog field "VARIABLE must be a symbol variable")) + ;; (KIND . VAR) + (setq arg (cons kind var)) + (setq keywords (dialog-parse-field-keywords + '(:tag :notify :help-echo :size + :secret :action) + 5 field dialog))) + ;; set field boundary + (let ((size (nth 3 keywords)) + (tag (or (nth 1 keywords) + (symbol-name (aref field 3))))) + (setq line-end (+ (aref field 1) + (if (consp size) + (car size) + 1)) + column-end (+ (aref field 2) + (if tag + (+ (length tag) 2) + 0) + (cond ((null size) + 100) ; occupy rest of line + ((consp size) + (cdr size)) + (t + size)))))) + ;; Otherwise, error! + (t + (dialog-error dialog "`%s' is not a valid field type" type))) + ;; return parsed structure + (apply + 'vector + (aref field 0) ; type symbol + (cdr (assq (aref field 0) ; + dialog-create-field-alist)) ; creation fun + (aref field 1) ; LINE + (aref field 2) ; COLUMN + line-end ; LINE END, LINE2 + column-end ; COLUMN END, COLUMN2 + arg ; TEXT, DIALOG, LENGTH, + ; (VAR ALIST), (VAR . VALUE), + ; (KIND . VAR), VAR + keywords) ; :notify + ; :tag + ; :help-echo + ; :size + ; :action + ; :secret + )) + + +(defun dialog-parse-field-keywords (valid-keywords index field dialog) + "Parse FIELD keywords of DIALOG. +VALID-KEYWORDS is a list of valid keywords for FIELD. +INDEX is the initial FIELD index to start parsing." + (let ((flen (length field)) + keyword arg + notify tag help size action secret) + (while (< (1+ index) flen) + (setq keyword (aref field index) + arg (aref field (1+ index)) + index (+ index 2)) + ;; check semantics + (cond + ((not (memq keyword valid-keywords)) + (dialog-error-field + dialog field "`%s' is not a valid keyword" + keyword)) + ;; :notify FUNCTION + ;; :action FUNCTION + ((memq keyword '(:notify :action)) + (if (eq keyword :notify) + (setq notify arg) + (setq action arg)) + (unless (and arg + (or (symbolp arg) + (functionp arg))) + (dialog-error-field + dialog field "%s value must be a function or symbol" + keyword))) + ;; :tag TAG + ((eq keyword :tag) + (setq tag arg) + (unless (and arg (stringp arg)) + (dialog-error-field + dialog field ":tag value must be string"))) + ;; :help-echo HELP + ((eq keyword :help-echo) + (setq help arg) + (unless (and arg + (or (stringp arg) + (functionp arg))) + (dialog-error-field + dialog field ":help-echo value must be string or function"))) + ;; :size SIZE + ((eq keyword :size) + (setq size arg) + (when (and (consp arg) + (integerp (car arg)) + (integerp (cdr arg))) + (dialog-error-field + dialog field ":size value not implemented yet: (integer . integer)")) + (unless (or (integerp arg) + (and (consp arg) + (integerp (car arg)) + (integerp (cdr arg)))) + (dialog-error-field + dialog field ":size value must be integer or (integer . integer)"))) + ;; :secret CHAR + ((eq keyword :secret) + (setq secret arg) + (unless (or (null arg) + (char-valid-p arg)) + (dialog-error-field + dialog field ":secret value must be nil or character"))))) + ;; return list of keyword values + (list notify tag help size action secret))) + + +;; Check field -line and -column values +(defun dialog-parse-field-line-column (field dialog &optional start) + "Parse line and column FIELD components of DIALOG. +If START is specified, it's the initial index of line and column +components." + (let ((istr (if start "2" "")) + (index (or start 1))) + (unless (< (1+ index) (length field)) + (dialog-error-field + dialog field "LINE%s or COLUMN%s isn't specified" + istr istr)) + ;; LINE, LINE2 + (unless (and (integerp (aref field index)) + (> (aref field index) 0)) + (dialog-error-field + dialog field "LINE%s must be an integer greater than zero" + istr)) + ;; COLUMN, COLUMN2 + (unless (and (integerp (aref field (1+ index))) + (>= (aref field (1+ index)) 0)) + (dialog-error-field + dialog field "COLUMN%s must be a non-negative integer" + istr)))) + + +(defun dialog-index-is-inside (index field dialog) + "Check if INDEX is inside FIELD vector." + (unless (< index (length field)) + (dialog-error-field + dialog field "invalid vector field specification"))) + + +(defun dialog-error (dialog mess &rest args) + "Give an error message with header \"Dialog `D': \"." + (apply 'error (format "Dialog `%%s': %s." mess) + dialog args)) + + +(defun dialog-error-field (dialog field mess &rest args) + "Give an error message with header \"Dialog `D' F field: \"." + (apply 'error (format "Dialog `%%s' %%s field: %s." mess) + dialog (aref field 0) args)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Internal functions --- Derivation + + +(defsubst dialog-field-decoration-p (field) + "Return t if FIELD is a decoration field." + (memq (aref field dialog-field-type) '(box vline hline))) + + +(defun dialog-field-overlap-p (field1 field2) + "Return t if field FIELD1 overlaps field FIELD2." + ;; LL LC o------+| p is inside when: + ;; | || LL <= p.line < UL + ;; | || LC <= p.column < UC + ;; +------+| + ;; --------o UL UC + (not (or (>= (aref field1 dialog-field-line) ; LL1 >= UL2 + (aref field2 dialog-field-line-end)) ; + (<= (aref field1 dialog-field-line-end) ; UL1 <= LL2 + (aref field2 dialog-field-line)) ; + (>= (aref field1 dialog-field-column) ; LC1 >= UC2 + (aref field2 dialog-field-column-end)) ; + (<= (aref field1 dialog-field-column-end) ; UC1 <= LC2 + (aref field2 dialog-field-column))))) ; + + +(defun dialog-overlap-between-fields (dialog dialog-value) + "Check if the DIALOG-VALUE fields overlap each other." + (let ((fl (cdr dialog-value)) + f decor non-decor) + (while fl + (setq f (car fl)) + (if (dialog-field-decoration-p f) + ;; f decoration + (setq decor (cons f decor)) + ;; f non-decoration + (dolist (n (cdr fl)) + (when (and (not (dialog-field-decoration-p n)) + (dialog-field-overlap-p f n)) + (dialog-error-field + dialog n "this field overlaps the preceding field `%s'" + (aref f dialog-field-type)))) + ;; f non-decoration without overlaping + (setq non-decor (cons f non-decor))) + (setq fl (cdr fl))) + (list (car dialog-value) ; style + (nreverse decor) ; decor field + (nreverse non-decor)))) ; non-decor field + + +(defun dialog-exclude-overlap (pfields dfields) + "Return a field list which the fields do not overlap themselves. +Exclude all PFIELDS field which overlaps with any field in DFIELDS list." + (let (ok overlap) + ;; get all pfields which does not overlap any dfields + (dolist (p pfields) + (setq overlap nil) + (dolist (f dfields) + (when (dialog-field-overlap-p p f) + (setq overlap t))) + (unless overlap + (setq ok (cons p ok)))) + (nreverse ok))) + + +(defun dialog-overlap-between-dialogs (fields fparent) + "Return a field list which the fields do not overlap themselves. +Exclude all FPARENT field which overlaps with any field in FIELDS list." + (let ((dpolicy (car fields)) + (ppolicy (aref (nth 0 fparent) dialog-style-decoration)) + decor non-decor) + ;; handle decoration + (cond + ((eq dpolicy 'kill) ; kill all decoration + (setq decor (nth 1 fields))) + ((eq dpolicy 'keep) ; keep all decoration + (setq decor (append (nth 1 fparent) (nth 1 fields)) + dpolicy ppolicy)) + ((eq dpolicy 'kill-overlap) ; kill decor when overlap + (when (eq ppolicy 'kill) (setq dpolicy 'kill)) + ;; exclude all parent decor which overlap any field decor + (setq decor (dialog-exclude-overlap (nth 1 fparent) + (nth 1 fields))) + ;; exclude all parent decor which overlap any field non-decor + (setq decor (dialog-exclude-overlap decor (nth 2 fields))))) + ;; handle non-decoration + (setq non-decor + (append + ;; exlude all parent fields which overlap any dialog field + (dialog-exclude-overlap (nth 2 fparent) (nth 2 fields)) + (nth 2 fields))) + ;; return overlap result + (list dpolicy ; decoration policy + decor ; decor field + non-decor))) ; non-decor field + + +(defun dialog-derive-fields (dialog) + "Return a field list derived from DIALOG." + (or (get dialog 'dialog-derived-fields) + (let ((f (cons (aref (car (symbol-value dialog)) + dialog-style-decoration) + (cdr (symbol-value dialog)))) + (p dialog)) + (while (setq p (aref (car (symbol-value p)) + dialog-style-parent)) + (setq f (dialog-overlap-between-dialogs f (symbol-value p)))) + (setq f (append (nth 1 f) (nth 2 f))) + (put dialog 'dialog-derived-fields f) + f))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Internal functions --- Actions + + +(defun dialog-action-quit (&rest dummy) + "Dialog action to quit all dialog chain." + (dialog-remove-hooks) + (let (previous config) + (while dialog-internal-previous-dialog + (setq previous dialog-internal-previous-dialog) + (dialog-kill-buffer) + (dialog-set-buffer previous)) + (setq config dialog-internal-window-config) + (dialog-kill-buffer) + (set-window-configuration config))) + + +(defun dialog-action-save-and-cancel (&rest dummy) + "Dialog action to save values and cancel current dialog." + (mapc #'(lambda (item) + (set (nth 0 item) (symbol-value (nth 1 item)))) + dialog-internal-variable-alist) + (dialog-action-cancel)) + + +(defun dialog-action-reset (&rest dummy) + "Dialog action to reset values of current dialog." + (mapc #'(lambda (item) + (let ((val (symbol-value (nth 0 item)))) + (set (nth 1 item) val) + (if (symbolp (nth 2 item)) + (widget-value-set (nth 2 item) val) + (dolist (wid (cddr item)) + (widget-value-set (car wid) (eq val (cdr wid))))))) + dialog-internal-variable-alist) + (when dialog-internal-variable-alist + (widget-setup))) + + +(defun dialog-action-cancel (&rest dummy) + "Dialog action to cancel current dialog." + (if dialog-internal-previous-dialog + (dialog-action-goto-previous) + (dialog-action-quit))) + + +(defun dialog-action-goto-previous (&rest dummy) + "Dialog action to cancel current dialog and goto previous dialog." + (let ((previous dialog-internal-previous-dialog)) + (when previous + (dialog-kill-buffer) + (dialog-set-buffer previous) + (dialog-pop-to-buffer dialog-internal-dialog + dialog-internal-style + dialog-internal-style-arg + (current-buffer))))) + + +(defun dialog-action-goto-dialog (dialog) + "Dialog action to cancel current dialog and goto DIALOG dialog." + (when (dialogp dialog) + (let ((buffer (dialog-buffer-name dialog))) + (if (get-buffer buffer) + ;; buffer already exists in the dialog chain + (let (previous) + (while (not (eq dialog-internal-dialog dialog)) + (setq previous dialog-internal-previous-dialog) + (dialog-kill-buffer) + (dialog-set-buffer previous)) + (dialog-pop-to-buffer dialog-internal-dialog + dialog-internal-style + dialog-internal-style-arg + (current-buffer)) + (setq dialog-internal-next-dialog nil)) + ;; new dialog buffer + (setq dialog-internal-next-dialog dialog) + (dialog-do-execute dialog))))) + + +(defun dialog-update-radio (var value fun) + "Update all radio widget associated with variable VAR. + +VALUE is the value used to update. + +FUN is a function activated at end of update all radio widget. +FUN can be a symbol function or a lambda function. +FUN is called without argument." + (let ((item (assq var dialog-internal-variable-alist))) + (when item + (set (nth 1 item) value) + (dolist (wid (cddr item)) + (widget-value-set (car wid) (eq (cdr wid) value))) + (widget-setup))) + (when fun + (funcall fun value))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Internal funcitons --- Misc + + +(defun dialog-add-hooks () + "Add buffer and window hooks." + (add-hook 'kill-buffer-hook 'dialog-hook-buffer) + (add-hook 'window-configuration-change-hook 'dialog-hook-window)) + + +(defun dialog-remove-hooks () + "Remove buffer and window hooks." + (remove-hook 'kill-buffer-hook 'dialog-hook-buffer) + (remove-hook 'window-configuration-change-hook 'dialog-hook-window)) + + +(defun dialog-hook-window () + "If `delete-window' command is activated, quit all dialog chain." + (when (and (eq this-command 'delete-window) + (dialogp dialog-internal-dialog)) + (dialog-action-quit))) + + +(defun dialog-hook-buffer () + "If `kill-buffer' command is activated, quit all dialog chain." + (when (and (eq this-command 'kill-buffer) + (dialogp dialog-internal-dialog)) + (dialog-action-quit))) + + +(defun dialog-hook-frame (frame) + "If `delete-frame' command is activated, quit all dialog chain at FRAME. + +FRAME is the frame which will be deleted." + (let (buffer next) + (when (and (frame-live-p frame) + (setq buffer (cdr (assq frame dialog-frame-alist)))) + (dialog-delete-frame-alist frame) + ;; delete frames and buffers whose depend on this frame + (save-excursion + (set-buffer buffer) + (setq next dialog-internal-next-dialog) + ;; adjust previous dialog + (save-excursion + (when (dialog-set-buffer dialog-internal-previous-dialog) + (setq dialog-internal-next-dialog nil))) + ;; delete frames and buffers in the next dialog chain + (delete-windows-on buffer) + (kill-buffer buffer) ; current frame is being delete + (while (and next (dialog-set-buffer next)) + (setq next dialog-internal-next-dialog) + (dialog-kill-buffer)))))) + + +(defun dialog-kill-buffer (&optional buffer) + "Kill a dialog BUFFER. + +If BUFFER is nil, kill the current buffer." + (unless buffer + (setq buffer (current-buffer))) ; buffer object + (when (setq buffer (get-buffer buffer)) ; buffer name string + (save-excursion + (set-buffer buffer) + (let (frame) + (if (and (eq dialog-internal-style 'frame) + (setq frame + (car (rassoc buffer dialog-frame-alist)))) + ;; `dialog-hook-frame' kills this buffer + (delete-frame frame t) + (delete-windows-on buffer) + (kill-buffer buffer)))))) + + +(defun dialog-set-buffer (dialog) + "Make the DIALOG buffer current for editing operations." + (let ((buffer (get-buffer (dialog-buffer-name dialog)))) + (and buffer (set-buffer buffer)) + buffer)) + + +(defun dialog-add-frame-alist (frame buffer) + "Add the association of FRAME and BUFFER." + (unless (assq frame dialog-frame-alist) + (setq dialog-frame-alist (cons (cons frame buffer) + dialog-frame-alist)) + (add-hook 'delete-frame-functions 'dialog-hook-frame))) + + +(defun dialog-delete-frame-alist (&optional frame) + "Delete the association of a buffer with FRAME." + (setq dialog-frame-alist (assq-delete-all (or frame + (selected-frame)) + dialog-frame-alist)) + (unless dialog-frame-alist + (remove-hook 'delete-frame-functions 'dialog-hook-frame))) + + +(defun dialog-make-temp-var (var) + "If VAR is not a local temporary variable symbol, make it." + (or (nth 1 (assq var dialog-internal-variable-alist)) + (let ((tmp (make-local-variable + (intern + (format + "dialog--temp--<%02d>" + (setq dialog-internal-variable-count + (1+ dialog-internal-variable-count))))))) + (set tmp (symbol-value var)) + tmp))) + + +(defun dialog-add-variable-alist (var tmp wid &optional value multiple-wid-p) + "Add the association of variables VAR and TMP. + +WID is the widget which uses TMP. + +Optional VALUE is the default value associated with TMP. + +MULTIPLE-WID-P indicates if TMP is used in more than one widget." + (let ((item (assq var dialog-internal-variable-alist))) + (cond + ((null item) + (setq dialog-internal-variable-alist + (cons (list var tmp + (if multiple-wid-p + (cons wid value) + wid)) + dialog-internal-variable-alist))) + (multiple-wid-p + (setcdr (cdr item) (cons (cons wid value) (cddr item))))))) + + +(defun dialog-add-symbol-alist (field) + "If text FIELD has a symbol, add the association of the symbol with FIELD." + (let ((sym (aref field dialog-field-arg))) + (when (and sym (symbolp sym)) + (let ((item (assq sym dialog-internal-sym-text-alist))) + (if item + (setcdr (cdr item) (cons field (cddr item))) + (setq dialog-internal-sym-text-alist + (cons (list sym field) + dialog-internal-sym-text-alist))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(provide 'dialog) + + +;;; dialog.el ends here diff --git a/lisp/dim.el b/lisp/dim.el new file mode 100644 index 00000000..0fad5450 --- /dev/null +++ b/lisp/dim.el @@ -0,0 +1,163 @@ +;;; dim.el --- Change mode-line names of major/minor modes -*- lexical-binding: t -*- + +;; Copyright © 2015, 2016 Alex Kost + +;; Author: Alex Kost +;; Created: 24 Dec 2015 +;; Version: 0.1 +;; Package-Version: 20160818.949 +;; URL: https://github.com/alezost/dim.el +;; Keywords: convenience +;; Package-Requires: ((emacs "24.4")) + +;; 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 . + +;;; Commentary: + +;; The purpose of this package is to "customize" the mode-line names of +;; major and minor modes. An example of using: +;; +;; (when (require 'dim nil t) +;; (dim-major-names +;; '((emacs-lisp-mode "EL") +;; (lisp-mode "CL") +;; (Info-mode "I") +;; (help-mode "H"))) +;; (dim-minor-names +;; '((auto-fill-function " ↵") +;; (isearch-mode " 🔎") +;; (whitespace-mode " _" whitespace) +;; (paredit-mode " ()" paredit) +;; (eldoc-mode "" eldoc)))) + +;; Along with `dim-major-names' and `dim-minor-names', you can use +;; `dim-major-name' and `dim-minor-name' to change the names by one. + +;; Many thanks to the author of +;; package, as the code of +;; this file is heavily based on it. + +;; For more verbose description, see README at +;; . + +;;; Code: + +(defgroup dim nil + "Change mode-line names of major and minor modes." + :group 'convenience) + +(defcustom dim-everywhere nil + "If non-nil, just set `mode-name' to the 'dimmed' name. +If nil, try to be more clever to change the name only for the +mode-line. Particularly, display the original `mode-name' in the +mode description (\\[describe-mode])." + :type 'boolean + :group 'dim) + +(defvar dim-major-names nil + "List of specifications for changing `mode-name'. +Each element of the list should be a list of arguments taken by +`dim-major-name' function.") + +(defvar dim-inhibit-major-name nil + "If non-nil, original mode names are used instead of names from +`dim-major-names' variable.") + +(defun dim-get-major-name (mode) + "Return MODE name from `dim-major-names' variable." + (cadr (assq mode dim-major-names))) + +(defun dim-set-major-name (&rest _) + "Replace `mode-name' of the current major mode. +Use the appropriate name from `dim-major-names' variable. + +This function ignores the arguments to make it suitable for using +in advices. For example, if you changed `mode-name' of +`dired-mode', you'll be surprised that it returns to \"Dired\" +after exiting from `wdired-mode'. This happens because \"Dired\" +string is hard-coded in `wdired-change-to-dired-mode'. This can +be workaround-ed by using the following advice: + + (advice-add 'wdired-change-to-dired-mode :after #'dim-set-major-name)" + (let ((new-name (dim-get-major-name major-mode))) + (when new-name + (setq mode-name + (if dim-everywhere + new-name + `(dim-inhibit-major-name ,mode-name ,new-name)))))) + +(add-hook 'after-change-major-mode-hook 'dim-set-major-name) + +(defun dim-inhibit-major-name (fun &rest args) + "Apply FUN to ARGS with temporary disabled 'dimmed' major mode names. +This function is intended to be used as an 'around' advice for +FUN. Such advice is needed for `format-mode-line' function, as +it allows to use the original `mode-name' value when it is +displayed in `describe-mode' help buffer." + (let ((dim-inhibit-major-name t)) + (apply fun args))) + +(advice-add 'format-mode-line :around #'dim-inhibit-major-name) + +(defun dim-add-or-set (var name &rest values) + "Add (NAME VALUES ...) element to the value of VAR. +If VAR already has NAME element, change its VALUES." + (set var + (cons (cons name values) + (assq-delete-all name (symbol-value var))))) + +;;;###autoload +(defun dim-major-name (mode new-name) + "Set mode-line name of the major MODE to NEW-NAME. +The change will take effect next time the MODE will be enabled." + (dim-add-or-set 'dim-major-names mode new-name)) + +;;;###autoload +(defun dim-major-names (specs) + "Change names of major modes according to SPECS list. +Each element of the list should be a list of arguments taken by +`dim-major-name' function." + (if (null dim-major-names) + (setq dim-major-names specs) + (dolist (spec specs) + (apply #'dim-major-name spec)))) + +(defun dim--minor-name (mode new-name) + "Subroutine of `dim-minor-name'." + (if (not (boundp mode)) + (message "Unknown minor mode '%S'." mode) + (dim-add-or-set 'minor-mode-alist mode new-name))) + +;;;###autoload +(defun dim-minor-name (mode new-name &optional file) + "Set mode-line name of the minor MODE to NEW-NAME. +FILE is a feature or file name where the MODE comes from. If it +is specified, it is passed to `eval-after-load'. If it is nil, +MODE name is changed immediately (if the MODE is available)." + (if file + (eval-after-load file + `(dim--minor-name ',mode ',new-name)) + (dim--minor-name mode new-name))) + +;;;###autoload +(defun dim-minor-names (specs) + "Change names of minor modes according to SPECS list. +Each element of the list should be a list of arguments taken by +`dim-minor-name' function." + (dolist (spec specs) + (apply #'dim-minor-name spec))) + +(provide 'dim) + +;;; dim.el ends here diff --git a/lisp/ess-R-data-view.el b/lisp/ess-R-data-view.el new file mode 100644 index 00000000..825da44e --- /dev/null +++ b/lisp/ess-R-data-view.el @@ -0,0 +1,156 @@ +;;; ess-R-data-view.el --- Data viewer for GNU R + +;; Author: myuhe +;; Maintainer: myuhe +;; URL: https://github.com/myuhe/ess-R-data-view.el +;; Package-Version: 20130509.1158 +;; Version: 0.1 +;; Created: 2013-05-09 +;; Keywords: convenience +;; Package-Requires: ((ctable "20130313.1743") (popup "20130324.1305") (ess "20130225.1754")) +;; Copyright (C) 2013 myuhe + +;; 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 +;; (a 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 . + +;;; Commentary: + +;; ess-R-data-view is data viewer for GNU R. It shows dataframe and matrix +;; on table view. +;; ess-R-data-view provides two commands. The first, `ess-R-dv-ctable' +;; shows table in other buffer. It includes border, and header is fixed. +;; The second, `ess-R-dv-pprint' shows pretty-printed text in other buffer. +;; It shows huge text smoothly. + +;;; Code: + +(require 'ess-inf) +(require 'ctable) +(require 'popup) + +(defvar ess-R-dv-buf " R data view" + "Buffer for R data") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;Command +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;###autoload +(defun ess-R-dv-pprint () + (interactive) + (pop-to-buffer (ess-R-dv-execute (current-word)))) + +;;;###autoload +(defun ess-R-dv-ctable () + (interactive) + (let ((obj (current-word)) + (type (ess-R-dv-type-of))) + (if (or (string= type "data.frame") + (string= type "matrix")) + (ess-R-dv-ctable-1 obj type) + (popup-tip (concat "\"" obj "\"" " is invalid data !!"))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;Internal +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun ess-R-dv-ctable-1 (obj type) + (with-current-buffer (ess-R-dv-execute obj) + (goto-char (point-min)) + (let ((param (copy-ctbl:param ctbl:default-rendering-param))) + (setf (ctbl:param-fixed-header param) t) + + (let* ((ln + (ess-R-dv-substring)) + (header-lst + (e2wm:dp-R-gen-header-lst ln type)) + (column-model + (mapcar + (lambda (i) (make-ctbl:cmodel :title i )) + (ess-R-dv-map ln header-lst))) + data) + + (dotimes (x (1- (count-lines (point-max) (point-min)))) + (forward-line 1) + (add-to-list + 'data (ess-R-dv-map (ess-R-dv-substring) header-lst) t)) + + (pop-to-buffer (ctbl:cp-get-buffer + (ctbl:create-table-component-buffer + :model (make-ctbl:model + :column-model column-model + :data data) + :param param))))))) + +(defun ess-R-dv-execute (obj) + (let ((buf (get-buffer-create ess-R-dv-buf))) + (ess-command (ess-R-dv-get obj) buf) + (with-current-buffer buf + (goto-char (point-min))) + buf)) + +(defun ess-R-dv-type-of () + (let ((obj (current-word)) + (tmpbuf (get-buffer-create " *ess-R-tmpbuf*")) + type) + (ess-command (concat "class(" obj ")\n") tmpbuf) + (with-current-buffer tmpbuf + (setq type (buffer-substring + (+ 2 (string-match "\".*\"" (buffer-string))) + (- (point-max) 2)))) + (kill-buffer tmpbuf) + type)) + +(defun ess-R-dv-map (ln lst) + (mapcar + (lambda (i) + (substring ln (car i) (cdr i))) lst)) + +(defun ess-R-dv-substring () + (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))) + +(defun ess-R-dv-get (name) + "Generate R code to get the value of the variable name. +This is complicated because some variables might have spaces in their names. +Otherwise, we could just pass the variable name directly to *R*." + (concat "get(" (ess-R-dv-quote name) ")\n")) + +(defun ess-R-dv-quote (name) + "Quote name if not already quoted." + (if (equal (substring name 0 1) "\"") + name + (concat "\"" name "\""))) + +(defun e2wm:dp-R-gen-header-lst (str type) + (let (header-lst + (pos (length (number-to-string (1- (count-lines (point-max) (point-min))))))) + (when (string= type "matrix") + (setq pos (+ 3 pos))) + (add-to-list + 'header-lst (cons 0 pos)) + (while + (> (length str) pos) + (add-to-list + 'header-lst + (cons pos (let ((pos-match (string-match "[^\\s ]\\s " str pos))) + (if pos-match + (+ 1 pos-match) + (length str)))) t) + (setq pos (+ 1 (cdar (last header-lst))))) + header-lst)) + +(provide 'ess-R-data-view) + +;;; ess-R-data-view.el ends here diff --git a/lisp/f.el b/lisp/f.el new file mode 100644 index 00000000..012727c3 --- /dev/null +++ b/lisp/f.el @@ -0,0 +1,624 @@ +;;; f.el --- Modern API for working with files and directories -*- lexical-binding: t; -*- + +;; Copyright (C) 2013 Johan Andersson + +;; Author: Johan Andersson +;; Maintainer: Johan Andersson +;; Version: 0.20.0 +;; Package-Version: 20191110.1357 +;; Keywords: files, directories +;; URL: http://github.com/rejeep/f.el +;; Package-Requires: ((s "1.7.0") (dash "2.2.0")) + +;; This file is NOT part of GNU Emacs. + +;;; License: + +;; 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, 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Code: + + + +(require 's) +(require 'dash) + +(put 'f-guard-error 'error-conditions '(error f-guard-error)) +(put 'f-guard-error 'error-message "Destructive operation outside sandbox") + +(defvar f--guard-paths nil + "List of allowed paths to modify when guarded. + +Do not modify this variable.") + +(defmacro f--destructive (path &rest body) + "If PATH is allowed to be modified, yield BODY. + +If PATH is not allowed to be modified, throw error." + (declare (indent 1)) + `(if f--guard-paths + (if (--any? (or (f-same? it ,path) + (f-ancestor-of? it ,path)) f--guard-paths) + (progn ,@body) + (signal 'f-guard-error (list ,path f--guard-paths))) + ,@body)) + + +;;;; Paths + +(defun f-join (&rest args) + "Join ARGS to a single path." + (let (path (relative (f-relative? (car args)))) + (-map + (lambda (arg) + (setq path (f-expand arg path))) + args) + (if relative (f-relative path) path))) + +(defun f-split (path) + "Split PATH and return list containing parts." + (let ((parts (s-split (f-path-separator) path 'omit-nulls))) + (if (f-absolute? path) + (push (f-path-separator) parts) + parts))) + +(defun f-expand (path &optional dir) + "Expand PATH relative to DIR (or `default-directory'). +PATH and DIR can be either a directory names or directory file +names. Return a directory name if PATH is a directory name, and +a directory file name otherwise. File name handlers are +ignored." + (let (file-name-handler-alist) + (expand-file-name path dir))) + +(defun f-filename (path) + "Return the name of PATH." + (file-name-nondirectory (directory-file-name path))) + +(defalias 'f-parent 'f-dirname) +(defun f-dirname (path) + "Return the parent directory to PATH." + (let ((parent (file-name-directory + (directory-file-name (f-expand path default-directory))))) + (unless (f-same? path parent) + (if (f-relative? path) + (f-relative parent) + (directory-file-name parent))))) + +(defun f-common-parent (paths) + "Return the deepest common parent directory of PATHS." + (cond + ((not paths) nil) + ((not (cdr paths)) (f-parent (car paths))) + (:otherwise + (let* ((paths (-map 'f-split paths)) + (common (caar paths)) + (re nil)) + (while (and (not (null (car paths))) (--all? (equal (car it) common) paths)) + (setq paths (-map 'cdr paths)) + (push common re) + (setq common (caar paths))) + (cond + ((null re) "") + ((and (= (length re) 1) (f-root? (car re))) + (f-root)) + (:otherwise + (concat (apply 'f-join (nreverse re)) "/"))))))) + +(defun f-ext (path) + "Return the file extension of PATH. + +The extension, in a file name, is the part that follows the last +'.', excluding version numbers and backup suffixes." + (file-name-extension path)) + +(defun f-no-ext (path) + "Return everything but the file extension of PATH." + (file-name-sans-extension path)) + +(defun f-swap-ext (path ext) + "Return PATH but with EXT as the new extension. +EXT must not be nil or empty." + (if (s-blank? ext) + (error "Extension cannot be empty or nil") + (concat (f-no-ext path) "." ext))) + +(defun f-base (path) + "Return the name of PATH, excluding the extension of file." + (f-no-ext (f-filename path))) + +(defun f-relative (path &optional dir) + "Return PATH relative to DIR." + (file-relative-name path dir)) + +(defalias 'f-abbrev 'f-short) +(defun f-short (path) + "Return abbrev of PATH. See `abbreviate-file-name'." + (abbreviate-file-name path)) + +(defun f-long (path) + "Return long version of PATH." + (f-expand path)) + +(defun f-canonical (path) + "Return the canonical name of PATH." + (file-truename path)) + +(defun f-slash (path) + "Append slash to PATH unless one already. + +Some functions, such as `call-process' requires there to be an +ending slash." + (if (f-dir? path) + (file-name-as-directory path) + path)) + +(defun f-full (path) + "Return absolute path to PATH, with ending slash." + (f-slash (f-long path))) + +(defun f--uniquify (paths) + "Helper for `f-uniquify' and `f-uniquify-alist'." + (let* ((files-length (length paths)) + (uniq-filenames (--map (cons it (f-filename it)) paths)) + (uniq-filenames-next (-group-by 'cdr uniq-filenames))) + (while (/= files-length (length uniq-filenames-next)) + (setq uniq-filenames-next + (-group-by 'cdr + (--mapcat + (let ((conf-files (cdr it))) + (if (> (length conf-files) 1) + (--map (cons (car it) (concat (f-filename (s-chop-suffix (cdr it) (car it))) (f-path-separator) (cdr it))) conf-files) + conf-files)) + uniq-filenames-next)))) + uniq-filenames-next)) + +(defun f-uniquify (files) + "Return unique suffixes of FILES. + +This function expects no duplicate paths." + (-map 'car (f--uniquify files))) + +(defun f-uniquify-alist (files) + "Return alist mapping FILES to unique suffixes of FILES. + +This function expects no duplicate paths." + (-map 'cadr (f--uniquify files))) + + +;;;; I/O + +(defun f-read-bytes (path) + "Read binary data from PATH. + +Return the binary data as unibyte string." + (with-temp-buffer + (set-buffer-multibyte nil) + (setq buffer-file-coding-system 'binary) + (insert-file-contents-literally path) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defalias 'f-read 'f-read-text) +(defun f-read-text (path &optional coding) + "Read text with PATH, using CODING. + +CODING defaults to `utf-8'. + +Return the decoded text as multibyte string." + (decode-coding-string (f-read-bytes path) (or coding 'utf-8))) + +(defalias 'f-write 'f-write-text) +(defun f-write-text (text coding path) + "Write TEXT with CODING to PATH. + +TEXT is a multibyte string. CODING is a coding system to encode +TEXT with. PATH is a file name to write to." + (f-write-bytes (encode-coding-string text coding) path)) + +(defun f-unibyte-string-p (s) + "Determine whether S is a unibyte string." + (not (multibyte-string-p s))) + +(defun f-write-bytes (data path) + "Write binary DATA to PATH. + +DATA is a unibyte string. PATH is a file name to write to." + (f--write-bytes data path nil)) + +(defalias 'f-append 'f-append-text) +(defun f-append-text (text coding path) + "Append TEXT with CODING to PATH. + +If PATH does not exist, it is created." + (f-append-bytes (encode-coding-string text coding) path)) + +(defun f-append-bytes (data path) + "Append binary DATA to PATH. + +If PATH does not exist, it is created." + (f--write-bytes data path :append)) + +(defun f--write-bytes (data filename append) + "Write binary DATA to FILENAME. +If APPEND is non-nil, append the DATA to the existing contents." + (f--destructive filename + (unless (f-unibyte-string-p data) + (signal 'wrong-type-argument (list 'f-unibyte-string-p data))) + (let ((coding-system-for-write 'binary) + (write-region-annotate-functions nil) + (write-region-post-annotation-function nil)) + (write-region data nil filename append :silent) + nil))) + + +;;;; Destructive + +(defun f-mkdir (&rest dirs) + "Create directories DIRS." + (let (path) + (-each + dirs + (lambda (dir) + (setq path (f-expand dir path)) + (unless (f-directory? path) + (f--destructive path (make-directory path))))))) + +(defun f-delete (path &optional force) + "Delete PATH, which can be file or directory. + +If FORCE is t, a directory will be deleted recursively." + (f--destructive path + (if (or (f-file? path) (f-symlink? path)) + (delete-file path) + (delete-directory path force)))) + +(defun f-symlink (source path) + "Create a symlink to SOURCE from PATH." + (f--destructive path (make-symbolic-link source path))) + +(defun f-move (from to) + "Move or rename FROM to TO. +If TO is a directory name, move FROM into TO." + (f--destructive to (rename-file from to t))) + +(defun f-copy (from to) + "Copy file or directory FROM to TO. +If FROM names a directory and TO is a directory name, copy FROM +into TO as a subdirectory." + (f--destructive to + (if (f-file? from) + (copy-file from to) + ;; The behavior of `copy-directory' differs between Emacs 23 and + ;; 24 in that in Emacs 23, the contents of `from' is copied to + ;; `to', while in Emacs 24 the directory `from' is copied to + ;; `to'. We want the Emacs 24 behavior. + (if (> emacs-major-version 23) + (copy-directory from to) + (if (f-dir? to) + (progn + (apply 'f-mkdir (f-split to)) + (let ((new-to (f-expand (f-filename from) to))) + (copy-directory from new-to))) + (copy-directory from to)))))) + +(defun f-copy-contents (from to) + "Copy contents in directory FROM, to directory TO." + (unless (f-exists? to) + (error "Cannot copy contents to non existing directory %s" to)) + (unless (f-dir? from) + (error "Cannot copy contents as %s is a file" from)) + (--each (f-entries from) + (f-copy it (file-name-as-directory to)))) + +(defun f-touch (path) + "Update PATH last modification date or create if it does not exist." + (f--destructive path + (if (f-file? path) + (set-file-times path) + (f-write-bytes "" path)))) + + +;;;; Predicates + +(defun f-exists? (path) + "Return t if PATH exists, false otherwise." + (file-exists-p path)) + +(defalias 'f-exists-p 'f-exists?) + +(defalias 'f-dir? 'f-directory?) +(defalias 'f-dir-p 'f-dir?) + +(defun f-directory? (path) + "Return t if PATH is directory, false otherwise." + (file-directory-p path)) + +(defalias 'f-directory-p 'f-directory?) + +(defun f-file? (path) + "Return t if PATH is file, false otherwise." + (file-regular-p path)) + +(defalias 'f-file-p 'f-file?) + +(defun f-symlink? (path) + "Return t if PATH is symlink, false otherwise." + (not (not (file-symlink-p path)))) + +(defalias 'f-symlink-p 'f-symlink?) + +(defun f-readable? (path) + "Return t if PATH is readable, false otherwise." + (file-readable-p path)) + +(defalias 'f-readable-p 'f-readable?) + +(defun f-writable? (path) + "Return t if PATH is writable, false otherwise." + (file-writable-p path)) + +(defalias 'f-writable-p 'f-writable?) + +(defun f-executable? (path) + "Return t if PATH is executable, false otherwise." + (file-executable-p path)) + +(defalias 'f-executable-p 'f-executable?) + +(defun f-absolute? (path) + "Return t if PATH is absolute, false otherwise." + (file-name-absolute-p path)) + +(defalias 'f-absolute-p 'f-absolute?) + +(defun f-relative? (path) + "Return t if PATH is relative, false otherwise." + (not (f-absolute? path))) + +(defalias 'f-relative-p 'f-relative?) + +(defun f-root? (path) + "Return t if PATH is root directory, false otherwise." + (not (f-parent path))) + +(defalias 'f-root-p 'f-root?) + +(defun f-ext? (path &optional ext) + "Return t if extension of PATH is EXT, false otherwise. + +If EXT is nil or omitted, return t if PATH has any extension, +false otherwise. + +The extension, in a file name, is the part that follows the last +'.', excluding version numbers and backup suffixes." + (if ext + (string= (f-ext path) ext) + (not (eq (f-ext path) nil)))) + +(defalias 'f-ext-p 'f-ext?) + +(defalias 'f-equal? 'f-same?) +(defalias 'f-equal-p 'f-equal?) + +(defun f-same? (path-a path-b) + "Return t if PATH-A and PATH-B are references to same file." + (when (and (f-exists? path-a) + (f-exists? path-b)) + (equal + (f-canonical (directory-file-name (f-expand path-a))) + (f-canonical (directory-file-name (f-expand path-b)))))) + +(defalias 'f-same-p 'f-same?) + +(defun f-parent-of? (path-a path-b) + "Return t if PATH-A is parent of PATH-B." + (--when-let (f-parent path-b) + (f-same? path-a it))) + +(defalias 'f-parent-of-p 'f-parent-of?) + +(defun f-child-of? (path-a path-b) + "Return t if PATH-A is child of PATH-B." + (--when-let (f-parent path-a) + (f-same? it path-b))) + +(defalias 'f-child-of-p 'f-child-of?) + +(defun f-ancestor-of? (path-a path-b) + "Return t if PATH-A is ancestor of PATH-B." + (unless (f-same? path-a path-b) + (s-starts-with? (f-full path-a) + (f-full path-b)))) + +(defalias 'f-ancestor-of-p 'f-ancestor-of?) + +(defun f-descendant-of? (path-a path-b) + "Return t if PATH-A is desendant of PATH-B." + (unless (f-same? path-a path-b) + (s-starts-with? (f-full path-b) + (f-full path-a)))) + +(defalias 'f-descendant-of-p 'f-descendant-of?) + +(defun f-hidden? (path) + "Return t if PATH is hidden, nil otherwise." + (unless (f-exists? path) + (error "Path does not exist: %s" path)) + (string= (substring path 0 1) ".")) + +(defalias 'f-hidden-p 'f-hidden?) + +(defun f-empty? (path) + "If PATH is a file, return t if the file in PATH is empty, nil otherwise. +If PATH is directory, return t if directory has no files, nil otherwise." + (if (f-directory? path) + (equal (f-files path nil t) nil) + (= (f-size path) 0))) + +(defalias 'f-empty-p 'f-empty?) + + +;;;; Stats + +(defun f-size (path) + "Return size of PATH. + +If PATH is a file, return size of that file. If PATH is +directory, return sum of all files in PATH." + (if (f-directory? path) + (-sum (-map 'f-size (f-files path nil t))) + (nth 7 (file-attributes path)))) + +(defun f-depth (path) + "Return the depth of PATH. + +At first, PATH is expanded with `f-expand'. Then the full path is used to +detect the depth. +'/' will be zero depth, '/usr' will be one depth. And so on." + (- (length (f-split (f-expand path))) 1)) + + +;;;; Misc + +(defun f-this-file () + "Return path to this file." + (cond + (load-in-progress load-file-name) + ((and (boundp 'byte-compile-current-file) byte-compile-current-file) + byte-compile-current-file) + (:else (buffer-file-name)))) + +(defvar f--path-separator nil + "A variable to cache result of `f-path-separator'.") + +(defun f-path-separator () + "Return path separator." + (or f--path-separator + (setq f--path-separator (substring (f-join "x" "y") 1 2)))) + +(defun f-glob (pattern &optional path) + "Find PATTERN in PATH." + (file-expand-wildcards + (f-join (or path default-directory) pattern))) + +(defun f--collect-entries (path recursive) + (let (result + (entries + (-reject + (lambda (file) + (or + (equal (f-filename file) ".") + (equal (f-filename file) ".."))) + (directory-files path t)))) + (cond (recursive + (-map + (lambda (entry) + (if (f-file? entry) + (setq result (cons entry result)) + (when (f-directory? entry) + (setq result (cons entry result)) + (setq result (append result (f--collect-entries entry recursive)))))) + entries)) + (t (setq result entries))) + result)) + +(defmacro f--entries (path body &optional recursive) + "Anaphoric version of `f-entries'." + `(f-entries + ,path + (lambda (path) + (let ((it path)) + ,body)) + ,recursive)) + +(defun f-entries (path &optional fn recursive) + "Find all files and directories in PATH. + +FN - called for each found file and directory. If FN returns a thruthy +value, file or directory will be included. +RECURSIVE - Search for files and directories recursive." + (let ((entries (f--collect-entries path recursive))) + (if fn (-select fn entries) entries))) + +(defmacro f--directories (path body &optional recursive) + "Anaphoric version of `f-directories'." + `(f-directories + ,path + (lambda (path) + (let ((it path)) + ,body)) + ,recursive)) + +(defun f-directories (path &optional fn recursive) + "Find all directories in PATH. See `f-entries'." + (let ((directories (-select 'f-directory? (f--collect-entries path recursive)))) + (if fn (-select fn directories) directories))) + +(defmacro f--files (path body &optional recursive) + "Anaphoric version of `f-files'." + `(f-files + ,path + (lambda (path) + (let ((it path)) + ,body)) + ,recursive)) + +(defun f-files (path &optional fn recursive) + "Find all files in PATH. See `f-entries'." + (let ((files (-select 'f-file? (f--collect-entries path recursive)))) + (if fn (-select fn files) files))) + +(defmacro f--traverse-upwards (body &optional path) + "Anaphoric version of `f-traverse-upwards'." + `(f-traverse-upwards + (lambda (dir) + (let ((it dir)) + ,body)) + ,path)) + +(defun f-traverse-upwards (fn &optional path) + "Traverse up as long as FN return nil, starting at PATH. + +If FN returns a non-nil value, the path sent as argument to FN is +returned. If no function callback return a non-nil value, nil is +returned." + (unless path + (setq path default-directory)) + (when (f-relative? path) + (setq path (f-expand path))) + (if (funcall fn path) + path + (unless (f-root? path) + (f-traverse-upwards fn (f-parent path))))) + +(defun f-root () + "Return absolute root." + (f-traverse-upwards 'f-root?)) + +(defmacro f-with-sandbox (path-or-paths &rest body) + "Only allow PATH-OR-PATHS and descendants to be modified in BODY." + (declare (indent 1)) + `(let ((paths (if (listp ,path-or-paths) + ,path-or-paths + (list ,path-or-paths)))) + (unwind-protect + (let ((f--guard-paths paths)) + ,@body) + (setq f--guard-paths nil)))) + +(provide 'f) + +;;; f.el ends here diff --git a/lisp/flycheck-ledger.el b/lisp/flycheck-ledger.el new file mode 100644 index 00000000..424f4d39 --- /dev/null +++ b/lisp/flycheck-ledger.el @@ -0,0 +1,141 @@ +;;; flycheck-ledger.el --- Flycheck integration for ledger files -*- lexical-binding: t -*- + +;; Copyright (C) 2013-2014 Steve Purcell + +;; Author: Steve Purcell +;; Homepage: https://github.com/purcell/flycheck-ledger +;; Version: DEV +;; Package-Version: 20200304.2204 +;; Package-Commit: 628e25ba66604946085571652a94a54f4d1ad96f +;; Keywords: convenience languages tools +;; Package-Requires: ((emacs "24.1") (flycheck "0.15")) + +;; 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 . + +;;; Commentary: + +;; This flychecker uses the output of "ledger balance" on the current file to +;; find errors such as unbalanced transactions and syntax errors. + +;;;; Setup + +;; (eval-after-load 'flycheck '(require 'flycheck-ledger)) + +;;; Code: + +(require 'flycheck) + +(flycheck-def-option-var flycheck-ledger-zero-accounts nil ledger-zero + "Whether to check account names, tags, and payees from cleared transactions." + :type '(repeat string) + :safe #'flycheck-string-list-p) + +(flycheck-define-checker ledger + "A checker for ledger files, showing unmatched balances and failed checks." + :command ("ledger" + (option-flag "--explicit" flycheck-ledger-explicit) + (option-flag "--pedantic" flycheck-ledger-pedantic) + (eval (when (eq flycheck-ledger-pedantic 'check-payees) "--check-payees")) + "-f" source-inplace + "balance" + ;; to find non-zero zero accounts: + "--flat" "--no-total" + "--balance-format" "%(scrub(display_total))\t\t%(account())\n" + (eval flycheck-ledger-zero-accounts)) + :error-patterns + ((error line-start "While parsing file \"" (file-name) "\", line " line ":" (zero-or-more whitespace) "\n" + (zero-or-more line-start (or "While " "> ") (one-or-more not-newline) "\n" ) + (message (minimal-match (zero-or-more line-start (zero-or-more not-newline) "\n")) + "Error: " (one-or-more not-newline) "\n"))) + :error-parser + (lambda (output checker buffer) + (let ((pattern-errors (flycheck-parse-with-patterns output checker buffer))) + (or pattern-errors + (when (> (length flycheck-ledger-zero-accounts) 0) + (flycheck-ledger--zero-error-parser output checker buffer))))) + :verify + (lambda (checker) + (let ((has-accounts (> (length flycheck-ledger-zero-accounts) 0))) + (list + (flycheck-verification-result-new + :label "accounts" + :message (if has-accounts (format "%s" flycheck-ledger-zero-accounts) "none") + :face 'success)))) + :modes ledger-mode) + +(flycheck-def-option-var flycheck-ledger-pedantic () ledger + "Whether to be pedantic in ledger. + +When equal to `check-payees', be pedantic on account name and payees, +When non-nil, be pedantic on account name, +otherwise don't be pedantic." + :type '(radio (const :tag "Run Ledger normally" nil) + (const :tag "Check account names (--pedantic)" t) + (const :tag "Also check payees (--check-payees)" check-payees))) + +(flycheck-def-option-var flycheck-ledger-explicit nil ledger + "Whether to check account names, tags, and payees from cleared transactions." + :type 'boolean) + +(defun flycheck-ledger--zero-last-position-of-account (account buffer) + "Return (LINE . COL) of last occurrence of ACCOUNT in BUFFER. + +Return nil if ACCOUNT can't be found in BUFFER." + (with-current-buffer buffer + (save-restriction + (save-excursion + (goto-char (point-max)) + (when (search-backward account nil t) + (cons (line-number-at-pos (point)) + (1+ (- (point) (line-beginning-position))))))))) + +(defun flycheck-ledger--zero-error-parser (output checker buffer) + "Return errors found in OUTPUT. + +CHECKER is a `flycheck-ledger-zero' checker. + +BUFFER is the buffer being checked by flycheck. + +Return a list of parsed errors and warnings (as `flycheck-error' +objects)." + (let ((errors (list)) + (buffer (current-buffer))) + (save-match-data + (with-temp-buffer + (insert output) + (goto-char (point-min)) + (while (re-search-forward "^\\(.*\\)\\>\t\t\\<\\(.*\\)$" nil t) + (let* ((amount (string-trim (match-string-no-properties 1))) + (account (string-trim (match-string-no-properties 2))) + (message (format "Account %s should have zero value but has %s" + account amount)) + (position (flycheck-ledger--zero-last-position-of-account account buffer)) + (line (or (car position) 1)) + (column (or (cdr position) 0))) + (push + (flycheck-error-new-at + line column 'error message + :checker checker + :filename (buffer-file-name buffer) :buffer buffer) + errors))))) + errors)) + +(flycheck-def-option-var flycheck-ledger-zero-accounts nil ledger-zero + "Whether to check account names, tags, and payees from cleared transactions." + :type '(repeat string)) + +(add-to-list 'flycheck-checkers 'ledger) + +(provide 'flycheck-ledger) +;;; flycheck-ledger.el ends here diff --git a/lisp/flycheck-pos-tip.el b/lisp/flycheck-pos-tip.el new file mode 100644 index 00000000..994646d6 --- /dev/null +++ b/lisp/flycheck-pos-tip.el @@ -0,0 +1,154 @@ +;;; flycheck-pos-tip.el --- Display Flycheck errors in GUI tooltips -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Sebastian Wiesner +;; Copyright (C) 2014 Akiha Senda + +;; Author: Akiha Senda +;; Sebastian Wiesner +;; Maintainer: Sebastian Wiesner +;; URL: https://github.com/flycheck/flycheck-pos-tip +;; Package-Version: 20200516.1600 +;; Package-Commit: dc57beac0e59669926ad720c7af38b27c3a30467 +;; Keywords: tools, convenience +;; Version: 0.4-cvs +;; Package-Requires: ((emacs "24.1") (flycheck "0.22") (pos-tip "0.4.6")) + +;; This file is not 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 . + +;;; Commentary: + +;; Provide an error display function to show errors in a tooltip. + +;;;; Setup + +;; (with-eval-after-load 'flycheck +;; (flycheck-pos-tip-mode)) + +;;; Code: + +(require 'flycheck) +(require 'pos-tip) + +(defgroup flycheck-pos-tip nil + "Display Flycheck errors in tooltips." + :prefix "flycheck-pos-tip-" + :group 'flycheck + :link '(url-link :tag "Github" "https://github.com/flycheck/flycheck-pos-tip")) + +(defcustom flycheck-pos-tip-max-width nil + "If non-nil, the max width of the tooltip in chars." + :group 'flycheck-pos-tip + :type '(choice (const :tag "Auto" nil) + (integer :tag "Characters")) + :package-version '(flycheck-pos-tip . "0.4")) + +(defcustom flycheck-pos-tip-timeout 5 + "Time in seconds to hide the tooltip after." + :group 'flycheck-pos-tip + :type 'number + :package-version '(flycheck-pos-tip . "0.2")) + +(defcustom flycheck-pos-tip-display-errors-tty-function + #'flycheck-display-error-messages + "Fallback function for error display on TTY frames. + +Like `flycheck-display-errors-function'; called to show error +messages on TTY frames if `flycheck-pos-tip-mode' is active." + :group 'flycheck-pos-tip + :type 'function + :package-version '(flycheck-pos-tip . "0.2")) + +(defvar-local flycheck-pos-tip--last-pos nil + "Last position for which a pos-tip was displayed.") + +(defun flycheck-pos-tip--check-pos () + "Update flycheck-pos-tip--last-pos, returning t if there was no change." + (equal flycheck-pos-tip--last-pos + (setq flycheck-pos-tip--last-pos + (list (current-buffer) (buffer-modified-tick) (point))))) + +(defun flycheck-pos-tip-error-messages (errors) + "Display ERRORS, using a graphical tooltip on GUI frames." + (when errors + (if (display-graphic-p) + (let ((message (flycheck-help-echo-all-error-messages errors)) + (line-height (car (window-line-height)))) + (flycheck-pos-tip--check-pos) + (pos-tip-show message nil nil nil flycheck-pos-tip-timeout + flycheck-pos-tip-max-width nil + ;; Add a little offset to the tooltip to move it away + ;; from the corresponding text in the buffer. We + ;; explicitly take the line height into account because + ;; pos-tip computes the offset from the top of the line + ;; apparently. + nil (and line-height (+ line-height 5)))) + (funcall flycheck-pos-tip-display-errors-tty-function errors)))) + +(defun flycheck-pos-tip-hide-messages () + "Hide messages currently being shown if any." + (unless (flycheck-pos-tip--check-pos) + (if (display-graphic-p) + (pos-tip-hide) + (flycheck-hide-error-buffer)))) + +(defvar flycheck-pos-tip-old-display-function nil + "The former value of `flycheck-display-errors-function'.") + +;;;###autoload +(define-minor-mode flycheck-pos-tip-mode + "A minor mode to show Flycheck error messages in a popup. + +When called interactively, toggle `flycheck-pos-tip-mode'. With +prefix ARG, enable `flycheck-pos-tip-mode' if ARG is positive, +otherwise disable it. + +When called from Lisp, enable `flycheck-pos-tip-mode' if ARG is +omitted, nil or positive. If ARG is `toggle', toggle +`flycheck-pos-tip-mode'. Otherwise behave as if called +interactively. + +In `flycheck-pos-tip-mode' show Flycheck's error messages in a +GUI tooltip. Falls back to `flycheck-display-error-messages' on +TTY frames." + :global t + :group 'flycheck + (let ((hooks '(post-command-hook focus-out-hook))) + (cond + ;; Use our display function and remember the old one but only if we haven't + ;; yet configured it, to avoid activating twice. + ((and flycheck-pos-tip-mode + (not (eq flycheck-display-errors-function + #'flycheck-pos-tip-error-messages))) + (setq flycheck-pos-tip-old-display-function + flycheck-display-errors-function + flycheck-display-errors-function + #'flycheck-pos-tip-error-messages) + (dolist (hook hooks) + (add-hook hook #'flycheck-pos-tip-hide-messages))) + ;; Reset the display function and remove ourselves from all hooks but only + ;; if the mode is still active. + ((and (not flycheck-pos-tip-mode) + (eq flycheck-display-errors-function + #'flycheck-pos-tip-error-messages)) + (setq flycheck-display-errors-function + flycheck-pos-tip-old-display-function + flycheck-pos-tip-old-display-function nil) + (dolist (hook hooks) + (remove-hook hook 'flycheck-pos-tip-hide-messages)))))) + +(provide 'flycheck-pos-tip) + +;;; flycheck-pos-tip.el ends here diff --git a/lisp/focus.el b/lisp/focus.el new file mode 100644 index 00000000..57963f90 --- /dev/null +++ b/lisp/focus.el @@ -0,0 +1,280 @@ +;;; focus.el --- Dim the font color of text in surrounding sections -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Lars Tveito + +;; Author: Lars Tveito +;; URL: http://github.com/larstvei/Focus +;; Package-Version: 20191209.2210 +;; Package-Commit: 5f3f20e7f22fb9fd7c48abce8bd38061d97e4bc0 +;; Created: 11th May 2015 +;; Version: 1.0.0 +;; Package-Requires: ((emacs "24.3") (cl-lib "0.5")) + +;; 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 . + +;;; Commentary: + +;; Focus provides `focus-mode` that dims the text of surrounding sections, +;; similar to [iA Writer's](https://ia.net/writer) Focus Mode. +;; +;; Enable the mode with `M-x focus-mode'. + +;;; Code: + +(require 'cl-lib) +(require 'thingatpt) + +(defgroup focus () + "Dim the font color of text in surrounding sections." + :group 'font-lock + :prefix "focus-") + +(defcustom focus-mode-to-thing '((prog-mode . defun) (text-mode . sentence)) + "An associated list between mode and thing. + +A thing is defined in thingatpt.el; the thing determines the +narrowness of the focused section. + +Note that the order of the list matters. The first mode that the +current mode is derived from is used, so more modes that have +many derivatives should be placed by the end of the list. + +Things that are defined include `symbol', `list', `sexp', +`defun', `filename', `url', `email', `word', `sentence', +`whitespace', `line', and `page'." + :type '(repeat symbol) + :group 'focus) + +(defcustom focus-read-only-blink-seconds 1 + "The duration of a cursor blink in `focus-read-only-mode'." + :type '(float) + :group 'focus) + +(defface focus-unfocused + '((t :inherit font-lock-comment-face)) + "The face that overlays the unfocused area." + :group 'focus) + +(defface focus-focused nil + "The face that overlays the focused area." + :group 'focus) + +(defvar focus-cursor-type cursor-type + "Used to restore the users `cursor-type'") + +(defvar-local focus-current-thing nil + "Overrides the choice of thing dictated by `focus-mode-to-thing' if set.") + +(defvar-local focus-buffer nil + "Local reference to the buffer focus functions operate on.") + +(defvar-local focus-pre-overlay nil + "The overlay that dims the text prior to the current-point.") + +(defvar-local focus-mid-overlay nil + "The overlay that surrounds the text of the current-point.") + +(defvar-local focus-post-overlay nil + "The overlay that dims the text past the current-point.") + +(defvar-local focus-read-only-blink-timer nil + "Timer started from `focus-read-only-cursor-blink'. +The timer calls `focus-read-only-hide-cursor' after +`focus-read-only-blink-seconds' seconds.") + +(defun focus-get-thing () + "Return the current thing, based on `focus-mode-to-thing'." + (or focus-current-thing + (let* ((modes (mapcar 'car focus-mode-to-thing)) + (mode (or (cl-find major-mode modes) + (apply #'derived-mode-p modes)))) + (if mode (cdr (assoc mode focus-mode-to-thing)) 'sentence)))) + +(defun focus-bounds () + "Return the current bounds, based on `focus-get-thing'." + (bounds-of-thing-at-point (focus-get-thing))) + +(defun focus-move-focus () + "Move the focused section according to `focus-bounds'. + +If `focus-mode' is enabled, this command fires after each +command." + (with-current-buffer focus-buffer + (let* ((bounds (focus-bounds))) + (when bounds + (focus-move-overlays (car bounds) (cdr bounds)))))) + +(defun focus-move-overlays (low high) + "Move `focus-pre-overlay', `focus-mid-overlay' and `focus-post-overlay'." + (move-overlay focus-pre-overlay (point-min) low) + (move-overlay focus-mid-overlay low high) + (move-overlay focus-post-overlay high (point-max))) + +(defun focus-init () + "This function is run when command `focus-mode' is enabled. + +It sets the `focus-pre-overlay', `focus-min-overlay', and +`focus-post-overlay' to overlays; these are invisible until +`focus-move-focus' is run. It adds `focus-move-focus' to +`post-command-hook'." + (unless (or focus-pre-overlay focus-post-overlay) + (setq focus-pre-overlay (make-overlay (point-min) (point-min)) + focus-mid-overlay (make-overlay (point-min) (point-max)) + focus-post-overlay (make-overlay (point-max) (point-max)) + focus-buffer (current-buffer)) + (overlay-put focus-mid-overlay 'face 'focus-focused) + (mapc (lambda (o) (overlay-put o 'face 'focus-unfocused)) + (list focus-pre-overlay focus-post-overlay)) + (add-hook 'post-command-hook 'focus-move-focus nil t) + (add-hook 'change-major-mode-hook 'focus-terminate nil t))) + +(defun focus-terminate () + "This function is run when command `focus-mode' is disabled. + +The overlays pointed to by `focus-pre-overlay', +`focus-mid-overlay' and `focus-post-overlay' are deleted, and +`focus-move-focus' is removed from `post-command-hook'." + (when (and focus-pre-overlay focus-post-overlay) + (mapc 'delete-overlay + (list focus-pre-overlay focus-mid-overlay focus-post-overlay)) + (remove-hook 'post-command-hook 'focus-move-focus t) + (setq focus-pre-overlay nil + focus-mid-overlay nil + focus-post-overlay nil))) + +(defun focus-goto-thing (bounds) + "Move point to the middle of BOUNDS." + (when bounds + (goto-char (/ (+ (car bounds) (cdr bounds)) 2)) + (recenter nil))) + +(defun focus-change-thing () + "Adjust the narrowness of the focused section for the current buffer. + +The variable `focus-mode-to-thing' dictates the default thing +according to major-mode. If `focus-current-thing' is set, this +default is overwritten. This function simply helps set the +`focus-current-thing'." + (interactive) + (let* ((candidates '(defun line list paragraph sentence sexp symbol word)) + (thing (completing-read "Thing: " candidates))) + (setq focus-current-thing (intern thing)))) + +(defun focus-pin () + "Pin the focused section to its current location or the region, if active." + (interactive) + (when (bound-and-true-p focus-mode) + (when (region-active-p) + (focus-move-overlays (region-beginning) (region-end))) + (remove-hook 'post-command-hook 'focus-move-focus t))) + +(defun focus-unpin () + "Unpin the focused section." + (interactive) + (when (bound-and-true-p focus-mode) + (add-hook 'post-command-hook 'focus-move-focus nil t))) + +(defun focus-next-thing (&optional n) + "Move the point to the middle of the Nth next thing." + (interactive "p") + (let ((current-bounds (focus-bounds)) + (thing (focus-get-thing))) + (forward-thing thing n) + (when (equal current-bounds (focus-bounds)) + (forward-thing thing (cl-signum n))) + (focus-goto-thing (focus-bounds)))) + +(defun focus-prev-thing (&optional n) + "Move the point to the middle of the Nth previous thing." + (interactive "p") + (focus-next-thing (- n))) + +(defun focus-read-only-hide-cursor () + "Hide the cursor. +This function is triggered by the `focus-read-only-blink-timer', +when `focus-read-only-mode' is activated." + (with-current-buffer focus-buffer + (when (and (bound-and-true-p focus-read-only-mode) + (not (null focus-read-only-blink-timer))) + (setq focus-read-only-blink-timer nil) + (setq cursor-type nil)))) + +(defun focus-read-only-cursor-blink () + "Make the cursor visible for `focus-read-only-blink-seconds'. +This is added to the `pre-command-hook' when +`focus-read-only-mode' is active." + (with-current-buffer focus-buffer + (when (and (bound-and-true-p focus-read-only-mode) + (not (member last-command '(focus-next-thing focus-prev-thing)))) + (when focus-read-only-blink-timer (cancel-timer focus-read-only-blink-timer)) + (setq cursor-type focus-cursor-type) + (setq focus-read-only-blink-timer + (run-at-time focus-read-only-blink-seconds nil + 'focus-read-only-hide-cursor))))) + +(defun focus-read-only-init () + "Run when `focus-read-only-mode' is activated. +Enables `read-only-mode', hides the cursor and adds +`focus-read-only-cursor-blink' to `pre-command-hook'. +Also `focus-read-only-terminate' is added to the `kill-buffer-hook'." + (read-only-mode 1) + (setq cursor-type nil + focus-buffer (current-buffer)) + (add-hook 'pre-command-hook 'focus-read-only-cursor-blink nil t) + (add-hook 'kill-buffer-hook 'focus-read-only-terminate nil t)) + +(defun focus-read-only-terminate () + "Run when `focus-read-only-mode' is deactivated. +Disables `read-only-mode' and shows the cursor again. +It cleans up the `focus-read-only-blink-timer' and hooks." + (read-only-mode -1) + (setq cursor-type focus-cursor-type) + (when focus-read-only-blink-timer + (cancel-timer focus-read-only-blink-timer)) + (setq focus-read-only-blink-timer nil) + (remove-hook 'pre-command-hook 'focus-read-only-cursor-blink t) + (remove-hook 'kill-buffer-hook 'focus-read-only-terminate t)) + +(defun focus-turn-off-focus-read-only-mode () + "Turn off `focus-read-only-mode'." + (interactive) + (focus-read-only-mode -1)) + +;;;###autoload +(define-minor-mode focus-mode + "Dim the font color of text in surrounding sections." + :init-value nil + :keymap (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-q") 'focus-read-only-mode) + map) + (if focus-mode (focus-init) (focus-terminate))) + +;;;###autoload +(define-minor-mode focus-read-only-mode + "A read-only mode optimized for `focus-mode'." + :init-value nil + :keymap (let ((map (make-sparse-keymap))) + (define-key map (kbd "n") 'focus-next-thing) + (define-key map (kbd "SPC") 'focus-next-thing) + (define-key map (kbd "p") 'focus-prev-thing) + (define-key map (kbd "S-SPC") 'focus-prev-thing) + (define-key map (kbd "i") 'focus-turn-off-focus-read-only-mode) + (define-key map (kbd "q") 'focus-turn-off-focus-read-only-mode) + map) + (when cursor-type + (setq focus-cursor-type cursor-type)) + (if focus-read-only-mode (focus-read-only-init) (focus-read-only-terminate))) + +(provide 'focus) +;;; focus.el ends here diff --git a/lisp/git-commit.el b/lisp/git-commit.el new file mode 100644 index 00000000..e7673521 --- /dev/null +++ b/lisp/git-commit.el @@ -0,0 +1,1015 @@ +;;; git-commit.el --- Edit Git commit messages -*- lexical-binding: t; -*- + +;; Copyright (C) 2010-2020 The Magit Project Contributors +;; +;; You should have received a copy of the AUTHORS.md file which +;; lists all contributors. If not, see http://magit.vc/authors. + +;; Authors: Jonas Bernoulli +;; Sebastian Wiesner +;; Florian Ragwitz +;; Marius Vollmer +;; Maintainer: Jonas Bernoulli + +;; Package-Requires: ((emacs "25.1") (dash "20200524") (transient "20200601") (with-editor "20200522")) +;; Package-Version: 20200608.928 +;; Package-Commit: 9e35f9892ca3987d979a6212ff79b23ddbb42103 +;; Keywords: git tools vc +;; Homepage: https://github.com/magit/magit + +;; 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. + +;; You should have received a copy of the GNU General Public License +;; along with this file. If not, see . + +;;; Commentary: + +;; This package assists the user in writing good Git commit messages. + +;; While Git allows for the message to be provided on the command +;; line, it is preferable to tell Git to create the commit without +;; actually passing it a message. Git then invokes the `$GIT_EDITOR' +;; (or if that is undefined `$EDITOR') asking the user to provide the +;; message by editing the file ".git/COMMIT_EDITMSG" (or another file +;; in that directory, e.g. ".git/MERGE_MSG" for merge commits). + +;; When `global-git-commit-mode' is enabled, which it is by default, +;; then opening such a file causes the features described below, to +;; be enabled in that buffer. Normally this would be done using a +;; major-mode but to allow the use of any major-mode, as the user sees +;; fit, it is done here by running a setup function, which among other +;; things turns on the preferred major-mode, by default `text-mode'. + +;; Git waits for the `$EDITOR' to finish and then either creates the +;; commit using the contents of the file as commit message, or, if the +;; editor process exited with a non-zero exit status, aborts without +;; creating a commit. Unfortunately Emacsclient (which is what Emacs +;; users should be using as `$EDITOR' or at least as `$GIT_EDITOR') +;; does not differentiate between "successfully" editing a file and +;; aborting; not out of the box that is. + +;; By making use of the `with-editor' package this package provides +;; both ways of finish an editing session. In either case the file +;; is saved, but Emacseditor's exit code differs. +;; +;; C-c C-c Finish the editing session successfully by returning +;; with exit code 0. Git then creates the commit using +;; the message it finds in the file. +;; +;; C-c C-k Aborts the edit editing session by returning with exit +;; code 1. Git then aborts the commit. + +;; Aborting the commit does not cause the message to be lost, but +;; relying solely on the file not being tampered with is risky. This +;; package additionally stores all aborted messages for the duration +;; of the current session (i.e. until you close Emacs). To get back +;; an aborted message use M-p and M-n while editing a message. +;; +;; M-p Replace the buffer contents with the previous message +;; from the message ring. Of course only after storing +;; the current content there too. +;; +;; M-n Replace the buffer contents with the next message from +;; the message ring, after storing the current content. + +;; Some support for pseudo headers as used in some projects is +;; provided by these commands: +;; +;; C-c C-s Insert a Signed-off-by header. +;; C-c C-a Insert a Acked-by header. +;; C-c C-m Insert a Modified-by header. +;; C-c C-t Insert a Tested-by header. +;; C-c C-r Insert a Reviewed-by header. +;; C-c C-o Insert a Cc header. +;; C-c C-p Insert a Reported-by header. +;; C-c C-i Insert a Suggested-by header. + +;; When Git requests a commit message from the user, it does so by +;; having her edit a file which initially contains some comments, +;; instructing her what to do, and providing useful information, such +;; as which files were modified. These comments, even when left +;; intact by the user, do not become part of the commit message. This +;; package ensures these comments are propertizes as such and further +;; prettifies them by using different faces for various parts, such as +;; files. + +;; Finally this package highlights style errors, like lines that are +;; too long, or when the second line is not empty. It may even nag +;; you when you attempt to finish the commit without having fixed +;; these issues. The style checks and many other settings can easily +;; be configured: +;; +;; M-x customize-group RET git-commit RET + +;;; Code: +;;;; Dependencies + +(require 'dash) +(require 'log-edit) +(require 'magit-git nil t) +(require 'magit-utils nil t) +(require 'ring) +(require 'server) +(require 'transient) +(require 'with-editor) + +(eval-when-compile + (require 'recentf) + (require 'subr-x)) + +;;;; Declarations + +(defvar diff-default-read-only) +(defvar flyspell-generic-check-word-predicate) +(defvar font-lock-beg) +(defvar font-lock-end) + +(declare-function magit-completing-read "magit-utils" + (prompt collection &optional predicate require-match + initial-input hist def fallback)) +(declare-function magit-expand-git-file-name "magit-git" (filename)) +(declare-function magit-git-lines "magit-git" (&rest args)) +(declare-function magit-list-local-branch-names "magit-git" ()) +(declare-function magit-list-remote-branch-names "magit-git" + (&optional remote relative)) + +;;; Options +;;;; Variables + +(defgroup git-commit nil + "Edit Git commit messages." + :prefix "git-commit-" + :link '(info-link "(magit)Editing Commit Messages") + :group 'tools) + +;;;###autoload +(define-minor-mode global-git-commit-mode + "Edit Git commit messages. +This global mode arranges for `git-commit-setup' to be called +when a Git commit message file is opened. That usually happens +when Git uses the Emacsclient as $GIT_EDITOR to have the user +provide such a commit message." + :group 'git-commit + :type 'boolean + :global t + :init-value t + :initialize (lambda (symbol exp) + (custom-initialize-default symbol exp) + (when global-git-commit-mode + (add-hook 'find-file-hook 'git-commit-setup-check-buffer))) + (if global-git-commit-mode + (add-hook 'find-file-hook 'git-commit-setup-check-buffer) + (remove-hook 'find-file-hook 'git-commit-setup-check-buffer))) + +(defcustom git-commit-major-mode 'text-mode + "Major mode used to edit Git commit messages. +The major mode configured here is turned on by the minor mode +`git-commit-mode'." + :group 'git-commit + :type '(choice (function-item text-mode) + (const :tag "No major mode"))) + +(defcustom git-commit-setup-hook + '(git-commit-save-message + git-commit-setup-changelog-support + git-commit-turn-on-auto-fill + git-commit-propertize-diff + bug-reference-mode + with-editor-usage-message) + "Hook run at the end of `git-commit-setup'." + :group 'git-commit + :type 'hook + :get (and (featurep 'magit-utils) 'magit-hook-custom-get) + :options '(git-commit-save-message + git-commit-setup-changelog-support + git-commit-turn-on-auto-fill + git-commit-turn-on-flyspell + git-commit-propertize-diff + bug-reference-mode + with-editor-usage-message)) + +(defcustom git-commit-post-finish-hook nil + "Hook run after the user finished writing a commit message. + +\\\ +This hook is only run after pressing \\[with-editor-finish] in a buffer used +to edit a commit message. If a commit is created without the +user typing a message into a buffer, then this hook is not run. + +This hook is not run until the new commit has been created. If +doing so takes Git longer than one second, then this hook isn't +run at all. For certain commands such as `magit-rebase-continue' +this hook is never run because doing so would lead to a race +condition. + +This hook is only run if `magit' is available. + +Also see `magit-post-commit-hook'." + :group 'git-commit + :type 'hook + :get (and (featurep 'magit-utils) 'magit-hook-custom-get)) + +(defcustom git-commit-finish-query-functions + '(git-commit-check-style-conventions) + "List of functions called to query before performing commit. + +The commit message buffer is current while the functions are +called. If any of them returns nil, then the commit is not +performed and the buffer is not killed. The user should then +fix the issue and try again. + +The functions are called with one argument. If it is non-nil, +then that indicates that the user used a prefix argument to +force finishing the session despite issues. Functions should +usually honor this wish and return non-nil." + :options '(git-commit-check-style-conventions) + :type 'hook + :group 'git-commit) + +(defcustom git-commit-style-convention-checks '(non-empty-second-line) + "List of checks performed by `git-commit-check-style-conventions'. +Valid members are `non-empty-second-line' and `overlong-summary-line'. +That function is a member of `git-commit-finish-query-functions'." + :options '(non-empty-second-line overlong-summary-line) + :type '(list :convert-widget custom-hook-convert-widget) + :group 'git-commit) + +(defcustom git-commit-summary-max-length 68 + "Column beyond which characters in the summary lines are highlighted. + +The highlighting indicates that the summary is getting too long +by some standards. It does in no way imply that going over the +limit a few characters or in some cases even many characters is +anything that deserves shaming. It's just a friendly reminder +that if you can make the summary shorter, then you might want +to consider doing so." + :group 'git-commit + :safe 'numberp + :type 'number) + +(defcustom git-commit-fill-column nil + "Override `fill-column' in commit message buffers. + +If this is non-nil, then it should be an integer. If that is the +case and the buffer-local value of `fill-column' is not already +set by the time `git-commit-turn-on-auto-fill' is called as a +member of `git-commit-setup-hook', then that function sets the +buffer-local value of `fill-column' to the value of this option. + +This option exists mostly for historic reasons. If you are not +already using it, then you probably shouldn't start doing so." + :group 'git-commit + :safe 'numberp + :type '(choice (const :tag "use regular fill-column") + number)) + +(make-obsolete-variable 'git-commit-fill-column 'fill-column + "Magit 2.11.0" 'set) + +(defcustom git-commit-known-pseudo-headers + '("Signed-off-by" "Acked-by" "Modified-by" "Cc" + "Suggested-by" "Reported-by" "Tested-by" "Reviewed-by" + "Co-authored-by") + "A list of Git pseudo headers to be highlighted." + :group 'git-commit + :safe (lambda (val) (and (listp val) (-all-p 'stringp val))) + :type '(repeat string)) + +;;;; Faces + +(defgroup git-commit-faces nil + "Faces used for highlighting Git commit messages." + :prefix "git-commit-" + :group 'git-commit + :group 'faces) + +(defface git-commit-summary + '((t :inherit font-lock-type-face)) + "Face used for the summary in commit messages." + :group 'git-commit-faces) + +(defface git-commit-overlong-summary + '((t :inherit font-lock-warning-face)) + "Face used for the tail of overlong commit message summaries." + :group 'git-commit-faces) + +(defface git-commit-nonempty-second-line + '((t :inherit font-lock-warning-face)) + "Face used for non-whitespace on the second line of commit messages." + :group 'git-commit-faces) + +(defface git-commit-keyword + '((t :inherit font-lock-string-face)) + "Face used for keywords in commit messages. +In this context a \"keyword\" is text surrounded be brackets." + :group 'git-commit-faces) + +(define-obsolete-face-alias 'git-commit-note + 'git-commit-keyword "Git-Commit 3.0.0") + +(defface git-commit-pseudo-header + '((t :inherit font-lock-string-face)) + "Face used for pseudo headers in commit messages." + :group 'git-commit-faces) + +(defface git-commit-known-pseudo-header + '((t :inherit font-lock-keyword-face)) + "Face used for the keywords of known pseudo headers in commit messages." + :group 'git-commit-faces) + +(defface git-commit-comment-branch-local + (if (featurep 'magit) + '((t :inherit magit-branch-local)) + '((t :inherit font-lock-variable-name-face))) + "Face used for names of local branches in commit message comments." + :group 'git-commit-faces) + +(define-obsolete-face-alias 'git-commit-comment-branch + 'git-commit-comment-branch-local "Git-Commit 2.12.0") + +(defface git-commit-comment-branch-remote + (if (featurep 'magit) + '((t :inherit magit-branch-remote)) + '((t :inherit font-lock-variable-name-face))) + "Face used for names of remote branches in commit message comments. +This is only used if Magit is available." + :group 'git-commit-faces) + +(defface git-commit-comment-detached + '((t :inherit git-commit-comment-branch-local)) + "Face used for detached `HEAD' in commit message comments." + :group 'git-commit-faces) + +(defface git-commit-comment-heading + '((t :inherit git-commit-known-pseudo-header)) + "Face used for headings in commit message comments." + :group 'git-commit-faces) + +(defface git-commit-comment-file + '((t :inherit git-commit-pseudo-header)) + "Face used for file names in commit message comments." + :group 'git-commit-faces) + +(defface git-commit-comment-action + '((t :inherit bold)) + "Face used for actions in commit message comments." + :group 'git-commit-faces) + +;;; Keymap + +(defvar git-commit-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "M-p") 'git-commit-prev-message) + (define-key map (kbd "M-n") 'git-commit-next-message) + (define-key map (kbd "C-c C-i") 'git-commit-insert-pseudo-header) + (define-key map (kbd "C-c C-a") 'git-commit-ack) + (define-key map (kbd "C-c M-i") 'git-commit-suggested) + (define-key map (kbd "C-c C-m") 'git-commit-modified) + (define-key map (kbd "C-c C-o") 'git-commit-cc) + (define-key map (kbd "C-c C-p") 'git-commit-reported) + (define-key map (kbd "C-c C-r") 'git-commit-review) + (define-key map (kbd "C-c C-s") 'git-commit-signoff) + (define-key map (kbd "C-c C-t") 'git-commit-test) + (define-key map (kbd "C-c M-s") 'git-commit-save-message) + map) + "Key map used by `git-commit-mode'.") + +;;; Menu + +(require 'easymenu) +(easy-menu-define git-commit-mode-menu git-commit-mode-map + "Git Commit Mode Menu" + '("Commit" + ["Previous" git-commit-prev-message t] + ["Next" git-commit-next-message t] + "-" + ["Ack" git-commit-ack :active t + :help "Insert an 'Acked-by' header"] + ["Sign-Off" git-commit-signoff :active t + :help "Insert a 'Signed-off-by' header"] + ["Modified-by" git-commit-modified :active t + :help "Insert a 'Modified-by' header"] + ["Tested-by" git-commit-test :active t + :help "Insert a 'Tested-by' header"] + ["Reviewed-by" git-commit-review :active t + :help "Insert a 'Reviewed-by' header"] + ["CC" git-commit-cc t + :help "Insert a 'Cc' header"] + ["Reported" git-commit-reported :active t + :help "Insert a 'Reported-by' header"] + ["Suggested" git-commit-suggested t + :help "Insert a 'Suggested-by' header"] + ["Co-authored-by" git-commit-co-authored t + :help "Insert a 'Co-authored-by' header"] + "-" + ["Save" git-commit-save-message t] + ["Cancel" with-editor-cancel t] + ["Commit" with-editor-finish t])) + +;;; Hooks + +;;;###autoload +(defconst git-commit-filename-regexp "/\\(\ +\\(\\(COMMIT\\|NOTES\\|PULLREQ\\|MERGEREQ\\|TAG\\)_EDIT\\|MERGE_\\|\\)MSG\ +\\|\\(BRANCH\\|EDIT\\)_DESCRIPTION\\)\\'") + +(eval-after-load 'recentf + '(add-to-list 'recentf-exclude git-commit-filename-regexp)) + +(add-to-list 'with-editor-file-name-history-exclude git-commit-filename-regexp) + +(defun git-commit-setup-font-lock-in-buffer () + (and buffer-file-name + (string-match-p git-commit-filename-regexp buffer-file-name) + (git-commit-setup-font-lock))) + +(add-hook 'after-change-major-mode-hook 'git-commit-setup-font-lock-in-buffer) + +;;;###autoload +(defun git-commit-setup-check-buffer () + (and buffer-file-name + (string-match-p git-commit-filename-regexp buffer-file-name) + (git-commit-setup))) + +(defvar git-commit-mode) + +(defun git-commit-file-not-found () + ;; cygwin git will pass a cygwin path (/cygdrive/c/foo/.git/...), + ;; try to handle this in window-nt Emacs. + (--when-let + (and (or (string-match-p git-commit-filename-regexp buffer-file-name) + (and (boundp 'git-rebase-filename-regexp) + (string-match-p git-rebase-filename-regexp + buffer-file-name))) + (not (file-accessible-directory-p + (file-name-directory buffer-file-name))) + (if (require 'magit-git nil t) + ;; Emacs prepends a "c:". + (magit-expand-git-file-name (substring buffer-file-name 2)) + ;; Fallback if we can't load `magit-git'. + (and (string-match "\\`[a-z]:/\\(cygdrive/\\)?\\([a-z]\\)/\\(.*\\)" + buffer-file-name) + (concat (match-string 2 buffer-file-name) ":/" + (match-string 3 buffer-file-name))))) + (when (file-accessible-directory-p (file-name-directory it)) + (let ((inhibit-read-only t)) + (insert-file-contents it t) + t)))) + +(when (eq system-type 'windows-nt) + (add-hook 'find-file-not-found-functions #'git-commit-file-not-found)) + +(defconst git-commit-usage-message "\ +Type \\[with-editor-finish] to finish, \ +\\[with-editor-cancel] to cancel, and \ +\\[git-commit-prev-message] and \\[git-commit-next-message] \ +to recover older messages") + +;;;###autoload +(defun git-commit-setup () + (when (fboundp 'magit-toplevel) + ;; `magit-toplevel' is autoloaded and defined in magit-git.el, + ;; That library declares this functions without loading + ;; magit-process.el, which defines it. + (require 'magit-process nil t)) + ;; Pretend that git-commit-mode is a major-mode, + ;; so that directory-local settings can be used. + (let ((default-directory + (or (and (not (file-exists-p ".dir-locals.el")) + ;; When $GIT_DIR/.dir-locals.el doesn't exist, + ;; fallback to $GIT_WORK_TREE/.dir-locals.el, + ;; because the maintainer can use the latter + ;; to enforce conventions, while s/he has no + ;; control over the former. + (fboundp 'magit-toplevel) ; silence byte-compiler + (magit-toplevel)) + default-directory))) + (let ((buffer-file-name nil) ; trick hack-dir-local-variables + (major-mode 'git-commit-mode)) ; trick dir-locals-collect-variables + (hack-dir-local-variables) + (hack-local-variables-apply))) + (when git-commit-major-mode + (let ((auto-mode-alist (list (cons (concat "\\`" + (regexp-quote buffer-file-name) + "\\'") + git-commit-major-mode))) + ;; The major-mode hook might want to consult these minor + ;; modes, while the minor-mode hooks might want to consider + ;; the major mode. + (git-commit-mode t) + (with-editor-mode t)) + (normal-mode t))) + ;; Show our own message using our hook. + (setq with-editor-show-usage nil) + (setq with-editor-usage-message git-commit-usage-message) + (unless with-editor-mode + ;; Maybe already enabled when using `shell-command' or an Emacs shell. + (with-editor-mode 1)) + (add-hook 'with-editor-finish-query-functions + 'git-commit-finish-query-functions nil t) + (add-hook 'with-editor-pre-finish-hook + 'git-commit-save-message nil t) + (add-hook 'with-editor-pre-cancel-hook + 'git-commit-save-message nil t) + (when (and (fboundp 'magit-rev-parse) + (not (memq last-command + '(magit-sequencer-continue + magit-sequencer-skip + magit-am-continue + magit-am-skip + magit-rebase-continue + magit-rebase-skip)))) + (add-hook 'with-editor-post-finish-hook + (apply-partially 'git-commit-run-post-finish-hook + (magit-rev-parse "HEAD")) + nil t) + (when (fboundp 'magit-wip-maybe-add-commit-hook) + (magit-wip-maybe-add-commit-hook))) + (setq with-editor-cancel-message + 'git-commit-cancel-message) + (make-local-variable 'log-edit-comment-ring-index) + (git-commit-mode 1) + (git-commit-setup-font-lock) + (when (boundp 'save-place) + (setq save-place nil)) + (save-excursion + (goto-char (point-min)) + (when (looking-at "\\`\\(\\'\\|\n[^\n]\\)") + (open-line 1))) + (with-demoted-errors "Error running git-commit-setup-hook: %S" + (run-hooks 'git-commit-setup-hook)) + (set-buffer-modified-p nil)) + +(defun git-commit-run-post-finish-hook (previous) + (when (and git-commit-post-finish-hook + (require 'magit nil t) + (fboundp 'magit-rev-parse)) + (cl-block nil + (let ((break (time-add (current-time) + (seconds-to-time 1)))) + (while (equal (magit-rev-parse "HEAD") previous) + (if (time-less-p (current-time) break) + (sit-for 0.01) + (message "No commit created after 1 second. Not running %s." + 'git-commit-post-finish-hook) + (cl-return)))) + (run-hooks 'git-commit-post-finish-hook)))) + +(define-minor-mode git-commit-mode + "Auxiliary minor mode used when editing Git commit messages. +This mode is only responsible for setting up some key bindings. +Don't use it directly, instead enable `global-git-commit-mode'." + :lighter "") + +(put 'git-commit-mode 'permanent-local t) + +(defun git-commit-setup-changelog-support () + "Treat ChangeLog entries as unindented paragraphs." + (setq-local fill-indent-according-to-mode t) + (setq-local paragraph-start (concat paragraph-start "\\|\\*\\|("))) + +(defun git-commit-turn-on-auto-fill () + "Unconditionally turn on Auto Fill mode. +If `git-commit-fill-column' is non-nil, and `fill-column' +doesn't already have a buffer-local value, then set that +to `git-commit-fill-column'." + (when (and (numberp git-commit-fill-column) + (not (local-variable-p 'fill-column))) + (setq fill-column git-commit-fill-column)) + (setq-local comment-auto-fill-only-comments nil) + (turn-on-auto-fill)) + +(defun git-commit-turn-on-flyspell () + "Unconditionally turn on Flyspell mode. +Also prevent comments from being checked and +finally check current non-comment text." + (require 'flyspell) + (turn-on-flyspell) + (setq flyspell-generic-check-word-predicate + 'git-commit-flyspell-verify) + (let ((end) + (comment-start-regex (format "^\\(%s\\|$\\)" comment-start))) + (save-excursion + (goto-char (point-max)) + (while (and (not (bobp)) (looking-at comment-start-regex)) + (forward-line -1)) + (unless (looking-at comment-start-regex) + (forward-line)) + (setq end (point))) + (flyspell-region (point-min) end))) + +(defun git-commit-flyspell-verify () + (not (= (char-after (line-beginning-position)) + (aref comment-start 0)))) + +(defun git-commit-finish-query-functions (force) + (run-hook-with-args-until-failure + 'git-commit-finish-query-functions force)) + +(defun git-commit-check-style-conventions (force) + "Check for violations of certain basic style conventions. + +For each violation ask the user if she wants to proceed anyway. +Option `git-commit-check-style-conventions' controls which +conventions are checked." + (or force + (save-excursion + (goto-char (point-min)) + (re-search-forward (git-commit-summary-regexp) nil t) + (if (equal (match-string 1) "") + t ; Just try; we don't know whether --allow-empty-message was used. + (and (or (not (memq 'overlong-summary-line + git-commit-style-convention-checks)) + (equal (match-string 2) "") + (y-or-n-p "Summary line is too long. Commit anyway? ")) + (or (not (memq 'non-empty-second-line + git-commit-style-convention-checks)) + (not (match-string 3)) + (y-or-n-p "Second line is not empty. Commit anyway? "))))))) + +(defun git-commit-cancel-message () + (message + (concat "Commit canceled" + (and (memq 'git-commit-save-message with-editor-pre-cancel-hook) + ". Message saved to `log-edit-comment-ring'")))) + +;;; History + +(defun git-commit-prev-message (arg) + "Cycle backward through message history, after saving current message. +With a numeric prefix ARG, go back ARG comments." + (interactive "*p") + (when (and (git-commit-save-message) (> arg 0)) + (setq log-edit-comment-ring-index + (log-edit-new-comment-index + arg (ring-length log-edit-comment-ring)))) + (save-restriction + (goto-char (point-min)) + (narrow-to-region (point) + (if (re-search-forward (concat "^" comment-start) nil t) + (max 1 (- (point) 2)) + (point-max))) + (log-edit-previous-comment arg))) + +(defun git-commit-next-message (arg) + "Cycle forward through message history, after saving current message. +With a numeric prefix ARG, go forward ARG comments." + (interactive "*p") + (git-commit-prev-message (- arg))) + +(defun git-commit-save-message () + "Save current message to `log-edit-comment-ring'." + (interactive) + (when-let ((message (git-commit-buffer-message))) + (when-let ((index (ring-member log-edit-comment-ring message))) + (ring-remove log-edit-comment-ring index)) + (ring-insert log-edit-comment-ring message))) + +(defun git-commit-buffer-message () + (let ((flush (concat "^" comment-start)) + (str (buffer-substring-no-properties (point-min) (point-max)))) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (when (re-search-forward (concat flush " -+ >8 -+$") nil t) + (delete-region (point-at-bol) (point-max))) + (goto-char (point-min)) + (flush-lines flush) + (goto-char (point-max)) + (unless (eq (char-before) ?\n) + (insert ?\n)) + (setq str (buffer-string))) + (unless (string-match "\\`[ \t\n\r]*\\'" str) + (when (string-match "\\`\n\\{2,\\}" str) + (setq str (replace-match "\n" t t str))) + (when (string-match "\n\\{2,\\}\\'" str) + (setq str (replace-match "\n" t t str))) + str))) + +;;; Headers + +(transient-define-prefix git-commit-insert-pseudo-header () + "Insert a commit message pseudo header." + [["Insert ... by yourself" + ("a" "Ack" git-commit-ack) + ("m" "Modified" git-commit-modified) + ("r" "Reviewed" git-commit-review) + ("s" "Signed-off" git-commit-signoff) + ("t" "Tested" git-commit-test)] + ["Insert ... by someone" + ("C-c" "Cc" git-commit-cc) + ("C-r" "Reported" git-commit-reported) + ("C-i" "Suggested" git-commit-suggested) + ("C-a" "Co-authored" git-commit-co-authored)]]) + +(defun git-commit-ack (name mail) + "Insert a header acknowledging that you have looked at the commit." + (interactive (git-commit-self-ident)) + (git-commit-insert-header "Acked-by" name mail)) + +(defun git-commit-modified (name mail) + "Insert a header to signal that you have modified the commit." + (interactive (git-commit-self-ident)) + (git-commit-insert-header "Modified-by" name mail)) + +(defun git-commit-review (name mail) + "Insert a header acknowledging that you have reviewed the commit." + (interactive (git-commit-self-ident)) + (git-commit-insert-header "Reviewed-by" name mail)) + +(defun git-commit-signoff (name mail) + "Insert a header to sign off the commit." + (interactive (git-commit-self-ident)) + (git-commit-insert-header "Signed-off-by" name mail)) + +(defun git-commit-test (name mail) + "Insert a header acknowledging that you have tested the commit." + (interactive (git-commit-self-ident)) + (git-commit-insert-header "Tested-by" name mail)) + +(defun git-commit-cc (name mail) + "Insert a header mentioning someone who might be interested." + (interactive (git-commit-read-ident "Cc")) + (git-commit-insert-header "Cc" name mail)) + +(defun git-commit-reported (name mail) + "Insert a header mentioning the person who reported the issue." + (interactive (git-commit-read-ident "Reported-by")) + (git-commit-insert-header "Reported-by" name mail)) + +(defun git-commit-suggested (name mail) + "Insert a header mentioning the person who suggested the change." + (interactive (git-commit-read-ident "Suggested-by")) + (git-commit-insert-header "Suggested-by" name mail)) + +(defun git-commit-co-authored (name mail) + "Insert a header mentioning the person who co-authored the commit." + (interactive (git-commit-read-ident "Co-authored-by")) + (git-commit-insert-header "Co-authored-by" name mail)) + +(defun git-commit-self-ident () + (list (or (getenv "GIT_AUTHOR_NAME") + (getenv "GIT_COMMITTER_NAME") + (ignore-errors (car (process-lines "git" "config" "user.name"))) + user-full-name + (read-string "Name: ")) + (or (getenv "GIT_AUTHOR_EMAIL") + (getenv "GIT_COMMITTER_EMAIL") + (getenv "EMAIL") + (ignore-errors (car (process-lines "git" "config" "user.email"))) + (read-string "Email: ")))) + +(defvar git-commit-read-ident-history nil) + +(defun git-commit-read-ident (prompt) + (if (require 'magit-git nil t) + (let ((str (magit-completing-read + prompt + (sort (delete-dups + (magit-git-lines "log" "-n9999" "--format=%aN <%ae>")) + 'string<) + nil nil nil 'git-commit-read-ident-history))) + (save-match-data + (if (string-match "\\`\\([^<]+\\) *<\\([^>]+\\)>\\'" str) + (list (save-match-data (string-trim (match-string 1 str))) + (string-trim (match-string 2 str))) + (user-error "Invalid input")))) + (list (read-string "Name: ") + (read-string "Email: ")))) + +(defun git-commit-insert-header (header name email) + (setq header (format "%s: %s <%s>" header name email)) + (save-excursion + (goto-char (point-max)) + (cond ((re-search-backward "^[-a-zA-Z]+: [^<]+? <[^>]+>" nil t) + (end-of-line) + (insert ?\n header) + (unless (= (char-after) ?\n) + (insert ?\n))) + (t + (while (re-search-backward (concat "^" comment-start) nil t)) + (unless (looking-back "\n\n" nil) + (insert ?\n)) + (insert header ?\n))) + (unless (or (eobp) (= (char-after) ?\n)) + (insert ?\n)))) + +;;; Font-Lock + +(defvar-local git-commit-need-summary-line t + "Whether the text should have a heading that is separated from the body. + +For commit messages that is a convention that should not +be violated. For notes it is up to the user. If you do +not want to insist on an empty second line here, then use +something like: + + (add-hook \\='git-commit-setup-hook + (lambda () + (when (equal (file-name-nondirectory (buffer-file-name)) + \"NOTES_EDITMSG\") + (setq git-commit-need-summary-line nil))))") + +(defun git-commit-summary-regexp () + (if git-commit-need-summary-line + (concat + ;; Leading empty lines and comments + (format "\\`\\(?:^\\(?:\\s-*\\|%s.*\\)\n\\)*" comment-start) + ;; Summary line + (format "\\(.\\{0,%d\\}\\)\\(.*\\)" git-commit-summary-max-length) + ;; Non-empty non-comment second line + (format "\\(?:\n%s\\|\n\\(.+\\)\\)?" comment-start)) + "\\(EASTER\\) \\(EGG\\)")) + +(defun git-commit-extend-region-summary-line () + "Identify the multiline summary-regexp construct. +Added to `font-lock-extend-region-functions'." + (save-excursion + (save-match-data + (goto-char (point-min)) + (when (looking-at (git-commit-summary-regexp)) + (let ((summary-beg (match-beginning 0)) + (summary-end (match-end 0))) + (when (or (< summary-beg font-lock-beg summary-end) + (< summary-beg font-lock-end summary-end)) + (setq font-lock-beg (min font-lock-beg summary-beg)) + (setq font-lock-end (max font-lock-end summary-end)))))))) + +(defvar-local git-commit--branch-name-regexp nil) + +(defconst git-commit-comment-headings + '("Changes to be committed:" + "Untracked files:" + "Changed but not updated:" + "Changes not staged for commit:" + "Unmerged paths:" + "Author:" + "Date:")) + +(defconst git-commit-font-lock-keywords-1 + '(;; Pseudo headers + (eval . `(,(format "^\\(%s:\\)\\( .*\\)" + (regexp-opt git-commit-known-pseudo-headers)) + (1 'git-commit-known-pseudo-header) + (2 'git-commit-pseudo-header))) + ("^[-a-zA-Z]+: [^<]+? <[^>]+>" + (0 'git-commit-pseudo-header)) + ;; Summary + (eval . `(,(git-commit-summary-regexp) + (1 'git-commit-summary))) + ;; - Keyword [aka "text in brackets"] (overrides summary) + ("\\[.+?\\]" + (0 'git-commit-keyword t)) + ;; - Non-empty second line (overrides summary and note) + (eval . `(,(git-commit-summary-regexp) + (2 'git-commit-overlong-summary t t) + (3 'git-commit-nonempty-second-line t t))))) + +(defconst git-commit-font-lock-keywords-2 + `(,@git-commit-font-lock-keywords-1 + ;; Comments + (eval . `(,(format "^%s.*" comment-start) + (0 'font-lock-comment-face append))) + (eval . `(,(format "^%s On branch \\(.*\\)" comment-start) + (1 'git-commit-comment-branch-local t))) + (eval . `(,(format "^%s \\(HEAD\\) detached at" comment-start) + (1 'git-commit-comment-detached t))) + (eval . `(,(format "^%s %s" comment-start + (regexp-opt git-commit-comment-headings t)) + (1 'git-commit-comment-heading t))) + (eval . `(,(format "^%s\t\\(?:\\([^:\n]+\\):\\s-+\\)?\\(.*\\)" comment-start) + (1 'git-commit-comment-action t t) + (2 'git-commit-comment-file t))))) + +(defconst git-commit-font-lock-keywords-3 + `(,@git-commit-font-lock-keywords-2 + ;; More comments + (eval + ;; Your branch is ahead of 'master' by 3 commits. + ;; Your branch is behind 'master' by 2 commits, and can be fast-forwarded. + . `(,(format + "^%s Your branch is \\(?:ahead\\|behind\\) of '%s' by \\([0-9]*\\)" + comment-start git-commit--branch-name-regexp) + (1 'git-commit-comment-branch-local t) + (2 'git-commit-comment-branch-remote t) + (3 'bold t))) + (eval + ;; Your branch is up to date with 'master'. + ;; Your branch and 'master' have diverged, + . `(,(format + "^%s Your branch \\(?:is up-to-date with\\|and\\) '%s'" + comment-start git-commit--branch-name-regexp) + (1 'git-commit-comment-branch-local t) + (2 'git-commit-comment-branch-remote t))) + (eval + ;; and have 1 and 2 different commits each, respectively. + . `(,(format + "^%s and have \\([0-9]*\\) and \\([0-9]*\\) commits each" + comment-start) + (1 'bold t) + (2 'bold t))))) + +(defvar git-commit-font-lock-keywords git-commit-font-lock-keywords-2 + "Font-Lock keywords for Git-Commit mode.") + +(defun git-commit-setup-font-lock () + (let ((table (make-syntax-table (syntax-table)))) + (when comment-start + (modify-syntax-entry (string-to-char comment-start) "." table)) + (modify-syntax-entry ?# "." table) + (modify-syntax-entry ?\" "." table) + (modify-syntax-entry ?\' "." table) + (modify-syntax-entry ?` "." table) + (set-syntax-table table)) + (setq-local comment-start + (or (ignore-errors + (car (process-lines "git" "config" "core.commentchar"))) + "#")) + (setq-local comment-start-skip (format "^%s+[\s\t]*" comment-start)) + (setq-local comment-end-skip "\n") + (setq-local comment-use-syntax nil) + (setq-local git-commit--branch-name-regexp + (if (and (featurep 'magit-git) + ;; When using cygwin git, we may end up in a + ;; non-existing directory, which would cause + ;; any git calls to signal an error. + (file-accessible-directory-p default-directory)) + (progn + ;; Make sure the below functions are available. + (require 'magit) + ;; Font-Lock wants every submatch to succeed, + ;; so also match the empty string. Do not use + ;; `regexp-quote' because that is slow if there + ;; are thousands of branches outweighing the + ;; benefit of an efficient regep. + (format "\\(\\(?:%s\\)\\|\\)\\(\\(?:%s\\)\\|\\)" + (mapconcat #'identity + (magit-list-local-branch-names) + "\\|") + (mapconcat #'identity + (magit-list-remote-branch-names) + "\\|"))) + "\\([^']*\\)")) + (setq-local font-lock-multiline t) + (add-hook 'font-lock-extend-region-functions + #'git-commit-extend-region-summary-line + t t) + (font-lock-add-keywords nil git-commit-font-lock-keywords)) + +(defun git-commit-propertize-diff () + (require 'diff-mode) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^diff --git" nil t) + (beginning-of-line) + (let ((buffer (current-buffer))) + (insert + (with-temp-buffer + (insert + (with-current-buffer buffer + (prog1 (buffer-substring-no-properties (point) (point-max)) + (delete-region (point) (point-max))))) + (let ((diff-default-read-only nil)) + (diff-mode)) + (let (font-lock-verbose font-lock-support-mode) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (with-no-warnings + (font-lock-fontify-buffer)))) + (let (next (pos (point-min))) + (while (setq next (next-single-property-change pos 'face)) + (put-text-property pos next 'font-lock-face + (get-text-property pos 'face)) + (setq pos next)) + (put-text-property pos (point-max) 'font-lock-face + (get-text-property pos 'face))) + (buffer-string))))))) + +;;; Elisp Text Mode + +(define-derived-mode git-commit-elisp-text-mode text-mode "ElText" + "Major mode for editing commit messages of elisp projects. +This is intended for use as `git-commit-major-mode' for projects +that expect `symbols' to look like this. I.e. like they look in +Elisp doc-strings, including this one. Unlike in doc-strings, +\"strings\" also look different than the other text." + (setq font-lock-defaults '(git-commit-elisp-text-mode-keywords))) + +(defvar git-commit-elisp-text-mode-keywords + `((,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]") + (1 font-lock-constant-face prepend)) + ("\"[^\"]*\"" (0 font-lock-string-face prepend)))) + +;;; _ +(provide 'git-commit) +;;; git-commit.el ends here diff --git a/lisp/git-messenger.el b/lisp/git-messenger.el new file mode 100644 index 00000000..03478952 --- /dev/null +++ b/lisp/git-messenger.el @@ -0,0 +1,432 @@ +;;; git-messenger.el --- Popup last commit of current line -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2020 by Syohei YOSHIDA and Neil Okamoto + +;; Author: Syohei YOSHIDA +;; Maintainer: Neil Okamoto +;; URL: https://github.com/emacsorphanage/git-messenger +;; Package-Version: 20200321.2337 +;; Package-Commit: 2d64e62e33be9f881ebb019afc183caac9c62eda +;; Version: 0.18 +;; Package-Requires: ((emacs "24.3") (popup "0.5.3")) + +;; 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 . + +;;; Commentary: + +;; This package provides a function called git-messenger:popup-message +;; that when called will pop-up the last git commit message for the +;; current line. This uses the git-blame tool internally. +;; +;; Example usage: +;; (require 'git-messenger) +;; (global-set-key (kbd "C-x v p") 'git-messenger:popup-message) +;; + +;;; Code: + +(require 'cl-lib) +(require 'popup) + +(declare-function magit-show-commit "magit-diff") + +(defgroup git-messenger nil + "git messenger" + :group 'vc) + +(defcustom git-messenger:show-detail nil + "Pop up commit ID and author name too." + :type 'boolean) + +(defcustom git-messenger:before-popup-hook nil + "Hook run before popup commit message. This hook is taken popup-ed message." + :type 'hook) + +(defcustom git-messenger:after-popup-hook nil + "Hook run after popup commit message. This hook is taken popup-ed message." + :type 'hook) + +(defcustom git-messenger:popup-buffer-hook nil + "Hook run after popup buffer (popup diff, popup show etc)." + :type 'hook) + +(defcustom git-messenger:handled-backends '(git svn hg) + "List of version control backends for which `git-messenger' will be used. +Entries in this list will be tried in order to determine whether a +file is under that sort of version control." + :type '(repeat symbol)) + +(defcustom git-messenger:use-magit-popup nil + "Use `magit-show-commit` instead `pop-to-buffer`." + :type 'boolean) + +(defvar git-messenger:last-message nil + "Last message displayed by git-messenger. + +This is set before the pop-up is displayed so accessible in the hooks +and menus.") + +(defvar git-messenger:last-commit-id nil + "Last commit id for the last message displayed. + +This is set before the pop-up is displayed so accessible in the hooks +and menus.") + +(defvar git-messenger:vcs nil) + +(defconst git-messenger:directory-of-vcs + '((git . ".git") + (svn . ".svn") + (hg . ".hg"))) + +(defun git-messenger:blame-arguments (vcs file line) + (let ((basename (file-name-nondirectory file))) + (cl-case vcs + (git (list "--no-pager" "blame" "-w" "-L" + (format "%d,+1" line) + "--porcelain" basename)) + (svn (list "blame" basename)) + (hg (list "blame" "-wuc" basename))))) + +(defsubst git-messenger:cat-file-arguments (commit-id) + (list "--no-pager" "cat-file" "commit" commit-id)) + +(defsubst git-messenger:vcs-command (vcs) + (cl-case vcs + (git "git") + (svn "svn") + (hg "hg"))) + +(defun git-messenger:execute-command (vcs args output) + (cl-case vcs + (git (apply 'process-file "git" nil output nil args)) + (svn + (let ((process-environment (cons "LANG=C" process-environment))) + (apply 'process-file "svn" nil output nil args))) + (hg + (let ((process-environment (cons + "HGPLAIN=1" + (cons "LANG=utf-8" process-environment)))) + (apply 'process-file "hg" nil output nil args))))) + +(defun git-messenger:git-commit-info-at-line () + (let* ((id-line (buffer-substring-no-properties + (line-beginning-position) (line-end-position))) + (commit-id (car (split-string id-line))) + (author (if (re-search-forward "^author \\(.+\\)$" nil t) + (match-string-no-properties 1) + "unknown"))) + (cons commit-id author))) + +(defun git-messenger:hg-commit-info-at-line (line) + (forward-line (1- line)) + (if (looking-at "^\\s-*\\(\\S-+\\)\\s-+\\([a-z0-9]+\\)") + (cons (match-string-no-properties 2) (match-string-no-properties 1)) + (cons "-" "-"))) + +(defun git-messenger:svn-commit-info-at-line (line) + (forward-line (1- line)) + (if (looking-at "^\\s-*\\([0-9]+\\)\\s-+\\(\\S-+\\)") + (cons (match-string-no-properties 1) (match-string-no-properties 2)) + (cons "-" "-"))) + +(defun git-messenger:commit-info-at-line (vcs file line) + (with-temp-buffer + (let ((args (git-messenger:blame-arguments vcs file line))) + (unless (zerop (git-messenger:execute-command vcs args t)) + (error "Failed: '%s blame'" (git-messenger:vcs-command vcs))) + (goto-char (point-min)) + (cl-case vcs + (git (git-messenger:git-commit-info-at-line)) + (svn (git-messenger:svn-commit-info-at-line line)) + (hg (git-messenger:hg-commit-info-at-line line)))))) + +(defsubst git-messenger:not-committed-id-p (commit-id) + (or (string-match-p "\\`\\(?:0+\\|-\\)\\'" commit-id))) + +(defun git-messenger:git-commit-message (commit-id) + (let ((args (git-messenger:cat-file-arguments commit-id))) + (unless (zerop (git-messenger:execute-command 'git args t)) + (error "Failed: 'git cat-file'")) + (goto-char (point-min)) + (forward-paragraph) + (buffer-substring-no-properties (point) (point-max)))) + +(defun git-messenger:hg-commit-message (commit-id) + (let ((args (list "log" "-T" "{desc}" "-r" commit-id))) + (unless (zerop (git-messenger:execute-command 'hg args t)) + (error "Failed: 'hg log")) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun git-messenger:svn-commit-message (commit-id) + (let ((args (list "log" "-c" commit-id))) + (unless (zerop (git-messenger:execute-command 'svn args t)) + (error "Failed: 'svn log")) + (let (end) + (goto-char (point-max)) + (when (re-search-backward "^-\\{25\\}" nil t) + (setq end (point))) + (buffer-substring-no-properties (point-min) (or end (point-max)))))) + +(defun git-messenger:commit-message (vcs commit-id) + (with-temp-buffer + (if (git-messenger:not-committed-id-p commit-id) + "* not yet committed *" + (cl-case vcs + (git (git-messenger:git-commit-message commit-id)) + (svn (git-messenger:svn-commit-message commit-id)) + (hg (git-messenger:hg-commit-message commit-id)))))) + +(defun git-messenger:commit-date (commit-id) + (let ((args (list "--no-pager" "show" "--pretty=%ad" commit-id))) + (with-temp-buffer + (unless (zerop (git-messenger:execute-command 'git args t)) + (error "Failed 'git show'")) + (goto-char (point-min)) + (buffer-substring-no-properties + (line-beginning-position) (line-end-position))))) + +(defun git-messenger:hg-commit-date (commit-id) + (let ((args (list "log" "-T" "{date|rfc822date}" "-r" commit-id))) + (with-temp-buffer + (unless (zerop (git-messenger:execute-command 'hg args t)) + (error "Failed 'hg log'")) + (goto-char (point-min)) + (buffer-substring-no-properties + (line-beginning-position) (line-end-position))))) + +(defun git-messenger:format-detail (vcs commit-id author message) + (cl-case vcs + (git (let ((date (git-messenger:commit-date commit-id))) + (format "commit : %s \nAuthor : %s\nDate : %s \n%s" + (substring commit-id 0 8) author date message))) + (hg (let ((date (git-messenger:hg-commit-date commit-id))) + (format "commit : %s \nAuthor : %s\nDate : %s \n%s" + commit-id author date message))) + (svn (with-temp-buffer + (insert message) + (goto-char (point-min)) + (forward-line 1) + (let ((line (buffer-substring-no-properties (point) (line-end-position))) + (re "^\\s-*\\(?:r[0-9]+\\)\\s-+|\\s-+\\([^|]+\\)|\\s-+\\([^|]+\\)")) + (unless (string-match re line) + (error "Can't get revision %s" line)) + (let ((author (match-string-no-properties 1 line)) + (date (match-string-no-properties 2 line))) + (forward-paragraph) + (format "commit : r%s \nAuthor : %s\nDate : %s\n%s" + commit-id author date + (buffer-substring-no-properties (point) (point-max))))))))) + +(defun git-messenger:show-detail-p (commit-id) + (and (or git-messenger:show-detail current-prefix-arg) + (not (git-messenger:not-committed-id-p commit-id)))) + +(defun git-messenger:popup-close () + (interactive) + (throw 'git-messenger-loop t)) + +(defun git-messenger:copy-message () + "Copy current displayed commit message to the kill ring`." + (interactive) + (when git-messenger:last-message + (kill-new git-messenger:last-message)) + (git-messenger:popup-close)) + +(defun git-messenger:copy-commit-id () + "Copy current displayed commit id to the kill ring." + (interactive) + (when git-messenger:last-commit-id + (kill-new git-messenger:last-commit-id)) + (git-messenger:popup-close)) + +(defun git-messenger:popup-common (vcs args &optional mode) + (with-current-buffer (get-buffer-create "*git-messenger*") + (view-mode -1) + (fundamental-mode) + (erase-buffer) + (unless (zerop (git-messenger:execute-command vcs args t)) + (error "Failed: '%s(args=%s)'" (git-messenger:vcs-command vcs) args)) + (if git-messenger:use-magit-popup + (magit-show-commit git-messenger:last-commit-id) + (pop-to-buffer (current-buffer)) + (when mode + (funcall mode))) + (run-hooks 'git-messenger:popup-buffer-hook) + (view-mode +1) + (goto-char (point-min))) + (git-messenger:popup-close)) + +(defun git-messenger:popup-svn-show () + (git-messenger:popup-common + 'svn (list "diff" "-c" git-messenger:last-commit-id) 'diff-mode)) + +(defun git-messenger:popup-hg-show () + (git-messenger:popup-common + 'hg (list "diff" "-c" git-messenger:last-commit-id) 'diff-mode)) + +(defun git-messenger:popup-diff () + (interactive) + (cl-case git-messenger:vcs + (git (let ((args (list "--no-pager" "diff" "--no-ext-diff" + (concat git-messenger:last-commit-id "^!")))) + (git-messenger:popup-common 'git args 'diff-mode))) + (svn (git-messenger:popup-svn-show)) + (hg (git-messenger:popup-hg-show)))) + +(defun git-messenger:popup-show () + (interactive) + (cl-case git-messenger:vcs + (git (let ((args (list "--no-pager" "show" "--no-ext-diff" "--stat" + git-messenger:last-commit-id))) + (git-messenger:popup-common 'git args))) + (svn (git-messenger:popup-svn-show)) + (hg (let ((args (list "log" "--stat" "-r" + git-messenger:last-commit-id))) + (git-messenger:popup-common 'hg args))))) + +(defun git-messenger:popup-show-verbose () + (interactive) + (cl-case git-messenger:vcs + (git (let ((args (list "--no-pager" "show" "--no-ext-diff" "--stat" "-p" + git-messenger:last-commit-id))) + (git-messenger:popup-common 'git args))) + (svn (error "'svn' does not support `popup-show-verbose'")) + (hg (let ((args (list "log" "-p" "--stat" "-r" + git-messenger:last-commit-id))) + (git-messenger:popup-common 'hg args))))) + +(defvar git-messenger-map + (let ((map (make-sparse-keymap))) + ;; key bindings + (define-key map (kbd "q") 'git-messenger:popup-close) + (define-key map (kbd "c") 'git-messenger:copy-commit-id) + (define-key map (kbd "d") 'git-messenger:popup-diff) + (define-key map (kbd "s") 'git-messenger:popup-show) + (define-key map (kbd "S") 'git-messenger:popup-show-verbose) + (define-key map (kbd "M-w") 'git-messenger:copy-message) + (define-key map (kbd ",") 'git-messenger:show-parent) + map) + "Key mappings of git-messenger. This is enabled when commit message is popup-ed.") + +(defun git-messenger:find-vcs () + (let ((longest 0) + result) + (dolist (vcs git-messenger:handled-backends result) + (let* ((dir (assoc-default vcs git-messenger:directory-of-vcs)) + (vcs-root (locate-dominating-file default-directory dir))) + (when (and vcs-root (> (length vcs-root) longest)) + (setq longest (length vcs-root) + result vcs)))))) + +(defun git-messenger:svn-message (msg) + (with-temp-buffer + (insert msg) + (goto-char (point-min)) + (forward-paragraph) + (buffer-substring-no-properties (point) (point-max)))) + +(defvar git-messenger:func-prompt + '((git-messenger:popup-show . "Show") + (git-messenger:popup-show-verbose . "Show verbose") + (git-messenger:popup-close . "Close") + (git-messenger:copy-commit-id . "Copy hash") + (git-messenger:popup-diff . "Diff") + (git-messenger:copy-message . "Copy message") + (git-messenger:show-parent . "Go Parent") + (git-messenger:popup-close . "Quit"))) + +(defsubst git-messenger:function-to-key (func) + (key-description (car-safe (where-is-internal func git-messenger-map)))) + +(defun git-messenger:prompt () + (mapconcat (lambda (fp) + (let* ((func (car fp)) + (desc (cdr fp)) + (key (git-messenger:function-to-key func))) + (when (and git-messenger:use-magit-popup + (eq func 'git-messenger:popup-show)) + (setq desc "magit-show-commit")) + (unless (and git-messenger:use-magit-popup + (memq func '(git-messenger:popup-show-verbose + git-messenger:popup-diff))) + (format "[%s]%s " key desc)))) + git-messenger:func-prompt "")) + +(defun git-messenger:show-parent () + (interactive) + (let ((file (buffer-file-name (buffer-base-buffer)))) + (cl-case git-messenger:vcs + (git (with-temp-buffer + (unless (zerop (process-file "git" nil t nil + "blame" "--increment" + git-messenger:last-commit-id "--" file)) + (error "No parent commit ID")) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" git-messenger:last-commit-id) + nil t) + (when (re-search-forward "previous \\(\\S-+\\)" nil t) + (let ((parent (match-string-no-properties 1))) + (setq git-messenger:last-commit-id parent + git-messenger:last-message (git-messenger:commit-message + 'git parent))))) + (throw 'git-messenger-loop nil))) + (otherwise (error "%s does not support for getting parent commit ID" + git-messenger:vcs))))) + +;;;###autoload +(defun git-messenger:popup-message () + (interactive) + (let* ((vcs (git-messenger:find-vcs)) + (file (buffer-file-name (buffer-base-buffer))) + (line (line-number-at-pos)) + (commit-info (git-messenger:commit-info-at-line vcs file line)) + (commit-id (car commit-info)) + (author (cdr commit-info)) + (msg (git-messenger:commit-message vcs commit-id)) + (popuped-message (if (git-messenger:show-detail-p commit-id) + (git-messenger:format-detail vcs commit-id author msg) + (cl-case vcs + (git msg) + (svn (if (string= commit-id "-") + msg + (git-messenger:svn-message msg))) + (hg msg))))) + (setq git-messenger:vcs vcs + git-messenger:last-message popuped-message + git-messenger:last-commit-id commit-id) + (let (finish) + (run-hook-with-args 'git-messenger:before-popup-hook popuped-message) + (while (not finish) + (let ((menu (popup-tip git-messenger:last-message :nowait t))) + (unwind-protect + (setq finish (catch 'git-messenger-loop + (popup-menu-event-loop menu + git-messenger-map + 'popup-menu-fallback + :prompt (git-messenger:prompt)) + t)) + (popup-delete menu))))) + (run-hook-with-args 'git-messenger:after-popup-hook popuped-message))) + +(provide 'git-messenger) + +;; Local Variables: +;; coding: utf-8 +;; indent-tabs-mode: nil +;; fill-column: 85 +;; End: + +;;; git-messenger.el ends here diff --git a/lisp/gnuplot-mode.el b/lisp/gnuplot-mode.el new file mode 100644 index 00000000..f1e161be --- /dev/null +++ b/lisp/gnuplot-mode.el @@ -0,0 +1,459 @@ +;;; gnuplot-mode.el --- Major mode for editing gnuplot scripts + +;; Copyright (C) 2010-2013 Mike McCourt +;; +;; Authors: Mike McCourt +;; URL: https://github.com/mkmcc/gnuplot-mode +;; Package-Version: 20171013.1616 +;; Version: 1.2.0 +;; Keywords: gnuplot, plotting + +;; 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. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + + +;;; Commentary: + +;; Defines a major mode for editing gnuplot scripts. I wanted to keep +;; it simpler than other modes -- just syntax highlighting, indentation, +;; and a command to plot the file. + +;; Some of this code is adapted from a more full-featured version by +;; Bruce Ravel (available here https://github.com/bruceravel/gnuplot-mode; +;; GPLv2). + +;; Thanks to everyone, including Christopher Gilbreth and Ralph Möritz, +;; for sending suggestions, improvements, and fixes. + +;;; Installation: + +;; Use package.el. You'll need to add MELPA to your archives: + +;; (require 'package) +;; (add-to-list 'package-archives +;; '("melpa" . "https://melpa.org/packages/") t) + +;; Alternatively, you can just save this file and do the standard +;; (add-to-list 'load-path "/path/to/gnuplot-mode.el") + +;;; Configuration: + +;; If you installed this via `package.el', you should take advantage +;; of autoloading. You can customize features using `defvar' and +;; `eval-after-load', as illustrated below: +;; +;; ;; specify the gnuplot executable (if other than "gnuplot") +;; (defvar gnuplot-program "/sw/bin/gnuplot") +;; +;; ;; set gnuplot arguments (if other than "-persist") +;; (defvar gnuplot-flags "-persist -pointsize 2") +;; +;; ;; if you want, add a mode hook. e.g., the following turns on +;; ;; spell-checking for strings and comments and automatically cleans +;; ;; up whitespace on save. +;; (eval-after-load 'gnuplot-mode +;; '(add-hook 'gnuplot-mode-hook +;; (lambda () +;; (flyspell-prog-mode) +;; (add-hook 'before-save-hook +;; 'whitespace-cleanup nil t)))) + +;; If you installed this file manually, you probably don't want to +;; muck around with autoload commands. Instead, add something like +;; the following to your .emacs: + +;; (require 'gnuplot-mode) +;; +;; ;; specify the gnuplot executable (if other than "gnuplot") +;; (setq gnuplot-program "/sw/bin/gnuplot") +;; +;; ;; set gnuplot arguments (if other than "-persist") +;; (setq gnuplot-flags "-persist -pointsize 2") +;; +;; ;; if you want, add a mode hook. e.g., the following turns on +;; ;; spell-checking for strings and comments and automatically cleans +;; ;; up whitespace on save. +;; (add-hook 'gnuplot-mode-hook +;; (lambda () +;; (flyspell-prog-mode) +;; (add-hook 'before-save-hook +;; 'whitespace-cleanup nil t))) + +;;; TODO: +;; 1. the indentation commands use regular expressions, which +;; probably isn't ideal. is it possible to rework them to use the +;; syntax table? +;; + +;;; Code: + +;;; user-settable options: + +(defvar gnuplot-program "gnuplot" + "Command to run gnuplot.") + +(defvar gnuplot-flags "-persist" + "Flags to pass to gnuplot.") + +(defvar gnuplot-mode-hook nil + "Hook to run after `gnuplot-mode'.") + +(defvar gnuplot-continued-commands-regexp + (concat + (regexp-opt '("splot" "plot" "fit") 'words) + "\\(\\s-*\\[[^]]+]\\s-*\\)*") ; optional range commands + "Regexp which matches all commands which might continue over +multiple lines. Used in `gnuplot-find-indent-column' and in +`gnuplot-last-line-p'.") + +(defvar gnuplot-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-x p") 'gnuplot-compile) + (define-key map (kbd "C-c C-c") 'gnuplot-compile) + (define-key map (kbd "C-c C-r") 'gnuplot-run-region) + (define-key map (kbd "C-c C-b") 'gnuplot-run-buffer) + map) + "Keymap for `gnuplot-mode'.") + +(defvar gnuplot-mode-syntax-table + (let ((st (make-syntax-table))) + (modify-syntax-entry ?* "." st) + (modify-syntax-entry ?+ "." st) + (modify-syntax-entry ?- "." st) + (modify-syntax-entry ?/ "." st) + (modify-syntax-entry ?% "." st) + (modify-syntax-entry ?' "\"" st) + (modify-syntax-entry ?` "w" st) + (modify-syntax-entry ?_ "w" st) + (modify-syntax-entry ?# "<" st) + (modify-syntax-entry ?\n ">" st) + st) + "Syntax table for `gnuplot-mode'.") + + + +;;; font lock. +;; first, define syntax types via explicit lists +(defvar gp-math-functions + (regexp-opt + '("abs" "acos" "acosh" "arg" "asin" + "asinh" "atan" "atan2" "atanh" "besj0" + "besj1" "besy0" "besy1" "ceil" "cos" + "cosh" "erf" "erfc" "exp" "floor" + "gamma" "ibeta" "inverf" "igamma" "imag" + "invnorm" "int" "lambertw" "lgamma" "log" + "log10" "norm" "rand" "real" "sgn" + "sin" "sinh" "sqrt" "tan" "tanh") + 'words) + "Gnuplot math functions.") + +(defvar gp-other-functions + (regexp-opt + '("gprintf" "sprintf" "strlen" "strstrr" + "substr" "strftime" "strptime" "system" + "word" "words" "column" "exists" + "stringcolumn" "timecolumn" "tm_hour" "tm_mday" + "tm_min" "tm_mon" "tm_sec" "tm_wday" + "tm_yday" "tm_year" "valid") + 'words) + "Gnuplot other functions.") + +(defvar gp-reserved-modifiers + (regexp-opt + '("axes" "every" "index" "title" "notitle" + "ps" "pt" "pointsize" "pointtype" "linetype" + "ls" "lw" "lt" "linestyle" "linewidth" + "smooth" "thru" "using" "with") + 'words) + "Gnuplot reserved words.") + +(defvar gp-other-keywords + (regexp-opt + '("term" "xrange" "yrange" "logscale" "out" "output") + 'words) + "Gnuplot keywords") + +(defvar gp-term-types + (regexp-opt + '("cairolatex" "canvas" "cgm" "context" "corel" "dumb" "dxf" + "eepic" "emf" "emtex" "epscairo" "epslatex" "fig" "gif" + "gpic" "hp2623A" "hp2648" "hpgl" "imagen" "jpeg" "latex" "lua" + "mf" "mif" "mp" "pcl5" "pdfcairo" "png" "pngcairo" "postscript" + "pslatex" "pstex" "pstricks" "qms" "regis" "svg" "tek40xx" + "tek410x" "texdraw" "tgif" "tikz" "tkcanvas" "tpic" "unknown" + "vttek" "wxt" "x11" "xlib" "xterm") + 'words) + "Gnuplot term types") + +(defvar gp-plot-types + (regexp-opt + '("lines" "points" "linespoints" "lp" "impulses" "dots" "steps" + "errorbars" "xerrorbars" "yerrorbars" "xyerrorbars" "boxes" + "boxerrorbars" "boxxyerrorbars" "candlesticks" "financebars" + "histeps" "vector") + 'words) + "Gnuplot plot styles") + +(defvar gp-commands + (regexp-opt + '("fit" "set" "unset" "do for" "if" "else" "while") + 'words) + "Gnuplot commands") + +(defvar gp-plot-commands + (regexp-opt + '("plot" "splot" "replot") + 'words) + "Gnuplot plot commands") + +(defvar gp-variables + (regexp-opt + '("pi" "NaN") + 'words) + "Gnuplot variables") + + +;; apply font lock commands +(defvar gnuplot-font-lock-keywords + `((,gp-commands . font-lock-constant-face) + (,gp-plot-commands . font-lock-keyword-face) + (,gp-math-functions . font-lock-function-name-face) + (,gp-other-functions . font-lock-function-name-face) + (,gp-reserved-modifiers . font-lock-type-face) + (,gp-other-keywords . font-lock-preprocessor-face) + (,gp-term-types . font-lock-reference-face) + (,gp-plot-types . font-lock-function-name-face) + (,gp-variables . font-lock-variable-name-face) + ("!" . font-lock-negation-char-face) + ("\\(\\<[a-z]+[a-z_0-9(),]*\\)[ \t]*=" . font-lock-variable-name-face) ; variable declaration + ("\$[0-9]+" . font-lock-string-face) ; columns + ("\\[\\([^]]+\\)\\]" 1 font-lock-string-face))) ; brackets + + + +;;; indentation +(defun gnuplot-find-indent-column () + "Find the column to indent to. + +Start with the value `back-to-indentation' gives for the previous +line. Next, check whether the previous line starts with a plot +command *and* ends with line continuation. If so, increment the +indent column by the size of the plot command." + (save-excursion + ;; start with the indentation of the previous line + (forward-line -1) + (back-to-indentation) + ;; check if there's a plot or fit command and a line + ;; continuation. if so, adjust the indentation. + ;; + ;; example: + ;; plot sin(x) w l,\ + ;; + ;; we want to indent under "sin", not "plot" + (let ((indent (current-column)) + (continuation-regexp ; matches a continued line + (concat "\\(" gnuplot-continued-commands-regexp "\\s-+" "\\)" + ".*" (regexp-quote "\\") "$"))) + (cond + ((looking-at continuation-regexp) + (let ((offset (length (match-string 1)))) + (+ indent offset))) + (t + indent))))) + +(defun gnuplot-last-line-p () + "Determine whether we're just after the last line of a +multi-line plot command. If so, we don't want to indent to the +previous line, but instead to the beginning of the command. See +comments for details. + +Returns nil if nothing needs to be done; otherwise return the +column to indent to." + (save-excursion + ;; check that the previous line does *not* end in a continuation, + ;; and that the line before it *does*. if so, we just ended a + ;; multi-line command. thus, we should not match indentation of + ;; the previous line (as above), but the indentation of the + ;; beginning of the command + ;; + ;; example: + ;; plot sin(x) w l,\ + ;; cos(x) w l,\ + ;; tan(x) + ;; + ;; we want to indent to under "plot," not "tan". + ;; + (end-of-line -1) ; go back *two* lines + (forward-char -1) + ;; this regexp is horrible. it means "a \, followed immediately + ;; by a newline, followed by some whitespace, followed by a single + ;; line which does not end in a slash." + (when (looking-at "\\\\\n\\s-+\\([^\n]+\\)[^\\\\\n]\n") + (when (re-search-backward gnuplot-continued-commands-regexp nil t) + (current-column))))) + +(defun gnuplot-indent-line () + "Indent the current line. + +See `gnuplot-find-indent-column' for details." + (interactive) + + (let ((indent + ; check last-line-p first! + (or (gnuplot-last-line-p) + (gnuplot-find-indent-column)))) + (save-excursion + (unless (= (current-indentation) indent) + (beginning-of-line) + (delete-horizontal-space) + (insert (make-string indent ? )))) + + (when (< (current-column) indent) + (back-to-indentation)))) + + + +;;; define a major mode +;;;###autoload +(define-derived-mode gnuplot-mode prog-mode ; how will pre emacs 24 react to this? + "Gnuplot" + "Major mode for editing gnuplot files" + :syntax-table gnuplot-mode-syntax-table + + ;; indentation + (set (make-local-variable 'indent-line-function) 'gnuplot-indent-line) + + ;; comment syntax for `newcomment.el' + (set (make-local-variable 'comment-start) "# ") + (set (make-local-variable 'comment-end) "") + (set (make-local-variable 'comment-start-skip) "#+\\s-*") + + ;; font lock + (set (make-local-variable 'font-lock-defaults) + '(gnuplot-font-lock-keywords)) + (setq show-trailing-whitespace t) + + ;; run user hooks + (run-mode-hooks 'gnuplot-mode-hook)) + +;;;###autoload +(dolist (pattern '("\\.gnuplot\\'" "\\.gp\\'")) + (add-to-list 'auto-mode-alist (cons pattern 'gnuplot-mode))) + + + +;;; functions to run gnuplot +(defun gnuplot-quit () + "Close the *gnuplot errors* buffer and restore the previous +window configuration." + (interactive) + (kill-buffer) + (when (get-register :gnuplot-errors) + (jump-to-register :gnuplot-errors))) + +(defun gnuplot-handle-exit-status (exit-status) + "Display output if gnuplot signals an error. Otherwise, clean +up our mess." + (cond + ((eq exit-status 0) + (kill-buffer "*gnuplot errors*") + (message "Running gnuplot... done.")) + (t + (window-configuration-to-register :gnuplot-errors) + (switch-to-buffer-other-window "*gnuplot errors*") + (compilation-mode) + (local-set-key (kbd "q") 'gnuplot-quit) + (message "Gnuplot encountered errors.")))) + +(defun gnuplot-compile-start (file) + "Set up the compilation buffer. + +Clears the buffer, prints some information, and sets local +variables which are used by `compilation-mode'." + (with-current-buffer (get-buffer-create "*gnuplot errors*") + (let ((inhibit-read-only t) + (command (concat gnuplot-program " " + gnuplot-flags " " + file))) + (erase-buffer) + (insert "-*- mode: compilation; default-directory: " + (prin1-to-string (abbreviate-file-name default-directory)) + " -*-\n\n" + command "\n\n") + (setq compile-command command)))) + +(defun gnuplot-compile-file (file) + "Runs gnuplot synchronously. + +Run gnuplot as `gnuplot-program', operating on FILE, with the +arguments stored in `gnuplot-flags'. Store the output in the +buffer *gnuplot errors*, and raise it if gnuplot returns an exit +code other than zero. Hitting 'q' inside the *gnuplot errors* +buffer kills the buffer and restores the previous window +configuration. + +The output in *gnuplot errors* should be parsable by +`compilation-mode', so commands like `next-error' and +`previous-error' should work. + +This uses `call-process', rather than a shell command, in an +attempt to be portable. Note that I pass FILE as an argument to +gnuplot, rather than as an input file. This ensures gnuplot is +run as 'gnuplot -persist FILE', rather than +'gnuplot -persist < FILE'. The latter doesn't produce useful +output for compilation-mode." + (interactive) + (message "Running gnuplot...") + (gnuplot-compile-start file) + (let ((exit-status (call-process gnuplot-program nil "*gnuplot errors*" + nil gnuplot-flags file))) + (gnuplot-handle-exit-status exit-status))) + +;;;###autoload +(defun gnuplot-compile () + "Runs gnuplot -persist as a synchronous process and passes the +current buffer to it. Buffer must be visiting a file for it to +work." + (interactive) + (if (or (buffer-modified-p) (eq (buffer-file-name) nil)) + (message "buffer isn't saved") + (gnuplot-compile-file (file-name-nondirectory (buffer-file-name))))) + +;;;###autoload +(defun gnuplot-run-region (start end) + "Send region to gnuplot, ensuring a final newline. Doesn't +require buffer to be visiting a file." + (interactive "r") + (let ((cmd-data + (buffer-substring-no-properties start end))) + (with-temp-buffer + (insert cmd-data "\n") + (message "Running gnuplot...") + (let* ((exit-status + (call-process-region + (point-min) (point-max) + gnuplot-program nil "*gnuplot errors*" nil gnuplot-flags))) + (gnuplot-handle-exit-status exit-status))))) + +;;;###autoload +(defun gnuplot-run-buffer () + "Send buffer to gnuplot, ensuring a final newline. Doesn't +require buffer to be visiting a file." + (interactive) + (gnuplot-run-region (point-min) (point-max))) + +(provide 'gnuplot-mode) + +;;; gnuplot-mode.el ends here diff --git a/lisp/highlight-indent-guides.el b/lisp/highlight-indent-guides.el new file mode 100644 index 00000000..1877eb91 --- /dev/null +++ b/lisp/highlight-indent-guides.el @@ -0,0 +1,1010 @@ +;;; highlight-indent-guides.el --- Minor mode to highlight indentation +;; +;; Copyright (c) 2015 DarthFennec +;; +;; Permission is hereby granted, free of charge, to any person obtaining a copy +;; of this software and associated documentation files (the "Software"), to deal +;; in the Software without restriction, including without limitation the rights +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;; copies of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;; +;; Author: DarthFennec +;; Version: 0.9.1 +;; Package-Version: 20200528.2128 +;; Package-Commit: a4f771418e4eed1f3f7879a43af28cf97747d41c +;; Package-Requires: ((emacs "24")) +;; URL: https://github.com/DarthFennec/highlight-indent-guides + +;;; Commentary: +;; This minor mode highlights indentation levels via font-lock. Indent widths +;; are dynamically discovered, which means this correctly highlights in any +;; mode, regardless of indent width, even in languages with non-uniform +;; indentation such as Haskell. This mode works properly around hard tabs and +;; mixed indentation, and it behaves well in large buffers. +;; +;; To install, put this file in your load-path, and do +;; M-x highlight-indent-guides-mode to enable it. To enable it automatically in +;; most programming modes, use the following: +;; +;; (add-hook 'prog-mode-hook 'highlight-indent-guides-mode) +;; +;; To set the display method, use: +;; +;; (setq highlight-indent-guides-method METHOD) +;; +;; Where METHOD is either 'fill, 'column, 'character, or 'bitmap. +;; +;; To change the character used for drawing guide lines with the 'character +;; method, use: +;; +;; (setq highlight-indent-guides-character ?ch) +;; +;; By default, this mode automatically inspects your theme and chooses +;; appropriate colors for highlighting. To tweak the subtlety of these colors, +;; use the following (all values are percentages): +;; +;; (setq highlight-indent-guides-auto-odd-face-perc 15) +;; (setq highlight-indent-guides-auto-even-face-perc 15) +;; (setq highlight-indent-guides-auto-character-face-perc 20) +;; +;; Or, to manually set the colors used for highlighting, use: +;; +;; (setq highlight-indent-guides-auto-enabled nil) +;; +;; (set-face-background 'highlight-indent-guides-odd-face "color") +;; (set-face-background 'highlight-indent-guides-even-face "color") +;; (set-face-foreground 'highlight-indent-guides-character-face "color") + +;;; Code: + +(require 'color) + +(defgroup highlight-indent-guides nil + "Indentation highlighting." + :group 'faces) + +(defface highlight-indent-guides-odd-face '((t nil)) + "Face to highlight odd indent levels." + :group 'highlight-indent-guides) + +(defface highlight-indent-guides-even-face '((t nil)) + "Face to highlight even indent levels." + :group 'highlight-indent-guides) + +(defface highlight-indent-guides-character-face '((t nil)) + "Face to highlight guide line characters and bitmaps." + :group 'highlight-indent-guides) + +(defface highlight-indent-guides-top-odd-face '((t nil)) + "Face to highlight odd indent levels." + :group 'highlight-indent-guides) + +(defface highlight-indent-guides-top-even-face '((t nil)) + "Face to highlight even indent levels." + :group 'highlight-indent-guides) + +(defface highlight-indent-guides-top-character-face '((t nil)) + "Face to highlight guide line characters and bitmaps." + :group 'highlight-indent-guides) + +(defface highlight-indent-guides-stack-odd-face '((t nil)) + "Face to highlight odd indent levels." + :group 'highlight-indent-guides) + +(defface highlight-indent-guides-stack-even-face '((t nil)) + "Face to highlight even indent levels." + :group 'highlight-indent-guides) + +(defface highlight-indent-guides-stack-character-face '((t nil)) + "Face to highlight guide line characters and bitmaps." + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-character ?\x2502 + "Character to use to display guide lines." + :type 'character + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-method 'fill + "Method to use when displaying indent guides. +This can be `fill', `column', `character', or `bitmap'." + :type '(choice (const fill) (const column) (const character) (const bitmap)) + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-responsive nil + "Whether responsive highlights should be used. +This allows different highlight colors to be used in response to the location of +the point. If this is nil, no responsive highlighting is used. If this is +`top', the indent level of the current line is colored distinctly. If this is +`stack', three colorations are used: one for the current indent level (as with +`top'), one for all parent levels of the current indent level, and one for all +other levels." + :type '(choice (const nil) (const top) (const stack)) + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-enabled t + "Whether to automatically calculate faces. +If this is enabled, highlight-indent-guides will use the current theme's +background color to automatically calculate reasonable indent guide colors." + :type 'boolean + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-suppress-auto-error nil + "Whether to suppress the error that sometimes prints when calculating faces. +When automatically calculating faces, sometimes there will be an error that +\"`default' face is not set properly\". If this flag is enabled, +highlight-indent-guides will not print this error. This can be helpful in +situations where faces are calculated correctly, but the error is printed +anyway, which can be annoying." + :type 'boolean + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-highlighter-function + 'highlight-indent-guides--highlighter-default + "Determine the correct face to use for a given indentation level. +Customizable function which applies faces to indentation. The function is +called once per indentation character, and takes three parameters: LEVEL is the +indentation level of the character, with 0 being the outermost level. +RESPONSIVE is either nil, `top', or `stack', depending on which responsive class +the character falls into. DISPLAY is the current display method setting, which +can be `fill', `column', or `character'. The return value is either the face to +apply to the guide character, or nil if the guide should not be displayed at +all. The results of this function are cached per indentation character, so the +function should consistently return the same output given the same input." + :type 'function + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-bitmap-function + 'highlight-indent-guides--bitmap-dots + "Determine the shape of the indent guide bitmap. +Customizable function which 'draws' the indent guide bitmap. The function is +called once per indentation character, and takes three parameters: WIDTH and +HEIGHT are the pixel width and height of the character, and CREP is the +character that should be used to represent a colored pixel. The return value is +a list of strings, with each string representing a row of pixels. The list +should be HEIGHT in size, and each string in the list should be WIDTH in size. +Each character represents a pixel, and should be CREP if the pixel is colored, +and ?0 if it isn't colored." + :type 'function + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-odd-face-perc 5 + "Color adjustment percentage for highlight-indent-guides-odd-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-even-face-perc 10 + "Color adjustment percentage for highlight-indent-guides-even-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-character-face-perc 10 + "Color adjustment percentage for highlight-indent-guides-character-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-top-odd-face-perc 25 + "Color adjustment percentage for highlight-indent-guides-odd-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-top-even-face-perc 30 + "Color adjustment percentage for highlight-indent-guides-even-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-top-character-face-perc 30 + "Color adjustment percentage for highlight-indent-guides-character-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-stack-odd-face-perc 15 + "Color adjustment percentage for highlight-indent-guides-odd-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-stack-even-face-perc 20 + "Color adjustment percentage for highlight-indent-guides-even-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-auto-stack-character-face-perc 20 + "Color adjustment percentage for highlight-indent-guides-character-face. +This is used to automatically calculate the indent guide faces from the +background color." + :type 'number + :group 'highlight-indent-guides) + +(defcustom highlight-indent-guides-delay 0.1 + "The number of seconds to wait for an idle state before redrawing. +This is only useful if `highlight-indent-guides-responsive' is not nil." + :type 'number + :group 'highlight-indent-guides) + +(defvar highlight-indent-guides--idle-timer nil + "The idle timer object for responsive mode.") + +(defvar highlight-indent-guides--line-cache '(nil nil nil) + "The line cache for responsive mode.") +(make-variable-buffer-local 'highlight-indent-guides--line-cache) + +(defun highlight-indent-guides--try-merge-ranges (&rest args) + "Given multiple character position ranges (ARGS), merge where possible. +When ranges are calculated separately, there is a possibility of overlap, which +can cause unnecessary redraws. This function merges overlapping ranges to +minimize redraws." + (let ((ranges (sort (delq nil args) (lambda (x y) (> (car x) (car y))))) + curr next results) + (unless (null ranges) + (setq curr (pop ranges)) + (while ranges + (setq next (pop ranges)) + (if (<= (car curr) (+ 2 (cdr next))) + (setq curr (cons (car next) (max (cdr curr) (cdr next)))) + (setq results (cons curr results)) + (setq curr next))) + (setq results (cons curr results)) + results))) + +(defun highlight-indent-guides--discover-ranges (sect1 sect2) + "Given two sections SECT1 and SECT2, discover the ranges where they differ. +Gives a list of two ranges that should be redrawn when the point moves between +SECT1 and SECT2. This is the shallowest indent level that is not shared." + (if (not (eq highlight-indent-guides-responsive 'stack)) + (list (car sect1) (car sect2)) + (let ((rsect1 (reverse sect1)) + (rsect2 (reverse sect2))) + (catch 'return + (while t + (if (and (cdr rsect1) (cdr rsect2) (eq (car rsect1) (car rsect2))) + (setq rsect1 (cdr rsect1) rsect2 (cdr rsect2)) + (throw 'return (list (car rsect1) (car rsect2))))))))) + +(defun highlight-indent-guides--update-line-cache () + "Update the line cache. +The line cache tracks the current line data to make it easy for the drawing +functions to quickly access the needed context data for responsive mode. This +function is called whenever the current line data changes." + (let ((higp 'highlight-indent-guides-prop)) + (save-excursion + (beginning-of-line) + (while (and (not (eobp)) + (or (let ((s (syntax-ppss))) (or (nth 3 s) (nth 4 s))) + (looking-at "[[:space:]]*$"))) + (forward-line)) + (back-to-indentation) + (unless (bolp) (nth 5 (get-text-property (1- (point)) higp)))))) + +(defun highlight-indent-guides--try-update-line-cache () + "Update the line cache, if necessary. +This function is called whenever the point moves in a way that might change the +line cache. It only updates the cache when absolutely necessary." + (when (and highlight-indent-guides-responsive + highlight-indent-guides-mode) + (let ((cached-pt (car highlight-indent-guides--line-cache)) + (cached-ln (nth 1 highlight-indent-guides--line-cache)) + (cached-dt (nth 2 highlight-indent-guides--line-cache)) + (pt (point)) + ln dt rng) + (catch 'nochange + (when (eq pt cached-pt) (throw 'nochange nil)) + (setcar highlight-indent-guides--line-cache pt) + (setq ln (line-number-at-pos)) + (when (eq ln cached-ln) (throw 'nochange nil)) + (setcar (cdr highlight-indent-guides--line-cache) ln) + (setq dt (highlight-indent-guides--update-line-cache)) + (when (equal dt cached-dt) (throw 'nochange nil)) + (setcar (cddr highlight-indent-guides--line-cache) dt) + (setq rng (highlight-indent-guides--discover-ranges dt cached-dt)) + (dolist (range (apply 'highlight-indent-guides--try-merge-ranges rng)) + (highlight-indent-guides--overdraw (car range) (cdr range))))))) + +(defun highlight-indent-guides--iscdr (sub sup) + "Calculate whether SUB is a cdr of SUP." + (if (null sub) t + (while (and sup (not (eq sub sup))) (setq sup (cdr sup))) + (eq sub sup))) + +(defun highlight-indent-guides--calc-guides (prev-guides) + "Calculate the indent guides for a line. +PREV-GUIDES are the previous line's indent guides, and INDENT is this line's +indent width." + (let ((indent (current-indentation)) + (guides (car prev-guides)) + (sections (cdr prev-guides)) + oldsections) + (while (and guides (< indent (car guides))) + (set-marker (cdar sections) (line-end-position 0)) + (setq oldsections sections) + (setq sections (cdr sections)) + (setq guides (cdr guides))) + (when (and (< 0 indent) (or (null guides) (> indent (car guides)))) + (if oldsections (setq sections oldsections) + (let* ((lbp (line-beginning-position)) + (begmark (copy-marker lbp)) (endmark (copy-marker lbp))) + (setq sections (cons (cons begmark endmark) sections)))) + (setq guides (cons indent guides))) + (cons guides sections))) + +(defun highlight-indent-guides--get-guides () + "Extract the indent guides from a line, by reading the text properties." + (save-excursion + (catch 'invalid + (let (prop face seg sect nface nseg nsect guides fst) + (while (looking-at "[[:space:]]") + (setq prop (get-text-property (point) 'highlight-indent-guides-prop)) + (setq nface (car prop) nseg (nth 1 prop) nsect (nth 5 prop)) + (setq fst (nth 2 prop)) + (unless (natnump nface) (throw 'invalid t)) + (unless (or seg nseg) + (when (and fst (eq face nface)) (throw 'invalid t)) + (when (not (or fst (eq face nface))) (throw 'invalid t))) + (unless (highlight-indent-guides--iscdr sect nsect) + (throw 'invalid t)) + (let ((l (- (length nsect) (length sect) (length nseg)))) + (when fst (setq l (1- l))) + (when nseg (setq l (1+ l))) + (when (not (zerop l)) (throw 'invalid t))) + (unless (and (eq face nface) (equal seg nseg)) + (let ((col (current-column))) + (when (and face (not (eq face nface))) + (setq guides (cons col guides))) + (dolist (segment nseg) + (setq guides (cons (+ segment col) guides)) + (setq nface (1+ nface)))) + (setq face nface seg nseg)) + (setq sect nsect) + (forward-char)) + (dolist (section sect) + (unless (and (eq (marker-buffer (car section)) (current-buffer)) + (eq (marker-buffer (cdr section)) (current-buffer)) + (<= (car section) (point) (cdr section))) + (throw 'invalid t))) + (let ((col (current-column))) + (when (< 0 col) (setq guides (cons col guides)))) + (cons guides sect))))) + +(defun highlight-indent-guides--get-prev-guides () + "Scan up the buffer to find a starting point to calculate guides from." + (let ((guides t)) + (while (and (nlistp guides) (let ((p (point))) + (or (/= -1 (forward-line -1)) + (not (goto-char p))))) + (unless (or (let ((s (syntax-ppss))) (or (nth 3 s) (nth 4 s))) + (looking-at "[[:space:]]*$")) + (setq guides (highlight-indent-guides--get-guides)))) + (if (listp guides) guides nil))) + +(defun highlight-indent-guides--guide-line (guides) + "Draw the indent guides specified by GUIDES on the current line." + (let ((guides (reverse (car guides))) + (sections (cdr guides)) + (column (current-column)) + (currpt (point)) + (starter t) + (face 0) currcol currface props oldprop newprop subsect) + (while guides + (setq props nil) + (setq currcol column) + (setq currface face) + (setq currpt (point)) + (forward-char) + (setq column (current-column)) + (while (and guides (< (car guides) column)) + (setq props (cons (- (car guides) currcol) props)) + (setq guides (cdr guides)) + (setq face (1+ face))) + (setq props (reverse props)) + (when (and props (zerop (car props))) + (setq props (cdr props)) + (setq currface (1+ currface)) + (setq starter t)) + (setq subsect (nthcdr (1- (length guides)) sections)) + (setq oldprop (get-text-property currpt 'highlight-indent-guides-prop)) + (setq newprop + (list currface props starter (- column currcol) nil subsect)) + (when (and oldprop + (eq (car newprop) (car oldprop)) + (equal (nth 1 newprop) (nth 1 oldprop)) + (eq (nth 2 newprop) (nth 2 oldprop)) + (eq (nth 3 newprop) (nth 3 oldprop))) + (setcar (nthcdr 4 newprop) (nth 4 oldprop))) + (when guides + (add-text-properties + currpt (1+ currpt) `(highlight-indent-guides-prop ,newprop))) + (setq starter nil)))) + +(defun highlight-indent-guides--replace-section (old search replace) + "Replace in a list OLD section prefixes SEARCH with REPLACE. +All lines in the same section should have the same (eq) section prefixes. If +the prefix changes on some lines, all other lines in the section need to be +updated to match." + (let* ((oldlen (length old)) + (replen (length replace)) + (minlen (min oldlen replen)) + (cparent (nthcdr (- oldlen minlen) (cons nil old))) + (cold (nthcdr (- oldlen minlen) old)) + (csearch (nthcdr (- replen minlen) search)) + (crepl (nthcdr (- replen minlen) replace))) + (while (and cold (not (eq cold csearch))) + (setq cparent (cdr cparent)) + (setq cold (cdr cold)) + (setq csearch (cdr csearch)) + (setq crepl (cdr crepl))) + (if (null cold) old + (setcdr cparent crepl) + (if (car cparent) old (cdr cparent))))) + +(defun highlight-indent-guides--guide-region (start end) + "Add or update indent guides in the buffer region from START to END." + (with-silent-modifications + (save-excursion + (goto-char start) + (beginning-of-line) + (let ((prop 'highlight-indent-guides-prop) + (guides (highlight-indent-guides--get-prev-guides)) + (eof (< 0 (forward-line))) + (startl (point)) (endl end) + chunk oldguides oldsect newsect lf le rng) + ;; for the given region, extract old guides and calculate new guides + (while (not (or eof (and (>= (point) endl) + (not (eq oldguides t)) + (equal (car guides) (car oldguides)) + (eq (cdr guides) (cdr oldguides))))) + (if (or (let ((s (syntax-ppss))) (or (nth 3 s) (nth 4 s))) + (looking-at "[[:space:]]*$")) + (setq chunk (cons (list (point)) chunk)) + (let ((tmpguides (cdr guides)) ends currend) + (while tmpguides + (when (car tmpguides) + (setq ends (cons (marker-position (cdar tmpguides)) ends))) + (setq tmpguides (cdr tmpguides))) + (setq guides (highlight-indent-guides--calc-guides guides)) + (setq endl (max endl (or (nth (length (cdr guides)) ends) 0)))) + (setq oldguides (highlight-indent-guides--get-guides)) + (setq chunk (cons (list (point) guides oldguides) chunk))) + (setq eof (< 0 (forward-line))) + ;; expand sections if necessary + (when (or eof (and (>= (point) endl) + (not (eq oldguides t)) + (equal (car guides) (car oldguides)))) + (let ((lep (line-end-position 0))) + (dolist (guide (cdr guides)) + (when (and (cdr guide) (> lep (cdr guide))) + (set-marker (cdr guide) lep))))) + ;; ensure chunk is flush with surrounding sections + (when (and (>= (point) endl) + (not (eq oldguides t)) + (equal (car guides) (car oldguides)) + (not (eq (cdr guides) (cdr oldguides)))) + (setq guides (cons (car guides) (cdr guides))) + (let ((ng (cdr guides)) (og (cdr oldguides)) (badguide t) + abovestart aboveend belowstart belowend above below) + (while (and og ng (nlistp badguide)) + (when (eq (cdr og) (cdr ng)) (setq badguide (cons og ng))) + (setq ng (cdr ng) og (cdr og))) + (setq abovestart (caar (cdr badguide)) aboveend startl) + (setq belowstart (point) belowend (cdar (car badguide))) + (setq above (- aboveend abovestart) below (- belowend belowstart)) + (if (>= (- belowstart abovestart) below) (setq endl belowend) + (if (>= 0 above) + (let ((ng (cdr guides)) (og (cdr oldguides))) + ;; transform existing lines in chunk to use new sections + (while (and og ng) + (set-marker (caar og) (caar ng)) + (setq ng (cdr ng) og (cdr og))) + (dolist (line chunk) + (when (cdr line) + (setcdr (nth 1 line) + (highlight-indent-guides--replace-section + (cdr (nth 1 line)) + (cdr guides) (cdr oldguides)))))) + (goto-char abovestart) + (setq guides (highlight-indent-guides--get-prev-guides)) + (setq eof (< 0 (forward-line))) + (setq startl (point) oldguides nil chunk nil)))))) + ;; rewrite text properties for all lines in chunk + (dolist (line chunk) + (goto-char (car line)) + (if (cdr line) + (setq lf (save-excursion (back-to-indentation) (point))) + (setq lf (car line))) + (setq le (line-end-position)) + (unless (and (null (get-text-property lf prop)) + (eq le (next-single-property-change lf prop nil le))) + (remove-text-properties lf le (list prop nil))) + (when (or (eq t (nth 2 line)) + (not (equal (car (nth 1 line)) (car (nth 2 line)))) + (not (eq (cdr (nth 1 line)) (cdr (nth 2 line))))) + (highlight-indent-guides--guide-line (nth 1 line)))) + ;; update the line cache if necessary + (when (car highlight-indent-guides--line-cache) + (goto-char (car highlight-indent-guides--line-cache)) + (setq oldsect (nth 2 highlight-indent-guides--line-cache)) + (setq newsect (highlight-indent-guides--update-line-cache)) + (setcar (cddr highlight-indent-guides--line-cache) newsect)) + ;; refontify updated regions + (if (equal oldsect newsect) + (font-lock-fontify-region startl endl) + (setq rng (highlight-indent-guides--discover-ranges oldsect newsect)) + (dolist (range (highlight-indent-guides--try-merge-ranges + (cons startl endl) (car rng) (cadr rng))) + (font-lock-fontify-region (car range) (cdr range)))))))) + +(defun highlight-indent-guides--unguide-region (start end) + "Remove all indent guides in the buffer region from START to END." + (with-silent-modifications + (remove-text-properties start end '(highlight-indent-guides-prop nil)))) + +(defun highlight-indent-guides--fill-keyword-matcher (limit) + "Search for indent guides between the point and LIMIT. +Find the next character that is part of any indentation. This is meant to be +used as a `font-lock-keywords' matcher." + (let* ((pos (point)) + (prop 'highlight-indent-guides-prop) + (face (car (get-text-property pos prop)))) + (while (and (not (natnump face)) (< pos limit)) + (setq pos (next-single-property-change pos prop nil limit)) + (setq face (car (get-text-property pos prop)))) + (when (< pos limit) + (set-match-data (list (copy-marker pos) (copy-marker (1+ pos)))) + (goto-char (1+ pos))))) + +(defun highlight-indent-guides--column-keyword-matcher (limit) + "Search for indent guides between the point and LIMIT. +Find the next character that contains the first column of an indentation level. +This is meant to be used as a `font-lock-keywords' matcher." + (let* ((pos (point)) + (prop 'highlight-indent-guides-prop) + (propval (get-text-property pos prop))) + (while (and (not (and (natnump (car propval)) + (or (nth 2 propval) (nth 1 propval)))) (< pos limit)) + (setq pos (1+ pos)) + (setq propval (get-text-property pos prop)) + (while (and (< pos limit) (not (natnump (car propval)))) + (setq pos (next-single-property-change pos prop nil limit)) + (setq propval (get-text-property pos prop)))) + (when (< pos limit) + (set-match-data (list (copy-marker pos) (copy-marker (1+ pos)))) + (goto-char (1+ pos))))) + +(defun highlight-indent-guides--highlighter-default (level responsive display) + "Determine the correct face to use for a given indentation level. +Uses the LEVEL, RESPONSIVE context, and DISPLAY method to decide on a correct +face for any given indentation. This is the default implementation of +`highlight-indent-guides-highlighter-function'." + (cond ((null responsive) + (cond ((or (eq display 'character) (eq display 'bitmap)) + 'highlight-indent-guides-character-face) + ((zerop (mod level 2)) + 'highlight-indent-guides-even-face) + (t 'highlight-indent-guides-odd-face))) + ((eq responsive 'top) + (cond ((or (eq display 'character) (eq display 'bitmap)) + 'highlight-indent-guides-top-character-face) + ((zerop (mod level 2)) + 'highlight-indent-guides-top-even-face) + (t 'highlight-indent-guides-top-odd-face))) + ((eq responsive 'stack) + (cond ((or (eq display 'character) (eq display 'bitmap)) + 'highlight-indent-guides-stack-character-face) + ((zerop (mod level 2)) + 'highlight-indent-guides-stack-even-face) + (t 'highlight-indent-guides-stack-odd-face))) + (t nil))) + +(defmacro highlight-indent-guides--cache-highlight (type prop hlkey &rest body) + "Memoize the highlighter results in the character's properties. +If a cached result with the right TYPE (`fill', `column', or `character') is +contained in PROP with a responsive context matching HLKEY, return that result +instead of calculating a new one. Otherwise, calculate a new result by running +BODY, cache it in PROP, and return it." + `(let ((cache (nth 4 ,prop)) plist result) + (if (and (eq ,type (car cache)) + (setq result (lax-plist-get (cdr cache) ,hlkey))) + result + (setq result (progn ,@body)) + (setq plist (lax-plist-put (cdr cache) ,hlkey result)) + (setcar (nthcdr 4 ,prop) (cons ,type plist)) + result))) + +(defun highlight-indent-guides--should-highlight (prop) + "Determine how a guide should be highlighted in responsive mode. +The guide's data is given as PROP." + (if (null highlight-indent-guides-responsive) nil + (let ((currseg (nth 5 prop)) + (segct (max 1 (+ (length (nth 1 prop)) (if (nth 2 prop) 1 0)))) + (cacheseg (nth 2 highlight-indent-guides--line-cache)) + (isstack (eq highlight-indent-guides-responsive 'stack)) + result) + (dotimes (segnum segct result) + (cond ((equal cacheseg currseg) + (setq result (cons 'top result))) + ((and isstack (highlight-indent-guides--iscdr currseg cacheseg)) + (setq result (cons 'stack result))) + (t (setq result (cons nil result)))) + (setq currseg (cdr currseg)))))) + +(defun highlight-indent-guides--fill-highlighter () + "Apply highlighting to the indentation. +Return highlighting information for the matched character. Highlights all +indentation characters in alternating colors. This is meant to be used as a +`font-lock-keywords' face definition." + (let* ((prop (get-text-property (match-beginning 0) 'highlight-indent-guides-prop)) + (shouldhl (highlight-indent-guides--should-highlight prop))) + (highlight-indent-guides--cache-highlight + 'fill prop shouldhl + (let ((highlighter highlight-indent-guides-highlighter-function) + (facep (car prop)) (segs (nth 1 prop)) (cwidth (nth 3 prop)) + (pseg 0) face showstr) + (if (null segs) (funcall highlighter facep (car shouldhl) 'fill) + (setq showstr (make-string cwidth ?\s)) + (dolist (seg segs) + (setq face (funcall highlighter facep (pop shouldhl) 'fill)) + (when face (add-text-properties pseg seg `(face ,face) showstr)) + (setq pseg seg) + (setq facep (1+ facep))) + (setq face (funcall highlighter facep (pop shouldhl) 'fill)) + (when face (add-text-properties pseg cwidth `(face ,face) showstr)) + `(face nil display ,showstr)))))) + +(defun highlight-indent-guides--column-highlighter () + "Apply highlighting to the indentation. +Return highlighting information for the matched character. Highlights the +first column of each indentation level in alternating colors. This is meant to +be used as a `font-lock-keywords' face definition." + (let* ((prop (get-text-property (match-beginning 0) 'highlight-indent-guides-prop)) + (shouldhl (highlight-indent-guides--should-highlight prop))) + (highlight-indent-guides--cache-highlight + 'column prop shouldhl + (let ((highlighter highlight-indent-guides-highlighter-function) + (facep (car prop)) (segs (nth 1 prop)) + (starter (nth 2 prop)) (cwidth (nth 3 prop)) + face showstr) + (if (and (null segs) (eq cwidth 1)) + (funcall highlighter facep (car shouldhl) 'column) + (setq showstr (make-string cwidth ?\s)) + (when starter + (setq face (funcall highlighter facep (pop shouldhl) 'column)) + (when face (add-text-properties 0 1 `(face ,face) showstr))) + (dolist (seg segs) + (setq face (funcall highlighter facep (pop shouldhl) 'column)) + (when face (add-text-properties seg (1+ seg) `(face ,face) showstr)) + (setq facep (1+ facep))) + `(face nil display ,showstr)))))) + +(defun highlight-indent-guides--character-highlighter () + "Apply highlighting to the indentation. +Return highlighting information for the matched character. Displays a character +in place of the first column of each indentation level. This is meant to be +used as a `font-lock-keywords' face definition." + (let* ((prop (get-text-property (match-beginning 0) 'highlight-indent-guides-prop)) + (shouldhl (highlight-indent-guides--should-highlight prop))) + (highlight-indent-guides--cache-highlight + 'character prop shouldhl + (let ((highlighter highlight-indent-guides-highlighter-function) + (facep (car prop)) (segs (nth 1 prop)) + (starter (nth 2 prop)) (cwidth (nth 3 prop)) + face showstr) + (if (and (null segs) (eq cwidth 1)) + (progn + (setq face (funcall highlighter facep (car shouldhl) 'character)) + (when face + (setq showstr + (char-to-string highlight-indent-guides-character))) + `(face ,face display ,showstr)) + (setq showstr (make-string cwidth ?\s)) + (when starter + (setq face (funcall highlighter facep (pop shouldhl) 'character)) + (when face + (aset showstr 0 highlight-indent-guides-character) + (add-text-properties 0 1 `(face ,face) showstr))) + (dolist (seg segs) + (setq face (funcall highlighter facep (pop shouldhl) 'character)) + (when face + (aset showstr seg highlight-indent-guides-character) + (add-text-properties seg (1+ seg) `(face ,face) showstr)) + (setq facep (1+ facep))) + `(face nil display ,showstr)))))) + +(defun highlight-indent-guides--bitmap-highlighter () + "Apply highlighting to the indentation. +Return highlighting information for the matched character. Displays a bitmap in +place of the first column of each indentation level. This is meant to be used +as a `font-lock-keywords' face definition." + (let* ((prop (get-text-property (match-beginning 0) 'highlight-indent-guides-prop)) + (shouldhl (highlight-indent-guides--should-highlight prop))) + (highlight-indent-guides--cache-highlight + 'bitmap prop shouldhl + (let ((highlighter highlight-indent-guides-highlighter-function) + (facep (car prop)) (segs (nth 1 prop)) + (starter (nth 2 prop)) (cwidth (nth 3 prop)) + face facelist showbmp) + (if (and (null segs) (eq cwidth 1)) + (progn + (setq face (funcall highlighter facep (car shouldhl) 'bitmap)) + (when face + (setq showbmp (highlight-indent-guides--draw-bitmap + (funcall + highlight-indent-guides-bitmap-function + (default-font-width) (default-font-height) ?1) + (list (cons "1" (face-foreground face)))))) + `(face nil display ,showbmp)) + (setq facelist (make-list cwidth nil)) + (when starter + (setq face (funcall highlighter facep (pop shouldhl) 'bitmap)) + (when face (setcar facelist (face-foreground face)))) + (dolist (seg segs) + (setq face (funcall highlighter facep (pop shouldhl) 'bitmap)) + (when face (setcar (nthcdr seg facelist) (face-foreground face))) + (setq facep (1+ facep))) + (setq showbmp (highlight-indent-guides--concat-bitmap + (default-font-width) (default-font-height) facelist)) + `(face nil display ,showbmp)))))) + +(defun highlight-indent-guides--concat-bitmap (width height facelist) + "Build a concatenated XPM image based on FACELIST. +FACELIST represents characters in the guide block (nil for no guide, and a color +string for a guide with that color). WIDTH and HEIGHT are the width and height +of each character in the block." + (let ((res (make-list height "")) + (crep 0) + colors nextbmp) + (while (not (null facelist)) + (if (null (car facelist)) + (let ((zlen 0)) + (while (and (not (null facelist)) (null (car facelist))) + (setq zlen (+ zlen width)) + (setq facelist (cdr facelist))) + (dotimes (i height) + (setcar (nthcdr i res) (concat (nth i res) (make-string zlen ?0))))) + (setq crep (1+ crep)) + (setq nextbmp (funcall + highlight-indent-guides-bitmap-function + width height (string-to-char (number-to-string crep)))) + (setq colors (cons (cons (number-to-string crep) (car facelist)) colors)) + (setq facelist (cdr facelist)) + (dotimes (i height) + (setcar (nthcdr i res) (concat (nth i res) (nth i nextbmp)))))) + (highlight-indent-guides--draw-bitmap res colors))) + +(defun highlight-indent-guides--draw-bitmap (lines colorset) + "Using pixel data LINES and color data COLORSET, build an XPM image." + (let* ((width (length (car lines))) + (height (length lines)) + (start "/* XPM */\nstatic char *guide[] = {") + (size (concat "\"" (number-to-string width) " " + (number-to-string height) " " + (number-to-string (1+ (length colorset))) " 1\",")) + (colors "\"0 c None\",") + (pixels (concat "\"" (mapconcat 'identity lines "\",\"") "\"")) + (end "};") + data csym) + (dolist (color colorset) + (setq colors (concat colors "\"" (car color) " c color" (car color) "\",")) + (setq csym (cons (cons (concat "color" (car color)) (cdr color)) csym))) + (setq data (concat start size colors pixels end)) + `(image :type xpm :data ,data :mask heuristic :ascent center + :color-symbols ,csym))) + +(defun highlight-indent-guides--bitmap-line (width height crep) + "Defines a solid guide line, two pixels wide." + (let* ((left (/ (- width 2) 2)) + (right (- width left 2)) + (row (concat (make-string left ?0) (make-string 2 crep) (make-string right ?0))) + rows) + (dotimes (i height rows) + (setq rows (cons row rows))))) + +(defun highlight-indent-guides--bitmap-dots (width height crep) + "Defines a dotted guide line, with 2x2 pixel dots, and four dots per row." + (let* ((left (/ (- width 2) 2)) + (right (- width left 2)) + (space (/ height 4)) + (space1 (/ (- space 2) 2)) + (row1 (concat (make-string left ?0) (make-string 2 crep) (make-string right ?0))) + (row2 (make-string width ?0)) + rows) + (dotimes (i height rows) + (if (let ((x (mod (- i space1) space))) (or (eq x 0) (eq x 1))) + (setq rows (cons row1 rows)) + (setq rows (cons row2 rows)))))) + +(defun highlight-indent-guides--overdraw (start end) + "Overdraw the guides in the region from START to END. +This function is like `font-lock-fontify-region' or `font-lock-ensure', except +it only draws indent guides. This function is called to update the display +whenever the active indent level changes, as long as responsive guides are +enabled. This function is used because it avoids doing extra work like clearing +existing fontification, redrawing syntax and other keywords, or calling jit-lock +recursively." + (with-silent-modifications + (save-excursion + (save-restriction + (let ((matcher + (pcase highlight-indent-guides-method + (`fill 'highlight-indent-guides--fill-keyword-matcher) + (`column 'highlight-indent-guides--column-keyword-matcher) + (`character 'highlight-indent-guides--column-keyword-matcher) + (`bitmap 'highlight-indent-guides--column-keyword-matcher))) + (highlight + (pcase highlight-indent-guides-method + (`fill 'highlight-indent-guides--fill-highlighter) + (`column 'highlight-indent-guides--column-highlighter) + (`character 'highlight-indent-guides--character-highlighter) + (`bitmap 'highlight-indent-guides--bitmap-highlighter))) + (inhibit-point-motion-hooks t)) + (unless font-lock-dont-widen (widen)) + (goto-char start) + (while (and (< (point) end) (funcall matcher end)) + (unless (> (point) (match-beginning 0)) (forward-char 1)) + (font-lock-apply-highlight (list 0 (list highlight) t)))))))) + +;;;###autoload +(defun highlight-indent-guides-auto-set-faces () + "Automatically calculate indent guide faces. +If this feature is enabled, calculate reasonable values for the indent guide +colors based on the current theme's colorscheme, and set them appropriately. +This runs whenever a theme is loaded, but it can also be run interactively." + (interactive) + (when highlight-indent-guides-auto-enabled + (let* ((bk (face-background 'default nil 'default)) + (fg (color-name-to-rgb (face-foreground 'default nil 'default))) + (bg (color-name-to-rgb bk)) + (oddf 'highlight-indent-guides-odd-face) + (evenf 'highlight-indent-guides-even-face) + (charf 'highlight-indent-guides-character-face) + (toddf 'highlight-indent-guides-top-odd-face) + (tevenf 'highlight-indent-guides-top-even-face) + (tcharf 'highlight-indent-guides-top-character-face) + (soddf 'highlight-indent-guides-stack-odd-face) + (sevenf 'highlight-indent-guides-stack-even-face) + (scharf 'highlight-indent-guides-stack-character-face) + (oddp highlight-indent-guides-auto-odd-face-perc) + (evenp highlight-indent-guides-auto-even-face-perc) + (charp highlight-indent-guides-auto-character-face-perc) + (toddp highlight-indent-guides-auto-top-odd-face-perc) + (tevenp highlight-indent-guides-auto-top-even-face-perc) + (tcharp highlight-indent-guides-auto-top-character-face-perc) + (soddp highlight-indent-guides-auto-stack-odd-face-perc) + (sevenp highlight-indent-guides-auto-stack-even-face-perc) + (scharp highlight-indent-guides-auto-stack-character-face-perc) + mod fl bl) + (if (not (and fg bg)) + (unless highlight-indent-guides-suppress-auto-error + (message "Error: %s: %s" + "highlight-indent-guides cannot auto set faces" + "`default' face is not set properly")) + (setq fl (nth 2 (apply 'color-rgb-to-hsl fg))) + (setq bl (nth 2 (apply 'color-rgb-to-hsl bg))) + (setq mod (cond ((< fl bl) -1) ((> fl bl) 1) ((< 0.5 bl) -1) (t 1))) + (set-face-background oddf (color-lighten-name bk (* mod oddp))) + (set-face-background evenf (color-lighten-name bk (* mod evenp))) + (set-face-foreground charf (color-lighten-name bk (* mod charp))) + (set-face-background toddf (color-lighten-name bk (* mod toddp))) + (set-face-background tevenf (color-lighten-name bk (* mod tevenp))) + (set-face-foreground tcharf (color-lighten-name bk (* mod tcharp))) + (set-face-background soddf (color-lighten-name bk (* mod soddp))) + (set-face-background sevenf (color-lighten-name bk (* mod sevenp))) + (set-face-foreground scharf (color-lighten-name bk (* mod scharp))))))) + +(defadvice load-theme (after highlight-indent-guides-auto-set-faces disable) + "Automatically calculate indent guide faces. +If this feature is enabled, calculate reasonable values for the indent guide +colors based on the current theme's colorscheme, and set them appropriately. +This runs whenever a theme is loaded." + (highlight-indent-guides-auto-set-faces)) + +(defadvice disable-theme (after highlight-indent-guides-auto-set-faces disable) + "Automatically calculate indent guide faces. +If this feature is enabled, calculate reasonable values for the indent guide +colors based on the current theme's colorscheme, and set them appropriately. +This runs whenever a theme is disabled." + (highlight-indent-guides-auto-set-faces)) + +(defun highlight-indent-guides--auto-set-faces-with-frame (frame) + "Run `highlight-indent-guides-auto-set-faces' in frame FRAME. +This function is designed to run from the `after-make-frame-functions' hook." + (with-selected-frame frame + (highlight-indent-guides-auto-set-faces))) + +(make-variable-buffer-local 'font-lock-extra-managed-props) +(make-variable-buffer-local 'text-property-default-nonsticky) + +;;;###autoload +(define-minor-mode highlight-indent-guides-mode + "Display indent guides in a buffer." + nil " h-i-g" nil + (let ((fill-method-keywords + '((highlight-indent-guides--fill-keyword-matcher + 0 (highlight-indent-guides--fill-highlighter) t))) + (column-method-keywords + '((highlight-indent-guides--column-keyword-matcher + 0 (highlight-indent-guides--column-highlighter) t))) + (character-method-keywords + '((highlight-indent-guides--column-keyword-matcher + 0 (highlight-indent-guides--character-highlighter) t))) + (bitmap-method-keywords + '((highlight-indent-guides--column-keyword-matcher + 0 (highlight-indent-guides--bitmap-highlighter) t)))) + (when highlight-indent-guides--idle-timer + (cancel-timer highlight-indent-guides--idle-timer) + (setq highlight-indent-guides--idle-timer nil)) + (if highlight-indent-guides-mode + (progn + ;; set highlight-indent-guides--line-cache so it becomes buffer-local + ;; After this, we can destructively modify it just fine, as every + ;; buffer has a unique object. + (setq highlight-indent-guides--line-cache (list nil nil nil)) + (unless (daemonp) (highlight-indent-guides-auto-set-faces)) + (add-to-list 'after-make-frame-functions + 'highlight-indent-guides--auto-set-faces-with-frame) + (ad-enable-advice 'load-theme 'after + 'highlight-indent-guides-auto-set-faces) + (ad-activate 'load-theme) + (ad-enable-advice 'disable-theme 'after + 'highlight-indent-guides-auto-set-faces) + (ad-activate 'disable-theme) + (add-to-list 'font-lock-extra-managed-props 'display) + (add-to-list 'text-property-default-nonsticky + (cons 'highlight-indent-guides-prop t)) + (setq highlight-indent-guides--idle-timer + (run-with-idle-timer + highlight-indent-guides-delay t + 'highlight-indent-guides--try-update-line-cache)) + (font-lock-add-keywords + nil + (pcase highlight-indent-guides-method + (`fill fill-method-keywords) + (`column column-method-keywords) + (`character character-method-keywords) + (`bitmap bitmap-method-keywords)) + t) + (jit-lock-register 'highlight-indent-guides--guide-region)) + (setq after-make-frame-functions + (delete 'highlight-indent-guides--auto-set-faces-with-frame + after-make-frame-functions)) + (ad-disable-advice 'load-theme 'after + 'highlight-indent-guides-auto-set-faces) + (ad-activate 'load-theme) + (ad-disable-advice 'disable-theme 'after + 'highlight-indent-guides-auto-set-faces) + (ad-activate 'disable-theme) + (font-lock-remove-keywords nil fill-method-keywords) + (font-lock-remove-keywords nil column-method-keywords) + (font-lock-remove-keywords nil character-method-keywords) + (jit-lock-unregister 'highlight-indent-guides--guide-region) + (highlight-indent-guides--unguide-region (point-min) (point-max)) + (if (fboundp 'font-lock-flush) (font-lock-flush) + (font-lock-fontify-buffer))))) + +(provide 'highlight-indent-guides) + +;;; highlight-indent-guides.el ends here diff --git a/lisp/ht.el b/lisp/ht.el new file mode 100644 index 00000000..f3627718 --- /dev/null +++ b/lisp/ht.el @@ -0,0 +1,310 @@ +;;; ht.el --- The missing hash table library for Emacs -*- lexical-binding: t; -*- + +;; Copyright (C) 2013 Wilfred Hughes + +;; Author: Wilfred Hughes +;; Version: 2.3 +;; Package-Version: 20200217.2331 +;; Package-Commit: fff8c43f0e03d5b98deb9f988522b839ce2ca253 +;; Keywords: hash table, hash map, hash +;; Package-Requires: ((dash "2.12.0")) + +;; 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 . + +;;; Commentary: + +;; The missing hash table library for Emacs. +;; +;; See documentation at https://github.com/Wilfred/ht.el + +;;; Code: + +(require 'dash) +(require 'gv) + +(defmacro ht (&rest pairs) + "Create a hash table with the key-value pairs given. +Keys are compared with `equal'. + +\(fn (KEY-1 VALUE-1) (KEY-2 VALUE-2) ...)" + (let* ((table-symbol (make-symbol "ht-temp")) + (assignments + (mapcar + (lambda (pair) `(ht-set! ,table-symbol ,@pair)) + pairs))) + `(let ((,table-symbol (ht-create))) + ,@assignments + ,table-symbol))) + +(defsubst ht-set! (table key value) + "Associate KEY in TABLE with VALUE." + (puthash key value table) + nil) + +(defalias 'ht-set 'ht-set!) + +(defsubst ht-create (&optional test) + "Create an empty hash table. + +TEST indicates the function used to compare the hash +keys. Default is `equal'. It can be `eq', `eql', `equal' or a +user-supplied test created via `define-hash-table-test'." + (make-hash-table :test (or test 'equal))) + +(defun ht<-alist (alist &optional test) + "Create a hash table with initial values according to ALIST. + +TEST indicates the function used to compare the hash +keys. Default is `equal'. It can be `eq', `eql', `equal' or a +user-supplied test created via `define-hash-table-test'." + (let ((h (ht-create test))) + ;; the first key-value pair in an alist gets precedence, so we + ;; start from the end of the list: + (dolist (pair (reverse alist) h) + (let ((key (car pair)) + (value (cdr pair))) + (ht-set! h key value))))) + +(defalias 'ht-from-alist 'ht<-alist) + +(defun ht<-plist (plist &optional test) + "Create a hash table with initial values according to PLIST. + +TEST indicates the function used to compare the hash +keys. Default is `equal'. It can be `eq', `eql', `equal' or a +user-supplied test created via `define-hash-table-test'." + (let ((h (ht-create test))) + (dolist (pair (nreverse (-partition 2 plist)) h) + (let ((key (car pair)) + (value (cadr pair))) + (ht-set! h key value))))) + +(defalias 'ht-from-plist 'ht<-plist) + +(defsubst ht-get (table key &optional default) + "Look up KEY in TABLE, and return the matching value. +If KEY isn't present, return DEFAULT (nil if not specified)." + (gethash key table default)) + +;; Don't use `ht-set!' here, gv setter was assumed to return the value +;; to be set. +(gv-define-setter ht-get (value table key) `(puthash ,key ,value ,table)) + +(defun ht-get* (table &rest keys) + "Look up KEYS in nested hash tables, starting with TABLE. +The lookup for each key should return another hash table, except +for the final key, which may return any value." + (while keys + (setf table (ht-get table (pop keys)))) + table) + +(put 'ht-get* 'compiler-macro + (lambda (_ table &rest keys) + (--reduce-from `(ht-get ,acc ,it) table keys))) + +(defun ht-update! (table from-table) + "Update TABLE according to every key-value pair in FROM-TABLE." + (maphash + (lambda (key value) (puthash key value table)) + from-table) + nil) + +(defalias 'ht-update 'ht-update!) + +(defun ht-merge (&rest tables) + "Crete a new tables that includes all the key-value pairs from TABLES. +If multiple have tables have the same key, the value in the last +table is used." + (let ((merged (ht-create))) + (mapc (lambda (table) (ht-update! merged table)) tables) + merged)) + +(defsubst ht-remove! (table key) + "Remove KEY from TABLE." + (remhash key table)) + +(defalias 'ht-remove 'ht-remove!) + +(defsubst ht-clear! (table) + "Remove all keys from TABLE." + (clrhash table) + nil) + +(defalias 'ht-clear 'ht-clear!) + +(defun ht-map (function table) + "Apply FUNCTION to each key-value pair of TABLE, and make a list of the results. +FUNCTION is called with two arguments, KEY and VALUE." + (let (results) + (maphash + (lambda (key value) + (push (funcall function key value) results)) + table) + results)) + +(defmacro ht-amap (form table) + "Anaphoric version of `ht-map'. +For every key-value pair in TABLE, evaluate FORM with the +variables KEY and VALUE bound. If you don't use both of +these variables, then use `ht-map' to avoid warnings." + `(ht-map (lambda (key value) ,form) ,table)) + +(defun ht-keys (table) + "Return a list of all the keys in TABLE." + (ht-map (lambda (key _value) key) table)) + +(defun ht-values (table) + "Return a list of all the values in TABLE." + (ht-map (lambda (_key value) value) table)) + +(defun ht-items (table) + "Return a list of two-element lists '(key value) from TABLE." + (ht-amap (list key value) table)) + +(defalias 'ht-each 'maphash + "Apply FUNCTION to each key-value pair of TABLE. +Returns nil, used for side-effects only.") + +(defmacro ht-aeach (form table) + "Anaphoric version of `ht-each'. +For every key-value pair in TABLE, evaluate FORM with the +variables key and value bound." + `(ht-each (lambda (key value) ,form) ,table)) + +(defun ht-select-keys (table keys) + "Return a copy of TABLE with only the specified KEYS." + (let (result) + (setq result (make-hash-table :test (hash-table-test table))) + (dolist (key keys result) + (if (not (equal (gethash key table 'key-not-found) 'key-not-found)) + (puthash key (gethash key table) result))))) + +(defun ht->plist (table) + "Return a flat list '(key1 value1 key2 value2...) from TABLE. + +Note that hash tables are unordered, so this cannot be an exact +inverse of `ht<-plist'. The following is not guaranteed: + +\(let ((data '(a b c d))) + (equalp data + (ht->plist (ht<-plist data))))" + (apply 'append (ht-items table))) + +(defalias 'ht-to-plist 'ht->plist) + +(defsubst ht-copy (table) + "Return a shallow copy of TABLE (keys and values are shared)." + (copy-hash-table table)) + +(defun ht->alist (table) + "Return a list of two-element lists '(key . value) from TABLE. + +Note that hash tables are unordered, so this cannot be an exact +inverse of `ht<-alist'. The following is not guaranteed: + +\(let ((data '((a . b) (c . d)))) + (equalp data + (ht->alist (ht<-alist data))))" + (ht-amap (cons key value) table)) + +(defalias 'ht-to-alist 'ht->alist) + +(defalias 'ht? 'hash-table-p) + +(defalias 'ht-p 'hash-table-p) + +(defun ht-contains? (table key) + "Return 't if TABLE contains KEY." + (let ((not-found-symbol (make-symbol "ht--not-found"))) + (not (eq (ht-get table key not-found-symbol) not-found-symbol)))) + +(defalias 'ht-contains-p 'ht-contains?) + +(defsubst ht-size (table) + "Return the actual number of entries in TABLE." + (hash-table-count table)) + +(defsubst ht-empty? (table) + "Return true if the actual number of entries in TABLE is zero." + (zerop (ht-size table))) + +(defalias 'ht-empty-p 'ht-empty?) + +(defun ht-select (function table) + "Return a hash table containing all entries in TABLE for which +FUNCTION returns a truthy value. + +FUNCTION is called with two arguments, KEY and VALUE." + (let ((results (ht-create))) + (ht-each + (lambda (key value) + (when (funcall function key value) + (ht-set! results key value))) + table) + results)) + +(defun ht-reject (function table) + "Return a hash table containing all entries in TABLE for which +FUNCTION returns a falsy value. + +FUNCTION is called with two arguments, KEY and VALUE." + (let ((results (ht-create))) + (ht-each + (lambda (key value) + (unless (funcall function key value) + (ht-set! results key value))) + table) + results)) + +(defun ht-reject! (function table) + "Delete entries from TABLE for which FUNCTION returns a falsy value. + +FUNCTION is called with two arguments, KEY and VALUE." + (ht-each + (lambda (key value) + (when (funcall function key value) + (remhash key table))) + table) + nil) + +(defalias 'ht-delete-if 'ht-reject!) + +(defun ht-find (function table) + "Return (key, value) from TABLE for which FUNCTION returns a truthy value. +Return nil otherwise. + +FUNCTION is called with two arguments, KEY and VALUE." + (catch 'break + (ht-each + (lambda (key value) + (when (funcall function key value) + (throw 'break (list key value)))) + table))) + +(defun ht-equal? (table1 table2) + "Return t if TABLE1 and TABLE2 have the same keys and values. +Does not compare equality predicates." + (let ((keys1 (ht-keys table1)) + (keys2 (ht-keys table2)) + (sentinel (make-symbol "ht-sentinel"))) + (and (equal (length keys1) (length keys2)) + (--all? + (equal (ht-get table1 it) + (ht-get table2 it sentinel)) + keys1)))) + +(defalias 'ht-equal-p 'ht-equal?) + +(provide 'ht) +;;; ht.el ends here diff --git a/lisp/htmlize.el b/lisp/htmlize.el new file mode 100644 index 00000000..3b23af35 --- /dev/null +++ b/lisp/htmlize.el @@ -0,0 +1,1884 @@ +;;; htmlize.el --- Convert buffer text and decorations to HTML. -*- lexical-binding: t -*- + +;; Copyright (C) 1997-2003,2005,2006,2009,2011,2012,2014,2017,2018 Hrvoje Niksic + +;; Author: Hrvoje Niksic +;; Homepage: https://github.com/hniksic/emacs-htmlize +;; Keywords: hypermedia, extensions +;; Package-Version: 20191111.2130 +;; Package-Commit: 86f22f211e9230857197c42a9823d3f05381deed +;; Version: 1.56 + +;; 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 2, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package converts the buffer text and the associated +;; decorations to HTML. Mail to to discuss +;; features and additions. All suggestions are more than welcome. + +;; To use it, just switch to the buffer you want HTML-ized and type +;; `M-x htmlize-buffer'. You will be switched to a new buffer that +;; contains the resulting HTML code. You can edit and inspect this +;; buffer, or you can just save it with C-x C-w. `M-x htmlize-file' +;; will find a file, fontify it, and save the HTML version in +;; FILE.html, without any additional intervention. `M-x +;; htmlize-many-files' allows you to htmlize any number of files in +;; the same manner. `M-x htmlize-many-files-dired' does the same for +;; files marked in a dired buffer. + +;; htmlize supports three types of HTML output, selected by setting +;; `htmlize-output-type': `css', `inline-css', and `font'. In `css' +;; mode, htmlize uses cascading style sheets to specify colors; it +;; generates classes that correspond to Emacs faces and uses ... to color parts of text. In this mode, the +;; produced HTML is valid under the 4.01 strict DTD, as confirmed by +;; the W3C validator. `inline-css' is like `css', except the CSS is +;; put directly in the STYLE attribute of the SPAN element, making it +;; possible to paste the generated HTML into existing HTML documents. +;; In `font' mode, htmlize uses ... to +;; colorize HTML, which is not standard-compliant, but works better in +;; older browsers. `css' mode is the default. + +;; You can also use htmlize from your Emacs Lisp code. When called +;; non-interactively, `htmlize-buffer' and `htmlize-region' will +;; return the resulting HTML buffer, but will not change current +;; buffer or move the point. htmlize will do its best to work on +;; non-windowing Emacs sessions but the result will be limited to +;; colors supported by the terminal. + +;; htmlize aims for compatibility with older Emacs versions. Please +;; let me know if it doesn't work on the version of GNU Emacs that you +;; are using. The package relies on the presence of CL extensions; +;; please don't try to remove that dependency. I see no practical +;; problems with using the full power of the CL extensions, except +;; that one might learn to like them too much. + +;; The latest version is available at: +;; +;; +;; +;; + +;; Thanks go to the many people who have sent reports and contributed +;; comments, suggestions, and fixes. They include Ron Gut, Bob +;; Weiner, Toni Drabik, Peter Breton, Ville Skytta, Thomas Vogels, +;; Juri Linkov, Maciek Pasternacki, and many others. + +;; User quotes: "You sir, are a sick, sick, _sick_ person. :)" +;; -- Bill Perry, author of Emacs/W3 + + +;;; Code: + +(require 'cl) +(eval-when-compile + (defvar font-lock-auto-fontify) + (defvar font-lock-support-mode) + (defvar global-font-lock-mode)) + +(defconst htmlize-version "1.56") + +(defgroup htmlize nil + "Convert buffer text and faces to HTML." + :group 'hypermedia) + +(defcustom htmlize-head-tags "" + "Additional tags to insert within HEAD of the generated document." + :type 'string + :group 'htmlize) + +(defcustom htmlize-output-type 'css + "Output type of generated HTML, one of `css', `inline-css', or `font'. +When set to `css' (the default), htmlize will generate a style sheet +with description of faces, and use it in the HTML document, specifying +the faces in the actual text with . + +When set to `inline-css', the style will be generated as above, but +placed directly in the STYLE attribute of the span ELEMENT: . This makes it easier to paste the resulting HTML to +other documents. + +When set to `font', the properties will be set using layout tags +, , , , and . + +`css' output is normally preferred, but `font' is still useful for +supporting old, pre-CSS browsers, and both `inline-css' and `font' for +easier embedding of colorized text in foreign HTML documents (no style +sheet to carry around)." + :type '(choice (const css) (const inline-css) (const font)) + :group 'htmlize) + +(defcustom htmlize-use-images t + "Whether htmlize generates `img' for images attached to buffer contents." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-force-inline-images nil + "Non-nil means generate all images inline using data URLs. +Normally htmlize converts image descriptors with :file properties to +relative URIs, and those with :data properties to data URIs. With this +flag set, the images specified as a file name are loaded into memory and +embedded in the HTML as data URIs." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-max-alt-text 100 + "Maximum size of text to use as ALT text in images. + +Normally when htmlize encounters text covered by the `display' property +that specifies an image, it generates an `alt' attribute containing the +original text. If the text is larger than `htmlize-max-alt-text' characters, +this will not be done." + :type 'integer + :group 'htmlize) + +(defcustom htmlize-transform-image 'htmlize-default-transform-image + "Function called to modify the image descriptor. + +The function is called with the image descriptor found in the buffer and +the text the image is supposed to replace. It should return a (possibly +different) image descriptor property list or a replacement string to use +instead of of the original buffer text. + +Returning nil is the same as returning the original text." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-generate-hyperlinks t + "Non-nil means auto-generate the links from URLs and mail addresses in buffer. + +This is on by default; set it to nil if you don't want htmlize to +autogenerate such links. Note that this option only turns off automatic +search for contents that looks like URLs and converting them to links. +It has no effect on whether htmlize respects the `htmlize-link' property." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-hyperlink-style " + a { + color: inherit; + background-color: inherit; + font: inherit; + text-decoration: inherit; + } + a:hover { + text-decoration: underline; + } +" + "The CSS style used for hyperlinks when in CSS mode." + :type 'string + :group 'htmlize) + +(defcustom htmlize-replace-form-feeds t + "Non-nil means replace form feeds in source code with HTML separators. +Form feeds are the ^L characters at line beginnings that are sometimes +used to separate sections of source code. If this variable is set to +`t', form feed characters are replaced with the
separator. If this +is a string, it specifies the replacement to use. Note that 
 is
+temporarily closed before the separator is inserted, so the default
+replacement is effectively \"
\".  If you specify
+another replacement, don't forget to close and reopen the 
 if you
+want the output to remain valid HTML.
+
+If you need more elaborate processing, set this to nil and use
+htmlize-after-hook."
+  :type 'boolean
+  :group 'htmlize)
+
+(defcustom htmlize-html-charset nil
+  "The charset declared by the resulting HTML documents.
+When non-nil, causes htmlize to insert the following in the HEAD section
+of the generated HTML:
+
+  
+
+where CHARSET is the value you've set for htmlize-html-charset.  Valid
+charsets are defined by MIME and include strings like \"iso-8859-1\",
+\"iso-8859-15\", \"utf-8\", etc.
+
+If you are using non-Latin-1 charsets, you might need to set this for
+your documents to render correctly.  Also, the W3C validator requires
+submitted HTML documents to declare a charset.  So if you care about
+validation, you can use this to prevent the validator from bitching.
+
+Needless to say, if you set this, you should actually make sure that
+the buffer is in the encoding you're claiming it is in.  (This is
+normally achieved by using the correct file coding system for the
+buffer.)  If you don't understand what that means, you should probably
+leave this option in its default setting."
+  :type '(choice (const :tag "Unset" nil)
+		 string)
+  :group 'htmlize)
+
+(defcustom htmlize-convert-nonascii-to-entities t
+  "Whether non-ASCII characters should be converted to HTML entities.
+
+When this is non-nil, characters with codes in the 128-255 range will be
+considered Latin 1 and rewritten as \"&#CODE;\".  Characters with codes
+above 255 will be converted to \"&#UCS;\", where UCS denotes the Unicode
+code point of the character.  If the code point cannot be determined,
+the character will be copied unchanged, as would be the case if the
+option were nil.
+
+When the option is nil, the non-ASCII characters are copied to HTML
+without modification.  In that case, the web server and/or the browser
+must be set to understand the encoding that was used when saving the
+buffer.  (You might also want to specify it by setting
+`htmlize-html-charset'.)
+
+Note that in an HTML entity \"&#CODE;\", CODE is always a UCS code point,
+which has nothing to do with the charset the page is in.  For example,
+\"©\" *always* refers to the copyright symbol, regardless of charset
+specified by the META tag or the charset sent by the HTTP server.  In
+other words, \"©\" is exactly equivalent to \"©\".
+
+For most people htmlize will work fine with this option left at the
+default setting; don't change it unless you know what you're doing."
+  :type 'sexp
+  :group 'htmlize)
+
+(defcustom htmlize-ignore-face-size 'absolute
+  "Whether face size should be ignored when generating HTML.
+If this is nil, face sizes are used.  If set to t, sizes are ignored
+If set to `absolute', only absolute size specifications are ignored.
+Please note that font sizes only work with CSS-based output types."
+  :type '(choice (const :tag "Don't ignore" nil)
+		 (const :tag "Ignore all" t)
+		 (const :tag "Ignore absolute" absolute))
+  :group 'htmlize)
+
+(defcustom htmlize-css-name-prefix ""
+  "The prefix used for CSS names.
+The CSS names that htmlize generates from face names are often too
+generic for CSS files; for example, `font-lock-type-face' is transformed
+to `type'.  Use this variable to add a prefix to the generated names.
+The string \"htmlize-\" is an example of a reasonable prefix."
+  :type 'string
+  :group 'htmlize)
+
+(defcustom htmlize-use-rgb-txt t
+  "Whether `rgb.txt' should be used to convert color names to RGB.
+
+This conversion means determining, for instance, that the color
+\"IndianRed\" corresponds to the (205, 92, 92) RGB triple.  `rgb.txt'
+is the X color database that maps hundreds of color names to such RGB
+triples.  When this variable is non-nil, `htmlize' uses `rgb.txt' to
+look up color names.
+
+If this variable is nil, htmlize queries Emacs for RGB components of
+colors using `color-instance-rgb-components' and `color-values'.
+This can yield incorrect results on non-true-color displays.
+
+If the `rgb.txt' file is not found (which will be the case if you're
+running Emacs on non-X11 systems), this option is ignored."
+  :type 'boolean
+  :group 'htmlize)
+
+(defvar htmlize-face-overrides nil
+  "Overrides for face definitions.
+
+Normally face definitions are taken from Emacs settings for fonts
+in the current frame.  For faces present in this plist, the
+definitions will be used instead.  Keys in the plist are symbols
+naming the face and values are the overriding definitions.  For
+example:
+
+  (setq htmlize-face-overrides
+        '(font-lock-warning-face \"black\"
+          font-lock-function-name-face \"red\"
+          font-lock-comment-face \"blue\"
+          default (:foreground \"dark-green\" :background \"yellow\")))
+
+This variable can be also be `let' bound when running `htmlize-buffer'.")
+
+(defcustom htmlize-untabify t
+  "Non-nil means untabify buffer contents during htmlization."
+  :type 'boolean
+  :group 'htmlize)
+
+(defcustom htmlize-html-major-mode nil
+  "The mode the newly created HTML buffer will be put in.
+Set this to nil if you prefer the default (fundamental) mode."
+  :type '(radio (const :tag "No mode (fundamental)" nil)
+		 (function-item html-mode)
+		 (function :tag "User-defined major mode"))
+  :group 'htmlize)
+
+(defcustom htmlize-pre-style nil
+  "When non-nil, `
' tags will be decorated with style
+information in `font' and `inline-css' modes. This allows a
+consistent background for captures of regions."
+  :type 'boolean
+  :group 'htmlize)
+
+(defvar htmlize-before-hook nil
+  "Hook run before htmlizing a buffer.
+The hook functions are run in the source buffer (not the resulting HTML
+buffer).")
+
+(defvar htmlize-after-hook nil
+  "Hook run after htmlizing a buffer.
+Unlike `htmlize-before-hook', these functions are run in the generated
+HTML buffer.  You may use them to modify the outlook of the final HTML
+output.")
+
+(defvar htmlize-file-hook nil
+  "Hook run by `htmlize-file' after htmlizing a file, but before saving it.")
+
+(defvar htmlize-buffer-places)
+
+;;; Some cross-Emacs compatibility.
+
+;; We need a function that efficiently finds the next change of a
+;; property regardless of whether the change occurred because of a
+;; text property or an extent/overlay.
+(defun htmlize-next-change (pos prop &optional limit)
+  (if prop
+      (next-single-char-property-change pos prop nil limit)
+    (next-char-property-change pos limit)))
+
+(defun htmlize-overlay-faces-at (pos)
+  (delq nil (mapcar (lambda (o) (overlay-get o 'face)) (overlays-at pos))))
+
+(defun htmlize-next-face-change (pos &optional limit)
+  ;; (htmlize-next-change pos 'face limit) would skip over entire
+  ;; overlays that specify the `face' property, even when they
+  ;; contain smaller text properties that also specify `face'.
+  ;; Emacs display engine merges those faces, and so must we.
+  (or limit
+      (setq limit (point-max)))
+  (let ((next-prop (next-single-property-change pos 'face nil limit))
+        (overlay-faces (htmlize-overlay-faces-at pos)))
+    (while (progn
+             (setq pos (next-overlay-change pos))
+             (and (< pos next-prop)
+                  (equal overlay-faces (htmlize-overlay-faces-at pos)))))
+    (setq pos (min pos next-prop))
+    ;; Additionally, we include the entire region that specifies the
+    ;; `display' property.
+    (when (get-char-property pos 'display)
+      (setq pos (next-single-char-property-change pos 'display nil limit)))
+    pos))
+
+(defmacro htmlize-lexlet (&rest letforms)
+  (declare (indent 1) (debug let))
+  (if (and (boundp 'lexical-binding)
+           lexical-binding)
+      `(let ,@letforms)
+    ;; cl extensions have a macro implementing lexical let
+    `(lexical-let ,@letforms)))
+
+
+;;; Transformation of buffer text: HTML escapes, untabification, etc.
+
+(defvar htmlize-basic-character-table
+  ;; Map characters in the 0-127 range to either one-character strings
+  ;; or to numeric entities.
+  (let ((table (make-vector 128 ?\0)))
+    ;; Map characters in the 32-126 range to themselves, others to
+    ;; &#CODE entities;
+    (dotimes (i 128)
+      (setf (aref table i) (if (and (>= i 32) (<= i 126))
+			       (char-to-string i)
+			     (format "&#%d;" i))))
+    ;; Set exceptions manually.
+    (setf
+     ;; Don't escape newline, carriage return, and TAB.
+     (aref table ?\n) "\n"
+     (aref table ?\r) "\r"
+     (aref table ?\t) "\t"
+     ;; Escape &, <, and >.
+     (aref table ?&) "&"
+     (aref table ?<) "<"
+     (aref table ?>) ">"
+     ;; Not escaping '"' buys us a measurable speedup.  It's only
+     ;; necessary to quote it for strings used in attribute values,
+     ;; which htmlize doesn't typically do.
+     ;(aref table ?\") """
+     )
+    table))
+
+;; A cache of HTML representation of non-ASCII characters.  Depending
+;; on the setting of `htmlize-convert-nonascii-to-entities', this maps
+;; non-ASCII characters to either "&#;" or "" (mapconcat's
+;; mapper must always return strings).  It's only filled as characters
+;; are encountered, so that in a buffer with e.g. French text, it will
+;; only ever contain French accented characters as keys.  It's cleared
+;; on each entry to htmlize-buffer-1 to allow modifications of
+;; `htmlize-convert-nonascii-to-entities' to take effect.
+(defvar htmlize-extended-character-cache (make-hash-table :test 'eq))
+
+(defun htmlize-protect-string (string)
+  "HTML-protect string, escaping HTML metacharacters and I18N chars."
+  ;; Only protecting strings that actually contain unsafe or non-ASCII
+  ;; chars removes a lot of unnecessary funcalls and consing.
+  (if (not (string-match "[^\r\n\t -%'-;=?-~]" string))
+      string
+    (mapconcat (lambda (char)
+		 (cond
+		  ((< char 128)
+		   ;; ASCII: use htmlize-basic-character-table.
+		   (aref htmlize-basic-character-table char))
+		  ((gethash char htmlize-extended-character-cache)
+		   ;; We've already seen this char; return the cached
+		   ;; string.
+		   )
+		  ((not htmlize-convert-nonascii-to-entities)
+		   ;; If conversion to entities is not desired, always
+		   ;; copy the char literally.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (char-to-string char)))
+		  ((< char 256)
+		   ;; Latin 1: no need to call encode-char.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (format "&#%d;" char)))
+		  ((encode-char char 'ucs)
+                   ;; Must check if encode-char works for CHAR;
+                   ;; it fails for Arabic and possibly elsewhere.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (format "&#%d;" (encode-char char 'ucs))))
+		  (t
+		   ;; encode-char doesn't work for this char.  Copy it
+		   ;; unchanged and hope for the best.
+		   (setf (gethash char htmlize-extended-character-cache)
+			 (char-to-string char)))))
+	       string "")))
+
+(defun htmlize-attr-escape (string)
+  ;; Like htmlize-protect-string, but also escapes double-quoted
+  ;; strings to make it usable in attribute values.
+  (setq string (htmlize-protect-string string))
+  (if (not (string-match "\"" string))
+      string
+    (mapconcat (lambda (char)
+                 (if (eql char ?\")
+                     """
+                   (char-to-string char)))
+               string "")))
+
+(defsubst htmlize-concat (list)
+  (if (and (consp list) (null (cdr list)))
+      ;; Don't create a new string in the common case where the list only
+      ;; consists of one element.
+      (car list)
+    (apply #'concat list)))
+
+(defun htmlize-format-link (linkprops text)
+  (let ((uri (if (stringp linkprops)
+                 linkprops
+               (plist-get linkprops :uri)))
+        (escaped-text (htmlize-protect-string text)))
+    (if uri
+        (format "%s" (htmlize-attr-escape uri) escaped-text)
+      escaped-text)))
+
+(defun htmlize-escape-or-link (string)
+  ;; Escape STRING and/or add hyperlinks.  STRING comes from a
+  ;; `display' property.
+  (let ((pos 0) (end (length string)) outlist)
+    (while (< pos end)
+      (let* ((link (get-char-property pos 'htmlize-link string))
+             (next-link-change (next-single-property-change
+                                pos 'htmlize-link string end))
+             (chunk (substring string pos next-link-change)))
+        (push
+         (cond (link
+                (htmlize-format-link link chunk))
+               ((get-char-property 0 'htmlize-literal chunk)
+                chunk)
+               (t
+                (htmlize-protect-string chunk)))
+         outlist)
+        (setq pos next-link-change)))
+    (htmlize-concat (nreverse outlist))))
+
+(defun htmlize-display-prop-to-html (display text)
+  (let (desc)
+    (cond ((stringp display)
+           ;; Emacs ignores recursive display properties.
+           (htmlize-escape-or-link display))
+          ((not (eq (car-safe display) 'image))
+           (htmlize-protect-string text))
+          ((null (setq desc (funcall htmlize-transform-image
+                                     (cdr display) text)))
+           (htmlize-escape-or-link text))
+          ((stringp desc)
+           (htmlize-escape-or-link desc))
+          (t
+           (htmlize-generate-image desc text)))))
+
+(defun htmlize-string-to-html (string)
+  ;; Convert the string to HTML, including images attached as
+  ;; `display' property and links as `htmlize-link' property.  In a
+  ;; string without images or links, this is equivalent to
+  ;; `htmlize-protect-string'.
+  (let ((pos 0) (end (length string)) outlist)
+    (while (< pos end)
+      (let* ((display (get-char-property pos 'display string))
+             (next-display-change (next-single-property-change
+                                   pos 'display string end))
+             (chunk (substring string pos next-display-change)))
+        (push
+         (if display
+             (htmlize-display-prop-to-html display chunk)
+           (htmlize-escape-or-link chunk))
+         outlist)
+        (setq pos next-display-change)))
+    (htmlize-concat (nreverse outlist))))
+
+(defun htmlize-default-transform-image (imgprops _text)
+  "Default transformation of image descriptor to something usable in HTML.
+
+If `htmlize-use-images' is nil, the function always returns nil, meaning
+use original text.  Otherwise, it tries to find the image for images that
+specify a file name.  If `htmlize-force-inline-images' is non-nil, it also
+converts the :file attribute to :data and returns the modified property
+list."
+  (when htmlize-use-images
+    (when (plist-get imgprops :file)
+      (let ((location (plist-get (cdr (find-image (list imgprops))) :file)))
+        (when location
+          (setq imgprops (plist-put (copy-list imgprops) :file location)))))
+    (if htmlize-force-inline-images
+        (let ((location (plist-get imgprops :file))
+              data)
+          (when location
+            (with-temp-buffer
+              (condition-case nil
+                  (progn
+                    (insert-file-contents-literally location)
+                    (setq data (buffer-string)))
+                (error nil))))
+          ;; if successful, return the new plist, otherwise return
+          ;; nil, which will use the original text
+          (and data
+               (plist-put (plist-put imgprops :file nil)
+                          :data data)))
+      imgprops)))
+
+(defun htmlize-alt-text (_imgprops origtext)
+  (and (/= (length origtext) 0)
+       (<= (length origtext) htmlize-max-alt-text)
+       (not (string-match "[\0-\x1f]" origtext))
+       origtext))
+
+(defun htmlize-generate-image (imgprops origtext)
+  (let* ((alt-text (htmlize-alt-text imgprops origtext))
+         (alt-attr (if alt-text
+                       (format " alt=\"%s\"" (htmlize-attr-escape alt-text))
+                     "")))
+    (cond ((plist-get imgprops :file)
+           ;; Try to find the image in image-load-path
+           (let* ((found-props (cdr (find-image (list imgprops))))
+                  (file (or (plist-get found-props :file)
+                            (plist-get imgprops :file))))
+             (format ""
+                     (htmlize-attr-escape (file-relative-name file))
+                     alt-attr)))
+          ((plist-get imgprops :data)
+           (format ""
+                   (or (plist-get imgprops :type) "")
+                   (base64-encode-string (plist-get imgprops :data))
+                   alt-attr)))))
+
+(defconst htmlize-ellipsis "...")
+(put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis)
+
+(defun htmlize-match-inv-spec (inv)
+  (member* inv buffer-invisibility-spec
+           :key (lambda (i)
+                  (if (symbolp i) i (car i)))))
+
+(defun htmlize-decode-invisibility-spec (invisible)
+  ;; Return t, nil, or `ellipsis', depending on how invisible text should be inserted.
+
+  (if (not (listp buffer-invisibility-spec))
+      ;; If buffer-invisibility-spec is not a list, then all
+      ;; characters with non-nil `invisible' property are visible.
+      (not invisible)
+
+    ;; Otherwise, the value of a non-nil `invisible' property can be:
+    ;; 1. a symbol -- make the text invisible if it matches
+    ;;    buffer-invisibility-spec.
+    ;; 2. a list of symbols -- make the text invisible if
+    ;;    any symbol in the list matches
+    ;;    buffer-invisibility-spec.
+    ;; If the match of buffer-invisibility-spec has a non-nil
+    ;; CDR, replace the invisible text with an ellipsis.
+    (let ((match (if (symbolp invisible)
+                     (htmlize-match-inv-spec invisible)
+                   (some #'htmlize-match-inv-spec invisible))))
+      (cond ((null match) t)
+            ((cdr-safe (car match)) 'ellipsis)
+            (t nil)))))
+
+(defun htmlize-add-before-after-strings (beg end text)
+  ;; Find overlays specifying before-string and after-string in [beg,
+  ;; pos).  If any are found, splice them into TEXT and return the new
+  ;; text.
+  (let (additions)
+    (dolist (overlay (overlays-in beg end))
+      (let ((before (overlay-get overlay 'before-string))
+            (after (overlay-get overlay 'after-string)))
+        (when after
+          (push (cons (- (overlay-end overlay) beg)
+                      after)
+                additions))
+        (when before
+          (push (cons (- (overlay-start overlay) beg)
+                      before)
+                additions))))
+    (if additions
+        (let ((textlist nil)
+              (strpos 0))
+          (dolist (add (stable-sort additions #'< :key #'car))
+            (let ((addpos (car add))
+                  (addtext (cdr add)))
+              (push (substring text strpos addpos) textlist)
+              (push addtext textlist)
+              (setq strpos addpos)))
+          (push (substring text strpos) textlist)
+          (apply #'concat (nreverse textlist)))
+      text)))
+
+(defun htmlize-copy-prop (prop beg end string)
+  ;; Copy the specified property from the specified region of the
+  ;; buffer to the target string.  We cannot rely on Emacs to copy the
+  ;; property because we want to handle properties coming from both
+  ;; text properties and overlays.
+  (let ((pos beg))
+    (while (< pos end)
+      (let ((value (get-char-property pos prop))
+            (next-change (htmlize-next-change pos prop end)))
+        (when value
+          (put-text-property (- pos beg) (- next-change beg)
+                             prop value string))
+        (setq pos next-change)))))
+
+(defun htmlize-get-text-with-display (beg end)
+  ;; Like buffer-substring-no-properties, except it copies the
+  ;; `display' property from the buffer, if found.
+  (let ((text (buffer-substring-no-properties beg end)))
+    (htmlize-copy-prop 'display beg end text)
+    (htmlize-copy-prop 'htmlize-link beg end text)
+    (setq text (htmlize-add-before-after-strings beg end text))
+    text))
+
+(defun htmlize-buffer-substring-no-invisible (beg end)
+  ;; Like buffer-substring-no-properties, but don't copy invisible
+  ;; parts of the region.  Where buffer-substring-no-properties
+  ;; mandates an ellipsis to be shown, htmlize-ellipsis is inserted.
+  (let ((pos beg)
+	visible-list invisible show last-show next-change)
+    ;; Iterate over the changes in the `invisible' property and filter
+    ;; out the portions where it's non-nil, i.e. where the text is
+    ;; invisible.
+    (while (< pos end)
+      (setq invisible (get-char-property pos 'invisible)
+	    next-change (htmlize-next-change pos 'invisible end)
+            show (htmlize-decode-invisibility-spec invisible))
+      (cond ((eq show t)
+	     (push (htmlize-get-text-with-display pos next-change)
+                   visible-list))
+            ((and (eq show 'ellipsis)
+                  (not (eq last-show 'ellipsis))
+                  ;; Conflate successive ellipses.
+                  (push htmlize-ellipsis visible-list))))
+      (setq pos next-change last-show show))
+    (htmlize-concat (nreverse visible-list))))
+
+(defun htmlize-trim-ellipsis (text)
+  ;; Remove htmlize-ellipses ("...") from the beginning of TEXT if it
+  ;; starts with it.  It checks for the special property of the
+  ;; ellipsis so it doesn't work on ordinary text that begins with
+  ;; "...".
+  (if (get-text-property 0 'htmlize-ellipsis text)
+      (substring text (length htmlize-ellipsis))
+    text))
+
+(defconst htmlize-tab-spaces
+  ;; A table of strings with spaces.  (aref htmlize-tab-spaces 5) is
+  ;; like (make-string 5 ?\ ), except it doesn't cons.
+  (let ((v (make-vector 32 nil)))
+    (dotimes (i (length v))
+      (setf (aref v i) (make-string i ?\ )))
+    v))
+
+(defun htmlize-untabify-string (text start-column)
+  "Untabify TEXT, assuming it starts at START-COLUMN."
+  (let ((column start-column)
+	(last-match 0)
+	(chunk-start 0)
+	chunks match-pos tab-size)
+    (while (string-match "[\t\n]" text last-match)
+      (setq match-pos (match-beginning 0))
+      (cond ((eq (aref text match-pos) ?\t)
+	     ;; Encountered a tab: create a chunk of text followed by
+	     ;; the expanded tab.
+	     (push (substring text chunk-start match-pos) chunks)
+	     ;; Increase COLUMN by the length of the text we've
+	     ;; skipped since last tab or newline.  (Encountering
+	     ;; newline resets it.)
+	     (incf column (- match-pos last-match))
+	     ;; Calculate tab size based on tab-width and COLUMN.
+	     (setq tab-size (- tab-width (% column tab-width)))
+	     ;; Expand the tab, carefully recreating the `display'
+	     ;; property if one was on the TAB.
+             (let ((display (get-text-property match-pos 'display text))
+                   (expanded-tab (aref htmlize-tab-spaces tab-size)))
+               (when display
+                 (put-text-property 0 tab-size 'display display expanded-tab))
+               (push expanded-tab chunks))
+	     (incf column tab-size)
+	     (setq chunk-start (1+ match-pos)))
+	    (t
+	     ;; Reset COLUMN at beginning of line.
+	     (setq column 0)))
+      (setq last-match (1+ match-pos)))
+    ;; If no chunks have been allocated, it means there have been no
+    ;; tabs to expand.  Return TEXT unmodified.
+    (if (null chunks)
+	text
+      (when (< chunk-start (length text))
+	;; Push the remaining chunk.
+	(push (substring text chunk-start) chunks))
+      ;; Generate the output from the available chunks.
+      (htmlize-concat (nreverse chunks)))))
+
+(defun htmlize-extract-text (beg end trailing-ellipsis)
+  ;; Extract buffer text, sans the invisible parts.  Then
+  ;; untabify it and escape the HTML metacharacters.
+  (let ((text (htmlize-buffer-substring-no-invisible beg end)))
+    (when trailing-ellipsis
+      (setq text (htmlize-trim-ellipsis text)))
+    ;; If TEXT ends up empty, don't change trailing-ellipsis.
+    (when (> (length text) 0)
+      (setq trailing-ellipsis
+            (get-text-property (1- (length text))
+                               'htmlize-ellipsis text)))
+    (when htmlize-untabify
+      (setq text (htmlize-untabify-string text (current-column))))
+    (setq text (htmlize-string-to-html text))
+    (values text trailing-ellipsis)))
+
+(defun htmlize-despam-address (string)
+  "Replace every occurrence of '@' in STRING with %40.
+This is used to protect mailto links without modifying their meaning."
+  ;; Suggested by Ville Skytta.
+  (while (string-match "@" string)
+    (setq string (replace-match "%40" nil t string)))
+  string)
+
+(defun htmlize-make-tmp-overlay (beg end props)
+  (let ((overlay (make-overlay beg end)))
+    (overlay-put overlay 'htmlize-tmp-overlay t)
+    (while props
+      (overlay-put overlay (pop props) (pop props)))
+    overlay))
+
+(defun htmlize-delete-tmp-overlays ()
+  (dolist (overlay (overlays-in (point-min) (point-max)))
+    (when (overlay-get overlay 'htmlize-tmp-overlay)
+      (delete-overlay overlay))))
+
+(defun htmlize-make-link-overlay (beg end uri)
+  (htmlize-make-tmp-overlay beg end `(htmlize-link (:uri ,uri))))
+
+(defun htmlize-create-auto-links ()
+  "Add `htmlize-link' property to all mailto links in the buffer."
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward
+            "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>"
+            nil t)
+      (let* ((address (match-string 3))
+             (beg (match-beginning 0)) (end (match-end 0))
+             (uri (concat "mailto:" (htmlize-despam-address address))))
+        (htmlize-make-link-overlay beg end uri)))
+    (goto-char (point-min))
+    (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>"
+                              nil t)
+      (htmlize-make-link-overlay
+       (match-beginning 0) (match-end 0) (match-string 3)))))
+
+;; Tests for htmlize-create-auto-links:
+
+;; 
+;; 
+;; 
+;; 
+;; 
+;; 
+
+(defun htmlize-shadow-form-feeds ()
+  (let ((s "\n
"))
+    (put-text-property 0 (length s) 'htmlize-literal t s)
+    (let ((disp `(display ,s)))
+      (while (re-search-forward "\n\^L" nil t)
+        (let* ((beg (match-beginning 0))
+               (end (match-end 0))
+               (form-feed-pos (1+ beg))
+               ;; don't process ^L if invisible or covered by `display'
+               (show (and (htmlize-decode-invisibility-spec
+                           (get-char-property form-feed-pos 'invisible))
+                          (not (get-char-property form-feed-pos 'display)))))
+          (when show
+            (htmlize-make-tmp-overlay beg end disp)))))))
+
+(defun htmlize-defang-local-variables ()
+  ;; Juri Linkov reports that an HTML-ized "Local variables" can lead
+  ;; visiting the HTML to fail with "Local variables list is not
+  ;; properly terminated".  He suggested changing the phrase to
+  ;; syntactically equivalent HTML that Emacs doesn't recognize.
+  (goto-char (point-min))
+  (while (search-forward "Local Variables:" nil t)
+    (replace-match "Local Variables:" nil t)))
+  
+
+;;; Color handling.
+
+(defvar htmlize-x-library-search-path
+  `(,data-directory
+    "/etc/X11/rgb.txt"
+    "/usr/share/X11/rgb.txt"
+    ;; the remainder of this list really belongs in a museum
+    "/usr/X11R6/lib/X11/"
+    "/usr/X11R5/lib/X11/"
+    "/usr/lib/X11R6/X11/"
+    "/usr/lib/X11R5/X11/"
+    "/usr/local/X11R6/lib/X11/"
+    "/usr/local/X11R5/lib/X11/"
+    "/usr/local/lib/X11R6/X11/"
+    "/usr/local/lib/X11R5/X11/"
+    "/usr/X11/lib/X11/"
+    "/usr/lib/X11/"
+    "/usr/local/lib/X11/"
+    "/usr/X386/lib/X11/"
+    "/usr/x386/lib/X11/"
+    "/usr/XFree86/lib/X11/"
+    "/usr/unsupported/lib/X11/"
+    "/usr/athena/lib/X11/"
+    "/usr/local/x11r5/lib/X11/"
+    "/usr/lpp/Xamples/lib/X11/"
+    "/usr/openwin/lib/X11/"
+    "/usr/openwin/share/lib/X11/"))
+
+(defun htmlize-get-color-rgb-hash (&optional rgb-file)
+  "Return a hash table mapping X color names to RGB values.
+The keys in the hash table are X11 color names, and the values are the
+#rrggbb RGB specifications, extracted from `rgb.txt'.
+
+If RGB-FILE is nil, the function will try hard to find a suitable file
+in the system directories.
+
+If no rgb.txt file is found, return nil."
+  (let ((rgb-file (or rgb-file (locate-file
+				"rgb.txt"
+				htmlize-x-library-search-path)))
+	(hash nil))
+    (when rgb-file
+      (with-temp-buffer
+	(insert-file-contents rgb-file)
+	(setq hash (make-hash-table :test 'equal))
+	(while (not (eobp))
+	  (cond ((looking-at "^\\s-*\\([!#]\\|$\\)")
+		 ;; Skip comments and empty lines.
+		 )
+		((looking-at
+		  "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)")
+		 (setf (gethash (downcase (match-string 4)) hash)
+		       (format "#%02x%02x%02x"
+			       (string-to-number (match-string 1))
+			       (string-to-number (match-string 2))
+			       (string-to-number (match-string 3)))))
+		(t
+		 (error
+		  "Unrecognized line in %s: %s"
+		  rgb-file
+		  (buffer-substring (point) (progn (end-of-line) (point))))))
+	  (forward-line 1))))
+    hash))
+
+;; Compile the RGB map when loaded.  On systems where rgb.txt is
+;; missing, the value of the variable will be nil, and rgb.txt will
+;; not be used.
+(defvar htmlize-color-rgb-hash (htmlize-get-color-rgb-hash))
+
+;;; Face handling.
+
+(defun htmlize-face-color-internal (face fg)
+  ;; Used only under GNU Emacs.  Return the color of FACE, but don't
+  ;; return "unspecified-fg" or "unspecified-bg".  If the face is
+  ;; `default' and the color is unspecified, look up the color in
+  ;; frame parameters.
+  (let* ((function (if fg #'face-foreground #'face-background))
+	 (color (funcall function face nil t)))
+    (when (and (eq face 'default) (null color))
+      (setq color (cdr (assq (if fg 'foreground-color 'background-color)
+			     (frame-parameters)))))
+    (when (or (eq color 'unspecified)
+	      (equal color "unspecified-fg")
+	      (equal color "unspecified-bg"))
+      (setq color nil))
+    (when (and (eq face 'default)
+	       (null color))
+      ;; Assuming black on white doesn't seem right, but I can't think
+      ;; of anything better to do.
+      (setq color (if fg "black" "white")))
+    color))
+
+(defun htmlize-face-foreground (face)
+  ;; Return the name of the foreground color of FACE.  If FACE does
+  ;; not specify a foreground color, return nil.
+  (htmlize-face-color-internal face t))
+
+(defun htmlize-face-background (face)
+  ;; Return the name of the background color of FACE.  If FACE does
+  ;; not specify a background color, return nil.
+  ;; GNU Emacs.
+  (htmlize-face-color-internal face nil))
+
+;; Convert COLOR to the #RRGGBB string.  If COLOR is already in that
+;; format, it's left unchanged.
+
+(defun htmlize-color-to-rgb (color)
+  (let ((rgb-string nil))
+    (cond ((null color)
+	   ;; Ignore nil COLOR because it means that the face is not
+	   ;; specifying any color.  Hence (htmlize-color-to-rgb nil)
+	   ;; returns nil.
+	   )
+	  ((string-match "\\`#" color)
+	   ;; The color is already in #rrggbb format.
+	   (setq rgb-string color))
+	  ((and htmlize-use-rgb-txt
+		htmlize-color-rgb-hash)
+	   ;; Use of rgb.txt is requested, and it's available on the
+	   ;; system.  Use it.
+	   (setq rgb-string (gethash (downcase color) htmlize-color-rgb-hash)))
+	  (t
+	   ;; We're getting the RGB components from Emacs.
+	   (let ((rgb (mapcar (lambda (arg)
+                                (/ arg 256))
+                              (color-values color))))
+	     (when rgb
+	       (setq rgb-string (apply #'format "#%02x%02x%02x" rgb))))))
+    ;; If RGB-STRING is still nil, it means the color cannot be found,
+    ;; for whatever reason.  In that case just punt and return COLOR.
+    ;; Most browsers support a decent set of color names anyway.
+    (or rgb-string color)))
+
+;; We store the face properties we care about into an
+;; `htmlize-fstruct' type.  That way we only have to analyze face
+;; properties, which can be time consuming, once per each face.  The
+;; mapping between Emacs faces and htmlize-fstructs is established by
+;; htmlize-make-face-map.  The name "fstruct" refers to variables of
+;; type `htmlize-fstruct', while the term "face" is reserved for Emacs
+;; faces.
+
+(defstruct htmlize-fstruct
+  foreground				; foreground color, #rrggbb
+  background				; background color, #rrggbb
+  size					; size
+  boldp					; whether face is bold
+  italicp				; whether face is italic
+  underlinep				; whether face is underlined
+  overlinep				; whether face is overlined
+  strikep				; whether face is struck through
+  css-name				; CSS name of face
+  )
+
+(defun htmlize-face-set-from-keyword-attr (fstruct attr value)
+  ;; For ATTR and VALUE, set the equivalent value in FSTRUCT.
+  (case attr
+    (:foreground
+     (setf (htmlize-fstruct-foreground fstruct) (htmlize-color-to-rgb value)))
+    (:background
+     (setf (htmlize-fstruct-background fstruct) (htmlize-color-to-rgb value)))
+    (:height
+     (setf (htmlize-fstruct-size fstruct) value))
+    (:weight
+     (when (string-match (symbol-name value) "bold")
+       (setf (htmlize-fstruct-boldp fstruct) t)))
+    (:slant
+     (setf (htmlize-fstruct-italicp fstruct) (or (eq value 'italic)
+						 (eq value 'oblique))))
+    (:bold
+     (setf (htmlize-fstruct-boldp fstruct) value))
+    (:italic
+     (setf (htmlize-fstruct-italicp fstruct) value))
+    (:underline
+     (setf (htmlize-fstruct-underlinep fstruct) value))
+    (:overline
+     (setf (htmlize-fstruct-overlinep fstruct) value))
+    (:strike-through
+     (setf (htmlize-fstruct-strikep fstruct) value))))
+
+(defun htmlize-face-size (face)
+  ;; The size (height) of FACE, taking inheritance into account.
+  ;; Only works in Emacs 21 and later.
+  (let* ((face-list (list face))
+         (head face-list)
+         (tail face-list))
+    (while head
+      (let ((inherit (face-attribute (car head) :inherit)))
+        (cond ((listp inherit)
+               (setcdr tail (copy-list inherit))
+               (setq tail (last tail)))
+              ((eq inherit 'unspecified))
+              (t
+               (setcdr tail (list inherit))
+               (setq tail (cdr tail)))))
+      (pop head))
+    (let ((size-list
+           (loop
+            for f in face-list
+            for h = (face-attribute f :height)
+            collect (if (eq h 'unspecified) nil h))))
+      (reduce 'htmlize-merge-size (cons nil size-list)))))
+
+(defun htmlize-face-css-name (face)
+  ;; Generate the css-name property for the given face.  Emacs places
+  ;; no restrictions on the names of symbols that represent faces --
+  ;; any characters may be in the name, even control chars.  We try
+  ;; hard to beat the face name into shape, both esthetically and
+  ;; according to CSS1 specs.
+  (let ((name (downcase (symbol-name face))))
+    (when (string-match "\\`font-lock-" name)
+      ;; font-lock-FOO-face -> FOO.
+      (setq name (replace-match "" t t name)))
+    (when (string-match "-face\\'" name)
+      ;; Drop the redundant "-face" suffix.
+      (setq name (replace-match "" t t name)))
+    (while (string-match "[^-a-zA-Z0-9]" name)
+      ;; Drop the non-alphanumerics.
+      (setq name (replace-match "X" t t name)))
+    (when (string-match "\\`[-0-9]" name)
+      ;; CSS identifiers may not start with a digit.
+      (setq name (concat "X" name)))
+    ;; After these transformations, the face could come out empty.
+    (when (equal name "")
+      (setq name "face"))
+    ;; Apply the prefix.
+    (concat htmlize-css-name-prefix name)))
+
+(defun htmlize-face-to-fstruct-1 (face)
+  "Convert Emacs face FACE to fstruct, internal."
+  (let ((fstruct (make-htmlize-fstruct
+		  :foreground (htmlize-color-to-rgb
+			       (htmlize-face-foreground face))
+		  :background (htmlize-color-to-rgb
+			       (htmlize-face-background face)))))
+    ;; GNU Emacs
+    (dolist (attr '(:weight :slant :underline :overline :strike-through))
+      (let ((value (face-attribute face attr nil t)))
+        (when (and value (not (eq value 'unspecified)))
+          (htmlize-face-set-from-keyword-attr fstruct attr value))))
+    (let ((size (htmlize-face-size face)))
+      (unless (eql size 1.0)            ; ignore non-spec
+        (setf (htmlize-fstruct-size fstruct) size)))
+    (setf (htmlize-fstruct-css-name fstruct) (htmlize-face-css-name face))
+    fstruct))
+
+(defun htmlize-face-to-fstruct (face)
+  (let* ((face-list (or (and (symbolp face)
+                             (cdr (assq face face-remapping-alist)))
+                        (list face)))
+         (fstruct (htmlize-merge-faces
+                   (mapcar (lambda (face)
+                             (if (symbolp face)
+                                 (or (htmlize-get-override-fstruct face)
+                                     (htmlize-face-to-fstruct-1 face))
+                               (htmlize-attrlist-to-fstruct face)))
+                           (nreverse face-list)))))
+    (when (symbolp face)
+      (setf (htmlize-fstruct-css-name fstruct) (htmlize-face-css-name face)))
+    fstruct))
+
+(defmacro htmlize-copy-attr-if-set (attr-list dest source)
+  ;; Generate code with the following pattern:
+  ;; (progn
+  ;;   (when (htmlize-fstruct-ATTR source)
+  ;;     (setf (htmlize-fstruct-ATTR dest) (htmlize-fstruct-ATTR source)))
+  ;;   ...)
+  ;; for the given list of boolean attributes.
+  (cons 'progn
+	(loop for attr in attr-list
+	      for attr-sym = (intern (format "htmlize-fstruct-%s" attr))
+	      collect `(when (,attr-sym ,source)
+                         (setf (,attr-sym ,dest) (,attr-sym ,source))))))
+
+(defun htmlize-merge-size (merged next)
+  ;; Calculate the size of the merge of MERGED and NEXT.
+  (cond ((null merged)     next)
+	((integerp next)   next)
+	((null next)       merged)
+	((floatp merged)   (* merged next))
+	((integerp merged) (round (* merged next)))))
+
+(defun htmlize-merge-two-faces (merged next)
+  (htmlize-copy-attr-if-set
+   (foreground background boldp italicp underlinep overlinep strikep)
+   merged next)
+  (setf (htmlize-fstruct-size merged)
+	(htmlize-merge-size (htmlize-fstruct-size merged)
+			    (htmlize-fstruct-size next)))
+  merged)
+
+(defun htmlize-merge-faces (fstruct-list)
+  (cond ((null fstruct-list)
+	 ;; Nothing to do, return a dummy face.
+	 (make-htmlize-fstruct))
+	((null (cdr fstruct-list))
+	 ;; Optimize for the common case of a single face, simply
+	 ;; return it.
+	 (car fstruct-list))
+	(t
+	 (reduce #'htmlize-merge-two-faces
+		 (cons (make-htmlize-fstruct) fstruct-list)))))
+
+;; GNU Emacs 20+ supports attribute lists in `face' properties.  For
+;; example, you can use `(:foreground "red" :weight bold)' as an
+;; overlay's "face", or you can even use a list of such lists, etc.
+;; We call those "attrlists".
+;;
+;; htmlize supports attrlist by converting them to fstructs, the same
+;; as with regular faces.
+
+(defun htmlize-attrlist-to-fstruct (attrlist &optional name)
+  ;; Like htmlize-face-to-fstruct, but accepts an ATTRLIST as input.
+  (let ((fstruct (make-htmlize-fstruct)))
+    (cond ((eq (car attrlist) 'foreground-color)
+	   ;; ATTRLIST is (foreground-color . COLOR)
+	   (setf (htmlize-fstruct-foreground fstruct)
+		 (htmlize-color-to-rgb (cdr attrlist))))
+	  ((eq (car attrlist) 'background-color)
+	   ;; ATTRLIST is (background-color . COLOR)
+	   (setf (htmlize-fstruct-background fstruct)
+		 (htmlize-color-to-rgb (cdr attrlist))))
+	  (t
+	   ;; ATTRLIST is a plist.
+	   (while attrlist
+	     (let ((attr (pop attrlist))
+		   (value (pop attrlist)))
+	       (when (and value (not (eq value 'unspecified)))
+		 (htmlize-face-set-from-keyword-attr fstruct attr value))))))
+    (setf (htmlize-fstruct-css-name fstruct) (or name "custom"))
+    fstruct))
+
+(defun htmlize-decode-face-prop (prop)
+  "Turn face property PROP into a list of face-like objects."
+  ;; PROP can be a symbol naming a face, a string naming such a
+  ;; symbol, a cons (foreground-color . COLOR) or (background-color
+  ;; COLOR), a property list (:attr1 val1 :attr2 val2 ...), or a list
+  ;; of any of those.
+  ;;
+  ;; (htmlize-decode-face-prop 'face) -> (face)
+  ;; (htmlize-decode-face-prop '(face1 face2)) -> (face1 face2)
+  ;; (htmlize-decode-face-prop '(:attr "val")) -> ((:attr "val"))
+  ;; (htmlize-decode-face-prop '((:attr "val") face (foreground-color "red")))
+  ;;   -> ((:attr "val") face (foreground-color "red"))
+  ;;
+  ;; Unrecognized atoms or non-face symbols/strings are silently
+  ;; stripped away.
+  (cond ((null prop)
+         nil)
+        ((symbolp prop)
+         (and (facep prop)
+              (list prop)))
+        ((stringp prop)
+         (and (facep (intern-soft prop))
+              (list prop)))
+        ((atom prop)
+         nil)
+        ((and (symbolp (car prop))
+              (eq ?: (aref (symbol-name (car prop)) 0)))
+         (list prop))
+        ((or (eq (car prop) 'foreground-color)
+             (eq (car prop) 'background-color))
+         (list prop))
+        (t
+         (apply #'nconc (mapcar #'htmlize-decode-face-prop prop)))))
+
+(defun htmlize-get-override-fstruct (face)
+  (let* ((raw-def (plist-get htmlize-face-overrides face))
+         (def (cond ((stringp raw-def) (list :foreground raw-def))
+                    ((listp raw-def) raw-def)
+                    (t
+                     (error (format (concat "face override must be an "
+                                            "attribute list or string, got %s")
+                                    raw-def))))))
+    (and def
+         (htmlize-attrlist-to-fstruct def (symbol-name face)))))
+
+(defun htmlize-make-face-map (faces)
+  ;; Return a hash table mapping Emacs faces to htmlize's fstructs.
+  ;; The keys are either face symbols or attrlists, so the test
+  ;; function must be `equal'.
+  (let ((face-map (make-hash-table :test 'equal))
+	css-names)
+    (dolist (face faces)
+      (unless (gethash face face-map)
+	;; Haven't seen FACE yet; convert it to an fstruct and cache
+	;; it.
+	(let ((fstruct (htmlize-face-to-fstruct face)))
+	  (setf (gethash face face-map) fstruct)
+	  (let* ((css-name (htmlize-fstruct-css-name fstruct))
+		 (new-name css-name)
+		 (i 0))
+	    ;; Uniquify the face's css-name by using NAME-1, NAME-2,
+	    ;; etc.
+	    (while (member new-name css-names)
+	      (setq new-name (format "%s-%s" css-name (incf i))))
+	    (unless (equal new-name css-name)
+	      (setf (htmlize-fstruct-css-name fstruct) new-name))
+	    (push new-name css-names)))))
+    face-map))
+
+(defun htmlize-unstringify-face (face)
+  "If FACE is a string, return it interned, otherwise return it unchanged."
+  (if (stringp face)
+      (intern face)
+    face))
+
+(defun htmlize-faces-in-buffer ()
+  "Return a list of faces used in the current buffer.
+This is the set of faces specified by the `face' text property and by buffer
+overlays that specify `face'."
+  (let (faces)
+    ;; Faces used by text properties.
+    (let ((pos (point-min)) face-prop next)
+      (while (< pos (point-max))
+        (setq face-prop (get-text-property pos 'face)
+              next (or (next-single-property-change pos 'face) (point-max)))
+        (setq faces (nunion (htmlize-decode-face-prop face-prop)
+                            faces :test 'equal))
+        (setq pos next)))
+    ;; Faces used by overlays.
+    (dolist (overlay (overlays-in (point-min) (point-max)))
+      (let ((face-prop (overlay-get overlay 'face)))
+        (setq faces (nunion (htmlize-decode-face-prop face-prop)
+                            faces :test 'equal))))
+    faces))
+
+(if (>= emacs-major-version 25)
+    (defun htmlize-sorted-overlays-at (pos)
+      (overlays-at pos t))
+
+  (defun htmlize-sorted-overlays-at (pos)
+    ;; Like OVERLAYS-AT with the SORTED argument, for older Emacsen.
+    (let ((overlays (overlays-at pos)))
+      (setq overlays (sort* overlays #'<
+                            :key (lambda (o)
+                                   (- (overlay-end o) (overlay-start o)))))
+      (setq overlays
+            (stable-sort overlays #'<
+                         :key (lambda (o)
+                                (let ((prio (overlay-get o 'priority)))
+                                  (if (numberp prio) prio 0)))))
+      (nreverse overlays))))
+
+
+;; htmlize-faces-at-point returns the faces in use at point.  The
+;; faces are sorted by increasing priority, i.e. the last face takes
+;; precedence.
+;;
+;; This returns all the faces in the `face' property and all the faces
+;; in the overlays at point.
+
+(defun htmlize-faces-at-point ()
+  (let (all-faces)
+    ;; Faces from text properties.
+    (let ((face-prop (get-text-property (point) 'face)))
+      ;; we need to reverse the `face' prop because we want
+      ;; more specific faces to come later
+      (setq all-faces (nreverse (htmlize-decode-face-prop face-prop))))
+    ;; Faces from overlays.
+    (let ((overlays
+           ;; Collect overlays at point that specify `face'.
+           (delete-if-not (lambda (o)
+                            (overlay-get o 'face))
+                          (nreverse (htmlize-sorted-overlays-at (point)))))
+          list face-prop)
+      (dolist (overlay overlays)
+        (setq face-prop (overlay-get overlay 'face)
+              list (nconc (htmlize-decode-face-prop face-prop) list)))
+      ;; Under "Merging Faces" the manual explicitly states
+      ;; that faces specified by overlays take precedence over
+      ;; faces specified by text properties.
+      (setq all-faces (nconc all-faces list)))
+    all-faces))
+
+;; htmlize supports generating HTML in several flavors, some of which
+;; use CSS, and others the  element.  We take an OO approach and
+;; define "methods" that indirect to the functions that depend on
+;; `htmlize-output-type'.  The currently used methods are `doctype',
+;; `insert-head', `body-tag', `pre-tag', and `text-markup'.  Not all
+;; output types define all methods.
+;;
+;; Methods are called either with (htmlize-method METHOD ARGS...) 
+;; special form, or by accessing the function with
+;; (htmlize-method-function 'METHOD) and calling (funcall FUNCTION).
+;; The latter form is useful in tight loops because `htmlize-method'
+;; conses.
+
+(defmacro htmlize-method (method &rest args)
+  ;; Expand to (htmlize-TYPE-METHOD ...ARGS...).  TYPE is the value of
+  ;; `htmlize-output-type' at run time.
+  `(funcall (htmlize-method-function ',method) ,@args))
+
+(defun htmlize-method-function (method)
+  ;; Return METHOD's function definition for the current output type.
+  ;; The returned object can be safely funcalled.
+  (let ((sym (intern (format "htmlize-%s-%s" htmlize-output-type method))))
+    (indirect-function (if (fboundp sym)
+			   sym
+			 (let ((default (intern (concat "htmlize-default-"
+							(symbol-name method)))))
+			   (if (fboundp default)
+			       default
+			     'ignore))))))
+
+(defvar htmlize-memoization-table (make-hash-table :test 'equal))
+
+(defmacro htmlize-memoize (key generator)
+  "Return the value of GENERATOR, memoized as KEY.
+That means that GENERATOR will be evaluated and returned the first time
+it's called with the same value of KEY.  All other times, the cached
+\(memoized) value will be returned."
+  (let ((value (gensym)))
+    `(let ((,value (gethash ,key htmlize-memoization-table)))
+       (unless ,value
+	 (setq ,value ,generator)
+	 (setf (gethash ,key htmlize-memoization-table) ,value))
+       ,value)))
+
+;;; Default methods.
+
+(defun htmlize-default-doctype ()
+  nil					; no doc-string
+  ;; Note that the `font' output is technically invalid under this DTD
+  ;; because the DTD doesn't allow embedding  in 
.
+  ""
+  )
+
+(defun htmlize-default-body-tag (face-map)
+  nil					; no doc-string
+  face-map ; shut up the byte-compiler
+  "")
+
+(defun htmlize-default-pre-tag (face-map)
+  nil					; no doc-string
+  face-map ; shut up the byte-compiler
+  "
")
+
+
+;;; CSS based output support.
+
+;; Internal function; not a method.
+(defun htmlize-css-specs (fstruct)
+  (let (result)
+    (when (htmlize-fstruct-foreground fstruct)
+      (push (format "color: %s;" (htmlize-fstruct-foreground fstruct))
+	    result))
+    (when (htmlize-fstruct-background fstruct)
+      (push (format "background-color: %s;"
+		    (htmlize-fstruct-background fstruct))
+	    result))
+    (let ((size (htmlize-fstruct-size fstruct)))
+      (when (and size (not (eq htmlize-ignore-face-size t)))
+	(cond ((floatp size)
+	       (push (format "font-size: %d%%;" (* 100 size)) result))
+	      ((not (eq htmlize-ignore-face-size 'absolute))
+	       (push (format "font-size: %spt;" (/ size 10.0)) result)))))
+    (when (htmlize-fstruct-boldp fstruct)
+      (push "font-weight: bold;" result))
+    (when (htmlize-fstruct-italicp fstruct)
+      (push "font-style: italic;" result))
+    (when (htmlize-fstruct-underlinep fstruct)
+      (push "text-decoration: underline;" result))
+    (when (htmlize-fstruct-overlinep fstruct)
+      (push "text-decoration: overline;" result))
+    (when (htmlize-fstruct-strikep fstruct)
+      (push "text-decoration: line-through;" result))
+    (nreverse result)))
+
+(defun htmlize-css-insert-head (buffer-faces face-map)
+  (insert "    \n"))
+
+(defun htmlize-css-text-markup (fstruct-list buffer)
+  ;; Open the markup needed to insert text colored with FACES into
+  ;; BUFFER.  Return the function that closes the markup.
+
+  ;; In CSS mode, this is easy: just nest the text in one  tag for each face in FSTRUCT-LIST.
+  (dolist (fstruct fstruct-list)
+    (princ "" buffer))
+  (htmlize-lexlet ((fstruct-list fstruct-list) (buffer buffer))
+    (lambda ()
+      (dolist (fstruct fstruct-list)
+        (ignore fstruct)                ; shut up the byte-compiler
+        (princ "" buffer)))))
+
+;; `inline-css' output support.
+
+(defun htmlize-inline-css-body-tag (face-map)
+  (format ""
+	  (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map))
+		     " ")))
+
+(defun htmlize-inline-css-pre-tag (face-map)
+  (if htmlize-pre-style
+      (format "
"
+              (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map))
+                         " "))
+    (format "
")))
+
+(defun htmlize-inline-css-text-markup (fstruct-list buffer)
+  (let* ((merged (htmlize-merge-faces fstruct-list))
+	 (style (htmlize-memoize
+		 merged
+		 (let ((specs (htmlize-css-specs merged)))
+		   (and specs
+			(mapconcat #'identity (htmlize-css-specs merged) " "))))))
+    (when style
+      (princ "" buffer))
+    (htmlize-lexlet ((style style) (buffer buffer))
+      (lambda ()
+        (when style
+          (princ "" buffer))))))
+
+;;; `font' tag based output support.
+
+(defun htmlize-font-body-tag (face-map)
+  (let ((fstruct (gethash 'default face-map)))
+    (format ""
+	    (htmlize-fstruct-foreground fstruct)
+	    (htmlize-fstruct-background fstruct))))
+
+(defun htmlize-font-pre-tag (face-map)
+  (if htmlize-pre-style
+      (let ((fstruct (gethash 'default face-map)))
+        (format "
"
+                (htmlize-fstruct-foreground fstruct)
+                (htmlize-fstruct-background fstruct)))
+    (format "
")))
+       
+(defun htmlize-font-text-markup (fstruct-list buffer)
+  ;; In `font' mode, we use the traditional HTML means of altering
+  ;; presentation:  tag for colors,  for bold,  for
+  ;; underline, and  for strike-through.
+  (let* ((merged (htmlize-merge-faces fstruct-list))
+	 (markup (htmlize-memoize
+		  merged
+		  (cons (concat
+			 (and (htmlize-fstruct-foreground merged)
+			      (format "" (htmlize-fstruct-foreground merged)))
+			 (and (htmlize-fstruct-boldp merged)      "")
+			 (and (htmlize-fstruct-italicp merged)    "")
+			 (and (htmlize-fstruct-underlinep merged) "")
+			 (and (htmlize-fstruct-strikep merged)    ""))
+			(concat
+			 (and (htmlize-fstruct-strikep merged)    "")
+			 (and (htmlize-fstruct-underlinep merged) "")
+			 (and (htmlize-fstruct-italicp merged)    "")
+			 (and (htmlize-fstruct-boldp merged)      "")
+			 (and (htmlize-fstruct-foreground merged) ""))))))
+    (princ (car markup) buffer)
+    (htmlize-lexlet ((markup markup) (buffer buffer))
+      (lambda ()
+        (princ (cdr markup) buffer)))))
+
+(defun htmlize-buffer-1 ()
+  ;; Internal function; don't call it from outside this file.  Htmlize
+  ;; current buffer, writing the resulting HTML to a new buffer, and
+  ;; return it.  Unlike htmlize-buffer, this doesn't change current
+  ;; buffer or use switch-to-buffer.
+  (save-excursion
+    ;; Protect against the hook changing the current buffer.
+    (save-excursion
+      (run-hooks 'htmlize-before-hook))
+    ;; Convince font-lock support modes to fontify the entire buffer
+    ;; in advance.
+    (htmlize-ensure-fontified)
+    (clrhash htmlize-extended-character-cache)
+    (clrhash htmlize-memoization-table)
+    ;; It's important that the new buffer inherits default-directory
+    ;; from the current buffer.
+    (let ((htmlbuf (generate-new-buffer (if (buffer-file-name)
+                                            (htmlize-make-file-name
+                                             (file-name-nondirectory
+                                              (buffer-file-name)))
+                                          "*html*")))
+          (completed nil))
+      (unwind-protect
+          (let* ((buffer-faces (htmlize-faces-in-buffer))
+                 (face-map (htmlize-make-face-map (adjoin 'default buffer-faces)))
+                 (places (gensym))
+                 (title (if (buffer-file-name)
+                            (file-name-nondirectory (buffer-file-name))
+                          (buffer-name))))
+            (when htmlize-generate-hyperlinks
+              (htmlize-create-auto-links))
+            (when htmlize-replace-form-feeds
+              (htmlize-shadow-form-feeds))
+
+            ;; Initialize HTMLBUF and insert the HTML prolog.
+            (with-current-buffer htmlbuf
+              (buffer-disable-undo)
+              (insert (htmlize-method doctype) ?\n
+                      (format "\n"
+                              htmlize-version htmlize-output-type)
+                      "\n  ")
+              (put places 'head-start (point-marker))
+              (insert "\n"
+                      "    " (htmlize-protect-string title) "\n"
+                      (if htmlize-html-charset
+                          (format (concat "    \n")
+                                  htmlize-html-charset)
+                        "")
+                      htmlize-head-tags)
+              (htmlize-method insert-head buffer-faces face-map)
+              (insert "  ")
+              (put places 'head-end (point-marker))
+              (insert "\n  ")
+              (put places 'body-start (point-marker))
+              (insert (htmlize-method body-tag face-map)
+                      "\n    ")
+              (put places 'content-start (point-marker))
+              (insert (htmlize-method pre-tag face-map) "\n"))
+            (let ((text-markup
+                   ;; Get the inserter method, so we can funcall it inside
+                   ;; the loop.  Not calling `htmlize-method' in the loop
+                   ;; body yields a measurable speed increase.
+                   (htmlize-method-function 'text-markup))
+                  ;; Declare variables used in loop body outside the loop
+                  ;; because it's faster to establish `let' bindings only
+                  ;; once.
+                  next-change text face-list trailing-ellipsis
+                  fstruct-list last-fstruct-list
+                  (close-markup (lambda ())))
+              ;; This loop traverses and reads the source buffer, appending
+              ;; the resulting HTML to HTMLBUF.  This method is fast
+              ;; because: 1) it doesn't require examining the text
+              ;; properties char by char (htmlize-next-face-change is used
+              ;; to move between runs with the same face), and 2) it doesn't
+              ;; require frequent buffer switches, which are slow because
+              ;; they rebind all buffer-local vars.
+              (goto-char (point-min))
+              (while (not (eobp))
+                (setq next-change (htmlize-next-face-change (point)))
+                ;; Get faces in use between (point) and NEXT-CHANGE, and
+                ;; convert them to fstructs.
+                (setq face-list (htmlize-faces-at-point)
+                      fstruct-list (delq nil (mapcar (lambda (f)
+                                                       (gethash f face-map))
+                                                     face-list)))
+                (multiple-value-setq (text trailing-ellipsis)
+                  (htmlize-extract-text (point) next-change trailing-ellipsis))
+                ;; Don't bother writing anything if there's no text (this
+                ;; happens in invisible regions).
+                (when (> (length text) 0)
+                  ;; Open the new markup if necessary and insert the text.
+                  (when (not (equalp fstruct-list last-fstruct-list))
+                    (funcall close-markup)
+                    (setq last-fstruct-list fstruct-list
+                          close-markup (funcall text-markup fstruct-list htmlbuf)))
+                  (princ text htmlbuf))
+                (goto-char next-change))
+
+              ;; We've gone through the buffer; close the markup from
+              ;; the last run, if any.
+              (funcall close-markup))
+
+            ;; Insert the epilog and post-process the buffer.
+            (with-current-buffer htmlbuf
+              (insert "
")
+              (put places 'content-end (point-marker))
+              (insert "\n  ")
+              (put places 'body-end (point-marker))
+              (insert "\n\n")
+              (htmlize-defang-local-variables)
+              (goto-char (point-min))
+              (when htmlize-html-major-mode
+                ;; What sucks about this is that the minor modes, most notably
+                ;; font-lock-mode, won't be initialized.  Oh well.
+                (funcall htmlize-html-major-mode))
+              (set (make-local-variable 'htmlize-buffer-places)
+                   (symbol-plist places))
+              (run-hooks 'htmlize-after-hook)
+              (buffer-enable-undo))
+            (setq completed t)
+            htmlbuf)
+
+        (when (not completed)
+          (kill-buffer htmlbuf))
+        (htmlize-delete-tmp-overlays)))))
+
+;; Utility functions.
+
+(defmacro htmlize-with-fontify-message (&rest body)
+  ;; When forcing fontification of large buffers in
+  ;; htmlize-ensure-fontified, inform the user that he is waiting for
+  ;; font-lock, not for htmlize to finish.
+  `(progn
+     (if (> (buffer-size) 65536)
+	 (message "Forcing fontification of %s..."
+		  (buffer-name (current-buffer))))
+     ,@body
+     (if (> (buffer-size) 65536)
+	 (message "Forcing fontification of %s...done"
+		  (buffer-name (current-buffer))))))
+
+(defun htmlize-ensure-fontified ()
+  ;; If font-lock is being used, ensure that the "support" modes
+  ;; actually fontify the buffer.  If font-lock is not in use, we
+  ;; don't care because, except in htmlize-file, we don't force
+  ;; font-lock on the user.
+  (when font-lock-mode
+    ;; In part taken from ps-print-ensure-fontified in GNU Emacs 21.
+    (when (and (boundp 'jit-lock-mode)
+               (symbol-value 'jit-lock-mode))
+      (htmlize-with-fontify-message
+       (jit-lock-fontify-now (point-min) (point-max))))
+
+    (if (fboundp 'font-lock-ensure)
+        (font-lock-ensure)
+      ;; Emacs prior to 25.1
+      (with-no-warnings
+        (font-lock-mode 1)
+        (font-lock-fontify-buffer)))))
+
+
+;;;###autoload
+(defun htmlize-buffer (&optional buffer)
+  "Convert BUFFER to HTML, preserving colors and decorations.
+
+The generated HTML is available in a new buffer, which is returned.
+When invoked interactively, the new buffer is selected in the current
+window.  The title of the generated document will be set to the buffer's
+file name or, if that's not available, to the buffer's name.
+
+Note that htmlize doesn't fontify your buffers, it only uses the
+decorations that are already present.  If you don't set up font-lock or
+something else to fontify your buffers, the resulting HTML will be
+plain.  Likewise, if you don't like the choice of colors, fix the mode
+that created them, or simply alter the faces it uses."
+  (interactive)
+  (let ((htmlbuf (with-current-buffer (or buffer (current-buffer))
+		   (htmlize-buffer-1))))
+    (when (interactive-p)
+      (switch-to-buffer htmlbuf))
+    htmlbuf))
+
+;;;###autoload
+(defun htmlize-region (beg end)
+  "Convert the region to HTML, preserving colors and decorations.
+See `htmlize-buffer' for details."
+  (interactive "r")
+  ;; Don't let zmacs region highlighting end up in HTML.
+  (when (fboundp 'zmacs-deactivate-region)
+    (zmacs-deactivate-region))
+  (let ((htmlbuf (save-restriction
+		   (narrow-to-region beg end)
+		   (htmlize-buffer-1))))
+    (when (interactive-p)
+      (switch-to-buffer htmlbuf))
+    htmlbuf))
+
+(defun htmlize-region-for-paste (beg end)
+  "Htmlize the region and return just the HTML as a string.
+This forces the `inline-css' style and only returns the HTML body,
+but without the BODY tag.  This should make it useful for inserting
+the text to another HTML buffer."
+  (let* ((htmlize-output-type 'inline-css)
+	 (htmlbuf (htmlize-region beg end)))
+    (unwind-protect
+	(with-current-buffer htmlbuf
+	  (buffer-substring (plist-get htmlize-buffer-places 'content-start)
+			    (plist-get htmlize-buffer-places 'content-end)))
+      (kill-buffer htmlbuf))))
+
+(defun htmlize-region-save-screenshot (beg end)
+  "Save the htmlized (see `htmlize-region-for-paste') region in
+the kill ring. Uses `inline-css', with style information in
+`
' tags, so that the rendering of the marked up text
+approximates the buffer as closely as possible."
+  (interactive "r")
+  (let ((htmlize-pre-style t))
+    (kill-new (htmlize-region-for-paste beg end)))
+  (deactivate-mark))
+
+(defun htmlize-make-file-name (file)
+  "Make an HTML file name from FILE.
+
+In its default implementation, this simply appends `.html' to FILE.
+This function is called by htmlize to create the buffer file name, and
+by `htmlize-file' to create the target file name.
+
+More elaborate transformations are conceivable, such as changing FILE's
+extension to `.html' (\"file.c\" -> \"file.html\").  If you want them,
+overload this function to do it and htmlize will comply."
+  (concat file ".html"))
+
+;; Older implementation of htmlize-make-file-name that changes FILE's
+;; extension to ".html".
+;(defun htmlize-make-file-name (file)
+;  (let ((extension (file-name-extension file))
+;	(sans-extension (file-name-sans-extension file)))
+;    (if (or (equal extension "html")
+;	    (equal extension "htm")
+;	    (equal sans-extension ""))
+;	(concat file ".html")
+;      (concat sans-extension ".html"))))
+
+;;;###autoload
+(defun htmlize-file (file &optional target)
+  "Load FILE, fontify it, convert it to HTML, and save the result.
+
+Contents of FILE are inserted into a temporary buffer, whose major mode
+is set with `normal-mode' as appropriate for the file type.  The buffer
+is subsequently fontified with `font-lock' and converted to HTML.  Note
+that, unlike `htmlize-buffer', this function explicitly turns on
+font-lock.  If a form of highlighting other than font-lock is desired,
+please use `htmlize-buffer' directly on buffers so highlighted.
+
+Buffers currently visiting FILE are unaffected by this function.  The
+function does not change current buffer or move the point.
+
+If TARGET is specified and names a directory, the resulting file will be
+saved there instead of to FILE's directory.  If TARGET is specified and
+does not name a directory, it will be used as output file name."
+  (interactive (list (read-file-name
+		      "HTML-ize file: "
+		      nil nil nil (and (buffer-file-name)
+				       (file-name-nondirectory
+					(buffer-file-name))))))
+  (let ((output-file (if (and target (not (file-directory-p target)))
+			 target
+		       (expand-file-name
+			(htmlize-make-file-name (file-name-nondirectory file))
+			(or target (file-name-directory file)))))
+	;; Try to prevent `find-file-noselect' from triggering
+	;; font-lock because we'll fontify explicitly below.
+	(font-lock-mode nil)
+	(font-lock-auto-fontify nil)
+	(global-font-lock-mode nil)
+	;; Ignore the size limit for the purposes of htmlization.
+	(font-lock-maximum-size nil))
+    (with-temp-buffer
+      ;; Insert FILE into the temporary buffer.
+      (insert-file-contents file)
+      ;; Set the file name so normal-mode and htmlize-buffer-1 pick it
+      ;; up.  Restore it afterwards so with-temp-buffer's kill-buffer
+      ;; doesn't complain about killing a modified buffer.
+      (let ((buffer-file-name file))
+	;; Set the major mode for the sake of font-lock.
+	(normal-mode)
+	;; htmlize the buffer and save the HTML.
+	(with-current-buffer (htmlize-buffer-1)
+	  (unwind-protect
+	      (progn
+		(run-hooks 'htmlize-file-hook)
+		(write-region (point-min) (point-max) output-file))
+	    (kill-buffer (current-buffer)))))))
+  ;; I haven't decided on a useful return value yet, so just return
+  ;; nil.
+  nil)
+
+;;;###autoload
+(defun htmlize-many-files (files &optional target-directory)
+  "Convert FILES to HTML and save the corresponding HTML versions.
+
+FILES should be a list of file names to convert.  This function calls
+`htmlize-file' on each file; see that function for details.  When
+invoked interactively, you are prompted for a list of files to convert,
+terminated with RET.
+
+If TARGET-DIRECTORY is specified, the HTML files will be saved to that
+directory.  Normally, each HTML file is saved to the directory of the
+corresponding source file."
+  (interactive
+   (list
+    (let (list file)
+      ;; Use empty string as DEFAULT because setting DEFAULT to nil
+      ;; defaults to the directory name, which is not what we want.
+      (while (not (equal (setq file (read-file-name
+				     "HTML-ize file (RET to finish): "
+				     (and list (file-name-directory
+						(car list)))
+				     "" t))
+			 ""))
+	(push file list))
+      (nreverse list))))
+  ;; Verify that TARGET-DIRECTORY is indeed a directory.  If it's a
+  ;; file, htmlize-file will use it as target, and that doesn't make
+  ;; sense.
+  (and target-directory
+       (not (file-directory-p target-directory))
+       (error "target-directory must name a directory: %s" target-directory))
+  (dolist (file files)
+    (htmlize-file file target-directory)))
+
+;;;###autoload
+(defun htmlize-many-files-dired (arg &optional target-directory)
+  "HTMLize dired-marked files."
+  (interactive "P")
+  (htmlize-many-files (dired-get-marked-files nil arg) target-directory))
+
+(provide 'htmlize)
+
+;; Local Variables:
+;; byte-compile-warnings: (not cl-functions unresolved obsolete)
+;; End:
+
+;;; htmlize.el ends here
diff --git a/lisp/indent-guide.el b/lisp/indent-guide.el
new file mode 100644
index 00000000..853f33b1
--- /dev/null
+++ b/lisp/indent-guide.el
@@ -0,0 +1,328 @@
+;;; indent-guide.el --- show vertical lines to guide indentation
+
+;; Copyright (C) 2013- zk_phi
+
+;; 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 2 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, write to the Free Software
+;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+;; Author: zk_phi
+;; URL: http://hins11.yu-yake.com/
+;; Package-Version: 20191106.240
+;; Package-Commit: 7fc710748f9e5a086acfe77970f117df89ee9749
+;; Version: 2.3.1
+
+;;; Commentary:
+
+;; Require this script
+;;
+;;   (require 'indent-guide)
+;;
+;; and call command "M-x indent-guide-mode".
+
+;; If you want to enable indent-guide-mode automatically,
+;; call "indent-guide-global-mode" function.
+;;
+;;   (indent-guide-global-mode)
+
+;; Column lines are propertized with "indent-guide-face". So you may
+;; configure this face to make guides more pretty in your colorscheme.
+;;
+;;   (set-face-background 'indent-guide-face "dimgray")
+;;
+;; You may also change the character for guides.
+;;
+;;   (setq indent-guide-char ":")
+
+;;; Change Log:
+
+;; 1.0.0 first released
+;; 1.0.1 cleaned and optimized code
+;;       works better for the file without trailing-whitespaces
+;; 1.0.2 modified behavior for lines with only whitespaces
+;; 1.0.3 Allow custom indent guide char
+;; 1.0.4 disabled in org-indent-mode
+;; 1.0.5 faster update of indent-guide (especially for huge files)
+;; 1.1.0 work with tab-indented files
+;; 1.1.1 turned into minor-mode
+;; 1.1.2 an infinite-loop bug fix
+;; 1.1.3 changed behavior for blank lines
+;; 2.0.0 rewrite almost everything
+;; 2.0.1 improve blank-line and tab handling
+;; 2.0.2 fixed bug that sometimes newline gets invisible
+;; 2.0.3 added indent-guide-global-mode
+;; 2.1.0 now lines are not drawn over the cursor
+;; 2.1.1 work better with blank lines
+;; 2.1.2 fixed bug in empty files
+;; 2.1.3 better bob and eob handling
+;; 2.1.4 use "display" property instead of "before-string"
+;;       (now works better with hl-line and linum)
+;; 2.1.5 add "indent-guide-inhibit-modes"
+;; 2.1.6 add option "indent-guide-recursive"
+;; 2.2.0 add option "indent-guide-threshold"
+;; 2.3.0 use regexp search to find the beginning of level
+;; 2.3.1 add option "indent-guide-lispy-modes"
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defconst indent-guide-version "2.3.1")
+
+;; * customs
+
+(defgroup indent-guide nil
+  "Show vertical lines to guide indentation."
+  :group 'environment)
+
+(defcustom indent-guide-char "|"
+  "Character used as vertical line."
+  :type 'string
+  :group 'indent-guide)
+
+(defcustom indent-guide-inhibit-modes
+  '(tabulated-list-mode
+    special-mode
+    dired-mode
+    eww-mode
+    eshell-mode
+    Custom-mode)
+  "List of major-modes in which indent-guide should be turned off."
+  :type '(repeat symbol)
+  :group 'indent-guide)
+
+(defcustom indent-guide-recursive nil
+  "When non-nil, draw multiple guide lines recursively."
+  :type 'boolean
+  :group 'indent-guide)
+
+(defcustom indent-guide-delay nil
+  "When a positive number, rendering guide lines is delayed DELAY
+seconds."
+  :type 'number
+  :group 'indent-guide)
+
+(defcustom indent-guide-threshold -1
+  "Guide lines are drawn only when the column number is over this
+value."
+  :type 'number
+  :group 'indent-guide)
+
+(defcustom indent-guide-lispy-modes
+  '(lisp-mode emacs-lisp-mode scheme-mode
+              lisp-interaction-mode gauche-mode scheme-mode
+              clojure-mode racket-mode egison-mode)
+  "List of lisp-like language modes, in which the last brace of
+blocks are NOT placed at beginning of line."
+  :type '(repeat symbol)
+  :group 'indent-guide)
+
+(defface indent-guide-face '((t (:foreground "#535353" :slant normal)))
+  "Face used to indent guide lines."
+  :group 'indent-guide)
+
+;; * variables
+
+(defvar indent-guide--timer-object nil)
+
+;; * utilities
+
+(defun indent-guide--active-overlays ()
+  "Return the list of all overlays created by indent-guide."
+  (delq nil
+        (mapcar
+         (lambda (ov)
+           (and (eq (overlay-get ov 'category) 'indent-guide) ov))
+         (overlays-in (point-min) (point-max)))))
+
+(defun indent-guide--indentation-candidates (level)
+  "*Internal function for `indent-guide--beginning-of-level'."
+  (cond ((<= level 0)
+         (list ""))
+        ((>= level tab-width)
+         (cons (concat "\t" (make-string (- level tab-width) ?\s))
+               (cons (make-string level ?\s)
+                     (indent-guide--indentation-candidates (1- level)))))
+        (t
+         (cons (make-string level ?\s)
+               (indent-guide--indentation-candidates (1- level))))))
+
+(defun indent-guide--beginning-of-level ()
+  "Move to the beginning of current indentation level and return
+the point. When no such points are found, just return nil."
+  (back-to-indentation)
+  (let* ((base-level (if (not (eolp))
+                         (current-column)
+                       (max (save-excursion
+                              (skip-chars-forward "\s\t\n")
+                              (current-column))
+                            (save-excursion
+                              (skip-chars-backward "\s\t\n")
+                              (back-to-indentation)
+                              (current-column)))))
+         (candidates (indent-guide--indentation-candidates (1- base-level)))
+         (regex (concat "^" (regexp-opt candidates t) "[^\s\t\n]")))
+    (unless (zerop base-level)
+      (and (search-backward-regexp regex nil t)
+           (goto-char (match-end 1))))))
+
+;; * generate guides
+
+(defun indent-guide--make-overlay (line col)
+  "draw line at (line, col)"
+  (let (diff string ov prop)
+    (save-excursion
+      ;; try to goto (line, col)
+      (goto-char (point-min))
+      (forward-line (1- line))
+      (move-to-column col)
+      ;; calculate difference from the actual col
+      (setq diff (- col (current-column)))
+      ;; make overlay or not
+      (cond ((and (eolp) (<= 0 diff))   ; the line is too short
+             ;; <-line-width->  <-diff->
+             ;;               []        |
+             (if (setq ov (cl-some
+                           (lambda (ov)
+                             (when (eq (overlay-get ov 'category) 'indent-guide)
+                               ov))
+                           (overlays-in (point) (point))))
+                 ;; we already have an overlay here => append to the existing overlay
+                 ;; (important when "recursive" is enabled)
+                 (setq string (let ((str (overlay-get ov 'before-string)))
+                                (concat str
+                                        (make-string (- diff (length str)) ?\s)
+                                        (propertize indent-guide-char 'face 'indent-guide-face)))
+                       prop   'before-string)
+               (setq string (concat (make-string diff ?\s)
+                                    (propertize indent-guide-char 'face 'indent-guide-face))
+                     prop   'before-string
+                     ov     (make-overlay (point) (point)))))
+            ((< diff 0)                 ; the column is inside a tab
+             ;;  <---tab-width-->
+             ;;      <-(- diff)->
+             ;;     |            []
+             (if (setq ov (cl-some
+                           (lambda (ov)
+                             (when (eq (overlay-get ov 'category) 'indent-guide)
+                               ov))
+                           (overlays-in (1- (point)) (point))))
+                 ;; we already have an overlay here => modify the existing overlay
+                 ;; (important when "recursive" is enabled)
+                 (setq string (let ((str (overlay-get ov 'display)))
+                                (aset str (+ 1 tab-width diff) ?|)
+                                str)
+                       prop   'display)
+               (setq string (concat (make-string (+ tab-width diff) ?\s)
+                                    (propertize indent-guide-char 'face 'indent-guide-face)
+                                    (make-string (1- (- diff)) ?\s))
+                     prop   'display
+                     ov     (make-overlay (point) (1- (point))))))
+            ((looking-at "\t")          ; okay but looking at tab
+             ;;    <-tab-width->
+             ;; [|]
+             (setq string (concat (propertize indent-guide-char 'face 'indent-guide-face)
+                                  (make-string (1- tab-width) ?\s))
+                   prop   'display
+                   ov     (make-overlay (point) (1+ (point)))))
+            (t                          ; okay and looking at a space
+             (setq string (propertize indent-guide-char 'face 'indent-guide-face)
+                   prop   'display
+                   ov     (make-overlay (point) (1+ (point))))))
+      (when ov
+        (overlay-put ov 'category 'indent-guide)
+        (overlay-put ov prop string)))))
+
+(defun indent-guide-show ()
+  (interactive)
+  (unless (or (indent-guide--active-overlays)
+              (active-minibuffer-window))
+    (let ((win-start (window-start))
+          (win-end (window-end nil t))
+          line-col line-start line-end)
+      ;; decide line-col, line-start
+      (save-excursion
+        (indent-guide--beginning-of-level)
+        (setq line-col (current-column)
+              line-start (max (1+ (line-number-at-pos))
+                              (line-number-at-pos win-start)))
+        ;; if recursive draw is enabled and (line-col > 0), recurse
+        ;; into lower level.
+        (when (and indent-guide-recursive (> line-col 0))
+          (indent-guide-show)))
+      (when (> line-col indent-guide-threshold)
+        ;; decide line-end
+        (save-excursion
+          (while (and (progn (back-to-indentation)
+                             (or (< line-col (current-column)) (eolp)))
+                      (forward-line 1)
+                      (not (eobp))
+                      (<= (point) win-end)))
+          (cond ((< line-col (current-column))
+                 (setq line-end (line-number-at-pos)))
+                ((not (memq major-mode indent-guide-lispy-modes))
+                 (setq line-end (1- (line-number-at-pos))))
+                (t
+                 (skip-chars-backward "\s\t\n")
+                 (setq line-end (line-number-at-pos)))))
+        ;; draw line
+        (dotimes (tmp (- (1+ line-end) line-start))
+          (indent-guide--make-overlay (+ line-start tmp) line-col))
+        (remove-overlays (point) (point) 'category 'indent-guide)))))
+
+(defun indent-guide-remove ()
+  (dolist (ov (indent-guide--active-overlays))
+    (delete-overlay ov)))
+
+;; * minor-mode
+
+(defun indent-guide-post-command-hook ()
+  (if (null indent-guide-delay)
+      (indent-guide-show)
+    (when (null indent-guide--timer-object)
+      (setq indent-guide--timer-object
+            (run-with-idle-timer indent-guide-delay nil
+                                 (lambda ()
+                                   (indent-guide-show)
+                                   (setq indent-guide--timer-object nil)))))))
+
+(defun indent-guide-pre-command-hook ()
+  ;; some commands' behavior may affected by indent-guide overlays, so
+  ;; remove all overlays in pre-command-hook.
+  (indent-guide-remove))
+
+;;;###autoload
+(define-minor-mode indent-guide-mode
+  "show vertical lines to guide indentation"
+  :init-value nil
+  :lighter " ing"
+  :global nil
+  (if indent-guide-mode
+      (progn
+        (add-hook 'pre-command-hook 'indent-guide-pre-command-hook nil t)
+        (add-hook 'post-command-hook 'indent-guide-post-command-hook nil t))
+    (remove-hook 'pre-command-hook 'indent-guide-pre-command-hook t)
+    (remove-hook 'post-command-hook 'indent-guide-post-command-hook t)))
+
+;;;###autoload
+(define-globalized-minor-mode indent-guide-global-mode
+  indent-guide-mode
+  (lambda ()
+    (unless (cl-some 'derived-mode-p indent-guide-inhibit-modes)
+      (indent-guide-mode 1))))
+
+;; * provide
+
+(provide 'indent-guide)
+
+;;; indent-guide.el ends here
diff --git a/lisp/ivy-bibtex.el b/lisp/ivy-bibtex.el
new file mode 100644
index 00000000..06639a83
--- /dev/null
+++ b/lisp/ivy-bibtex.el
@@ -0,0 +1,206 @@
+;;; ivy-bibtex.el --- A bibliography manager based on Ivy
+
+;; Author: Justin Burkett 
+;; Maintainer: Titus von der Malsburg 
+;; URL: https://github.com/tmalsburg/helm-bibtex
+;; Package-Version: 20200429.1606
+;; Package-Commit: 8a0dd9841316793aacddea744d6b8ca4a7857a35
+;; Version: 1.0.1
+;; Package-Requires: ((bibtex-completion "1.0.0") (swiper "0.7.0") (cl-lib "0.5"))
+
+;; 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 .
+
+;;; Commentary:
+
+;; A BibTeX bibliography manager based on Ivy and the
+;; bibtex-completion backend.  If you are familiar with helm-bibtex,
+;; this is the ivy version.
+;;
+;; News:
+;; - 09/06/2018: Added virtual APA field `author-or-editor` for use in
+;;   notes templates.
+;; - 02/06/2018: Reload bibliography proactively when bib files are
+;;   changed.
+;; - 21/10/2017: Added support for multiple PDFs and other file
+;;   types.  See `bibtex-completion-pdf-extension' and
+;;   `bibtex-completion-find-additional-pdfs' for details.
+;; - 10/10/2017: Added support for ~@string~ constants.
+;; - 02/10/2017: Date field is used when year is undefined.
+;; - 29/09/2017: BibTeX entry, citation macro, or org-bibtex entry at
+;;   point, will be pre-selected in helm-bibtex and ivy-bibtex giving
+;;   quick access to PDFs and other functions.
+;;
+;; See NEWS.org for old news.
+;;
+;; Key features:
+;; - Quick access to your bibliography from within Emacs
+;; - Tightly integrated workflows
+;; - Provides instant search results as you type
+;; - Powerful search expressions
+;; - Open the PDFs, URLs, or DOIs associated with an entry
+;; - Insert LaTeX cite commands, Ebib links, or Pandoc citations,
+;;   BibTeX entries, or plain text references at point, attach PDFs to
+;;   emails
+;; - Attach notes to publications
+;;
+;; Install:
+;;
+;;   Put this file in a directory included in your load path or
+;;   install ivy-bibtex from MELPA (preferred).  Then add the
+;;   following in your Emacs startup file:
+;;
+;;     (require 'ivy-bibtex)
+;;
+;;   Alternatively, you can use autoload:
+;;
+;;     (autoload 'ivy-bibtex "ivy-bibtex" "" t)
+;;
+;;   Requirements are parsebib, swiper, s, dash, and f.  The easiest way
+;;   to install these packages is through MELPA.
+;;
+;;   Let ivy-bibtex know where it can find your bibliography by
+;;   setting the variable `bibtex-completion-bibliography'.  See the
+;;   manual for more details:
+;;
+;;     https://github.com/tmalsburg/helm-bibtex/blob/master/README.ivy-bibtex.org
+;;
+;; Usage:
+;;
+;;    Do M-x ivy-bibtex and start typing a search query when prompted.
+
+;;; Code:
+
+(require 'ivy)
+(require 'bibtex-completion)
+
+(defcustom ivy-bibtex-default-action 'ivy-bibtex-open-any
+  "The default action for the `ivy-bibtex` command."
+  :group 'bibtex-completion
+  :type 'function)
+  
+(defun ivy-bibtex-display-transformer (candidate)
+  "Prepare bib entry CANDIDATE for display."
+  (let* ((width (1- (frame-width)))
+         (idx (get-text-property 0 'idx candidate))
+         (entry (cdr (nth idx (ivy-state-collection ivy-last)))))
+    (bibtex-completion-format-entry entry width)))
+
+(defmacro ivy-bibtex-ivify-action (action name)
+  "Wraps the function ACTION in another function named NAME which extracts the key from the candidate selected in ivy and passes it to ACTION."
+  `(defun ,name (candidate)
+     (let ((key (cdr (assoc "=key=" (cdr candidate)))))
+       (,action (list key)))))
+
+(ivy-bibtex-ivify-action bibtex-completion-open-any ivy-bibtex-open-any)
+(ivy-bibtex-ivify-action bibtex-completion-open-pdf ivy-bibtex-open-pdf)
+(ivy-bibtex-ivify-action bibtex-completion-open-url-or-doi ivy-bibtex-open-url-or-doi)
+(ivy-bibtex-ivify-action bibtex-completion-insert-citation ivy-bibtex-insert-citation)
+(ivy-bibtex-ivify-action bibtex-completion-insert-reference ivy-bibtex-insert-reference)
+(ivy-bibtex-ivify-action bibtex-completion-insert-key ivy-bibtex-insert-key)
+(ivy-bibtex-ivify-action bibtex-completion-insert-bibtex ivy-bibtex-insert-bibtex)
+(ivy-bibtex-ivify-action bibtex-completion-add-PDF-attachment ivy-bibtex-add-PDF-attachment)
+(ivy-bibtex-ivify-action bibtex-completion-edit-notes ivy-bibtex-edit-notes)
+(ivy-bibtex-ivify-action bibtex-completion-show-entry ivy-bibtex-show-entry)
+(ivy-bibtex-ivify-action bibtex-completion-add-pdf-to-library ivy-bibtex-add-pdf-to-library)
+
+(defun ivy-bibtex-fallback (search-expression)
+  "Select a fallback option for SEARCH-EXPRESSION.
+This is meant to be used as an action in `ivy-read`, with
+`ivy-text` as search expression."
+  (ivy-read "Fallback options: "
+            (bibtex-completion-fallback-candidates)
+            :caller 'ivy-bibtex-fallback
+            :action (lambda (candidate) (bibtex-completion-fallback-action (cdr candidate) search-expression))))
+
+;;;###autoload
+(defun ivy-bibtex (&optional arg local-bib)
+  "Search BibTeX entries using ivy.
+
+With a prefix ARG the cache is invalidated and the bibliography
+reread.
+
+If LOCAL-BIB is non-nil, display that the BibTeX entries are read
+from the local bibliography.  This is set internally by
+`ivy-bibtex-with-local-bibliography'."
+  (interactive "P")
+  (when arg
+    (bibtex-completion-clear-cache))
+  (bibtex-completion-init)
+  (let* ((candidates (bibtex-completion-candidates))
+         (key (bibtex-completion-key-at-point))
+         (preselect (and key
+                         (cl-position-if (lambda (cand)
+                                           (member (cons "=key=" key)
+                                                   (cdr cand)))
+                                         candidates))))
+    (ivy-read (format "BibTeX entries%s: " (if local-bib " (local)" ""))
+              candidates
+              :preselect preselect
+              :caller 'ivy-bibtex
+              :action ivy-bibtex-default-action)))
+
+;;;###autoload
+(defun ivy-bibtex-with-local-bibliography (&optional arg)
+  "Search BibTeX entries with local bibliography.
+
+With a prefix ARG the cache is invalidated and the bibliography
+reread."
+  (interactive "P")
+  (let* ((local-bib (bibtex-completion-find-local-bibliography))
+         (bibtex-completion-bibliography (or local-bib
+                                             bibtex-completion-bibliography)))
+    (ivy-bibtex arg local-bib)))
+
+;;;###autoload
+(defun ivy-bibtex-with-notes (&optional arg)
+  "Search BibTeX entries with notes.
+
+With a prefix ARG the cache is invalidated and the bibliography
+reread."
+  (interactive "P")
+  (cl-letf* ((candidates (bibtex-completion-candidates))
+             ((symbol-function 'bibtex-completion-candidates)
+              (lambda ()
+                (seq-filter
+                 (lambda (candidate) (assoc "=has-note=" candidate))
+                 candidates))))
+    (ivy-bibtex arg)))
+
+(ivy-set-display-transformer
+ 'ivy-bibtex
+ 'ivy-bibtex-display-transformer)
+
+(ivy-set-actions
+ 'ivy-bibtex
+ '(("p" ivy-bibtex-open-pdf "Open PDF file (if present)")
+   ("u" ivy-bibtex-open-url-or-doi "Open URL or DOI in browser")
+   ("c" ivy-bibtex-insert-citation "Insert citation")
+   ("r" ivy-bibtex-insert-reference "Insert reference")
+   ("k" ivy-bibtex-insert-key "Insert BibTeX key")
+   ("b" ivy-bibtex-insert-bibtex "Insert BibTeX entry")
+   ("a" ivy-bibtex-add-PDF-attachment "Attach PDF to email")
+   ("e" ivy-bibtex-edit-notes "Edit notes")
+   ("s" ivy-bibtex-show-entry "Show entry")
+   ("l" ivy-bibtex-add-pdf-to-library "Add PDF to library")
+   ("f" (lambda (_candidate) (ivy-bibtex-fallback ivy-text)) "Fallback options")))
+
+(provide 'ivy-bibtex)
+
+;; Local Variables:
+;; byte-compile-warnings: (not cl-functions obsolete)
+;; coding: utf-8
+;; indent-tabs-mode: nil
+;; End:
+
+;;; ivy-bibtex.el ends here
diff --git a/lisp/langtool.el b/lisp/langtool.el
new file mode 100644
index 00000000..d75aae56
--- /dev/null
+++ b/lisp/langtool.el
@@ -0,0 +1,1731 @@
+;;; langtool.el --- Grammar check utility using LanguageTool
+
+;; Copyright (C) 2011-2020 Masahiro Hayashi
+
+;; Author: Masahiro Hayashi 
+;; Keywords: docs
+;; Package-Version: 20200529.230
+;; Package-Commit: 8276eccc5587bc12fd205ee58a7a982f0a136e41
+;; URL: https://github.com/mhayashi1120/Emacs-langtool
+;; Emacs: GNU Emacs 24 or later
+;; Version: 2.2.1
+;; Package-Requires: ((cl-lib "0.3"))
+
+;; 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, 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; ## Install:
+
+;; Install LanguageTool version 3.0 or later (and java)
+;; https://languagetool.org/
+
+;; Put this file into load-path'ed directory, and byte compile it if
+;; desired. And put the following expression into your ~/.emacs.
+;;
+;;     (require 'langtool)
+
+;; ## Settings (required):
+;;
+;; langtool.el have 3 types of client.
+
+;; 1. Command line
+;;
+;;  This setting should be set, if you use rest of clients, to get full of
+;;  completion support. And you should be set the variables before load
+;;  this library.
+;;
+;;     (setq langtool-language-tool-jar "/path/to/languagetool-commandline.jar")
+;;     (require 'langtool)
+;;
+;; Alternatively, you can set the classpath where LanguageTool's jars reside
+;; (e.g. ArchLinux):
+;;
+;;     (setq langtool-java-classpath
+;;           "/usr/share/languagetool:/usr/share/java/languagetool/*")
+;;     (require 'langtool)
+;;
+;;
+;; You can set a script that hold java setting (e.g. Gentoo):
+;;
+;;     (setq langtool-bin "/path/to/your/langtool")
+;;     (require 'langtool)
+
+;; 2. HTTP server & client
+;;
+;;  You can use HTTP server implementation. This is very fast after listen server,
+;;  but has security risk if there are multiple user on a same host.
+;;
+;;     (setq langtool-language-tool-server-jar "/path/to/languagetool-server.jar")
+;;
+;; You can change HTTP server port number like following.
+;;
+;;     (setq langtool-server-user-arguments '("-p" "8082"))
+
+;; 3. HTTP client
+;;
+;; If you have running HTTP LanguageTool server instance on any machine:
+;;
+;;     (setq langtool-http-server-host "localhost"
+;;           langtool-http-server-port 8082)
+;;
+;; Now testing although, that running instance is working under HTTPSServer or via
+;; general ssl support (e.g. nginx) following may be working. Again, this is now
+;; testing, so please open issue when the ssl/tls connection is not working.
+;;
+;;     (setq langtool-http-server-stream-type 'tls)
+
+;; ## Optional settings
+;;
+;; * Key binding if you desired.
+;;
+;;     (global-set-key "\C-x4w" 'langtool-check)
+;;     (global-set-key "\C-x4W" 'langtool-check-done)
+;;     (global-set-key "\C-x4l" 'langtool-switch-default-language)
+;;     (global-set-key "\C-x44" 'langtool-show-message-at-point)
+;;     (global-set-key "\C-x4c" 'langtool-correct-buffer)
+
+;; * Default language is detected by LanguageTool automatically.
+;;   Please set `langtool-default-language` if you need specific language.
+;;
+;;     (setq langtool-default-language "en-US")
+;;
+;;   Otherwise, invoke `M-x langtool-check` with `C-u` (universal-argument)
+
+;; * Currently GNU java version is not working.
+;;   Please change the variable to your favorite java executable.
+;;
+;;     (setq langtool-java-bin "/path/to/java")
+
+;; * Maybe your LanguageTool have launcher. (e.g. Gentoo)
+;;   You need to set `langtool-bin'.
+;;   See https://github.com/mhayashi1120/Emacs-langtool/issues/24
+;;
+;;     (setq langtool-bin "/usr/bin/languagetool")
+
+;; * Maybe you want to specify your mother tongue.
+;;
+;;     (setq langtool-mother-tongue "en")
+
+;; * To customize LanguageTool commandline arguments.
+;;
+;;     (setq langtool-java-user-arguments '("-Dfile.encoding=UTF-8"))
+;;
+;;   You can also make the variable to buffer local like following:
+;;
+;;     (add-hook '**SOME**-mode-hook
+;;               (lambda () (set (make-local-variable 'langtool-java-user-arguments)
+;;                              '("-Dfile.encoding=UTF-8"))))
+;;
+;;   NOTE: Although there is no good example, `langtool-user-arguments' is
+;;   a similar custom variable.
+
+;; ## Usage:
+
+;; * To check current buffer and show warnings.
+;;
+;;     M-x langtool-check
+;;
+;;   Check with different language. You can complete supported language
+;;   with C-i/TAB
+;;
+;;     C-u M-x langtool-check
+
+;; * To correct marker follow LanguageTool suggestions.
+;;
+;;     M-x langtool-correct-buffer
+
+;; * Go to warning point you can see a report from LanguageTool.
+;;   Otherwise:
+;;
+;;     M-x langtool-show-message-at-point
+
+;; * Show LanguageTool report automatically by `popup'
+;;   This idea come from:
+;;   https://laclefyoshi.hatenablog.com/entry/20150912/langtool_popup
+;;
+;;     (defun langtool-autoshow-detail-popup (overlays)
+;;       (when (require 'popup nil t)
+;;         ;; Do not interrupt current popup
+;;         (unless (or popup-instances
+;;                     ;; suppress popup after type `C-g' .
+;;                     (memq last-command '(keyboard-quit)))
+;;           (let ((msg (langtool-details-error-message overlays)))
+;;             (popup-tip msg)))))
+;;
+;;     (setq langtool-autoshow-message-function
+;;           'langtool-autoshow-detail-popup)
+
+;; * To finish checking. All langtool marker is removed.
+;;
+;;     M-x langtool-check-done
+
+;;; TODO:
+
+;; * process coding system (test on Windows)
+;; * check only docstring (emacs-lisp-mode)
+;;    or using (derived-mode-p 'prog-mode) and only string and comment
+;; * java encoding <-> elisp encoding (No enough information..)
+;; * change to --json argument to parse.
+
+;;; Code:
+
+
+(require 'cl-lib)
+(require 'compile)
+(require 'json)
+(require 'pcase)
+
+(defgroup langtool nil
+  "Customize langtool"
+  :prefix "langtool-"
+  :group 'applications)
+
+;;;
+;;; Variables / Faces
+;;;
+
+;;
+;; constants
+;;
+
+(defconst langtool-output-regexp
+  (eval-when-compile
+    (concat
+     "^[0-9]+\\.) Line \\([0-9]+\\), column \\([0-9]+\\), Rule ID: \\(.*\\)\n"
+     "Message: \\(.*\\)\n"
+     "\\(?:Suggestion: \\(.*\\)\n\\)?"
+     ;; As long as i can read
+     ;; src/dev/de/danielnaber/languagetool/dev/wikipedia/OutputDumpHandler.java
+     "\\(\\(?:.*\\)\n\\(?:[ ^]+\\)\\)\n"
+     "\n?"                              ; last result have no new-line
+     )))
+
+;;
+;; externals
+;;
+
+(defvar current-prefix-arg)
+(defvar unread-command-events)
+(defvar locale-language-names)
+
+;;
+;; faces
+;;
+
+(defface langtool-errline
+  '((((class color) (background dark)) (:background "Firebrick4"))
+    (((class color) (background light)) (:background "LightPink"))
+    (t (:bold t)))
+  "Face used for marking error lines."
+  :group 'langtool)
+
+(defface langtool-correction-face
+  '((((class mono)) (:inverse-video t :bold t :underline t))
+    (t (:background "red1" :foreground "yellow" :bold t)))
+  "Face used to visualize correction."
+  :group 'langtool)
+
+;;
+;; customize variables
+;;
+
+(defcustom langtool-java-bin "java"
+  "Executing java command."
+  :group 'langtool
+  :type 'file)
+
+(defcustom langtool-bin nil
+  "Executing LanguageTool command."
+  :group 'langtool
+  :type 'file)
+
+(defcustom langtool-java-user-arguments nil
+  "List of string which is passed to java command as arguments.
+This java command holds LanguageTool process.
+Otherwise, function which return above value.
+
+e.g. ( Described at http://wiki.languagetool.org/command-line-options )
+\(setq langtool-java-user-arguments '(\"-Dfile.encoding=UTF-8\"))
+
+"
+  :group 'langtool
+  :type '(choice
+          (repeat string)
+          function))
+
+(defcustom langtool-language-tool-jar nil
+  "LanguageTool jar file.
+
+No need to set this variable when `langtool-java-classpath' is set."
+  :group 'langtool
+  :type 'file)
+
+(defcustom langtool-language-tool-server-jar nil
+  "LanguageTool server jar file.
+Very fast, but do not use it if there is unreliable user on a same host."
+  :group 'langtool
+  :type 'file)
+
+(defcustom langtool-http-server-host nil
+  "Normally should be \"localhost\" . Do not set the untrusted host/network.
+Your post may not be encrypted application layer, so your privacy may be leaked.
+
+Please set `langtool-http-server-port' either.
+"
+  :group 'langtool
+  :type 'string)
+
+(defcustom langtool-http-server-port nil
+  "See `langtool-http-server-host' ."
+  :group 'langtool
+  :type 'number)
+
+(defcustom langtool-http-server-stream-type nil
+  "This is now testing and not enough tested yet. This value is passed to
+`open-network-stream' `:type' argument.
+Valid arguments are same to above except `nil'. This means `plain'."
+  :group 'langtool
+  :type 'symbol)
+
+(defcustom langtool-java-classpath nil
+  "Custom classpath to use on special environment. (e.g. Arch Linux)
+Do not set both of this variable and `langtool-language-tool-jar'.
+
+https://github.com/mhayashi1120/Emacs-langtool/pull/12
+https://github.com/mhayashi1120/Emacs-langtool/issues/8"
+  :group 'langtool
+  :type 'string)
+
+(defcustom langtool-default-language nil
+  "Language name pass to LanguageTool command.
+This is string which indicate locale or `auto' or `nil'.
+Currently `auto' and `nil' is a same meaning."
+  :group 'langtool
+  :type '(choice
+          string
+          (const auto)
+          (const nil)))
+
+(defcustom langtool-mother-tongue nil
+  "Your mothertongue Language name pass to LanguageTool."
+  :group 'langtool
+  :type 'string)
+
+(defcustom langtool-disabled-rules nil
+  "Disabled rules pass to LanguageTool.
+String that separated by comma or list of string.
+"
+  :group 'langtool
+  :type '(choice
+          (list string)
+          string))
+
+(defcustom langtool-user-arguments nil
+  "Similar to `langtool-java-user-arguments' except this list is appended
+ after `-jar' argument.
+
+Valid values are described below:
+http://wiki.languagetool.org/command-line-options
+
+Do not change this variable if you don't understand what you are doing.
+"
+  :group 'langtool
+  :type '(choice
+          (repeat string)
+          function))
+
+(defcustom langtool-server-user-arguments nil
+  "`langtool-language-tool-server-jar' customize arguments.
+You can pass `--config' option to the server that indicate java property file.
+
+You can see all valid arguments with following command (Replace path by yourself):
+java -jar /path/to/languagetool-server.jar --help
+"
+  :group 'langtool
+  :type '(choice
+          (repeat string)
+          function))
+
+(defcustom langtool-client-filter-query-function nil
+  "Filter function that accept one query form argument.
+This query form is an alist will be encoded by `url-build-query-string'.
+Call just before POST with `application/x-www-form-urlencoded'."
+  :group 'langtool
+  :type 'function)
+
+(defcustom langtool-error-exists-hook
+  '(langtool-autoshow-ensure-timer)
+  "Hook run after LanguageTool process found any error(s)."
+  :group 'langtool
+  :type 'hook)
+
+(defcustom langtool-noerror-hook nil
+  "Hook run after LanguageTool report no error."
+  :group 'langtool
+  :type 'hook)
+
+(defcustom langtool-finish-hook
+  '(langtool-autoshow-cleanup-timer-maybe)
+  "Hook run after cleanup buffer."
+  :group 'langtool
+  :type 'hook)
+
+;;
+;; local variables
+;;
+
+(defvar langtool-local-disabled-rules nil)
+(make-variable-buffer-local 'langtool-local-disabled-rules)
+
+(defvar langtool-temp-file nil)
+(make-variable-buffer-local 'langtool-temp-file)
+
+(defvar langtool-buffer-process nil)
+(make-variable-buffer-local 'langtool-buffer-process)
+
+(defvar langtool-mode-line-message nil)
+(make-variable-buffer-local 'langtool-mode-line-message)
+(put 'langtool-mode-line-message 'risky-local-variable t)
+
+(defvar langtool-mode-line-process nil)
+(make-variable-buffer-local 'langtool-mode-line-process)
+(put 'langtool-mode-line-process 'risky-local-variable t)
+
+(defvar langtool-mode-line-server-process nil)
+(put 'langtool-mode-line-server-process 'risky-local-variable t)
+
+(defvar langtool-error-buffer-name " *LanguageTool Errors* ")
+
+(defvar langtool--debug nil)
+
+(defvar langtool--correction-keys
+  ;; (q)uit, (c)lear, (e)dit, (i)gnore
+  [?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
+      ;; suggestions may over 10.
+      ;; define rest of alphabet just in case.
+      ?a ?b ?d ?f ?g ?h ?j ?k ?l ?m ?n
+      ?o ?p ?r ?s ?t ?u ?v ?w ?x ?y ?z])
+
+;;;
+;;; Internal functions
+;;;
+
+;;
+;; basic functions
+;;
+
+(defun langtool-region-active-p ()
+  (cond
+   ((fboundp 'region-active-p)
+    (funcall 'region-active-p))
+   (t
+    (and transient-mark-mode mark-active))))
+
+(defun langtool--debug (key fmt &rest args)
+  (when langtool--debug
+    (let ((buf (get-buffer-create "*Langtool Debug*")))
+      (with-current-buffer buf
+        (goto-char (point-max))
+        (insert "---------- [" key "] ----------\n")
+        (insert (apply 'format fmt args) "\n")))))
+
+(defun langtool--chomp (s)
+  (if (string-match "\\(?:\\(\r\n\\)+\\|\\(\n\\)+\\)\\'" s)
+      (substring s 0 (match-beginning 0))
+    s))
+
+(defun langtool--make-temp-file ()
+  (make-temp-file "langtool-"))
+
+;;
+;; HTTP basic
+;;
+
+(defun langtool-http--parse-response-header ()
+  ;; Not a exact parser. Just a necessary. ;-)
+  (save-excursion
+    (goto-char (point-min))
+    (unless (re-search-forward "^\r\n" nil t)
+      (error "Parse error. Not found http header separator."))
+    (let (status headers body-start)
+      (setq body-start (point))
+      (forward-line -1)
+      (save-restriction
+        (narrow-to-region (point-min) (point))
+        (goto-char (point-min))
+        (unless (looking-at "^HTTP/[0-9.]+[\s\t]+\\([0-9]+\\)")
+          (error "Parse error. Not found HTTP status code"))
+        (setq status (string-to-number (match-string-no-properties 1)))
+        (forward-line)
+        (while (not (eobp))
+          (let (key value)
+            (unless (looking-at "^\\([^:]+\\):")
+              (error "Invalid header of HTTP response"))
+            (setq key (match-string-no-properties 1))
+            (goto-char (match-end 0))
+            (while (looking-at "[\s\t]+\\(.*\\)\r")
+              (setq value (concat value (match-string-no-properties 1)))
+              (forward-line 1))
+            (setq headers (cons (cons key value) headers))))
+        (list status headers body-start)))))
+
+;;
+;; handle error overlay
+;;
+
+;;FIXME
+;;http://sourceforge.net/tracker/?func=detail&aid=3054895&group_id=110216&atid=655717
+(defun langtool--fuzzy-search (context-regexp length)
+  (let* ((regexp (concat ".*?" context-regexp))
+         (default (cons (point) (+ (point) length))))
+    (or (and (null regexp)
+             (cons (point) (+ (point) length)))
+        (and (looking-at regexp)
+             (cons (match-beginning 1) (match-end 1)))
+        (let ((beg (min (point-at-bol) (- (point) 20))))
+          (cl-loop while (and (not (bobp))
+                              (<= beg (point)))
+                   ;; backward just sentence length to search sentence after point
+                   do (condition-case nil
+                          (backward-char length)
+                        (beginning-of-buffer nil))
+                   if (looking-at regexp)
+                   return (cons (match-beginning 1) (match-end 1))))
+        default)))
+
+(defun langtool--compute-start&end (version check)
+  (let ((line (nth 0 check))
+        (col (nth 1 check))
+        (len (nth 2 check))
+        (context (nth 7 check))
+        ;; Only Server <-> Client have the data
+        (offset (nth 8 check)))
+    (cond
+     (offset
+      (let* ((start (+ (point-min) offset))
+             (end (+ start len)))
+        (cons start end)))
+     (context
+      ;; Command-line client have a bug that point to wrong place.
+      (goto-char (point-min))
+      (forward-line (1- line))
+      ;;  1. sketchy move to column that is indicated by LanguageTool.
+      ;;  2. fuzzy match to reported sentence which indicated by ^^^ like string.
+      ;;  3. restrict to the current line
+      (when (< 0 col)
+        (forward-char (1- col)))
+      (langtool--fuzzy-search context len))
+     (t
+      (goto-char (point-min))
+      (forward-line (1- line))
+      (forward-char col)
+      (cons (point) (+ (point) len))))))
+
+(defun langtool--create-overlay (version check)
+  (cl-destructuring-bind (start . end)
+      (langtool--compute-start&end version check)
+    (let ((ov (make-overlay start end)))
+      (overlay-put ov 'langtool-simple-message (nth 4 check))
+      (overlay-put ov 'langtool-message (nth 5 check))
+      (overlay-put ov 'langtool-suggestions (nth 3 check))
+      (overlay-put ov 'langtool-rule-id (nth 6 check))
+      (overlay-put ov 'priority 1)
+      (overlay-put ov 'face 'langtool-errline))))
+
+(defun langtool--clear-buffer-overlays ()
+  (mapc
+   (lambda (ov)
+     (delete-overlay ov))
+   (langtool--overlays-region (point-min) (point-max))))
+
+(defun langtool--overlays-region (start end)
+  (sort
+   (remove
+    nil
+    (mapcar
+     (lambda (ov)
+       (when (overlay-get ov 'langtool-message)
+         ov))
+     (overlays-in start end)))
+   (lambda (ov1 ov2)
+     (< (overlay-start ov1) (overlay-start ov2)))))
+
+(defun langtool--current-error-overlays ()
+  (remove nil
+          (mapcar
+           (lambda (ov)
+             (and (overlay-get ov 'langtool-message)
+                  ov))
+           (overlays-at (point)))))
+
+(defun langtool--expire-buffer-overlays ()
+  (mapc
+   (lambda (o)
+     (unless (overlay-get o 'face)
+       (delete-overlay o)))
+   (langtool--overlays-region (point-min) (point-max))))
+
+(defun langtool--erase-overlay (ov)
+  (overlay-put ov 'face nil))
+
+(defun langtool--next-overlay (current overlays)
+  (cl-loop for o in (cdr (memq current overlays))
+           if (overlay-get o 'face)
+           return o))
+
+(defun langtool--prev-overlay (current overlays)
+  (cl-loop for o in (cdr (memq current (reverse overlays)))
+           if (overlay-get o 'face)
+           return o))
+
+(defun langtool--goto-error (overlays predicate)
+  (catch 'done
+    (mapc
+     (lambda (ov)
+       (when (funcall predicate ov)
+         (goto-char (overlay-start ov))
+         (throw 'done t)))
+     overlays)
+    nil))
+
+(defun langtool-working-p ()
+  (cl-loop with current = (current-buffer)
+           for buf in (buffer-list)
+           when (and (not (eq buf current))
+                     (with-current-buffer buf
+                       (langtool--overlays-region
+                        (point-min) (point-max))))
+           return buf
+           finally return nil))
+
+;;
+;; utility
+;;
+
+(defun langtool-simple-error-message (overlays)
+  "Textify error messages as long as simple."
+  (mapconcat
+   (lambda (ov)
+     (format
+      "[%s] %s%s"
+      (overlay-get ov 'langtool-rule-id)
+      (overlay-get ov 'langtool-simple-message)
+      (if (overlay-get ov 'langtool-suggestions)
+          (concat
+           " -> ("
+           (mapconcat 'identity (overlay-get ov 'langtool-suggestions) ", ")
+           ")")
+        "")))
+   overlays "\n"))
+
+(defun langtool-details-error-message (overlays)
+  "Textify error messages."
+  (mapconcat
+   (lambda (ov)
+     (concat
+      (format "Rule ID: %s\n"
+              (overlay-get ov 'langtool-rule-id))
+      (format "Message: %s\n"
+              (overlay-get ov 'langtool-simple-message))
+      (if (overlay-get ov 'langtool-suggestions)
+          (concat
+           "Suggestions: "
+           (mapconcat
+            'identity
+            (overlay-get ov 'langtool-suggestions)
+            "; "))
+        "")))
+   overlays
+   "\n\n"))
+
+(defun langtool--current-error-messages ()
+  (mapcar
+   (lambda (ov)
+     (overlay-get ov 'langtool-message))
+   (langtool--current-error-overlays)))
+
+;;;
+;;; LanguageTool Process
+;;;
+
+;;
+;; Process basic
+;;
+
+(defmacro langtool--with-java-environ (&rest form)
+  `(let ((coding-system-for-read langtool-process-coding-system))
+     (progn ,@form)))
+
+(defun langtool--process-file-name (path)
+  "Correct the file name depending on the underlying platform.
+
+PATH: The file-name path to be corrected.
+
+Currently corrects the file-name-path when running under Cygwin."
+  (setq path (expand-file-name path))
+  (cond
+   ((eq system-type 'cygwin)
+    ;; no need to catch error. (e.g. cygpath is not found)
+    ;; this failure means LanguageTools is not working completely.
+    (with-temp-buffer
+      (call-process "cygpath" nil t nil "--windows" path)
+      (langtool--chomp (buffer-string))))
+   (t
+    path)))
+
+(defcustom langtool-process-coding-system
+  (cond
+   ((eq system-type 'cygwin)
+    'dos)
+   (t nil))
+  "LanguageTool process coding-system.
+Ordinary no need to change this."
+  :group 'langtool
+  :type 'coding-system)
+
+(defun langtool--custom-arguments (var)
+  (let ((value (symbol-value var))
+        args)
+    (cond
+     ((functionp value)
+      (setq args (funcall value)))
+     ((consp value)
+      (setq args value)))
+    (copy-sequence args)))
+
+;;
+;; Command interaction
+;;
+
+(defun langtool--disabled-rules ()
+  (let ((custom langtool-disabled-rules)
+        (locals langtool-local-disabled-rules))
+    (cond
+     ((stringp custom)
+      (mapconcat 'identity
+                 (cons custom locals)
+                 ","))
+     (t
+      (mapconcat 'identity
+                 (append custom locals)
+                 ",")))))
+
+(defun langtool--basic-command&args ()
+  (cond
+   (langtool-bin
+    (list langtool-bin nil))
+   (t
+    (let (command args)
+      (setq command langtool-java-bin)
+      ;; Construct arguments pass to java command
+      (setq args (langtool--custom-arguments 'langtool-java-user-arguments))
+      (cond
+       (langtool-java-classpath
+        (setq args (append
+                    args
+                    (list "-cp" langtool-java-classpath
+                          "org.languagetool.commandline.Main")))
+        (list command args))
+       (langtool-language-tool-jar
+        (setq args (append
+                    args
+                    (list "-jar" (langtool--process-file-name langtool-language-tool-jar))))
+        (list command args))
+       (t nil))))))
+
+(defun langtool--process-create-client-buffer ()
+  (generate-new-buffer " *Langtool* "))
+
+(defun langtool--sentence-to-fuzzy (sentence)
+  (mapconcat 'regexp-quote
+             ;; this sentence is reported by LanguageTool
+             (split-string sentence " +")
+             ;; LanguageTool interpreted newline as space.
+             "[[:space:]\n]+?"))
+
+(defun langtool--pointed-length (message)
+  (or
+   (and (string-match "\n\\( *\\)\\(\\^+\\)" message)
+        (length (match-string 2 message)))
+   ;; never through here, but if return nil from this function make stop everything.
+   1))
+
+;;FIXME sometimes LanguageTool reports wrong column.
+(defun langtool--pointed-context-regexp (message)
+  (when (string-match "\\(.*\\)\n\\( *\\)\\(\\^+\\)" message)
+    (let* ((msg1 (match-string 1 message))
+           ;; calculate marker "^" start at column
+           (pre (length (match-string 2 message)))
+           ;; "^" marker length
+           (len (length (match-string 3 message)))
+           (end (+ pre len))
+           (sentence (substring msg1 pre end))
+           (regexp (cond
+                    ((string-match "^[[:space:]]+$" sentence)
+                     ;; invalid sentence only have whitespace,
+                     ;; search with around sentence.
+                     (concat
+                      "\\("
+                      (let* ((count (length sentence))
+                             (spaces (format "[[:space:]\n]\\{%d\\}" count)))
+                        spaces)
+                      "\\)"
+                      ;; considered truncated spaces that is caused by
+                      ;; `langtool--sentence-to-fuzzy'
+                      "[[:space:]]*?"
+                      ;; to match the correct block
+                      ;; suffix of invalid spaces.
+                      (langtool--sentence-to-fuzzy
+                       (let ((from (min end (length msg1))))
+                         ;;TODO magic number.
+                         (substring msg1 from (min (length msg1) (+ from 20)))))))
+                    (t
+                     (concat "\\("
+                             (langtool--sentence-to-fuzzy sentence)
+                             "\\)")))))
+      regexp)))
+
+;;
+;; Commandline / HTTP integration
+;;
+
+(defun langtool--checker-mode ()
+  ;; NOTE: This priority is order by light weight.
+  (cond
+   ((and langtool-http-server-host
+         langtool-http-server-port)
+    'http-client)
+   (langtool-language-tool-server-jar
+    'client-server)
+   ((or langtool-language-tool-jar
+        langtool-java-classpath
+        langtool-bin)
+    'commandline)
+   (t
+    (error "There is no valid setting."))))
+
+(defun langtool--apply-checks (proc checks)
+  (let ((source (process-get proc 'langtool-source-buffer))
+        (version (process-get proc 'langtool-jar-version))
+        (begin (process-get proc 'langtool-region-begin))
+        (finish (process-get proc 'langtool-region-finish)))
+    (when (buffer-live-p source)
+      (with-current-buffer source
+        (save-excursion
+          (save-restriction
+            (when (and begin finish)
+              (narrow-to-region begin finish))
+            (mapc
+             (lambda (check)
+               (langtool--create-overlay version check))
+             (nreverse checks))))))))
+
+(defun langtool--lazy-apply-checks (proc version checks)
+  (let ((source (process-get proc 'langtool-source-buffer))
+        (begin (process-get proc 'langtool-region-begin))
+        (finish (process-get proc 'langtool-region-finish)))
+    (when (buffer-live-p source)
+      (with-current-buffer source
+        (save-excursion
+          (save-restriction
+            (when (and begin finish)
+              (narrow-to-region begin finish))
+            (cond
+             ((consp checks)
+              (langtool--create-overlay version (car checks))
+              (run-with-idle-timer
+               1 nil 'langtool--lazy-apply-checks
+               proc version (cdr checks)))
+             (t
+              (let ((source (process-get proc 'langtool-source-buffer)))
+                (langtool--check-finish source nil))))))))))
+
+(defun langtool--check-finish (source errmsg)
+  (let (marks face)
+    (when (buffer-live-p source)
+      (with-current-buffer source
+        (setq marks (langtool--overlays-region (point-min) (point-max)))
+        (setq face (cond
+                    (errmsg
+                     compilation-error-face)
+                    (marks
+                     compilation-warning-face)
+                    (t
+                     compilation-info-face)))
+        (setq langtool-buffer-process nil)
+        (setq langtool-mode-line-process
+              (propertize ":exit" 'face face))
+        (cond
+         (errmsg
+          (message "%s" errmsg))
+         (marks
+          (run-hooks 'langtool-error-exists-hook)
+          (message "%s"
+                   (substitute-command-keys
+                    "Type \\[langtool-correct-buffer] to correct buffer.")))
+         (t
+          (run-hooks 'langtool-noerror-hook)
+          (message "LanguageTool successfully finished with no error.")))))))
+
+;;
+;; LanguageTool Commandline
+;;
+
+(defun langtool-command--check-command ()
+  (cond
+   (langtool-bin
+    (unless (executable-find langtool-bin)
+      (error "LanguageTool command not executable")))
+   ((or (null langtool-java-bin)
+        (not (executable-find langtool-java-bin)))
+    (error "java command is not found")))
+  (cond
+   (langtool-java-classpath)
+   (langtool-language-tool-jar
+    (unless (file-readable-p langtool-language-tool-jar)
+      (error "langtool jar file is not readable"))))
+  (when langtool-buffer-process
+    (error "Another process is running")))
+
+;; Create utf-8-unix temporary file if need. This coding-system is
+;; troubleless, I think.
+(defun langtool-command--maybe-create-temp-file (&optional begin finish)
+  (let* ((file (buffer-file-name))
+         (cs buffer-file-coding-system)
+         (cs-base (coding-system-base cs))
+         custom-cs)
+    (unless langtool-temp-file
+      (setq langtool-temp-file (langtool--make-temp-file)))
+    ;; create temporary file to pass the text contents to LanguageTool
+    (when (or (null file)
+              (buffer-modified-p)
+              (and begin finish)
+              ;; 1 is dos EOL style, this must convert to unix
+              ;; dos (CR-LF) style EOL may destroy position of marker.
+              (eq (coding-system-eol-type cs) 1)
+              ;; us-ascii is included in utf-8
+              (and (not (coding-system-equal cs-base 'us-ascii))
+                   (not (coding-system-equal cs-base 'utf-8))))
+      (save-restriction
+        (widen)
+        (let ((coding-system-for-write 'utf-8-unix))
+          ;; BEGIN nil means entire buffer
+          (write-region begin finish langtool-temp-file nil 'no-msg))
+        (setq file langtool-temp-file)))
+    file))
+
+(defun langtool-command--invoke-process (file begin finish &optional lang)
+  (let ((version (langtool--jar-version)))
+    (cl-destructuring-bind (command args)
+        (langtool--basic-command&args)
+      ;; Construct arguments pass to jar file.
+      ;; http://wiki.languagetool.org/command-line-options
+      (setq args (append
+                  args
+                  (list
+                   "-d" (langtool--disabled-rules))))
+      (cond
+       ((stringp (or lang langtool-default-language))
+        (setq args (append args (list "-l" (or lang langtool-default-language)))))
+       (t
+        (setq args (append args (list "--autoDetect")))))
+      (when langtool-mother-tongue
+        (setq args (append args (list "-m" langtool-mother-tongue))))
+      (setq args (append args (langtool--custom-arguments 'langtool-user-arguments)))
+      (setq args (append args (list (langtool--process-file-name file))))
+      (langtool--debug "Command" "%s: %s" command args)
+      (let* ((buffer (langtool--process-create-client-buffer))
+             (proc (langtool--with-java-environ
+                    (apply 'start-process "LanguageTool" buffer command args))))
+        (set-process-filter proc 'langtool-command--process-filter)
+        (set-process-sentinel proc 'langtool-command--process-sentinel)
+        (process-put proc 'langtool-source-buffer (current-buffer))
+        (process-put proc 'langtool-region-begin begin)
+        (process-put proc 'langtool-region-finish finish)
+        (process-put proc 'langtool-jar-version version)
+        proc))))
+
+(defun langtool-command--process-filter (proc event)
+  (langtool--debug "Filter" "%s" event)
+  (with-current-buffer (process-buffer proc)
+    (goto-char (point-max))
+    (insert event)
+    (let ((min (or (process-get proc 'langtool-process-done)
+                   (point-min)))
+          checks)
+      (goto-char min)
+      (while (re-search-forward langtool-output-regexp nil t)
+        (let* ((line (string-to-number (match-string 1)))
+               (column (1- (string-to-number (match-string 2))))
+               (rule-id (match-string 3))
+               (suggest (match-string 5))
+               (msg1 (match-string 4))
+               ;; rest of line. Point the raw message.
+               (msg2 (match-string 6))
+               (message
+                (concat "Rule ID: " rule-id "\n"
+                        msg1 "\n\n"
+                        msg2))
+               (suggestions (and suggest (split-string suggest "; ")))
+               (context (langtool--pointed-context-regexp msg2))
+               (len (langtool--pointed-length msg2)))
+          (setq checks (cons
+                         (list line column len suggestions
+                               msg1 message rule-id context)
+                         checks))))
+      (process-put proc 'langtool-process-done (point))
+      (langtool--apply-checks proc checks))))
+
+(defun langtool-command--process-sentinel (proc event)
+  (langtool--debug "Sentinel" "event: %s" event)
+  (unless (process-live-p proc)
+    (let ((code (process-exit-status proc))
+          (pbuf (process-buffer proc))
+          (source (process-get proc 'langtool-source-buffer))
+          dead marks errmsg face)
+      (cond
+       ((buffer-live-p pbuf)
+        (when (/= code 0)
+          ;; Get first line of output.
+          (with-current-buffer pbuf
+            (goto-char (point-min))
+            (setq errmsg
+                  (format "LanguageTool exited abnormally with code %d (%s)"
+                          code (buffer-substring (point) (point-at-eol))))))
+        (kill-buffer pbuf))
+       (t
+        (setq errmsg "Buffer was dead")))
+      (langtool--check-finish source errmsg))))
+
+;;;
+;;; Adapter for internal/external server
+;;;
+
+(defvar langtool-adapter--plist nil)
+
+(defun langtool-adapter-ensure-internal (process)
+  (setq langtool-adapter--plist
+        (cons 'internal
+              (list
+               'process process
+               'finalizer `(lambda () (langtool-server-ensure-stop ,process))
+               'host (process-get process 'langtool-server-host)
+               'port (process-get process 'langtool-server-port)))))
+
+(defun langtool-adapter-ensure-external ()
+  (setq langtool-adapter--plist
+        (cons 'external
+              (list
+               'host langtool-http-server-host
+               'port langtool-http-server-port
+               'stream-type langtool-http-server-stream-type))))
+
+(defun langtool-adapter-get (key)
+  (plist-get (cdr langtool-adapter--plist) key))
+
+(defun langtool-adapter-ensure-terminate ()
+  (when langtool-adapter--plist
+    (let ((finalizer (langtool-adapter-get 'finalizer)))
+      (when finalizer
+        (funcall finalizer)))
+    (setq langtool-adapter--plist nil)))
+
+;;
+;; LanguageTool HTTP Server <-> Client
+;;
+
+(defun langtool-server--check-command ()
+  (cond
+   ((or (null langtool-java-bin)
+        (not (executable-find langtool-java-bin)))
+    (error "java command is not found")))
+  (unless langtool-language-tool-server-jar
+    (error "Please set `langtool-language-tool-server-jar'"))
+  (unless (file-readable-p langtool-language-tool-server-jar)
+    (error "languagetool-server jar file is not readable")))
+
+(defun langtool-http-client-check-command ()
+  ;; Currently no need to check command. Just HTTP post.
+  )
+
+(defun langtool-server-ensure-stop (proc)
+  (when (processp proc)
+    (let ((buffer (process-buffer proc)))
+      (delete-process proc)
+      (when (buffer-live-p buffer)
+        (kill-buffer buffer)))))
+
+(defun langtool-server--parse-initial-buffer ()
+  (save-excursion
+    (goto-char (point-min))
+    (cond
+     ((re-search-forward (eval-when-compile
+                           (concat
+                            "Starting LanguageTool "
+                            "\\([0-9.]+\\)\\(?:-SNAPSHOT\\)? "
+                            ".+?"
+                            "server on https?://\\([^:]+\\):\\([0-9]+\\)"
+                            "\\.\\.\\."
+                            "$"))
+                         nil t))
+     (t
+      (error "Unable parse initial buffer")))
+    (let ((version (match-string 1))
+          (host (match-string 2))
+          (port (string-to-number (match-string 3))))
+      (list version host port))))
+
+(defun langtool-server--rendezvous (proc buffer)
+  (message "Waiting for server")
+  (catch 'rendezvous
+    (with-current-buffer buffer
+      (save-excursion
+        (while t
+          (goto-char (point-min))
+          (when (re-search-forward "Server started" nil t)
+            (cl-destructuring-bind (version host port)
+                (langtool-server--parse-initial-buffer)
+              (when (version< version "4.0")
+                (langtool-server-ensure-stop proc)
+                (error "LanguageTool Server version must be than 4.0 but now %s"
+                       version))
+              (process-put proc 'langtool-server-host host)
+              (process-put proc 'langtool-server-port port)
+              (message "%s done." (current-message))
+              (throw 'rendezvous t)))
+          (unless (eq (process-status proc) 'run)
+            (langtool-server-ensure-stop proc)
+            (error "Failed to start LanguageTool Server."))
+          (message "%s." (current-message))
+          (accept-process-output proc 0.1 nil t))))))
+
+(defvar langtool-server--process-exit-hook nil)
+
+(defun langtool-server--process-sentinel (proc event)
+  (langtool--debug "Sentinel" "event: %s" event)
+  (unless (process-live-p proc)
+    (run-hooks 'langtool-server--process-exit-hook)))
+
+(defun langtool-server--ensure-running ()
+  (langtool-server--check-command)
+  (unless (let ((proc (langtool-adapter-get 'process)))
+            (and  (processp proc)
+                  (eq (process-status proc) 'run)))
+    ;; Force terminate previous server process if exists.
+    (langtool-adapter-ensure-terminate)
+    (let* ((bin langtool-java-bin)
+           (args '()))
+      ;; jar Default setting is "HTTPSServer" .
+      ;; This application no need to use SSL since local app.
+      ;; http://wiki.languagetool.org/http-server
+      (setq args (append args (list
+                               "-cp" (langtool--process-file-name
+                                      langtool-language-tool-server-jar))))
+      (setq args (append args (list "org.languagetool.server.HTTPServer")))
+      (setq args (append args langtool-server-user-arguments))
+      (langtool--debug "HTTPServer" "%s: %s" bin args)
+      (let* ((buffer (get-buffer-create " *LangtoolHttpServer* "))
+             (proc (apply
+                    'start-process
+                    "LangtoolHttpServer" buffer
+                    bin
+                    args)))
+        (langtool-server--rendezvous proc buffer)
+        (set-process-sentinel proc 'langtool-server--process-sentinel)
+        (langtool-adapter-ensure-internal proc)
+        proc))))
+
+(defun langtool-client--parse-response-body/json ()
+  (let* ((json (json-read))
+         (matches (cdr (assq 'matches json)))
+         (software (cdr (assq 'software json)))
+         (version (cdr (assq 'version software)))
+         checks)
+    (cl-loop for match across matches
+             do (let* ((offset (cdr (assoc 'offset match)))
+                       (len (cdr (assoc 'length match)))
+                       (rule (cdr (assoc 'rule match)))
+                       (rule-id (cdr (assoc 'id rule)))
+                       (replacements (cdr (assoc 'replacements match)))
+                       (suggestions (mapcar
+                                     (lambda (x) (cdr (assoc 'value x)))
+                                     replacements))
+                       (msg1 (cdr (assoc 'message match)))
+                       ;; rest of line. Point the raw message.
+                       (msg2 (cdr (assoc 'shortMessage match)))
+                       (message
+                        (concat "Rule ID: " rule-id "\n"
+                                msg1 "\n\n"
+                                msg2))
+                       ;; No need this value when json
+                       (context nil)
+                       line column)
+                  (setq checks (cons
+                                 (list line column len suggestions
+                                       msg1 message rule-id context
+                                       offset)
+                                 checks))))
+    (setq checks (nreverse checks))
+    (list version checks)))
+
+(defun langtool-client--parse-response-body (http-headers)
+  (let ((ct (cdr (assoc-string "content-type" http-headers t))))
+    (cond
+     ((string= ct "application/json")
+      (langtool-client--parse-response-body/json))
+     (t
+      (error "Not a supported Content-Type %s" ct)))))
+
+(defun langtool-client--process-sentinel (proc event)
+  (unless (process-live-p proc)
+    (let ((pbuf (process-buffer proc))
+          (source (process-get proc 'langtool-source-buffer))
+          errmsg version checks)
+      (with-current-buffer pbuf
+        (cl-destructuring-bind (status headers body-start)
+            (langtool-http--parse-response-header)
+          (goto-char body-start)
+          (cond
+           ((= status 200)
+            (cl-destructuring-bind (ver result)
+                (langtool-client--parse-response-body headers)
+              (setq checks result)
+              (setq version ver)))
+           (t
+            (setq errmsg (buffer-substring-no-properties (point) (point-max)))))
+          (kill-buffer pbuf)))
+      ;; after cleanup buffer.
+      (cond
+       (errmsg
+        (langtool--check-finish source errmsg))
+       (t
+        (langtool--lazy-apply-checks proc version checks))))))
+
+(defun langtool-client--process-filter (proc event)
+  (langtool--debug "Filter" "%s" event)
+  (with-current-buffer (process-buffer proc)
+    (goto-char (point-max))
+    (insert event)))
+
+(defun langtool-client--make-post-data (&optional begin finish lang)
+  (let* ((text (buffer-substring-no-properties (or begin (point-min)) (or finish (point-max))))
+         (disabled-rules (langtool--disabled-rules))
+         (language (cond
+                    ((stringp (or lang langtool-default-language))
+                     (or lang langtool-default-language))
+                    (t
+                     "auto")))
+         (query `(
+                  ("language" ,language)
+                  ("text" ,text)
+                  ,@(and langtool-mother-tongue
+                         `(("motherTongue" ,langtool-mother-tongue)))
+                  ("disabledRules" ,disabled-rules)
+                  ))
+         query-string)
+    (when (and langtool-client-filter-query-function
+               (functionp langtool-client-filter-query-function))
+      (setq query (funcall langtool-client-filter-query-function query)))
+    ;; UTF-8 encoding if value is multibyte character
+    (setq query-string (url-build-query-string query))
+    query-string))
+
+(defun langtool-client--http-post (data)
+  (let* ((host (langtool-adapter-get 'host))
+         (port (langtool-adapter-get 'port))
+         (buffer (langtool--process-create-client-buffer))
+         (url-path "/v2/check")
+         (client (let ((coding-system-for-write 'binary)
+                       (coding-system-for-read 'utf-8-unix))
+                   (open-network-stream
+                    "LangtoolHttpClient" buffer host port
+                    :type (or (langtool-adapter-get 'stream-type) 'plain)))))
+    (process-send-string
+     client
+     (concat
+      (format "POST %s HTTP/1.1\r\n" url-path)
+      (format "Host: %s:%d\r\n" host port)
+      (format "Content-length: %d\r\n" (length data))
+      (format "Content-Type: application/x-www-form-urlencoded\r\n")
+      (format "\r\n")
+      data))
+    (process-send-eof client)
+    client))
+
+(defun langtool-client--invoke-process (&optional begin finish lang)
+  (let* ((data (langtool-client--make-post-data begin finish lang))
+         (proc (langtool-client--http-post data)))
+    (set-process-sentinel proc 'langtool-client--process-sentinel)
+    (set-process-filter proc 'langtool-client--process-filter)
+    (process-put proc 'langtool-source-buffer (current-buffer))
+    (process-put proc 'langtool-region-begin begin)
+    (process-put proc 'langtool-region-finish finish)
+    proc))
+
+;;
+;; HTTP or commandline interface caller
+;;
+
+(defun langtool--invoke-checker-process (&optional begin finish lang)
+  (when (listp mode-line-process)
+    (add-to-list 'mode-line-process '(t langtool-mode-line-message)))
+  ;; clear previous check
+  (langtool--clear-buffer-overlays)
+  (let (proc)
+    (cl-ecase (langtool--checker-mode)
+      ('commandline
+       ;; Ensure adapter is closed. That has been constructed other checker-mode.
+       (langtool-adapter-ensure-terminate)
+       (let ((file (langtool-command--maybe-create-temp-file begin finish)))
+         (setq proc (langtool-command--invoke-process file begin finish lang))))
+      ('client-server
+       (langtool-server--ensure-running)
+       (setq langtool-mode-line-server-process
+             (propertize ":server" 'face compilation-info-face))
+       (add-hook 'langtool-server--process-exit-hook
+                 (lambda ()
+                   (setq langtool-mode-line-server-process nil)))
+       (setq proc (langtool-client--invoke-process begin finish lang)))
+      ('http-client
+       (langtool-adapter-ensure-terminate)
+       ;; Construct new adapter each check.
+       ;; Since maybe change customize variable in a Emacs session.
+       (langtool-adapter-ensure-external)
+       (setq proc (langtool-client--invoke-process begin finish lang))))
+    (setq langtool-buffer-process proc)
+    (setq langtool-mode-line-process
+          (propertize ":run" 'face compilation-info-face))
+    (setq langtool-mode-line-message
+          (list " "
+                "LT"                    ; LT <= LanguageTool shorthand
+                'langtool-mode-line-server-process
+                'langtool-mode-line-process))))
+
+(defun langtool--cleanup-process ()
+  ;; cleanup mode-line
+  (let ((cell (and (listp mode-line-process) ; Check type
+                   (rassoc '(langtool-mode-line-message) mode-line-process))))
+    (when cell
+      (remq cell mode-line-process)))
+  (when (and langtool-buffer-process
+             (processp langtool-buffer-process))
+    ;; TODO buffer killed, error. if process is local process (e.g. urllib)
+    (delete-process langtool-buffer-process))
+  (kill-local-variable 'langtool-buffer-process)
+  (kill-local-variable 'langtool-mode-line-message)
+  (kill-local-variable 'langtool-local-disabled-rules)
+  (langtool--clear-buffer-overlays)
+  (run-hooks 'langtool-finish-hook))
+
+(defun langtool--check-command ()
+  (cl-ecase (langtool--checker-mode)
+    ('commandline
+     (langtool-command--check-command))
+    ('client-server
+     (langtool-server--check-command))
+    ('http-client
+     (langtool-http-client-check-command))))
+
+(defun langtool--brief-execute (langtool-args parser)
+  (pcase (langtool--basic-command&args)
+    (`(,command ,args)
+     ;; Construct arguments pass to jar file.
+     (setq args (append args langtool-args))
+     (with-temp-buffer
+       (when (and command args
+                  (executable-find command)
+                  (= (langtool--with-java-environ
+                      (apply 'call-process command nil t nil args) 0)))
+         (goto-char (point-min))
+         (funcall parser))))
+    (_
+     nil)))
+
+(defun langtool--available-languages ()
+  (langtool--brief-execute
+   (list "--list")
+   (lambda ()
+     (let ((res '()))
+       (while (re-search-forward "^\\([^\s\t]+\\)" nil t)
+         (setq res (cons (match-string 1) res)))
+       (nreverse res)))))
+
+(defun langtool--jar-version-string ()
+  (langtool--brief-execute
+   (list "--version")
+   (lambda ()
+     (langtool--chomp (buffer-string)))))
+
+(defun langtool--jar-version ()
+  (let ((string (langtool--jar-version-string)))
+    (cond
+     ((null string) nil)
+     ((string-match "version \\([0-9.]+\\)" string)
+      (match-string 1 string))
+     (t
+      ;; Unknown version, but should not raise error in this function.
+      "0.0"))))
+
+;;
+;; interactive correction
+;;
+
+(defun langtool--ignore-rule (rule overlays)
+  (cl-loop for ov in overlays
+           do (let ((r (overlay-get ov 'langtool-rule-id)))
+                (when (equal r rule)
+                  (langtool--erase-overlay ov)))))
+
+(defun langtool--correction (overlays)
+  (let ((conf (current-window-configuration)))
+    (unwind-protect
+        (let ((next (car overlays)))
+          (while (setq next (langtool--correction-loop next overlays))))
+      (langtool--expire-buffer-overlays)
+      (set-window-configuration conf)
+      (kill-buffer (langtool--correction-buffer)))))
+
+(defun langtool--correction-loop (ov overlays)
+  (let* ((suggests (overlay-get ov 'langtool-suggestions))
+         (msg (overlay-get ov 'langtool-simple-message))
+         (alist (langtool--correction-popup msg suggests)))
+    (catch 'next
+      (while (progn
+               (goto-char (overlay-start ov))
+               (let (message-log-max)
+                 (message (concat "C-h or ? for more options; "
+                                  "SPC to leave unchanged, "
+                                  "Digit to replace word")))
+               (let* ((echo-keystrokes) ; suppress echoing
+                      (c (downcase (read-char)))
+                      (pair (assq c alist)))
+                 (cond
+                  (pair
+                   (let ((sug (nth 1 pair)))
+                     ;;TODO when region contains newline.
+                     ;; -> insert newline after suggestion.
+                     (delete-region (overlay-start ov) (overlay-end ov))
+                     (insert sug)
+                     (langtool--erase-overlay ov))
+                   nil)
+                  ((memq c '(?q))
+                   (keyboard-quit))
+                  ((memq c '(?c))
+                   (langtool--erase-overlay ov)
+                   nil)
+                  ((memq c '(?e))
+                   (message (substitute-command-keys
+                             "Type \\[exit-recursive-edit] to finish the edit."))
+                   (recursive-edit)
+                   ;; stay current cursor and wait next user command.
+                   (throw 'next ov))
+                  ((memq c '(?i))
+                   (let ((rule (overlay-get ov 'langtool-rule-id)))
+                     (unless (member rule langtool-local-disabled-rules)
+                       (setq langtool-local-disabled-rules
+                             (cons rule langtool-local-disabled-rules)))
+                     (langtool--ignore-rule rule overlays))
+                   nil)
+                  ((memq c '(?\C-h ?\?))
+                   (langtool--correction-help)
+                   t)
+                  ((memq c '(?\d))
+                   (throw 'next (langtool--prev-overlay ov overlays)))
+                  ((memq c '(?\s)) nil)
+                  (t (ding) t)))))
+      ;; next item
+      (langtool--next-overlay ov overlays))))
+
+(defun langtool--correction-popup (msg suggests)
+  (let ((buf (langtool--correction-buffer)))
+    (delete-other-windows)
+    (let ((win (split-window)))
+      (set-window-buffer win buf))
+    (with-current-buffer buf
+      (let ((inhibit-read-only t))
+        (erase-buffer)
+        (insert msg "\n\n")
+        (cl-loop for s in suggests
+                 for c across langtool--correction-keys
+                 do (progn
+                      (insert "(" c ") ")
+                      (let ((start (point)))
+                        (insert s)
+                        ;; colorize suggestion.
+                        ;; suggestion may contains whitespace.
+                        (let ((ov (make-overlay start (point))))
+                          (overlay-put ov 'face 'langtool-correction-face)))
+                      (insert "\n"))
+                 collect (list c s))))))
+
+(defun langtool--correction-help ()
+  (let ((help-1 "[q/Q]uit correction; [c/C]lear the colorized text; ")
+        (help-2 "[i/I]gnore the rule over current session.")
+        (help-3 "[e/E]dit the buffer manually")
+        (help-4 "SPC skip; DEL move backward;")
+        )
+    (save-window-excursion
+      (unwind-protect
+          (let ((resize-mini-windows 'grow-only))
+            (select-window (minibuffer-window))
+            (erase-buffer)
+            (message nil)
+            ;;(set-minibuffer-window (selected-window))
+            (enlarge-window 2)
+            (insert (concat help-1 "\n" help-2 "\n" help-3 "\n" help-4))
+            (sit-for 5))
+        (erase-buffer)))))
+
+(defun langtool--correction-buffer ()
+  (get-buffer-create "*Langtool Correction*"))
+
+;;
+;; Misc UI
+;;
+
+(defun langtool--show-message-buffer (msg)
+  (let ((buf (get-buffer-create langtool-error-buffer-name)))
+    (with-current-buffer buf
+      (erase-buffer)
+      (insert msg))
+    (save-window-excursion
+      (display-buffer buf)
+      (let* ((echo-keystrokes)
+             (event (read-event)))
+        (setq unread-command-events (list event))))))
+
+;;
+;; initialize
+;;
+
+(defun langtool--guess-language ()
+  (let ((env (or (getenv "LANG")
+                 (getenv "LC_ALL")))
+        (supported-langs (langtool--available-languages))
+        lang country mems)
+    (and env
+         (string-match "\\`\\(..\\)_\\(..\\)?" env)
+         (setq lang (downcase (match-string 1 env)))
+         (setq country (and (match-string 2 env)
+                            (upcase (match-string 2 env)))))
+    (or
+     (and
+      lang country
+      (setq mems (member (format "%s-%s" lang country) supported-langs))
+      (car mems))
+     (and
+      lang
+      (setq mems (cl-member-if
+                  (lambda (x) (string-match
+                               (concat "\\`" (regexp-quote lang)) x))
+                  supported-langs))
+      (car mems)))))
+
+;;
+;; autoshow message
+;;
+
+(defcustom langtool-autoshow-message-function
+  'langtool-autoshow-default-message
+  "Function with one argument which displaying error overlays reported by LanguageTool.
+These overlays hold some useful properties:
+ `langtool-simple-message', `langtool-rule-id', `langtool-suggestions' .
+`langtool-autoshow-default-message' is a default/sample implementations.
+See the Commentary section for `popup' implementation."
+  :group 'langtool
+  :type '(choice
+          (const nil)
+          function))
+
+(defcustom langtool-autoshow-idle-delay 0.5
+  "Number of seconds while idle time to wait before showing error message."
+  :group 'langtool
+  :type 'number)
+
+(defvar langtool-autoshow--current-idle-delay nil)
+
+(defvar langtool-autoshow--timer nil
+  "Hold idle timer watch every LanguageTool processed buffer.")
+
+(defun langtool-autoshow-default-message (overlays)
+  ;; Do not interrupt current message
+  (unless (current-message)
+    (let ((msg (langtool-simple-error-message overlays)))
+      (message "%s" msg))))
+
+(defun langtool-autoshow--maybe ()
+  (when langtool-autoshow-message-function
+    (let ((delay (langtool-autoshow--idle-delay)))
+      (cond
+       ((equal langtool-autoshow--current-idle-delay delay))
+       (t
+        (setq langtool-autoshow--current-idle-delay delay)
+        (timer-set-idle-time langtool-autoshow--timer
+                             langtool-autoshow--current-idle-delay t))))
+    (condition-case err
+        (let ((error-overlays (langtool--current-error-overlays)))
+          (when error-overlays
+            (funcall langtool-autoshow-message-function error-overlays)))
+      (error
+       (message "langtool: %s" err)))))
+
+(defun langtool-autoshow--idle-delay ()
+  (if (numberp langtool-autoshow-idle-delay)
+      langtool-autoshow-idle-delay
+    (default-value 'langtool-autoshow-idle-delay)))
+
+(defun langtool-autoshow-ensure-timer ()
+  (unless (and (timerp langtool-autoshow--timer)
+               (memq langtool-autoshow--timer timer-idle-list))
+    (setq langtool-autoshow--timer
+          (run-with-idle-timer
+           (langtool-autoshow--idle-delay) t 'langtool-autoshow--maybe)))
+  (add-hook 'kill-buffer-hook 'langtool-autoshow-cleanup-timer-maybe nil t))
+
+(defun langtool-autoshow-cleanup-timer-maybe ()
+  (unless (langtool-working-p)
+    (when (timerp langtool-autoshow--timer)
+      (cancel-timer langtool-autoshow--timer)
+      (setq langtool-autoshow--timer nil))))
+
+;;;
+;;; interactive commands
+;;;
+
+(defun langtool-read-lang-name ()
+  (let ((completion-ignore-case t)
+        (set
+         (append
+          '(("auto" . auto))
+          (or (mapcar 'list (langtool--available-languages))
+              (mapcar (lambda (x) (list (car x))) locale-language-names)))))
+    (let ((key (completing-read "Lang: " set)))
+      (or (cdr (assoc key set)) key))))
+
+(defun langtool-goto-next-error ()
+  "Obsoleted function. Should use `langtool-correct-buffer'.
+Go to next error."
+  (interactive)
+  (let ((overlays (langtool--overlays-region (point) (point-max))))
+    (langtool--goto-error
+     overlays
+     (lambda (ov) (< (point) (overlay-start ov))))))
+
+(defun langtool-goto-previous-error ()
+  "Obsoleted function. Should use `langtool-correct-buffer'.
+Goto previous error."
+  (interactive)
+  (let ((overlays (langtool--overlays-region (point-min) (point))))
+    (langtool--goto-error
+     (reverse overlays)
+     (lambda (ov) (< (overlay-end ov) (point))))))
+
+(defun langtool-show-message-at-point ()
+  "Show error details at point."
+  (interactive)
+  (let ((ovs (langtool--current-error-overlays)))
+    (if (null ovs)
+        (message "No errors")
+      (let ((msg (langtool-details-error-message ovs)))
+        (langtool--show-message-buffer msg)))))
+
+(defun langtool-show-brief-message-at-point ()
+  "Show error brief message at point."
+  (interactive)
+  (let ((msgs (langtool--current-error-messages)))
+    (if (null msgs)
+        (message "No errors")
+      (langtool--show-message-buffer
+       (mapconcat 'identity msgs "\n")))))
+
+(defun langtool-check-done ()
+  "Finish LanguageTool process and cleanup existing colorized texts."
+  (interactive)
+  (langtool--cleanup-process)
+  (force-mode-line-update)
+  (message "Cleaned up LanguageTool."))
+
+;;;###autoload
+(defalias 'langtool-check 'langtool-check-buffer)
+
+;;;###autoload
+(defun langtool-check-buffer (&optional lang)
+  "Check context current buffer and light up errors.
+Optional \\[universal-argument] read LANG name.
+
+You can change the `langtool-default-language' to apply all session.
+Restrict to selection when region is activated.
+"
+  (interactive
+   (when current-prefix-arg
+     (list (langtool-read-lang-name))))
+  (langtool--check-command)
+  ;; probablly ok...
+  (let* ((region-p (langtool-region-active-p))
+         (begin (and region-p (region-beginning)))
+         (finish (and region-p (region-end))))
+    (when region-p
+      (deactivate-mark))
+    (langtool--invoke-checker-process begin finish lang)
+    (force-mode-line-update)))
+
+;;;###autoload
+(defun langtool-switch-default-language (lang)
+  "Switch `langtool-default-language' to LANG"
+  (interactive (list (langtool-read-lang-name)))
+  (setq langtool-default-language lang)
+  (message "Now default language is `%s'" lang))
+
+(defun langtool-correct-buffer ()
+  "Execute interactive correction after `langtool-check'"
+  (interactive)
+  (let ((ovs (langtool--overlays-region (point-min) (point-max))))
+    (if (null ovs)
+        (message "No error found. %s"
+                 (substitute-command-keys
+                  (concat
+                   "Type \\[langtool-check-done] to finish checking "
+                   "or type \\[langtool-check] to re-check buffer")))
+      (barf-if-buffer-read-only)
+      (langtool--correction ovs))))
+
+(defun langtool-server-stop ()
+  "Terminate LanguageTool HTTP server."
+  (interactive)
+  (langtool-adapter-ensure-terminate)
+  (message "Server is terminated."))
+
+(defun langtool-toggle-debug ()
+  "Toggle LanguageTool debugging."
+  (interactive)
+  (setq langtool--debug (not langtool--debug))
+  (if langtool--debug
+      (message "Langtool debug ON.")
+    (message "Langtool debug off.")))
+
+;;;
+;;; initialize
+;;;
+
+;; initialize custom variables guessed from environment.
+(let ((mt (langtool--guess-language)))
+  (unless langtool-mother-tongue
+    (setq langtool-mother-tongue mt)))
+
+(provide 'langtool)
+
+;;; langtool.el ends here
diff --git a/lisp/lv.el b/lisp/lv.el
new file mode 100644
index 00000000..40e2ee4c
--- /dev/null
+++ b/lisp/lv.el
@@ -0,0 +1,150 @@
+;;; lv.el --- Other echo area
+;; Package-Version: 20200507.1518
+;; Package-Commit: 8a9124f80b6919ad5288172b3e9f46c5332763ca
+
+;; Copyright (C) 2015  Free Software Foundation, Inc.
+
+;; Author: Oleh Krehel
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 Emacs 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 GNU Emacs.  If not, see .
+
+;;; Commentary:
+;;
+;; This package provides `lv-message' intended to be used in place of
+;; `message' when semi-permanent hints are needed, in order to not
+;; interfere with Echo Area.
+;;
+;;    "Я тихо-тихо пiдглядаю,
+;;     І тiшуся собi, як бачу то,
+;;     Шо страшить i не пiдпускає,
+;;     А iншi п’ють тебе, як воду пiсок."
+;;     --  Андрій Кузьменко, L.V.
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defgroup lv nil
+  "The other echo area."
+  :group 'minibuffer
+  :group 'hydra)
+
+(defcustom lv-use-separator nil
+  "Whether to draw a line between the LV window and the Echo Area."
+  :group 'lv
+  :type 'boolean)
+
+(defcustom lv-use-padding nil
+  "Whether to use horizontal padding in the LV window."
+  :group 'lv
+  :type 'boolean)
+
+(defface lv-separator
+  '((((class color) (background light)) :background "grey80")
+    (((class color) (background  dark)) :background "grey30"))
+  "Face used to draw line between the lv window and the echo area.
+This is only used if option `lv-use-separator' is non-nil.
+Only the background color is significant."
+  :group 'lv)
+
+(defvar lv-wnd nil
+  "Holds the current LV window.")
+
+(defvar display-line-numbers)
+(defvar display-fill-column-indicator)
+(defvar tab-line-format)
+
+(defvar lv-window-hook nil
+  "Hook to run by `lv-window' when a new window is created.")
+
+(defun lv-window ()
+  "Ensure that LV window is live and return it."
+  (if (window-live-p lv-wnd)
+      lv-wnd
+    (let ((ori (selected-window))
+          buf)
+      (prog1 (setq lv-wnd
+                   (select-window
+                    (let ((ignore-window-parameters t))
+                      (split-window
+                       (frame-root-window) -1 'below))
+                    'norecord))
+        (if (setq buf (get-buffer " *LV*"))
+            (switch-to-buffer buf 'norecord)
+          (switch-to-buffer " *LV*" 'norecord)
+          (fundamental-mode)
+          (set-window-hscroll lv-wnd 0)
+          (setq window-size-fixed t)
+          (setq mode-line-format nil)
+          (setq header-line-format nil)
+          (setq tab-line-format nil)
+          (setq cursor-type nil)
+          (setq display-line-numbers nil)
+          (setq display-fill-column-indicator nil)
+          (set-window-dedicated-p lv-wnd t)
+          (set-window-parameter lv-wnd 'no-other-window t)
+          (run-hooks 'lv-window-hook))
+        (select-window ori 'norecord)))))
+
+(defvar golden-ratio-mode)
+
+(defvar lv-force-update nil
+  "When non-nil, `lv-message' will refresh even for the same string.")
+
+(defun lv--pad-to-center (str width)
+  "Pad STR with spaces on the left to be centered to WIDTH."
+  (let* ((strs (split-string str "\n"))
+         (padding (make-string
+                   (/ (- width (length (car strs))) 2)
+                   ?\ )))
+    (mapconcat (lambda (s) (concat padding s)) strs "\n")))
+
+(defun lv-message (format-string &rest args)
+  "Set LV window contents to (`format' FORMAT-STRING ARGS)."
+  (let* ((str (apply #'format format-string args))
+         (n-lines (cl-count ?\n str))
+         deactivate-mark
+         golden-ratio-mode)
+    (with-selected-window (lv-window)
+      (when lv-use-padding
+        (setq str (lv--pad-to-center str (window-width))))
+      (unless (and (string= (buffer-string) str)
+                   (null lv-force-update))
+        (delete-region (point-min) (point-max))
+        (insert str)
+        (when (and (window-system) lv-use-separator)
+          (unless (looking-back "\n" nil)
+            (insert "\n"))
+          (insert
+           (propertize "__" 'face 'lv-separator 'display '(space :height (1)))
+           (propertize "\n" 'face 'lv-separator 'line-height t)))
+        (set (make-local-variable 'window-min-height) n-lines)
+        (setq truncate-lines (> n-lines 1))
+        (let ((window-resize-pixelwise t)
+              (window-size-fixed nil))
+          (fit-window-to-buffer nil nil 1)))
+      (goto-char (point-min)))))
+
+(defun lv-delete-window ()
+  "Delete LV window and kill its buffer."
+  (when (window-live-p lv-wnd)
+    (let ((buf (window-buffer lv-wnd)))
+      (delete-window lv-wnd)
+      (kill-buffer buf))))
+
+(provide 'lv)
+
+;;; lv.el ends here
diff --git a/lisp/markdown-mode.el b/lisp/markdown-mode.el
new file mode 100644
index 00000000..95dc2863
--- /dev/null
+++ b/lisp/markdown-mode.el
@@ -0,0 +1,9622 @@
+;;; markdown-mode.el --- Major mode for Markdown-formatted text -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2007-2020 Jason R. Blevins and markdown-mode
+;; contributors (see the commit log for details).
+
+;; Author: Jason R. Blevins 
+;; Maintainer: Jason R. Blevins 
+;; Created: May 24, 2007
+;; Version: 2.5-dev
+;; Package-Version: 20200622.20
+;; Package-Commit: 399df42755ccf31cecb61c9f5d8ad72bc30d7e4b
+;; Package-Requires: ((emacs "25.1"))
+;; Keywords: Markdown, GitHub Flavored Markdown, itex
+;; URL: https://jblevins.org/projects/markdown-mode/
+
+;; This file is not 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 .
+
+;;; Commentary:
+
+;; See the README.md file for details.
+
+
+;;; Code:
+
+(require 'easymenu)
+(require 'outline)
+(require 'thingatpt)
+(require 'cl-lib)
+(require 'url-parse)
+(require 'button)
+(require 'color)
+(require 'rx)
+(require 'subr-x)
+
+(defvar jit-lock-start)
+(defvar jit-lock-end)
+(defvar flyspell-generic-check-word-predicate)
+(defvar electric-pair-pairs)
+
+
+;;; Constants =================================================================
+
+(defconst markdown-mode-version "2.5-dev"
+  "Markdown mode version number.")
+
+(defconst markdown-output-buffer-name "*markdown-output*"
+  "Name of temporary buffer for markdown command output.")
+
+
+;;; Global Variables ==========================================================
+
+(defvar markdown-reference-label-history nil
+  "History of used reference labels.")
+
+(defvar markdown-live-preview-mode nil
+  "Sentinel variable for command `markdown-live-preview-mode'.")
+
+(defvar markdown-gfm-language-history nil
+  "History list of languages used in the current buffer in GFM code blocks.")
+
+
+;;; Customizable Variables ====================================================
+
+(defvar markdown-mode-hook nil
+  "Hook run when entering Markdown mode.")
+
+(defvar markdown-before-export-hook nil
+  "Hook run before running Markdown to export XHTML output.
+The hook may modify the buffer, which will be restored to it's
+original state after exporting is complete.")
+
+(defvar markdown-after-export-hook nil
+  "Hook run after XHTML output has been saved.
+Any changes to the output buffer made by this hook will be saved.")
+
+(defgroup markdown nil
+  "Major mode for editing text files in Markdown format."
+  :prefix "markdown-"
+  :group 'text
+  :link '(url-link "https://jblevins.org/projects/markdown-mode/"))
+
+(defcustom markdown-command (let ((command (cl-loop for cmd in '("markdown" "pandoc")
+                                                    when (executable-find cmd)
+                                                    return (file-name-nondirectory it))))
+                              (or command "markdown"))
+  "Command to run markdown."
+  :group 'markdown
+  :type '(choice (string :tag "Shell command") (repeat (string)) function))
+
+(defcustom markdown-command-needs-filename nil
+  "Set to non-nil if `markdown-command' does not accept input from stdin.
+Instead, it will be passed a filename as the final command line
+option.  As a result, you will only be able to run Markdown from
+buffers which are visiting a file."
+  :group 'markdown
+  :type 'boolean)
+
+(defcustom markdown-open-command nil
+  "Command used for opening Markdown files directly.
+For example, a standalone Markdown previewer.  This command will
+be called with a single argument: the filename of the current
+buffer.  It can also be a function, which will be called without
+arguments."
+  :group 'markdown
+  :type '(choice file function (const :tag "None" nil)))
+
+(defcustom markdown-open-image-command nil
+  "Command used for opening image files directly at `markdown-follow-link-at-point'."
+  :group 'markdown
+  :type '(choice file function (const :tag "None" nil)))
+
+(defcustom markdown-hr-strings
+  '("-------------------------------------------------------------------------------"
+    "* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *"
+    "---------------------------------------"
+    "* * * * * * * * * * * * * * * * * * * *"
+    "---------"
+    "* * * * *")
+  "Strings to use when inserting horizontal rules.
+The first string in the list will be the default when inserting a
+horizontal rule.  Strings should be listed in decreasing order of
+prominence (as in headings from level one to six) for use with
+promotion and demotion functions."
+  :group 'markdown
+  :type '(repeat string))
+
+(defcustom markdown-bold-underscore nil
+  "Use two underscores when inserting bold text instead of two asterisks."
+  :group 'markdown
+  :type 'boolean)
+
+(defcustom markdown-italic-underscore nil
+  "Use underscores when inserting italic text instead of asterisks."
+  :group 'markdown
+  :type 'boolean)
+
+(defcustom markdown-marginalize-headers nil
+  "When non-nil, put opening atx header markup in a left margin.
+
+This setting goes well with `markdown-asymmetric-header'.  But
+sadly it conflicts with `linum-mode' since they both use the
+same margin."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.4"))
+
+(defcustom markdown-marginalize-headers-margin-width 6
+  "Character width of margin used for marginalized headers.
+The default value is based on there being six heading levels
+defined by Markdown and HTML.  Increasing this produces extra
+whitespace on the left.  Decreasing it may be preferred when
+fewer than six nested heading levels are used."
+  :group 'markdown
+  :type 'natnump
+  :safe 'natnump
+  :package-version '(markdown-mode . "2.4"))
+
+(defcustom markdown-asymmetric-header nil
+  "Determines if atx header style will be asymmetric.
+Set to a non-nil value to use asymmetric header styling, placing
+header markup only at the beginning of the line. By default,
+balanced markup will be inserted at the beginning and end of the
+line around the header title."
+  :group 'markdown
+  :type 'boolean)
+
+(defcustom markdown-indent-function 'markdown-indent-line
+  "Function to use to indent."
+  :group 'markdown
+  :type 'function)
+
+(defcustom markdown-indent-on-enter t
+  "Determines indentation behavior when pressing \\[newline].
+Possible settings are nil, t, and 'indent-and-new-item.
+
+When non-nil, pressing \\[newline] will call `newline-and-indent'
+to indent the following line according to the context using
+`markdown-indent-function'.  In this case, note that
+\\[electric-newline-and-maybe-indent] can still be used to insert
+a newline without indentation.
+
+When set to 'indent-and-new-item and the point is in a list item
+when \\[newline] is pressed, the list will be continued on the next
+line, where a new item will be inserted.
+
+When set to nil, simply call `newline' as usual.  In this case,
+you can still indent lines using \\[markdown-cycle] and continue
+lists with \\[markdown-insert-list-item].
+
+Note that this assumes the variable `electric-indent-mode' is
+non-nil (enabled).  When it is *disabled*, the behavior of
+\\[newline] and `\\[electric-newline-and-maybe-indent]' are
+reversed."
+  :group 'markdown
+  :type '(choice (const :tag "Don't automatically indent" nil)
+                 (const :tag "Automatically indent" t)
+                 (const :tag "Automatically indent and insert new list items" indent-and-new-item)))
+
+(defcustom markdown-enable-wiki-links nil
+  "Syntax highlighting for wiki links.
+Set this to a non-nil value to turn on wiki link support by default.
+Support can be toggled later using the `markdown-toggle-wiki-links'
+function or \\[markdown-toggle-wiki-links]."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.2"))
+
+(defcustom markdown-wiki-link-alias-first t
+  "When non-nil, treat aliased wiki links like [[alias text|PageName]].
+Otherwise, they will be treated as [[PageName|alias text]]."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp)
+
+(defcustom markdown-wiki-link-search-subdirectories nil
+  "When non-nil, search for wiki link targets in subdirectories.
+This is the default search behavior for GitHub and is
+automatically set to t in `gfm-mode'."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.2"))
+
+(defcustom markdown-wiki-link-search-parent-directories nil
+  "When non-nil, search for wiki link targets in parent directories.
+This is the default search behavior of Ikiwiki."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.2"))
+
+(defcustom markdown-wiki-link-fontify-missing nil
+  "When non-nil, change wiki link face according to existence of target files.
+This is expensive because it requires checking for the file each time the buffer
+changes or the user switches windows.  It is disabled by default because it may
+cause lag when typing on slower machines."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.2"))
+
+(defcustom markdown-uri-types
+  '("acap" "cid" "data" "dav" "fax" "file" "ftp"
+    "gopher" "http" "https" "imap" "ldap" "mailto"
+    "mid" "message" "modem" "news" "nfs" "nntp"
+    "pop" "prospero" "rtsp" "service" "sip" "tel"
+    "telnet" "tip" "urn" "vemmi" "wais")
+  "Link types for syntax highlighting of URIs."
+  :group 'markdown
+  :type '(repeat (string :tag "URI scheme")))
+
+(defcustom markdown-url-compose-char
+  '(?∞ ?… ?⋯ ?# ?★ ?⚓)
+  "Placeholder character for hidden URLs.
+This may be a single character or a list of characters. In case
+of a list, the first one that satisfies `char-displayable-p' will
+be used."
+  :type '(choice
+          (character :tag "Single URL replacement character")
+          (repeat :tag "List of possible URL replacement characters"
+                  character))
+  :package-version '(markdown-mode . "2.3"))
+
+(defcustom markdown-blockquote-display-char
+  '("▌" "┃" ">")
+  "String to display when hiding blockquote markup.
+This may be a single string or a list of string. In case of a
+list, the first one that satisfies `char-displayable-p' will be
+used."
+  :type 'string
+  :type '(choice
+          (string :tag "Single blockquote display string")
+          (repeat :tag "List of possible blockquote display strings" string))
+  :package-version '(markdown-mode . "2.3"))
+
+(defcustom markdown-hr-display-char
+  '(?─ ?━ ?-)
+  "Character for hiding horizontal rule markup.
+This may be a single character or a list of characters.  In case
+of a list, the first one that satisfies `char-displayable-p' will
+be used."
+  :group 'markdown
+  :type '(choice
+          (character :tag "Single HR display character")
+          (repeat :tag "List of possible HR display characters" character))
+  :package-version '(markdown-mode . "2.3"))
+
+(defcustom markdown-definition-display-char
+  '(?⁘ ?⁙ ?≡ ?⌑ ?◊ ?:)
+  "Character for replacing definition list markup.
+This may be a single character or a list of characters.  In case
+of a list, the first one that satisfies `char-displayable-p' will
+be used."
+  :type '(choice
+          (character :tag "Single definition list character")
+          (repeat :tag "List of possible definition list characters" character))
+  :package-version '(markdown-mode . "2.3"))
+
+(defcustom markdown-enable-math nil
+  "Syntax highlighting for inline LaTeX and itex expressions.
+Set this to a non-nil value to turn on math support by default.
+Math support can be enabled, disabled, or toggled later using
+`markdown-toggle-math' or \\[markdown-toggle-math]."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp)
+(make-variable-buffer-local 'markdown-enable-math)
+
+(defcustom markdown-enable-html t
+  "Enable font-lock support for HTML tags and attributes."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.4"))
+
+(defcustom markdown-css-paths nil
+  "List of URLs of CSS files to link to in the output XHTML."
+  :group 'markdown
+  :type '(repeat (string :tag "CSS File Path")))
+
+(defcustom markdown-content-type "text/html"
+  "Content type string for the http-equiv header in XHTML output.
+When set to an empty string, this attribute is omitted.  Defaults to
+`text/html'."
+  :group 'markdown
+  :type 'string)
+
+(defcustom markdown-coding-system nil
+  "Character set string for the http-equiv header in XHTML output.
+Defaults to `buffer-file-coding-system' (and falling back to
+`utf-8' when not available).  Common settings are `iso-8859-1'
+and `iso-latin-1'.  Use `list-coding-systems' for more choices."
+  :group 'markdown
+  :type 'coding-system)
+
+(defcustom markdown-export-kill-buffer t
+  "Kill output buffer after HTML export.
+When non-nil, kill the HTML output buffer after
+exporting with `markdown-export'."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.4"))
+
+(defcustom markdown-xhtml-header-content ""
+  "Additional content to include in the XHTML  block."
+  :group 'markdown
+  :type 'string)
+
+(defcustom markdown-xhtml-body-preamble ""
+  "Content to include in the XHTML  block, before the output."
+  :group 'markdown
+  :type 'string
+  :safe 'stringp
+  :package-version '(markdown-mode . "2.4"))
+
+(defcustom markdown-xhtml-body-epilogue ""
+  "Content to include in the XHTML  block, after the output."
+  :group 'markdown
+  :type 'string
+  :safe 'stringp
+  :package-version '(markdown-mode . "2.4"))
+
+(defcustom markdown-xhtml-standalone-regexp
+  "^\\(<\\?xml\\| Links & Images menu."
+  :group 'markdown
+  :type 'boolean
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.3"))
+(make-variable-buffer-local 'markdown-hide-urls)
+
+(defcustom markdown-translate-filename-function #'identity
+  "Function to use to translate filenames when following links.
+\\\\[markdown-follow-thing-at-point] and \\[markdown-follow-link-at-point]
+call this function with the filename as only argument whenever
+they encounter a filename (instead of a URL) to be visited and
+use its return value instead of the filename in the link.  For
+example, if absolute filenames are actually relative to a server
+root directory, you can set
+`markdown-translate-filename-function' to a function that
+prepends the root directory to the given filename."
+  :group 'markdown
+  :type 'function
+  :risky t
+  :package-version '(markdown-mode . "2.4"))
+
+(defcustom markdown-max-image-size nil
+  "Maximum width and height for displayed inline images.
+This variable may be nil or a cons cell (MAX-WIDTH . MAX-HEIGHT).
+When nil, use the actual size.  Otherwise, use ImageMagick to
+resize larger images to be of the given maximum dimensions.  This
+requires Emacs to be built with ImageMagick support."
+  :group 'markdown
+  :package-version '(markdown-mode . "2.4")
+  :type '(choice
+          (const :tag "Use actual image width" nil)
+          (cons (choice (sexp :tag "Maximum width in pixels")
+                        (const :tag "No maximum width" nil))
+                (choice (sexp :tag "Maximum height in pixels")
+                        (const :tag "No maximum height" nil)))))
+
+(defcustom markdown-mouse-follow-link t
+  "Non-nil means mouse on a link will follow the link.
+This variable must be set before loading markdown-mode."
+  :group 'markdown
+  :type 'bool
+  :safe 'booleanp
+  :package-version '(markdown-mode . "2.5"))
+
+
+;;; Markdown-Specific `rx' Macro ==============================================
+
+;; Based on python-rx from python.el.
+(eval-and-compile
+  (defconst markdown-rx-constituents
+    `((newline . ,(rx "\n"))
+      ;; Note: #405 not consider markdown-list-indent-width however this is never used
+      (indent . ,(rx (or (repeat 4 " ") "\t")))
+      (block-end . ,(rx (and (or (one-or-more (zero-or-more blank) "\n") line-end))))
+      (numeral . ,(rx (and (one-or-more (any "0-9#")) ".")))
+      (bullet . ,(rx (any "*+:-")))
+      (list-marker . ,(rx (or (and (one-or-more (any "0-9#")) ".")
+                              (any "*+:-"))))
+      (checkbox . ,(rx "[" (any " xX") "]")))
+    "Markdown-specific sexps for `markdown-rx'")
+
+  (defun markdown-rx-to-string (form &optional no-group)
+    "Markdown mode specialized `rx-to-string' function.
+This variant supports named Markdown expressions in FORM.
+NO-GROUP non-nil means don't put shy groups around the result."
+    (let ((rx-constituents (append markdown-rx-constituents rx-constituents)))
+      (rx-to-string form no-group)))
+
+  (defmacro markdown-rx (&rest regexps)
+    "Markdown mode specialized rx macro.
+This variant of `rx' supports common Markdown named REGEXPS."
+    (cond ((null regexps)
+           (error "No regexp"))
+          ((cdr regexps)
+           (markdown-rx-to-string `(and ,@regexps) t))
+          (t
+           (markdown-rx-to-string (car regexps) t)))))
+
+
+;;; Regular Expressions =======================================================
+
+(defconst markdown-regex-comment-start
+  "")
+  (setq-local comment-start-skip "")))
+    (org-export-to-buffer 'tufte-html "*Org Tufte Export*"
+      async subtreep visible-only nil nil (lambda () (text-mode)))))
+
+;;;###autoload
+(defun org-tufte-export-to-file (&optional async subtreep visible-only)
+  "Export current buffer to a Tufte HTML file.
+
+If narrowing is active in the current buffer, only export its
+narrowed part.
+
+If a region is active, export that region.
+
+A non-nil optional argument ASYNC means the process should happen
+asynchronously.  The resulting file should be accessible through
+the `org-export-stack' interface.
+
+When optional argument SUBTREEP is non-nil, export the sub-tree
+at point, extracting information from the headline properties
+first.
+
+When optional argument VISIBLE-ONLY is non-nil, don't export
+contents of hidden elements.
+
+Return output file's name."
+  (interactive)
+  (let ((outfile (org-export-output-file-name ".html" subtreep))
+        ;; need to bind this because tufte treats footnotes specially, so we
+        ;; don't want to display them at the bottom
+        (org-html-footnotes-section (if org-tufte-include-footnotes-at-bottom
+                                        org-html-footnotes-section
+                                      "")))
+    (org-export-to-file 'tufte-html outfile async subtreep visible-only)))
+
+
+;;; publishing function
+
+;;;###autoload
+(defun org-html-publish-to-tufte-html (plist filename pub-dir)
+  "Publish an org file to Tufte-styled HTML.
+
+PLIST is the property list for the given project.  FILENAME is
+the filename of the Org file to be published.  PUB-DIR is the
+publishing directory.
+
+Return output file name."
+  (org-publish-org-to 'tufte-html filename
+                      (concat "." (or (plist-get plist :html-extension)
+                                      org-html-extension
+                                      "html"))
+                      plist pub-dir))
+
+(provide 'ox-tufte)
+
+;;; ox-tufte.el ends here
diff --git a/lisp/page-break-lines.el b/lisp/page-break-lines.el
new file mode 100644
index 00000000..c29f87a9
--- /dev/null
+++ b/lisp/page-break-lines.el
@@ -0,0 +1,182 @@
+;;; page-break-lines.el --- Display ^L page breaks as tidy horizontal lines  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2012-2015 Steve Purcell
+
+;; Author: Steve Purcell 
+;; URL: https://github.com/purcell/page-break-lines
+;; Package-Commit: f8c4cd7fc67638ae4113551dcffdf87fcd252d9b
+;; Package-Version: 20200305.244
+;; Package-X-Original-Version: 0
+;; Package-Requires: ((emacs "24.4"))
+;; Keywords: convenience, faces
+
+;; 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 .
+
+;;; Commentary:
+
+;; This library provides a global mode which displays form feed
+;; characters as horizontal rules.
+
+;; Install from Melpa or Marmalade, or add to `load-path' and use
+;; (require 'page-break-lines).
+
+;; Use `page-break-lines-mode' to enable the mode in specific buffers,
+;; or customize `page-break-lines-modes' and enable the mode globally with
+;; `global-page-break-lines-mode'.
+
+;; Issues and limitations:
+
+;; If `page-break-lines-char' is displayed at a different width to
+;; regular characters, the rule may be either too short or too long:
+;; rules may then wrap if `truncate-lines' is nil.  On some systems,
+;; Emacs may erroneously choose a different font for the page break
+;; symbol, which choice can be overridden using code such as:
+
+;; (set-fontset-font "fontset-default"
+;;                   (cons page-break-lines-char page-break-lines-char)
+;;                   (face-attribute 'default :family))
+
+;; Use `describe-char' on a page break char to determine whether this
+;; is the case.
+
+;; Additionally, the use of `text-scale-increase' or
+;; `text-scale-decrease' will cause the rule width to be incorrect,
+;; because the reported window width (in characters) will continue to
+;; be the width in the frame's default font, not the scaled font used to
+;; display the rule.
+
+;; Adapted from code http://www.emacswiki.org/emacs/PageBreaks
+
+;;; Code:
+
+(defgroup page-break-lines nil
+  "Display ugly ^L page breaks as tidy horizontal lines."
+  :prefix "page-break-lines-"
+  :group 'faces)
+
+(defcustom page-break-lines-char ?─
+  "Character used to render page break lines."
+  :type 'character
+  :group 'page-break-lines)
+
+(defcustom page-break-lines-lighter " PgLn"
+  "Mode-line indicator for `page-break-lines-mode'."
+  :type '(choice (const :tag "No lighter" "") string)
+  :group 'page-break-lines)
+
+(defcustom page-break-lines-max-width nil
+  "If non-nil, maximum width (in characters) of page break indicator.
+If nil, indicator will span the width of the frame."
+  :type '(choice integer (const :tag "Full width" nil))
+  :group 'page-break-lines)
+
+(defcustom page-break-lines-modes
+  '(emacs-lisp-mode lisp-mode scheme-mode compilation-mode outline-mode help-mode)
+  "Modes in which to enable `page-break-lines-mode'."
+  :type '(repeat symbol)
+  :group 'page-break-lines)
+
+(defface page-break-lines
+  '((t :inherit font-lock-comment-face :bold nil :italic nil))
+  "Face used to colorize page break lines.
+If using :bold or :italic, please ensure `page-break-lines-char'
+is available in that variant of your font, otherwise it may be
+displayed as a junk character."
+  :group 'page-break-lines)
+
+
+
+;;;###autoload
+(define-minor-mode page-break-lines-mode
+  "Toggle Page Break Lines mode.
+
+In Page Break mode, page breaks (^L characters) are displayed as a
+horizontal line of `page-break-lines-char' characters."
+  :lighter page-break-lines-lighter
+  :group 'page-break-lines
+  (page-break-lines--update-display-tables))
+
+;;;###autoload
+(define-obsolete-function-alias 'turn-on-page-break-lines-mode 'page-break-lines-mode)
+
+(dolist (hook '(window-configuration-change-hook
+                window-size-change-functions
+                after-setting-font-hook
+                display-line-numbers-mode-hook))
+  (add-hook hook 'page-break-lines--update-display-tables))
+
+
+
+(defun page-break-lines--update-display-table (window)
+  "Modify a display-table that displays page-breaks prettily.
+If the buffer inside WINDOW has `page-break-lines-mode' enabled,
+its display table will be modified as necessary."
+  (with-current-buffer (window-buffer window)
+    (with-selected-window window
+      (if page-break-lines-mode
+          (progn
+            (unless buffer-display-table
+              (setq buffer-display-table (make-display-table)))
+            (let ((default-height (face-attribute 'default :height nil 'default)))
+              (set-face-attribute 'page-break-lines nil :height default-height)
+              (let* ((cwidth (char-width page-break-lines-char))
+                     (wwidth-pix (- (window-width nil t)
+                                    (if (and (bound-and-true-p display-line-numbers)
+                                             (fboundp 'line-number-display-width))
+                                        (line-number-display-width t)
+                                      0)))
+                     (width (- (/ wwidth-pix (frame-char-width) cwidth)
+                               (if (display-graphic-p) 0 1)))
+                     (width (if page-break-lines-max-width
+                                (min width page-break-lines-max-width)
+                              width))
+                     (glyph (make-glyph-code page-break-lines-char 'page-break-lines))
+                     (new-display-entry (vconcat (make-list width glyph))))
+                (unless (equal new-display-entry (elt buffer-display-table ?\^L))
+                  (aset buffer-display-table ?\^L new-display-entry)))))
+        (when (and (apply 'derived-mode-p page-break-lines-modes)
+                   buffer-display-table)
+          (aset buffer-display-table ?\^L nil))))))
+
+(defun page-break-lines--update-display-tables  (&optional frame)
+  "Function called for updating display table in windows of FRAME."
+  (unless (minibufferp)
+    (mapc 'page-break-lines--update-display-table (window-list frame 'no-minibuffer))))
+
+
+
+;;;###autoload
+(defun page-break-lines-mode-maybe ()
+  "Enable `page-break-lines-mode' in the current buffer if desired.
+When `major-mode' is listed in `page-break-lines-modes', then
+`page-break-lines-mode' will be enabled."
+  (if (and (not (minibufferp))
+           (apply 'derived-mode-p page-break-lines-modes))
+      (page-break-lines-mode 1)))
+
+;;;###autoload
+(define-global-minor-mode global-page-break-lines-mode
+  page-break-lines-mode page-break-lines-mode-maybe
+  :require 'page-break-lines
+  :group 'page-break-lines)
+
+
+(provide 'page-break-lines)
+
+;; Local Variables:
+;; coding: utf-8
+;; checkdoc-minor-mode: t
+;; End:
+
+;;; page-break-lines.el ends here
diff --git a/lisp/parsebib.el b/lisp/parsebib.el
new file mode 100644
index 00000000..0519a48f
--- /dev/null
+++ b/lisp/parsebib.el
@@ -0,0 +1,677 @@
+;;; parsebib.el --- A library for parsing bib files  -*- lexical-binding: t -*-
+
+;; Copyright (c) 2014-2017 Joost Kremers
+;; All rights reserved.
+
+;; Author: Joost Kremers 
+;; Maintainer: Joost Kremers 
+;; Created: 2014
+;; Version: 2.3
+;; Package-Version: 20200513.2352
+;; Package-Commit: 3497b6068d78ae15ba1eaf94e4315d18e9ae6b00
+;; Keywords: text bibtex
+;; URL: https://github.com/joostkremers/parsebib
+;; Package-Requires: ((emacs "24.3"))
+
+;; 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:
+
+;;
+
+;;; Code:
+
+(require 'bibtex)
+(require 'cl-lib)
+(eval-when-compile (require 'subr-x)) ; for `string-join'.
+
+(defvar parsebib--biblatex-inheritances '(("all"
+					   "all"
+					   (("ids" . none)
+					    ("crossref" . none)
+					    ("xref" . none)
+					    ("entryset" . none)
+					    ("entrysubtype" . none)
+					    ("execute" . none)
+					    ("label" . none)
+					    ("options" . none)
+					    ("presort" . none)
+					    ("related" . none)
+					    ("relatedoptions" . none)
+					    ("relatedstring" . none)
+					    ("relatedtype" . none)
+					    ("shorthand" . none)
+					    ("shorthandintro" . none)
+					    ("sortkey" . none)))
+
+					  ("mvbook, book"
+					   "inbook, bookinbook, suppbook"
+					   (("author" . "author")
+					    ("author" . "bookauthor")))
+
+					  ("mvbook"
+					   "book, inbook, bookinbook, suppbook"
+					   (("title" . "maintitle")
+					    ("subtitle" . "mainsubtitle")
+					    ("titleaddon" . "maintitleaddon")
+					    ("shorttitle" . none)
+					    ("sorttitle" . none)
+					    ("indextitle" . none)
+					    ("indexsorttitle" . none)))
+
+					  ("mvcollection, mvreference"
+					   "collection, reference, incollection, inreference, suppcollection"
+					   (("title" . "maintitle")
+					    ("subtitle" . "mainsubtitle")
+					    ("titleaddon" . "maintitleaddon")
+					    ("shorttitle" . none)
+					    ("sorttitle" . none)
+					    ("indextitle" . none)
+					    ("indexsorttitle" . none)))
+
+					  ("mvproceedings"
+					   "proceedings, inproceedings"
+					   (("title" . "maintitle")
+					    ("subtitle" . "mainsubtitle")
+					    ("titleaddon" . "maintitleaddon")
+					    ("shorttitle" . none)
+					    ("sorttitle" . none)
+					    ("indextitle" . none)
+					    ("indexsorttitle" . none)))
+
+					  ("book"
+					   "inbook, bookinbook, suppbook"
+					   (("title" . "booktitle")
+					    ("subtitle" . "booksubtitle")
+					    ("titleaddon" . "booktitleaddon")
+					    ("shorttitle" . none)
+					    ("sorttitle" . none)
+					    ("indextitle" . none)
+					    ("indexsorttitle" . none)))
+
+					  ("collection, reference"
+					   "incollection, inreference, suppcollection"
+					   (("title" . "booktitle")
+					    ("subtitle" . "booksubtitle")
+					    ("titleaddon" . "booktitleaddon")
+					    ("shorttitle" . none)
+					    ("sorttitle" . none)
+					    ("indextitle" . none)
+					    ("indexsorttitle" . none)))
+
+					  ("proceedings"
+					   "inproceedings"
+					   (("title" . "booktitle")
+					    ("subtitle" . "booksubtitle")
+					    ("titleaddon" . "booktitleaddon")
+					    ("shorttitle" . none)
+					    ("sorttitle" . none)
+					    ("indextitle" . none)
+					    ("indexsorttitle" . none)))
+
+					  ("periodical"
+					   "article, suppperiodical"
+					   (("title" . "journaltitle")
+					    ("subtitle" . "journalsubtitle")
+					    ("shorttitle" . none)
+					    ("sorttitle" . none)
+					    ("indextitle" . none)
+					    ("indexsorttitle" . none))))
+  "Inheritance scheme for BibLaTeX cross-referencing.
+Inheritances are specified for pairs of source and target entry
+type, where the target is the cross-referencing entry and the
+source the cross-referenced entry.  Each pair specifies the
+fields in the source and the fields in the target that they
+correspond with.
+
+Inheritances valid for all entry types are defined by specifying
+the entry type as \"all\".  The entry type may also be a
+comma-separated list of entry types.
+
+If no inheritance rule is set up for a given entry type+field
+combination, the field inherits from the same-name field in the
+cross-referenced entry.  If no inheritance should take place, the
+target field is set to the symbol `none'.")
+
+;; Regexes describing BibTeX identifiers and keys.  Note that while $ ^ & are
+;; valid in BibTeX keys, they may nonetheless be problematic, because they are
+;; special for TeX.  The difference between `parsebib--bibtex-identifier' and
+;; `parsebib--key-regexp' are the parentheses (), which are valid in keys.  It may in
+;; fact not be necessary (or desirable) to distinguish the two, but until
+;; someone complains, I'll keep it this way.
+(defconst parsebib--bibtex-identifier "[^\"@\\#%',={}() \t\n\f]+" "Regexp describing a licit BibTeX identifier.")
+(defconst parsebib--key-regexp        "[^\"@\\#%',={} \t\n\f]+" "Regexp describing a licit key.")
+(defconst parsebib--entry-start "^[ \t]*@" "Regexp describing the start of an entry.")
+
+;; Emacs 24.3 compatibility code.
+(unless (fboundp 'define-error)
+  ;; This definition is simply copied from the Emacs 24.4 sources
+  (defun define-error (name message &optional parent)
+    "Define NAME as a new error signal.
+MESSAGE is a string that will be output to the echo area if such an error
+is signaled without being caught by a `condition-case'.
+PARENT is either a signal or a list of signals from which it inherits.
+Defaults to `error'."
+    (unless parent (setq parent 'error))
+    (let ((conditions
+           (if (consp parent)
+               (apply #'nconc
+                      (mapcar (lambda (parent)
+                                (cons parent
+                                      (or (get parent 'error-conditions)
+                                          (error "Unknown signal `%s'" parent))))
+                              parent))
+             (cons parent (get parent 'error-conditions)))))
+      (put name 'error-conditions
+           (delete-dups (copy-sequence (cons name conditions))))
+      (when message (put name 'error-message message)))))
+
+(define-error 'parsebib-entry-type-error "Illegal entry type" 'error)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; matching and parsing stuff ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun parsebib--looking-at-goto-end (str &optional match)
+  "Like `looking-at' but move point to the end of the matching string STR.
+MATCH acts just like the argument to MATCH-END, and defaults to
+0. Comparison is done case-insensitively."
+  (or match (setq match 0))
+  (let ((case-fold-search t))
+    (if (looking-at str)
+        (goto-char (match-end match)))))
+
+(defun parsebib--match-paren-forward ()
+  "Move forward to the closing paren matching the opening paren at point.
+This function handles parentheses () and braces {}.  Return t if
+a matching parenthesis was found.  This function puts point
+immediately after the matching parenthesis."
+  (cond
+   ((eq (char-after) ?\{)
+    (parsebib--match-brace-forward))
+   ((eq (char-after) ?\()
+    (bibtex-end-of-entry))))
+
+(defun parsebib--match-delim-forward ()
+  "Move forward to the closing delimiter matching the delimiter at point.
+This function handles braces {} and double quotes \"\". Return t
+if a matching delimiter was found."
+  (let ((result (cond
+                 ((eq (char-after) ?\{)
+                  (parsebib--match-brace-forward))
+                 ((eq (char-after) ?\")
+                  (parsebib--match-quote-forward)))))
+    result))
+
+(defun parsebib--match-brace-forward ()
+  "Move forward to the closing brace matching the opening brace at point."
+  (with-syntax-table bibtex-braced-string-syntax-table
+    (forward-sexp 1)
+    ;; if forward-sexp does not result in an error, we want to return t
+    t))
+
+(defun parsebib--match-quote-forward ()
+  "Move to the closing double quote matching the quote at point."
+  (with-syntax-table bibtex-quoted-string-syntax-table
+    (forward-sexp 1)
+    ;; if forward-sexp does not result in an error, we want to return t
+    t))
+
+(defun parsebib--parse-value (limit &optional strings)
+  "Parse value at point.
+A value is either a field value or a @String expansion.  Return
+the value as a string.  No parsing is done beyond LIMIT, but note
+that parsing may stop well before LIMIT.
+
+STRINGS, if non-nil, is a hash table of @String definitions.
+@String abbrevs in the value to be parsed are then replaced with
+their expansions.  Additionally, newlines in field values are
+removed, white space is reduced to a single space and braces or
+double quotes around field values are removed."
+  (let (res)
+    (while (and (< (point) limit)
+                (not (looking-at-p ",")))
+      (cond
+       ((looking-at-p "[{\"]")
+        (let ((beg (point)))
+          (parsebib--match-delim-forward)
+          (push (buffer-substring-no-properties beg (point)) res)))
+       ((looking-at parsebib--bibtex-identifier)
+        (push (buffer-substring-no-properties (point) (match-end 0)) res)
+        (goto-char (match-end 0)))
+       ((looking-at "[[:space:]]*#[[:space:]]*")
+        (goto-char (match-end 0)))
+       (t (forward-char 1)))) ; so as not to get stuck in an infinite loop.
+    (if strings
+        (string-join (parsebib--expand-strings (nreverse res) strings))
+      (string-join (nreverse res) " # "))))
+
+;;;;;;;;;;;;;;;;;;;;;
+;; expanding stuff ;;
+;;;;;;;;;;;;;;;;;;;;;
+
+(defun parsebib--expand-strings (strings abbrevs)
+  "Expand strings in STRINGS using expansions in ABBREVS.
+STRINGS is a list of strings.  If a string in STRINGS has an
+expansion in hash table ABBREVS, replace it with its expansion.
+Otherwise, if the string is enclosed in braces {} or double
+quotes \"\", remove the delimiters.  In addition, newlines and
+multiple spaces in the string are replaced with a single space."
+  (mapcar (lambda (str)
+            (setq str (replace-regexp-in-string "[ \t\n\f]+" " " str))
+            (cond
+             ((gethash str abbrevs))
+             ((string-match "\\`[\"{]\\(.*?\\)[\"}]\\'" str)
+              (match-string 1 str))
+             (t str)))
+          strings))
+
+(defun parsebib-expand-xrefs (entries inheritance)
+  "Expand cross-referencing items in ENTRIES.
+BibTeX entries in ENTRIES that have a `crossref' field are
+expanded with the fields in the cross-referenced entry.  ENTRIES
+is a hash table with entries.  This hash table is updated with
+the new fields.  The return value of this function is always nil.
+
+INHERITANCE indicates the inheritance schema.  It can be a symbol
+`BibTeX' or `biblatex', or it can be an explicit inheritance
+schema.  See the variable `parsebib--biblatex-inheritances' for
+details on the structure of such an inheritance schema."
+  (maphash (lambda (key fields)
+             (let ((xref (cdr (assoc-string "crossref" fields))))
+               (when xref
+                 (if (string-match-p (concat "\\b[\"{]" parsebib--key-regexp "[\"}]\\b") xref)
+                     (setq xref (substring xref 1 -1)))
+                 (let* ((source (gethash xref entries))
+                        (updated-entry (parsebib--get-xref-fields fields source inheritance)))
+                   (when updated-entry
+                     (puthash key updated-entry entries))))))
+           entries))
+
+(defun parsebib--get-xref-fields (target-entry source-entry inheritance)
+  "Return TARGET-ENTRY supplemented with fields inherited from SOURCE-ENTRY.
+TARGET-ENTRY and SOURCE-ENTRY are entry alists.  Fields in
+SOURCE-ENTRY for which TARGET-ENTRY has no value are added to
+TARGET-ENTRY.  Return value is the modified TARGET-ENTRY.
+
+INHERITANCE is an inheritance schema.  It can either be one of
+the symbols `BibTeX' or `biblatex', or it can be an explicit
+inheritance schema.  See the variable
+`parsebib--biblatex-inheritances' for details on the structure of
+such an inheritance schema."
+  (when (and target-entry source-entry)
+    (when (eq inheritance 'biblatex)
+      (setq inheritance parsebib--biblatex-inheritances))
+    (let* ((inheritable-fields (unless (eq inheritance 'BibTeX)
+                                 (append (cl-third (cl-find-if (lambda (elem)
+                                                                 (and (string-match-p (concat "\\b" (cdr (assoc-string "=type=" source-entry)) "\\b") (cl-first elem))
+                                                                      (string-match-p (concat "\\b" (cdr (assoc-string "=type=" target-entry)) "\\b") (cl-second elem))))
+                                                               inheritance))
+                                         (cl-third (assoc-string "all" inheritance)))))
+           (new-fields (delq nil (mapcar (lambda (field)
+                                           (let ((target-field (parsebib--get-target-field (car field) inheritable-fields)))
+                                             (if (and target-field
+                                                      (not (assoc-string target-field target-entry 'case-fold)))
+                                                 (cons target-field (cdr field)))))
+                                         source-entry))))
+      (append target-entry new-fields))))
+
+(defun parsebib--get-target-field (source-field inheritances)
+  "Return the target field for inheritance from SOURCE-FIELD.
+Inheritance is determined by INHERITANCES, which is an alist of
+source/target pairs.  If no inheritance should take place for
+SOURCE-FIELD, the target in the relevant item in INHERITANCES is
+the symbol `none'.  If there is no item for SOURCE-FIELD in
+INHERITANCES, SOURCE-FIELD is returned.  Note that it is valid
+for INHERITANCES to be nil."
+  ;; Note: the argument INHERITANCES differs from the INHERITANCE argument in
+  ;; the previous two functions.  It is a simple alist of (source-field
+  ;; . target-field) pairs.
+  (let ((target-field (cdr (assoc-string source-field inheritances 'case-fold))))
+    (cond
+     ((null target-field)
+      source-field)
+     ((eq target-field 'none)
+      nil)
+     (t target-field))))
+
+;;;;;;;;;;;;;;;;;;;
+;; low-level API ;;
+;;;;;;;;;;;;;;;;;;;
+
+(defun parsebib-find-next-item (&optional pos)
+  "Find the first (potential) BibTeX item following POS.
+This function simply searches for an @ at the start of a line,
+possibly preceded by spaces or tabs, followed by a string of
+characters as defined by `parsebib--bibtex-identifier'.  When
+successful, point is placed right after the item's type, i.e.,
+generally on the opening brace or parenthesis following the entry
+type, \"@Comment\", \"@Preamble\" or \"@String\".
+
+The return value is the name of the item as a string, either
+\"Comment\", \"Preamble\" or \"String\", or the entry
+type (without the @). If an item name is found that includes an
+illegal character, an error of type `parsebib-entry-type-error'
+is raised. If no item is found, nil is returned and point is left
+at the end of the buffer.
+
+POS can be a number or a marker and defaults to point."
+  (when pos (goto-char pos))
+  (when (re-search-forward parsebib--entry-start nil 0)
+    (if (parsebib--looking-at-goto-end (concat "\\(" parsebib--bibtex-identifier "\\)" "[[:space:]]*[\(\{]?") 1)
+        (match-string-no-properties 1)
+      (signal 'parsebib-entry-type-error (list (point))))))
+
+(defun parsebib-read-comment (&optional pos)
+  "Read the @Comment beginning at the line POS is on.
+Return value is the text of the @Comment including the braces.
+For comments that last until the end of the line (i.e., comments
+that are not delimited by braces), the return value includes the
+whitespace between `@comment' and the actual comment text.
+
+If no comment could be found, return nil.
+
+POS can be a number or a marker.  It does not have to be at the
+beginning of a line, but the @Comment entry must start at the
+beginning of the line POS is on.  If POS is nil, it defaults to
+point."
+  (when pos (goto-char pos))
+  (beginning-of-line)
+  (when (parsebib--looking-at-goto-end (concat parsebib--entry-start "\\(comment\\)[[:space:]]*[\(\{]?") 1)
+    (let ((beg (point)))
+      (if (looking-at-p "[[:space:]]*[\(\{]")
+          (progn (skip-chars-forward "[:space:]")
+                 (parsebib--match-paren-forward))
+        (goto-char (point-at-eol)))
+      (buffer-substring-no-properties beg (point)))))
+
+(defun parsebib-read-string (&optional pos strings)
+  "Read the @String definition beginning at the line POS is on.
+If a proper abbreviation and expansion are found, they are
+returned as a cons cell ( . ).  Otherwise, nil
+is returned.
+
+POS can be a number or a marker.  It does not have to be at the
+beginning of a line, but the @String entry must start at the
+beginning of the line POS is on.  If POS is nil, it defaults to
+point.
+
+If STRINGS is provided it should be a hash table with string
+abbreviations, which are used to expand abbrevs in the string's
+expansion."
+  (when pos (goto-char pos))
+  (beginning-of-line)
+  (when (parsebib--looking-at-goto-end (concat parsebib--entry-start "\\(string[[:space:]]*\\)[\(\{]") 1)
+    (let ((limit (save-excursion
+                   (parsebib--match-paren-forward)
+                   (point))))
+      (parsebib--looking-at-goto-end (concat "[({]\\(" parsebib--bibtex-identifier "\\)[[:space:]]*=[[:space:]]*"))
+      (let ((abbr (match-string-no-properties 1)))
+        (when (and abbr (> (length abbr) 0))            ; if we found an abbrev
+          (let ((expansion (parsebib--parse-value limit strings)))
+            (goto-char limit)
+            (cons abbr expansion)))))))
+
+(defun parsebib-read-preamble (&optional pos)
+  "Read the @Preamble definition at the line POS is on.
+Return the preamble as a string (including the braces surrounding
+the preamble text), or nil if no preamble was found.
+
+POS can be a number or a marker.  It does not have to be at the
+beginning of a line, but the @Preamble must start at the
+beginning of the line POS is on.  If POS is nil, it defaults to
+point."
+  (when pos (goto-char pos))
+  (beginning-of-line)
+  (when (parsebib--looking-at-goto-end (concat parsebib--entry-start "\\(preamble[[:space:]]*\\)[\(\{]") 1)
+    (let ((beg (point)))
+      (when (parsebib--match-paren-forward)
+        (buffer-substring-no-properties beg (point))))))
+
+(defun parsebib-read-entry (type &optional pos strings)
+  "Read a BibTeX entry of type TYPE at the line POS is on.
+TYPE should be a string and should not contain the @
+sign.  The return value is the entry as an alist of ( .
+) cons pairs, or nil if no entry was found.  In this
+alist, the entry key is provided in the field \"=key=\" and the
+entry type in the field \"=type=\".
+
+POS can be a number or a marker.  It does not have to be at the
+beginning of a line, but the entry must start at the beginning of
+the line POS is on.  If POS is nil, it defaults to point.
+
+ENTRY should not be \"Comment\", \"Preamble\" or \"String\", but
+is otherwise not limited to any set of possible entry types. If
+so required, the calling function has to ensure that the entry
+type is valid.
+
+If STRINGS is provided, it should be a hash table with string
+abbreviations, which are used to expand abbrevs in the entry's
+fields."
+  (unless (member-ignore-case type '("comment" "preamble" "string"))
+    (when pos (goto-char pos))
+    (beginning-of-line)
+    (when (parsebib--looking-at-goto-end (concat parsebib--entry-start type "[[:space:]]*[\(\{]"))
+      ;; find the end of the entry and the beginning of the entry key
+      (let* ((limit (save-excursion
+                      (backward-char)
+                      (parsebib--match-paren-forward)
+                      (point)))
+             (beg (progn
+                    (skip-chars-forward " \n\t\f") ; note the space!
+                    (point)))
+             (key (when (parsebib--looking-at-goto-end (concat "\\(" parsebib--key-regexp "\\)[ \t\n\f]*,") 1)
+                    (buffer-substring-no-properties beg (point)))))
+        (or key (setq key "")) ; if no key was found, we pretend it's empty and try to read the entry anyway
+        (skip-chars-forward "^," limit) ; move to the comma after the entry key
+        (let ((fields (cl-loop for field = (parsebib--find-bibtex-field limit strings)
+                               while field collect field)))
+          (push (cons "=type=" type) fields)
+          (push (cons "=key=" key) fields)
+          (nreverse fields))))))
+
+(defun parsebib--find-bibtex-field (limit &optional strings)
+  "Find the field after point.
+Do not search beyond LIMIT (a buffer position).  Return a
+cons (FIELD . VALUE), or nil if no field was found.
+
+If STRINGS is provided it should be a hash table with string
+abbreviations, which are used to expand abbrevs in the field's
+value."
+  (skip-chars-forward "\"#%'(),={} \n\t\f" limit) ; move to the first char of the field name
+  (unless (>= (point) limit)                      ; if we haven't reached the end of the entry
+    (let ((beg (point)))
+      (if (parsebib--looking-at-goto-end (concat "\\(" parsebib--bibtex-identifier "\\)[[:space:]]*=[[:space:]]*") 1)
+          (let ((field-type (buffer-substring-no-properties beg (point))))
+            (let ((field-contents (parsebib--parse-value limit strings)))
+              (cons field-type field-contents)))))))
+
+;;;;;;;;;;;;;;;;;;;;
+;; high-level API ;;
+;;;;;;;;;;;;;;;;;;;;
+
+(defun parsebib-collect-preambles ()
+  "Collect all @Preamble definitions in the current buffer.
+Return a list of strings, each string a separate @Preamble."
+  (save-excursion
+    (goto-char (point-min))
+    (let (res)
+      (cl-loop for item = (parsebib-find-next-item)
+               while item do
+               (when (cl-equalp item "preamble")
+                 (push (parsebib-read-preamble) res)))
+      (nreverse res))))
+
+(defun parsebib-collect-comments ()
+  "Collect all @Comment definitions in the current buffer.
+Return a list of strings, each string a separate @Comment."
+  (save-excursion
+    (goto-char (point-min))
+    (let (res)
+      (cl-loop for item = (parsebib-find-next-item)
+               while item do
+               (when (cl-equalp item "comment")
+                 (push (parsebib-read-comment) res)))
+      (nreverse (delq nil res)))))
+
+(defun parsebib-collect-strings (&optional hash expand-strings)
+  "Collect all @String definitions in the current buffer.
+Return value is a hash with the abbreviations as keys and the
+expansions as values.  If HASH is a hash table with test function
+`equal', it is used to store the @String definitions.  If
+EXPAND-STRINGS is non-nil, @String expansions are expanded
+themselves using the @String definitions already stored in HASH."
+  (or (and (hash-table-p hash)
+           (eq 'equal (hash-table-test hash)))
+      (setq hash (make-hash-table :test #'equal)))
+  (save-excursion
+    (goto-char (point-min))
+    (cl-loop with string = nil
+             for item = (parsebib-find-next-item)
+             while item do
+             (when (cl-equalp item "string")
+               (setq string (parsebib-read-string nil (if expand-strings hash)))
+               (puthash (car string) (cdr string) hash)))
+    hash))
+
+(defun parsebib-collect-entries (&optional hash strings inheritance)
+  "Collect all entries in the current buffer.
+Return value is a hash table containing the entries.  If HASH is
+a hash table, with test function `equal', it is used to store the
+entries.  If STRINGS is non-nil, it should be a hash table of
+string definitions, which are used to expand abbreviations used
+in the entries.
+
+If INHERITANCE is non-nil, cross-references in the entries are
+resolved: if the crossref field of an entry points to an entry
+already in HASH, the fields of the latter that do not occur in
+the entry are added to it.  INHERITANCE indicates the inheritance
+schema used for determining which fields inherit from which
+fields.  It can be a symbol `BibTeX' or `biblatex', or it can be
+an explicit inheritance schema.  (See the variable
+`parsebib--biblatex-inheritances' for details on the structure of
+such an inheritance schema.)  It can also be the symbol t, in
+which case the local variable block is checked for a
+dialect (using the variable `bibtex-dialect'), or, if no such
+local variable is found, the value of the variable
+`bibtex-dialect'."
+  (or (and (hash-table-p hash)
+           (eq 'equal (hash-table-test hash)))
+      (setq hash (make-hash-table :test #'equal)))
+  (if (eq inheritance t)
+      (setq inheritance (or (parsebib-find-bibtex-dialect)
+                            bibtex-dialect
+                            'BibTeX)))
+  (save-excursion
+    (goto-char (point-min))
+    (cl-loop with entry = nil
+             for entry-type = (parsebib-find-next-item)
+             while entry-type do
+             (unless (member-ignore-case entry-type '("preamble" "string" "comment"))
+               (setq entry (parsebib-read-entry entry-type nil strings))
+               (if entry
+                   (puthash (cdr (assoc-string "=key=" entry)) entry hash))))
+    (when inheritance
+      (parsebib-expand-xrefs hash inheritance))
+    hash))
+
+(defun parsebib-find-bibtex-dialect ()
+  "Find the BibTeX dialect of a file if one is set.
+This function looks for a local value of the variable
+`bibtex-dialect' in the local variable block at the end of the
+file.  Return nil if no dialect is found."
+  (save-excursion
+    (goto-char (point-max))
+    (let ((case-fold-search t))
+      (when (re-search-backward (concat parsebib--entry-start "comment") (- (point-max) 3000) t)
+        (let ((comment (parsebib-read-comment)))
+          (when (and comment
+                     (string-match-p "\\`{[ \n\t\r]*Local Variables:" comment)
+                     (string-match-p "End:[ \n\t\r]*}\\'" comment)
+                     (string-match (concat "bibtex-dialect: " (regexp-opt (mapcar #'symbol-name bibtex-dialect-list) t)) comment))
+            (intern (match-string 1 comment))))))))
+
+(defun parsebib-parse-buffer (&optional entries strings expand-strings inheritance)
+  "Parse the current buffer and return all BibTeX data.
+Return list of five elements: a hash table with the entries, a
+hash table with the @String definitions, a list of @Preamble
+definitions, a list of @Comments and the BibTeX dialect, if
+present in the file.
+
+If ENTRIES is a hash table with test function `equal', it is used
+to store the entries.  Any existing entries with identical keys
+are overwritten.  Similarly, if STRINGS is a hash table with test
+function `equal', the @String definitions are stored in it.
+
+If EXPAND-STRINGS is non-nil, abbreviations in the entries and
+@String definitions are expanded using the @String definitions
+already in STRINGS.
+
+If INHERITANCE is non-nil, cross-references in the entries are
+resolved: if the crossref field of an entry points to an entry
+already in ENTRIES, the fields of the latter that do not occur in
+the entry are added to it.  INHERITANCE indicates the inheritance
+schema used for determining which fields inherit from which
+fields.  It can be a symbol `BibTeX' or `biblatex', which means
+to use the default inheritance schema for either dialect, or it
+can be an explicit inheritance schema.  (See the variable
+`parsebib--biblatex-inheritances' for details on the structure of
+such an inheritance schema.)  It can also be the symbol t, in
+which case the local variable block is checked for a
+dialect (using the variable `bibtex-dialect'), or, if no such
+local variable is found, the value of the variable
+`bibtex-dialect'."
+  (save-excursion
+    (goto-char (point-min))
+    (or (and (hash-table-p entries)
+             (eq (hash-table-test entries) 'equal))
+        (setq entries (make-hash-table :test #'equal)))
+    (or (and (hash-table-p strings)
+             (eq (hash-table-test strings) 'equal))
+        (setq strings (make-hash-table :test #'equal)))
+    (let ((dialect (or (parsebib-find-bibtex-dialect)
+                       bibtex-dialect
+                       'BibTeX))
+          preambles comments)
+      (cl-loop for item = (parsebib-find-next-item)
+               while item do
+               (cond
+                ((cl-equalp item "string") ; `cl-equalp' compares strings case-insensitively.
+                 (let ((string (parsebib-read-string nil (if expand-strings strings))))
+                   (if string
+                       (puthash (car string) (cdr string) strings))))
+                ((cl-equalp item "preamble")
+                 (push (parsebib-read-preamble) preambles))
+                ((cl-equalp item "comment")
+                 (push (parsebib-read-comment) comments))
+                ((stringp item)
+                 (let ((entry (parsebib-read-entry item nil (if expand-strings strings))))
+                   (when entry
+                     (puthash (cdr (assoc-string "=key=" entry)) entry entries))))))
+      (when inheritance (parsebib-expand-xrefs entries (if (eq inheritance t) dialect inheritance)))
+      (list entries strings (nreverse preambles) (nreverse comments) dialect))))
+
+(provide 'parsebib)
+
+;;; parsebib.el ends here
diff --git a/lisp/pfuture.el b/lisp/pfuture.el
new file mode 100644
index 00000000..6ae3cd2b
--- /dev/null
+++ b/lisp/pfuture.el
@@ -0,0 +1,292 @@
+;;; pfuture.el --- a simple wrapper around asynchronous processes -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020 Alexander Miller
+
+;; Author: Alexander Miller 
+;; Homepage: https://github.com/Alexander-Miller/pfuture
+;; Package-Requires: ((emacs "25.2"))
+;; Package-Version: 20200425.1357
+;; Package-Commit: d7926de3ba0105a36cfd00811fd6278aea903eef
+;; Version: 1.9
+
+;; 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 .
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'inline)
+
+(defvar pfuture--dummy-buffer nil
+  "Dummy buffer for stderr pipes.")
+
+(define-inline pfuture--delete-process (process)
+  "Delete PROCESS with redisplay inhibited."
+  (inline-letevals (process)
+    (inline-quote
+     (let ((inhibit-redisplay t))
+       (delete-process ,process)))))
+
+(defun pfuture--sentinel (process _)
+  "Delete the stderr pipe process of PROCESS."
+  (unless (process-live-p process)
+    (let* ((stderr-process (process-get process 'stderr-process)))
+      ;; Set stderr-process to nil so that await-to-finish does not delete
+      ;; the buffer again.
+      (process-put process 'stderr-process nil)
+      ;; delete-process may trigger other sentinels. If there are many pfutures,
+      ;; this will overflow the stack.
+      (run-with-idle-timer 0 nil #'pfuture--delete-process stderr-process))))
+
+;;;###autoload
+(defun pfuture-new (&rest cmd)
+  "Create a new future process for command CMD.
+Any arguments after the command are interpreted as arguments to the command.
+This will return a process object with additional 'stderr and 'stdout
+properties, which can be read via \(process-get process 'stdout\) and
+\(process-get process 'stderr\) or alternatively with
+\(pfuture-result process\) or \(pfuture-stderr process\).
+
+Note that CMD must be a *sequence* of strings, meaning
+this is wrong: (pfuture-new \"git status\")
+this is right: (pfuture-new \"git\" \"status\")"
+  (let ((stderr (make-pipe-process
+                 :name "Process Future stderr"
+                 ;; Use a dummy buffer for the stderr process. make-pipe-process creates a
+                 ;; buffer unless one is specified, even when :filter is specified and the
+                 ;; buffer is not used at all.
+                 :buffer (or pfuture--dummy-buffer
+                             (setq pfuture--dummy-buffer (get-buffer-create " *pfuture stderr dummy*")))
+                 :noquery t
+                 :filter #'pfuture--append-stderr)))
+    ;; Make sure that the same buffer is not shared between processes.
+    ;; This is not a race condition, since the pipe is not yet connected and
+    ;; cannot receive input.
+    (set-process-buffer stderr nil)
+    (condition-case err
+        (let ((process
+               (make-process
+                :name "Process Future"
+                :stderr stderr
+                :sentinel #'pfuture--sentinel
+                :filter #'pfuture--append-stdout
+                :command cmd
+                :noquery t))
+              ;; Make the processes share their plist so that 'stderr is easily accessible.
+              (plist (list 'stdout "" 'stderr "" 'stderr-process stderr)))
+          (set-process-plist process plist)
+          (set-process-plist stderr plist)
+          process)
+      (error
+       (pfuture--delete-process stderr)
+       (signal (car err) (cdr err))))))
+
+(defmacro pfuture--decompose-fn-form (fn &rest args)
+  "Expands into the correct call form for FN and ARGS.
+FN may either be a (sharp) quoted function, and unquoted function or an sexp."
+  (declare (indent 1))
+  (pcase fn
+    (`(function ,fn)
+     `(,fn ,@args))
+    (`(quote ,fn)
+     `(,fn ,@args))
+    ((or `(,_ . ,_) `(,_))
+     fn)
+    ((pred null)
+     (ignore fn))
+    (fn
+     `(funcall ,fn ,@args))))
+
+(cl-defmacro pfuture-callback
+    (command &key
+             directory
+             on-success
+             on-error
+             on-status-change
+             name
+             connection-type
+             buffer
+             filter)
+  "Pfuture variant that supports a callback-based workflow.
+Internally based on `make-process'. Requires lexical scope.
+
+The first - and only required - argument is COMMAND. It is an (unquoted) list of
+the command and the arguments for the process that should be started. A vector
+is likewise acceptable - the difference is purely cosmetic (this does not apply
+when command is passed as a variable, in this case it must be a list).
+
+The rest of the argument list is made up of the following keyword arguments:
+
+ON-SUCCESS is the code that will run once the process has finished with an exit
+code of 0. In its context, these variables are bound:
+`process': The process object, as passed to the sentinel callback function.
+`status': The string exit status, as passed to the sentinel callback function.
+`pfuture-buffer': The buffer where the output of the process is collected,
+ including both stdin and stdout. You can use `pfuture-callback-output' to
+ quickly grab the buffer's content.
+
+ON-SUCCESS may take one of 3 forms: an unquoted sexp, a quoted function or an
+unquoted function. In the former two cases the passed fuction will be called
+with `process', `status' and `buffer' as its arguments.
+
+ON-FAILURE is the inverse to ON-SUCCESS; it will only run if the process has
+finished with a non-zero exit code. Otherwise the same conditions apply as for
+ON-SUCCESS.
+
+ON-STATUS-CHANGE will run on every status change, even if the process remains
+running. It is meant for debugging and has access to the same variables as
+ON-SUCCESS and ON-ERROR, including the (potentially incomplete) process output
+buffer. Otherwise the same conditions as for ON-SUCCESS and ON-ERROR apply.
+
+DIRECTORY is the value given to `default-directory' for the context of the
+process. If not given it will fall back the current value of `default-directory'.
+
+NAME will be passed to the :name property of `make-process'. If not given it will
+fall back to \"Pfuture Callback [$COMMAND]\".
+
+CONNECTION-TYPE will be passed to the :connection-process property of
+`make-process'. If not given it will fall back to 'pipe.
+
+BUFFER is the buffer that will be used by the process to collect its output,
+quickly collectible with `pfuture-output-from-buffer'.
+Providing a buffer outside of specific use-cases is not necessary, as by default
+pfuture will assign every launched command its own unique buffer and kill it
+after ON-SUCCESS or ON-ERROR have finished running. However, no such cleanup
+will take place if a custom buffer is provided.
+
+FILTER is a process filter-function (quoted function reference) that can be used
+to overwrite pfuture's own filter. By default pfuture uses its filter function
+to collect the launched process' output in its buffer, thus when providing a
+custom filter output needs to be gathered another way. Note that the process'
+buffer is stored in its `buffer' property and is therefore accessible via
+\(process-get process 'buffer\)."
+  (declare (indent 1))
+  (let* ((command (if (vectorp command)
+                      `(quote ,(cl-map 'list #'identity command))
+                    command))
+         (connection-type (or connection-type (quote 'pipe)))
+         (directory (or directory default-directory)))
+    (unless (or on-success on-error)
+      (setq on-success '(function ignore)))
+    `(let* ((default-directory ,directory)
+            (name (or ,name (format "Pfuture-Callback %s" ,command)))
+            ;; pfuture's buffers are internal implementation details
+            ;; nobody should care if a new one is created
+            (pfuture-buffer (or ,buffer (let (buffer-list-update-hook) (generate-new-buffer name))))
+            (process
+             (make-process
+              :name name
+              :command ,command
+              :connection-type ,connection-type
+              :filter ,(or filter '(function pfuture--append-output-to-buffer))
+              :sentinel (lambda (process status)
+                          (ignore status)
+                          ,@(when on-status-change
+                              `((pfuture--decompose-fn-form ,on-status-change
+                                  process status pfuture-buffer)))
+                          (unless (process-live-p process)
+                            (if (= 0 (process-exit-status process))
+                                (pfuture--decompose-fn-form ,on-success
+                                  process status pfuture-buffer)
+                              (pfuture--decompose-fn-form ,on-error
+                                process status pfuture-buffer))
+                            ,(unless buffer
+                               `(kill-buffer (process-get process 'buffer))))))))
+       (process-put process 'buffer pfuture-buffer)
+       process)))
+
+(defmacro pfuture-callback-output ()
+  "Retrieve the output from the pfuture-buffer variable in the current scope.
+Meant to be used with `pfuture-callback'."
+  `(pfuture-output-from-buffer pfuture-buffer))
+
+(cl-defun pfuture-await (process &key (timeout 1) (just-this-one t))
+  "Block until PROCESS has produced output and return it.
+
+Will accept the following optional keyword arguments:
+
+TIMEOUT: The timeout in seconds to wait for the process. May be a float to
+specify fractional number of seconds. In case of a timeout nil will be returned.
+
+JUST-THIS-ONE: When t only read from the process of FUTURE and no other. For
+details see documentation of `accept-process-output'."
+  (let (inhibit-quit)
+    (accept-process-output
+     process timeout nil just-this-one))
+  (process-get process 'result))
+
+(cl-macrolet
+    ((define-getter (name doc variable )
+       `(define-inline ,name (process)
+          ,doc
+          (declare (side-effect-free t))
+          (inline-letevals (process)
+            (inline-quote
+             (process-get ,',process ',variable))))))
+  (define-getter pfuture-result "Return the output of a pfuture PROCESS." stdout)
+  (define-getter pfuture-stderr "Return the error output of a pfuture PROCESS." stderr))
+
+(defun pfuture-await-to-finish (process)
+  "Keep reading the output of PROCESS until it is done.
+Same as `pfuture-await', but will keep reading (and blocking) so long as the
+process is *alive*.
+
+If the process never quits this method will block forever. Use with caution!"
+  ;; If the sentinel hasn't run, disable it. We are going to delete
+  ;; the stderr process here.
+  (set-process-sentinel process nil)
+  (let (inhibit-quit)
+    (while (accept-process-output process)))
+  (let* ((plist (process-plist process))
+         (stderr-process (plist-get plist 'stderr-process)))
+    (when stderr-process
+      (pfuture--delete-process stderr-process))
+    (plist-get plist 'stdout)))
+
+(defun pfuture--append-output-to-buffer (process msg)
+  "Append PROCESS' MSG to its output buffer."
+  (with-current-buffer (process-get process 'buffer)
+    (goto-char (point-max))
+    (insert msg)))
+
+(defun pfuture--append-stdout (process msg)
+  "Append PROCESS' MSG to the already saved stdout output."
+  (let* ((process-plist (process-plist process))
+         (previous-output (plist-get process-plist 'stdout)))
+    (plist-put process-plist 'stdout
+               (if (zerop (string-bytes previous-output))
+                   msg
+                 (concat previous-output msg)))))
+
+(defun pfuture--append-stderr (process msg)
+  "Append PROCESS' MSG to the already saved stderr output."
+  (let* ((process-plist (process-plist process))
+         (previous-output (plist-get process-plist 'stderr)))
+    (plist-put process-plist 'stderr
+               (if (zerop (string-bytes previous-output))
+                   msg
+                 (concat previous-output msg)))))
+
+(define-inline pfuture-output-from-buffer (buffer)
+  "Return the process output collected in BUFFER."
+  (declare (side-effect-free t))
+  (inline-letevals (buffer)
+    (inline-quote
+     (with-current-buffer ,buffer
+       (buffer-string)))))
+
+(provide 'pfuture)
+
+;;; pfuture.el ends here
diff --git a/lisp/plantuml-mode.el b/lisp/plantuml-mode.el
new file mode 100644
index 00000000..18368f9d
--- /dev/null
+++ b/lisp/plantuml-mode.el
@@ -0,0 +1,763 @@
+;;; plantuml-mode.el --- Major mode for PlantUML    -*- lexical-binding: t; -*-
+
+;; Filename: plantuml-mode.el
+;; Description: Major mode for PlantUML diagrams sources
+;; Compatibility: Tested with Emacs 25 through 27 (current master)
+;; Author: Zhang Weize (zwz)
+;; Maintainer: Carlo Sciolla (skuro)
+;; Keywords: uml plantuml ascii
+;; Package-Commit: ea45a13707abd2a70df183f1aec6447197fc9ccc
+;; Version: 1.2.9
+;; Package-Version: 20191102.2056
+;; Package-X-Original-Version: 1.2.9
+;; Package-Requires: ((dash "2.0.0") (emacs "25.0"))
+
+;; 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see .
+
+;;; Commentary:
+;;
+;; A major mode for plantuml, see: http://plantuml.sourceforge.net/
+;; Plantuml is an open-source tool in java that allows to quickly write :
+;;     - sequence diagram,
+;;     - use case diagram,
+;;     - class diagram,
+;;     - activity diagram,
+;;     - component diagram,
+;;     - state diagram
+;;     - object diagram
+
+;;; Change log:
+;;
+;; version 1.4.1, 2019-09-03 Better indentation; more bugfixing; actually adding `executable' mode
+;; version 1.4.0, 2019-08-21 Added `executable' exec mode to use locally installed `plantuml' binaries, various bugfixes
+;; version 1.3.1, 2019-08-02 Fixed interactive behavior of `plantuml-set-exec-mode'
+;; version 1.3.0, 2019-05-31 Added experimental support for multiple rendering modes and, specifically, preview using a PlantUML server
+;; version 1.2.11, 2019-04-09 Added `plantuml-download-jar'
+;; version 1.2.10, 2019-04-03 Avoid messing with window layouts and buffers -- courtesy of https://github.com/wailo
+;; version 1.2.9, Revamped indentation support, now working with a greater number of keywords
+;; version 1.2.8, 2019-01-07 Support indentation for activate / deactivate blocks; allow customization of `plantuml-java-args'
+;; version 1.2.7, 2018-08-15 Added support for indentation; Fixed the comiling error when installing with melpa
+;; version 1.2.6, 2018-07-17 Introduced custom variable `plantuml-jar-args' to control which arguments are passed to PlantUML jar. Fix the warning of failing to specify types of 'defcustom' variables
+;; version 1.2.5, 2017-08-19 #53 Fixed installation warnings
+;; version 1.2.4, 2017-08-18 #60 Licensed with GPLv3+ to be compatible with Emacs
+;; version 1.2.3, 2016-12-25 #50 unicode support in generated output
+;; version 1.2.2, 2016-11-11 Fixed java commands handling under windows; support spaces in `plantuml-jar-path'
+;; version 1.2.1, 2016-11-11 Support for paths like `~/.plantuml/plantuml.jar' for `plantuml-jar-path' (the tilde was previously unsupported)
+;; version 1.2.0, 2016-11-09 Added `plantuml-preview-current-buffer', courtesy of @7mamu4
+;; version 1.1.1, 2016-11-08 Fix process handling with Windows native emacs; better file extention match for autoloading the mode
+;; version 1.1.0, 2016-10-18 Make PlantUML run headless by default; introduced custom variable `plantuml-java-args' to control which arguments are passed to Plantuml.
+;; version 1.0.1, 2016-10-17 Bugfix release: proper auto-mode-alist regex; init delayed at mode load; avoid calling hooks twice.
+;; version 1.0.0, 2016-10-16 Moved the mode to plantuml-mode, superseding zwz/plantuml-mode and skuro/puml-mode. Added preview for the currently selected region.
+;; version 0.6.7, 2016-10-11 [from puml-mode] Added deprecation warning in favor of plantuml-mode
+;; version 0.6.6, 2016-07-19 [from puml-mode] Added autoload, minor bug fixes
+;; version 0.6.5, 2016-03-24 [from puml-mode] Added UTF8 support and open in new window / frame shortcuts
+;; version 0.6.4, 2015-12-12 [from puml-mode] Added support for comments (single and multiline) -- thanks to https://github.com/nivekuil
+;; version 0.6.3, 2015-11-07 [from puml-mode] Added per-buffer configurability of output type (thanks to https://github.com/davazp)
+;; version 0.6.2, 2015-11-07 [from puml-mode] Added debugging capabilities to improve issue analysis
+;; version 0.6.1, 2015-09-26 [from puml-mode] Bugfix: use eq to compare symbols instead of cl-equalp
+;; version 0.6, 2015-09-26 [from puml-mode] Fixed PNG preview
+;; version 0.5, 2015-09-21 [from puml-mode] Added preview capabilities
+;; version 0.4, 2015-06-14 [from puml-mode] Use a puml- prefix to distinguish from the other plantuml-mode
+;; version 0.3, 2015-06-13 [from puml-mode] Compatibility with Emacs 24.x
+;; version 0.2, 2010-09-20 [from puml-mode] Initialize the keywords from the -language output of plantuml.jar instead of the hard-coded way.
+;; version 0.1, 2010-08-25 [from puml-mode] First version
+
+;;; Code:
+(require 'thingatpt)
+(require 'dash)
+(require 'xml)
+
+(defgroup plantuml-mode nil
+  "Major mode for editing plantuml file."
+  :group 'languages)
+
+(defcustom plantuml-jar-path
+  (expand-file-name "~/plantuml.jar")
+  "The location of the PlantUML executable JAR."
+  :type 'string
+  :group 'plantuml)
+
+(defcustom plantuml-executable-path
+  "plantuml"
+  "The location of the PlantUML executable."
+  :type 'string
+  :group 'plantuml)
+
+(defvar plantuml-mode-hook nil "Standard hook for plantuml-mode.")
+
+(defconst plantuml-mode-version "20190905.838" "The plantuml-mode version string.")
+
+(defvar plantuml-mode-debug-enabled nil)
+
+(defvar plantuml-font-lock-keywords nil)
+
+(defvar plantuml-mode-map
+  (let ((keymap (make-sparse-keymap)))
+    (define-key keymap (kbd "C-c C-c") 'plantuml-preview)
+    keymap)
+  "Keymap for plantuml-mode.")
+
+(defcustom plantuml-java-command "java"
+  "The java command used to execute PlantUML."
+  :type 'string
+  :group 'plantuml)
+
+(defcustom plantuml-java-args (list "-Djava.awt.headless=true" "-jar" "--illegal-access=deny")
+  "The parameters passed to `plantuml-java-command' when executing PlantUML."
+  :type '(repeat string)
+  :group 'plantuml)
+
+(defcustom plantuml-jar-args (list "-charset" "UTF-8" )
+  "The parameters passed to `plantuml.jar', when executing PlantUML."
+  :type '(repeat string)
+  :group 'plantuml)
+
+(defcustom plantuml-server-url "https://www.plantuml.com/plantuml"
+  "The base URL of the PlantUML server."
+  :type 'string
+  :group 'plantuml)
+
+(defcustom plantuml-executable-args (list "-headless")
+  "The parameters passed to plantuml executable when executing PlantUML."
+  :type '(repeat string)
+  :group 'plantuml)
+
+(defcustom plantuml-default-exec-mode 'server
+  "Default execution mode for PlantUML.  Valid values are:
+- `jar': run PlantUML as a JAR file (requires a local install of the PlantUML JAR file, see `plantuml-jar-path'"
+  :type 'symbol
+  :group 'plantuml
+  :options '(jar server executable))
+
+(defcustom plantuml-suppress-deprecation-warning t
+  "To silence the deprecation warning when `puml-mode' is found upon loading."
+  :type 'boolean
+  :group 'plantuml)
+
+(defcustom plantuml-indent-level 8
+  "Indentation level of PlantUML lines")
+
+(defun plantuml-jar-render-command (&rest arguments)
+  "Create a command line to execute PlantUML with arguments (as ARGUMENTS)."
+  (let* ((cmd-list (append plantuml-java-args (list (expand-file-name plantuml-jar-path)) plantuml-jar-args arguments))
+         (cmd (mapconcat 'identity cmd-list "|")))
+    (plantuml-debug (format "Command is [%s]" cmd))
+    cmd-list))
+
+;;; syntax table
+(defvar plantuml-mode-syntax-table
+  (let ((synTable (make-syntax-table)))
+    (modify-syntax-entry ?\/  ". 14c"   synTable)
+    (modify-syntax-entry ?'   "< 23"    synTable)
+    (modify-syntax-entry ?\n  ">"       synTable)
+    (modify-syntax-entry ?\r  ">"       synTable)
+    (modify-syntax-entry ?!   "w"       synTable)
+    (modify-syntax-entry ?@   "w"       synTable)
+    (modify-syntax-entry ?#   "'"       synTable)
+    synTable)
+  "Syntax table for `plantuml-mode'.")
+
+(defvar plantuml-types nil)
+(defvar plantuml-keywords nil)
+(defvar plantuml-preprocessors nil)
+(defvar plantuml-builtins nil)
+
+;; keyword completion
+(defvar plantuml-kwdList nil "The plantuml keywords.")
+
+;; PlantUML execution mode
+(defvar-local plantuml-exec-mode nil
+  "The Plantuml execution mode override. See `plantuml-default-exec-mode' for acceptable values.")
+
+(defun plantuml-set-exec-mode (mode)
+  "Set the execution mode MODE for PlantUML."
+  (interactive (let* ((completion-ignore-case t)
+                      (supported-modes        '("jar" "server" "executable")))
+                 (list (completing-read (format "Exec mode [%s]: " plantuml-exec-mode)
+                                        supported-modes
+                                        nil
+                                        t
+                                        nil
+                                        nil
+                                        plantuml-exec-mode))))
+  (if (member mode '("jar" "server" "executable"))
+      (setq plantuml-exec-mode (intern mode))
+    (error (concat "Unsupported mode:" mode))))
+
+(defun plantuml-get-exec-mode ()
+  "Retrieves the currently active PlantUML exec mode."
+  (or plantuml-exec-mode
+      plantuml-default-exec-mode))
+
+(defun plantuml-enable-debug ()
+  "Enables debug messages into the *PLANTUML Messages* buffer."
+  (interactive)
+  (setq plantuml-mode-debug-enabled t))
+
+(defun plantuml-disable-debug ()
+  "Stops any debug messages to be added into the *PLANTUML Messages* buffer."
+  (interactive)
+  (setq plantuml-mode-debug-enabled nil))
+
+(defun plantuml-debug (msg)
+  "Writes msg (as MSG) into the *PLANTUML Messages* buffer without annoying the user."
+  (if plantuml-mode-debug-enabled
+      (let* ((log-buffer-name "*PLANTUML Messages*")
+             (log-buffer (get-buffer-create log-buffer-name)))
+        (save-excursion
+          (with-current-buffer log-buffer
+            (goto-char (point-max))
+            (insert msg)
+            (insert "\n"))))))
+
+(defun plantuml-download-jar ()
+  "Download the latest PlantUML JAR file and install it into `plantuml-jar-path'."
+  (interactive)
+  (if (y-or-n-p (format "Download the latest PlantUML JAR file into %s? " plantuml-jar-path))
+      (if (or (not (file-exists-p plantuml-jar-path))
+              (y-or-n-p (format "The PlantUML jar file already exists at %s, overwrite? " plantuml-jar-path)))
+          (with-current-buffer (url-retrieve-synchronously "https://search.maven.org/solrsearch/select?q=g:net.sourceforge.plantuml+AND+a:plantuml&core=gav&start=0&rows=1&wt=xml")
+            (mkdir (file-name-directory plantuml-jar-path) t)
+            (let* ((parse-tree (xml-parse-region))
+                   (doc        (->> parse-tree
+                                    (assq 'response)
+                                    (assq 'result)
+                                    (assq 'doc)))
+                   (strs       (xml-get-children doc 'str))
+                   (version    (->> strs
+                                    (--filter (string-equal "v" (xml-get-attribute it 'name)))
+                                    (car)
+                                    (xml-node-children)
+                                    (car))))
+              (message (concat "Downloading PlantUML v" version " into " plantuml-jar-path))
+              (url-copy-file (format "https://search.maven.org/remotecontent?filepath=net/sourceforge/plantuml/plantuml/%s/plantuml-%s.jar" version version) plantuml-jar-path t)
+              (kill-buffer)))
+        (message "Aborted."))
+    (message "Aborted.")))
+
+(defun plantuml-jar-java-version ()
+  "Inspects the Java runtime version of the configured Java command in `plantuml-java-command'."
+  (save-excursion
+    (save-match-data
+      (with-temp-buffer
+        (call-process plantuml-java-command nil t nil "-XshowSettings:properties" "-version")
+        (re-search-backward "java.version = \\(1.\\)?\\([[:digit:]]+\\)")
+        (string-to-number (match-string 2))))))
+
+(defun plantuml-jar-get-language (buf)
+  "Retrieve the language specification from the PlantUML JAR file and paste it into BUF."
+  (unless (or (eq system-type 'cygwin) (file-exists-p plantuml-jar-path))
+    (error "Could not find plantuml.jar at %s" plantuml-jar-path))
+  (with-current-buffer buf
+    (let ((cmd-args (append (list plantuml-java-command nil t nil)
+                            (plantuml-jar-render-command "-language"))))
+      (apply 'call-process cmd-args)
+      (goto-char (point-min)))))
+
+(defun plantuml-server-get-language (buf)
+  "Retrieve the language specification from the PlantUML server and paste it into BUF."
+  (let ((lang-url (concat plantuml-server-url "/language")))
+    (with-current-buffer buf
+      (url-insert-file-contents lang-url))))
+
+(defun plantuml-executable-get-language (buf)
+  "Retrieve the language specification from the PlantUML executable and paste it into BUF."
+  (with-current-buffer buf
+    (let ((cmd-args (append (list plantuml-executable-path nil t nil) (list "-language"))))
+      (apply 'call-process cmd-args)
+      (goto-char (point-min)))))
+
+(defun plantuml-get-language (mode buf)
+  "Retrieve the language spec using the preferred PlantUML execution mode MODE.  Paste the result into BUF."
+  (let ((get-fn (pcase mode
+                  ('jar #'plantuml-jar-get-language)
+                  ('server #'plantuml-server-get-language)
+                  ('executable #'plantuml-executable-get-language))))
+    (if get-fn
+        (funcall get-fn buf)
+      (error "Unsupported execution mode %s" mode))))
+
+(defun plantuml-init (mode)
+  "Initialize the keywords or builtins from the cmdline language output.  Use exec mode MODE to load the language details."
+  (with-temp-buffer
+    (plantuml-get-language mode (current-buffer))
+    (let ((found (search-forward ";" nil t))
+          (word "")
+          (count 0)
+          (pos 0))
+      (while found
+        (forward-char)
+        (setq word (current-word))
+        (if (string= word "EOF") (setq found nil)
+          ;; else
+          (forward-line)
+          (setq count (string-to-number (current-word)))
+          (beginning-of-line 2)
+          (setq pos (point))
+          (forward-line count)
+          (cond ((string= word "type")
+                 (setq plantuml-types
+                       (split-string
+                        (buffer-substring-no-properties pos (point)))))
+                ((string= word "keyword")
+                 (setq plantuml-keywords
+                       (split-string
+                        (buffer-substring-no-properties pos (point)))))
+                ((string= word "preprocessor")
+                 (setq plantuml-preprocessors
+                       (split-string
+                        (buffer-substring-no-properties pos (point)))))
+                (t (setq plantuml-builtins
+                         (append
+                          plantuml-builtins
+                          (split-string
+                           (buffer-substring-no-properties pos (point)))))))
+          (setq found (search-forward ";" nil nil)))))))
+
+(defconst plantuml-preview-buffer "*PLANTUML Preview*")
+
+(defvar plantuml-output-type
+  (if (not (display-images-p))
+      "txt"
+    (cond ((image-type-available-p 'svg) "svg")
+          ((image-type-available-p 'png) "png")
+          (t "txt")))
+  "Specify the desired output type to use for generated diagrams.")
+
+(defun plantuml-read-output-type ()
+  "Read from the minibuffer a output type."
+  (let* ((completion-ignore-case t)
+         (available-types
+          (append
+           (and (image-type-available-p 'svg) '("svg"))
+           (and (image-type-available-p 'png) '("png"))
+           '("txt"))))
+    (completing-read (format "Output type [%s]: " plantuml-output-type)
+                     available-types
+                     nil
+                     t
+                     nil
+                     nil
+                     plantuml-output-type)))
+
+(defun plantuml-set-output-type (type)
+  "Set the desired output type (as TYPE) for the current buffer.
+If the
+major mode of the current buffer mode is not plantuml-mode, set the
+default output type for new buffers."
+  (interactive (list (plantuml-read-output-type)))
+  (setq plantuml-output-type type))
+
+(defun plantuml-is-image-output-p ()
+  "Return non-nil if the diagram output format is an image, false if it's text based."
+  (not (equal "txt" plantuml-output-type)))
+
+(defun plantuml-jar-output-type-opt (output-type)
+  "Create the flag to pass to PlantUML according to OUTPUT-TYPE.
+Note that output type `txt' is promoted to `utxt' for better rendering."
+  (concat "-t" (pcase output-type
+                 ("txt" "utxt")
+                 (_     output-type))))
+
+(defun plantuml-jar-start-process (buf)
+  "Run PlantUML as an Emacs process and puts the output into the given buffer (as BUF)."
+  (let ((java-args (if (<= 8 (plantuml-jar-java-version))
+                       (remove "--illegal-access=deny" plantuml-java-args)
+                     plantuml-java-args)))
+    (apply #'start-process
+           "PLANTUML" buf plantuml-java-command
+           `(,@java-args
+             ,(expand-file-name plantuml-jar-path)
+             ,(plantuml-jar-output-type-opt plantuml-output-type)
+             ,@plantuml-jar-args
+             "-p"))))
+
+(defun plantuml-executable-start-process (buf)
+  "Run PlantUML as an Emacs process and puts the output into the given buffer (as BUF)."
+  (apply #'start-process
+         "PLANTUML" buf plantuml-executable-path
+         `(,@plantuml-executable-args
+           ,(plantuml-jar-output-type-opt plantuml-output-type)
+           "-p")))
+
+(defun plantuml-update-preview-buffer (prefix buf)
+  "Show the preview in the preview buffer BUF.
+Window is selected according to PREFIX:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (let ((imagep (and (display-images-p)
+                     (plantuml-is-image-output-p))))
+    (cond
+     ((= prefix 16) (switch-to-buffer-other-frame buf))
+     ((= prefix 4)  (switch-to-buffer-other-window buf))
+     (t             (display-buffer buf)))
+    (when imagep
+      (with-current-buffer buf
+        (image-mode)
+        (set-buffer-multibyte t)))))
+
+(defun plantuml-jar-preview-string (prefix string buf)
+  "Preview the diagram from STRING by running the PlantUML JAR.
+Put the result into buffer BUF.  Window is selected according to PREFIX:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (let* ((process-connection-type nil)
+         (ps (plantuml-jar-start-process buf)))
+    (process-send-string ps string)
+    (process-send-eof ps)
+    (set-process-sentinel ps
+                          (lambda (_ps event)
+                            (unless (equal event "finished\n")
+                              (error "PLANTUML Preview failed: %s" event))
+                            (plantuml-update-preview-buffer prefix buf)))))
+
+(defun plantuml-server-encode-url (string)
+  "Encode the string STRING into a URL suitable for PlantUML server interactions."
+  (let* ((coding-system (or buffer-file-coding-system
+                            "utf8"))
+         (encoded-string (base64-encode-string (encode-coding-string string coding-system) t)))
+    (concat plantuml-server-url "/" plantuml-output-type "/-base64-" encoded-string)))
+
+(defun plantuml-server-preview-string (prefix string buf)
+  "Preview the diagram from STRING as rendered by the PlantUML server.
+Put the result into buffer BUF and place it according to PREFIX:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (let* ((url-request-location (plantuml-server-encode-url string)))
+    (save-current-buffer
+      (save-match-data
+        (url-retrieve url-request-location
+                      (lambda (status)
+                        ;; TODO: error check
+                        (goto-char (point-min))
+                        ;; skip the HTTP headers
+                        (while (not (looking-at "\n"))
+                          (forward-line))
+                        (kill-region (point-min) (+ 1 (point)))
+                        (copy-to-buffer buf (point-min) (point-max))
+                        (plantuml-update-preview-buffer prefix buf)))))))
+
+(defun plantuml-executable-preview-string (prefix string buf)
+  "Preview the diagram from STRING by running the PlantUML JAR.
+Put the result into buffer BUF.  Window is selected according to PREFIX:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (let* ((process-connection-type nil)
+         (ps (plantuml-executable-start-process buf)))
+    (process-send-string ps string)
+    (process-send-eof ps)
+    (set-process-sentinel ps
+                          (lambda (_ps event)
+                            (unless (equal event "finished\n")
+                              (error "PLANTUML Preview failed: %s" event))
+                            (plantuml-update-preview-buffer prefix buf)))))
+
+(defun plantuml-exec-mode-preview-string (prefix mode string buf)
+  "Preview the diagram from STRING using the execution mode MODE.
+Put the result into buffer BUF, selecting the window according to PREFIX:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (let ((preview-fn (pcase mode
+                      ('jar    #'plantuml-jar-preview-string)
+                      ('server #'plantuml-server-preview-string)
+                      ('executable #'plantuml-executable-preview-string))))
+    (if preview-fn
+        (funcall preview-fn prefix string buf)
+      (error "Unsupported execution mode %s" mode))))
+
+(defun plantuml-preview-string (prefix string)
+  "Preview diagram from PlantUML sources (as STRING), using prefix (as PREFIX)
+to choose where to display it."
+  (let ((b (get-buffer plantuml-preview-buffer)))
+    (when b
+      (kill-buffer b)))
+
+  (let* ((imagep (and (display-images-p)
+                      (plantuml-is-image-output-p)))
+         (buf (get-buffer-create plantuml-preview-buffer))
+         (coding-system-for-read (and imagep 'binary))
+         (coding-system-for-write (and imagep 'binary)))
+    (plantuml-exec-mode-preview-string prefix (plantuml-get-exec-mode) string buf)))
+
+(defun plantuml-preview-buffer (prefix)
+  "Preview diagram from the PlantUML sources in the current buffer.
+Uses prefix (as PREFIX) to choose where to display it:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (interactive "p")
+  (plantuml-preview-string prefix (buffer-string)))
+
+(defun plantuml-preview-region (prefix begin end)
+  "Preview diagram from the PlantUML sources in from BEGIN to END.
+Uses the current region when called interactively.
+Uses prefix (as PREFIX) to choose where to display it:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (interactive "p\nr")
+  (plantuml-preview-string prefix (concat "@startuml\n"
+                                          (buffer-substring-no-properties
+                                           begin end)
+                                          "\n@enduml")))
+
+(defun plantuml-preview-current-block (prefix)
+  "Preview diagram from the PlantUML sources from the previous @startuml to the next @enduml.
+Uses prefix (as PREFIX) to choose where to display it:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (interactive "p")
+  (save-restriction
+    (narrow-to-region
+     (search-backward "@startuml") (search-forward "@enduml"))
+    (plantuml-preview-buffer prefix)))
+
+(defun plantuml-preview (prefix)
+  "Preview diagram from the PlantUML sources.
+Uses the current region if one is active, or the entire buffer otherwise.
+Uses prefix (as PREFIX) to choose where to display it:
+- 4  (when prefixing the command with C-u) -> new window
+- 16 (when prefixing the command with C-u C-u) -> new frame.
+- else -> new buffer"
+  (interactive "p")
+  (if mark-active
+      (plantuml-preview-region prefix (region-beginning) (region-end))
+    (plantuml-preview-buffer prefix)))
+
+(defun plantuml-init-once (&optional mode)
+  "Ensure initialization only happens once.  Use exec mode MODE to load the language details or by first querying `plantuml-get-exec-mode'."
+  (let ((mode (or mode (plantuml-get-exec-mode))))
+    (unless plantuml-kwdList
+      (plantuml-init mode)
+      (defvar plantuml-types-regexp (concat "^\\s *\\(" (regexp-opt plantuml-types 'words) "\\|\\<\\(note\\s +over\\|note\\s +\\(left\\|right\\|bottom\\|top\\)\\s +\\(of\\)?\\)\\>\\|\\<\\(\\(left\\|center\\|right\\)\\s +\\(header\\|footer\\)\\)\\>\\)"))
+      (defvar plantuml-keywords-regexp (concat "^\\s *" (regexp-opt plantuml-keywords 'words)  "\\|\\(<\\|<|\\|\\*\\|o\\)\\(\\.+\\|-+\\)\\|\\(\\.+\\|-+\\)\\(>\\||>\\|\\*\\|o\\)\\|\\.\\{2,\\}\\|-\\{2,\\}"))
+      (defvar plantuml-builtins-regexp (regexp-opt plantuml-builtins 'words))
+      (defvar plantuml-preprocessors-regexp (concat "^\\s *" (regexp-opt plantuml-preprocessors 'words)))
+
+      ;; Below are the regexp's for indentation.
+      ;; Notes:
+      ;; - there is some control on what it is indented by overriding some of below
+      ;;   X-start and X-end regexp before plantuml-mode is loaded. E.g., to disable
+      ;;   indentation on activate, you might define in your .emacs something like
+      ;;      (setq plantuml-indent-regexp-activate-start
+      ;;         "NEVER MATCH THIS EXPRESSION"); define _before_ load plantuml-mode!
+      ;;      (setq plantuml-indent-regexp-activate-end
+      ;;          "NEVER MATCH THIS EXPRESSION"); define _before_ load plantuml-mode!
+      ;; - due to the nature of using (context-insensitive) regexp, indentation have
+      ;;   following limitations
+      ;;   - commands commented out by /' ... '/ will _not_ be ignored
+      ;;     and potentially lead to miss-indentation
+      ;; - you can though somewhat correct mis-indentation by adding in '-comment lines
+      ;;   PLANTUML_MODE_INDENT_INCREASE and/or PLANTUML_MODE_INDENT_DECREASE
+      ;;   to increase and/or decrease the level of indentation
+      ;;   (Note: the line with the comment should not contain any text matching other indent
+      ;;    regexp or this user-control instruction will be ignored; also at most will count
+      ;;    per line ...)
+      (defvar plantuml-indent-regexp-block-start "^.*{\s*$"
+        "Indentation regex for all plantuml elements that might define a {} block.
+Plantuml elements like skinparam, rectangle, sprite, package, etc.
+The opening { has to be the last visible character in the line (whitespace
+might follow).")
+      (defvar plantuml-indent-regexp-note-start "^\s*\\(floating\s+\\)?[hr]?note\s+\\(right\\|left\\|top\\|bottom\\|over\\)[^:]*?$" "simplyfied regex; note syntax is especially inconsistent across diagrams")
+      (defvar plantuml-indent-regexp-group-start "^\s*\\(alt\\|else\\|opt\\|loop\\|par\\|break\\|critical\\|group\\)\\(?:\s+.+\\|$\\)"
+        "Indentation regex for plantuml group elements that are defined for sequence diagrams.
+Two variants for groups: keyword is either followed by whitespace and some text
+or it is followed by line end.")
+      (defvar plantuml-indent-regexp-activate-start "^\s*activate\s+.+$")
+      (defvar plantuml-indent-regexp-box-start "^\s*box\s+.+$")
+      (defvar plantuml-indent-regexp-ref-start "^\s*ref\s+over\s+[^:]+?$")
+      (defvar plantuml-indent-regexp-title-start "^\s*title\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-header-start "^\s*\\(?:\\(?:center\\|left\\|right\\)\s+header\\|header\\)\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-footer-start "^\s*\\(?:\\(?:center\\|left\\|right\\)\s+footer\\|footer\\)\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-legend-start "^\s*\\(?:legend\\|legend\s+\\(?:bottom\\|top\\)\\|legend\s+\\(?:center\\|left\\|right\\)\\|legend\s+\\(?:bottom\\|top\\)\s+\\(?:center\\|left\\|right\\)\\)\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-oldif-start "^.*if\s+\".*\"\s+then\s*\\('.*\\)?$" "used in current activity diagram, sometimes already mentioned as deprecated")
+      (defvar plantuml-indent-regexp-newif-start "^\s*\\(?:else\\)?if\s+(.*)\s+then\s*.*$")
+      (defvar plantuml-indent-regexp-loop-start "^\s*\\(?:repeat\s*\\|while\s+(.*).*\\)$")
+      (defvar plantuml-indent-regexp-fork-start "^\s*\\(?:fork\\|split\\)\\(?:\s+again\\)?\s*$")
+      (defvar plantuml-indent-regexp-macro-start "^\s*!definelong.*$")
+      (defvar plantuml-indent-regexp-user-control-start "^.*'.*\s*PLANTUML_MODE_INDENT_INCREASE\s*.*$")
+      (defvar plantuml-indent-regexp-start (list plantuml-indent-regexp-block-start
+                                                 plantuml-indent-regexp-group-start
+                                                 plantuml-indent-regexp-activate-start
+                                                 plantuml-indent-regexp-box-start
+                                                 plantuml-indent-regexp-ref-start
+                                                 plantuml-indent-regexp-legend-start
+                                                 plantuml-indent-regexp-note-start
+                                                 plantuml-indent-regexp-newif-start
+                                                 plantuml-indent-regexp-loop-start
+                                                 plantuml-indent-regexp-fork-start
+                                                 plantuml-indent-regexp-title-start
+                                                 plantuml-indent-regexp-header-start
+                                                 plantuml-indent-regexp-footer-start
+                                                 plantuml-indent-regexp-macro-start
+                                                 plantuml-indent-regexp-oldif-start
+                                                 plantuml-indent-regexp-user-control-start))
+      (defvar plantuml-indent-regexp-block-end "^\s*\\(?:}\\|endif\\|else\s*.*\\|end\\)\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-note-end "^\s*\\(end\s+note\\|end[rh]note\\)\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-group-end "^\s*end\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-activate-end "^\s*deactivate\s+.+$")
+      (defvar plantuml-indent-regexp-box-end "^\s*end\s+box\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-ref-end "^\s*end\s+ref\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-title-end "^\s*end\s+title\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-header-end "^\s*endheader\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-footer-end "^\s*endfooter\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-legend-end "^\s*endlegend\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-oldif-end "^\s*\\(endif\\|else\\)\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-newif-end "^\s*\\(endif\\|elseif\\|else\\)\s*.*$")
+      (defvar plantuml-indent-regexp-loop-end "^\s*\\(repeat\s*while\\|endwhile\\)\s*.*$")
+      (defvar plantuml-indent-regexp-fork-end "^\s*\\(\\(fork\\|split\\)\s+again\\|end\s+\\(fork\\|split\\)\\)\s*$")
+      (defvar plantuml-indent-regexp-macro-end "^\s*!enddefinelong\s*\\('.*\\)?$")
+      (defvar plantuml-indent-regexp-user-control-end "^.*'.*\s*PLANTUML_MODE_INDENT_DECREASE\s*.*$")
+      (defvar plantuml-indent-regexp-end (list plantuml-indent-regexp-block-end
+                                               plantuml-indent-regexp-group-end
+                                               plantuml-indent-regexp-activate-end
+                                               plantuml-indent-regexp-box-end
+                                               plantuml-indent-regexp-ref-end
+                                               plantuml-indent-regexp-legend-end
+                                               plantuml-indent-regexp-note-end
+                                               plantuml-indent-regexp-newif-end
+                                               plantuml-indent-regexp-loop-end
+                                               plantuml-indent-regexp-fork-end
+                                               plantuml-indent-regexp-title-end
+                                               plantuml-indent-regexp-header-end
+                                               plantuml-indent-regexp-footer-end
+                                               plantuml-indent-regexp-macro-end
+                                               plantuml-indent-regexp-oldif-end
+                                               plantuml-indent-regexp-user-control-end))
+      (setq plantuml-font-lock-keywords
+            `(
+              (,plantuml-types-regexp . font-lock-type-face)
+              (,plantuml-keywords-regexp . font-lock-keyword-face)
+              (,plantuml-builtins-regexp . font-lock-builtin-face)
+              (,plantuml-preprocessors-regexp . font-lock-preprocessor-face)
+              ;; note: order matters
+              ))
+
+      (setq plantuml-kwdList (make-hash-table :test 'equal))
+      (mapc (lambda (x) (puthash x t plantuml-kwdList)) plantuml-types)
+      (mapc (lambda (x) (puthash x t plantuml-kwdList)) plantuml-keywords)
+      (mapc (lambda (x) (puthash x t plantuml-kwdList)) plantuml-builtins)
+      (mapc (lambda (x) (puthash x t plantuml-kwdList)) plantuml-preprocessors)
+      (put 'plantuml-kwdList 'risky-local-variable t)
+
+      ;; clear memory
+      (setq plantuml-types nil)
+      (setq plantuml-keywords nil)
+      (setq plantuml-builtins nil)
+      (setq plantuml-preprocessors nil)
+      (setq plantuml-types-regexp nil)
+      (setq plantuml-keywords-regexp nil)
+      (setq plantuml-builtins-regexp nil)
+      (setq plantuml-preprocessors-regexp nil))))
+
+(defun plantuml-complete-symbol ()
+  "Perform keyword completion on word before cursor."
+  (interactive)
+  (let ((posEnd (point))
+        (meat (thing-at-point 'symbol))
+        maxMatchResult)
+
+    (when (not meat) (setq meat ""))
+
+    (setq maxMatchResult (try-completion meat plantuml-kwdList))
+    (cond ((eq maxMatchResult t))
+          ((null maxMatchResult)
+           (message "Can't find completion for \"%s\"" meat)
+           (ding))
+          ((not (string= meat maxMatchResult))
+           (delete-region (- posEnd (length meat)) posEnd)
+           (insert maxMatchResult))
+          (t (message "Making completion list...")
+             (with-output-to-temp-buffer "*Completions*"
+               (display-completion-list
+                (all-completions meat plantuml-kwdList)))
+             (message "Making completion list...%s" "done")))))
+
+
+;; indentation
+
+
+(defun plantuml-current-block-depth ()
+  "Trace the current block indentation level by recursively looking back line by line."
+  (save-excursion
+    (let ((relative-depth 0))
+      ;; current line
+      (beginning-of-line)
+      (if (-any? 'looking-at plantuml-indent-regexp-end)
+          (setq relative-depth (1- relative-depth)))
+
+      ;; from current line backwards to beginning of buffer
+      (while (not (bobp))
+        (forward-line -1)
+        (if (-any? 'looking-at plantuml-indent-regexp-end)
+            (setq relative-depth (1- relative-depth)))
+        (if (-any? 'looking-at plantuml-indent-regexp-start)
+            (setq relative-depth (1+ relative-depth))))
+
+      (if (<= relative-depth 0)
+          0
+        relative-depth))))
+
+(defun plantuml-indent-line ()
+  "Indent the current line to its desired indentation level.
+Restore point to same position in text of the line as before indentation."
+  (interactive)
+  ;; store position of point in line measured from end of line
+  (let ((original-position-eol (- (line-end-position) (point))))
+    (save-excursion
+      (beginning-of-line)
+      (indent-line-to (* plantuml-indent-level (plantuml-current-block-depth))))
+
+    ;; restore position in text of line
+    (goto-char (- (line-end-position) original-position-eol))))
+
+
+;;;###autoload
+(add-to-list 'auto-mode-alist '("\\.\\(plantuml\\|pum\\|plu\\)\\'" . plantuml-mode))
+
+;;;###autoload
+(define-derived-mode plantuml-mode prog-mode "plantuml"
+  "Major mode for plantuml.
+
+Shortcuts             Command Name
+\\[plantuml-complete-symbol]      `plantuml-complete-symbol'"
+  (plantuml-init-once)
+  (make-local-variable 'plantuml-output-type)
+  (set (make-local-variable 'comment-start-skip) "\\('+\\|/'+\\)\\s *")
+  (set (make-local-variable 'comment-start) "/'")
+  (set (make-local-variable 'comment-end) "'/")
+  (set (make-local-variable 'comment-multi-line) t)
+  (set (make-local-variable 'comment-style) 'extra-line)
+  (set (make-local-variable 'indent-line-function) 'plantuml-indent-line)
+  (setq font-lock-defaults '((plantuml-font-lock-keywords) nil t)))
+
+(defun plantuml-deprecation-warning ()
+  "Warns the user about the deprecation of the `puml-mode' project."
+  (if (and plantuml-suppress-deprecation-warning
+           (featurep 'puml-mode))
+      (display-warning :warning
+                       "`puml-mode' is now deprecated and no longer updated, but it's still present in your system. \
+You should move your configuration to use `plantuml-mode'. \
+See more at https://github.com/skuro/puml-mode/issues/26")))
+
+(add-hook 'plantuml-mode-hook 'plantuml-deprecation-warning)
+
+(provide 'plantuml-mode)
+;;; plantuml-mode.el ends here
diff --git a/lisp/popup.el b/lisp/popup.el
new file mode 100644
index 00000000..71aa3f61
--- /dev/null
+++ b/lisp/popup.el
@@ -0,0 +1,1435 @@
+;;; popup.el --- Visual Popup User Interface
+
+;; Copyright (C) 2009-2015  Tomohiro Matsuyama
+
+;; Author: Tomohiro Matsuyama 
+;; Keywords: lisp
+;; Package-Version: 20200610.317
+;; Package-Commit: 9d104d4bbbcb37bbc9d9ce762e74d41174683f86
+;; Version: 0.5.8
+;; Package-Requires: ((cl-lib "0.5"))
+
+;; 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 .
+
+;;; Commentary:
+
+;; popup.el is a visual popup user interface library for Emacs.  This
+;; provides a basic API and common UI widgets such as popup tooltips
+;; and popup menus.
+;; See README.markdown for more information.
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defconst popup-version "0.5.8")
+
+
+
+;;; Utilities
+
+(defun popup-calculate-max-width (max-width)
+  "Determines whether the width with MAX-WIDTH desired is character or window \
+proportion based, And return the result."
+  (cl-typecase max-width
+    (integer max-width)
+    (float (* (ceiling (/ (round (* max-width (window-width))) 10.0)) 10))))
+
+(defvar popup-use-optimized-column-computation t
+  "Use the optimized column computation routine.
+If there is a problem, please set it nil.")
+
+(defmacro popup-aif (test then &rest else)
+  "Anaphoric if."
+  (declare (indent 2))
+  `(let ((it ,test))
+     (if it ,then ,@else)))
+
+(defmacro popup-awhen (test &rest body)
+  "Anaphoric when."
+  (declare (indent 1))
+  `(let ((it ,test))
+     (when it ,@body)))
+
+(defun popup-x-to-string (x)
+  "Convert any object to string efficiently.
+This is faster than `prin1-to-string' in many cases."
+  (cl-typecase x
+    (string x)
+    (symbol (symbol-name x))
+    (integer (number-to-string x))
+    (float (number-to-string x))
+    (t (format "%s" x))))
+
+(defun popup-substring-by-width (string width)
+  "Return a cons cell of substring and remaining string by
+splitting with WIDTH."
+  ;; Expand tabs into 4 spaces
+  (setq string (replace-regexp-in-string "\t" "    " string))
+  (cl-loop with len = (length string)
+           with w = 0
+           for l from 0
+           for c in (append string nil)
+           while (<= (cl-incf w (char-width c)) width)
+           finally return
+           (if (< l len)
+               (cons (substring string 0 l) (substring string l))
+             (list string))))
+
+(defun popup-fill-string (string &optional width max-width justify squeeze)
+  "Split STRING into fixed width strings and return a cons cell
+like \(WIDTH . ROWS). Here, the car WIDTH indicates the actual
+maxim width of ROWS.
+
+The argument WIDTH specifies the width of filling each
+paragraph. WIDTH nil means don't perform any justification and
+word wrap. Note that this function doesn't add any padding
+characters at the end of each row.
+
+MAX-WIDTH, if WIDTH is nil, specifies the maximum number of
+columns.
+
+The optional fourth argument JUSTIFY specifies which kind of
+justification to do: `full', `left', `right', `center', or
+`none' (equivalent to nil).  A value of t means handle each
+paragraph as specified by its text properties.
+
+SQUEEZE nil means leave whitespaces other than line breaks
+untouched."
+  (if (eq width 0)
+      (error "Can't fill string with 0 width"))
+  (if width
+      (setq max-width width))
+  (with-temp-buffer
+    (let ((tab-width 4)
+          (fill-column width)
+          (left-margin 0)
+          (kinsoku-limit 1)
+          indent-tabs-mode
+          row rows)
+      (insert string)
+      (untabify (point-min) (point-max))
+      (if width
+          (fill-region (point-min) (point-max) justify (not squeeze)))
+      (goto-char (point-min))
+      (setq width 0)
+      (while (prog2
+                 (let ((line (buffer-substring
+                              (point) (progn (end-of-line) (point)))))
+                   (if max-width
+                       (while (progn
+                                (setq row (truncate-string-to-width line max-width)
+                                      width (max width (string-width row)))
+                                (push row rows)
+                                (if (not (= (length row) (length line)))
+                                    (setq line (substring line (length row))))))
+                     (setq width (max width (string-width line)))
+                     (push line rows)))
+                 (< (point) (point-max))
+               (beginning-of-line 2)))
+      (cons width (nreverse rows)))))
+
+(defmacro popup-save-buffer-state (&rest body)
+  (declare (indent 0))
+  `(save-excursion
+     (let ((buffer-undo-list t)
+           (inhibit-read-only t)
+           (modified (buffer-modified-p)))
+       (unwind-protect
+           (progn ,@body)
+         (set-buffer-modified-p modified)))))
+
+(defun popup-vertical-motion (column direction)
+  "A portable version of `vertical-motion'."
+  (when (bound-and-true-p display-line-numbers-mode)
+    (setq column (- column (line-number-display-width 'columns))))
+  (if (>= emacs-major-version 23)
+      (vertical-motion (cons column direction))
+    (vertical-motion direction)
+    (move-to-column (+ (current-column) column))))
+
+(defun popup-last-line-of-buffer-p ()
+  "Return non-nil if the cursor is at the last line of the
+buffer."
+  (save-excursion (end-of-line) (/= (forward-line) 0)))
+
+(defun popup-lookup-key-by-event (function event)
+  (or (funcall function (vector event))
+      (if (symbolp event)
+          (popup-aif (get event 'event-symbol-element-mask)
+              (funcall function
+                       (vector (logior (or (get (car it) 'ascii-character)
+                                           0)
+                                       (cadr it))))))))
+
+
+
+;;; Core
+
+(defgroup popup nil
+  "Visual Popup User Interface"
+  :group 'lisp
+  :prefix "popup-")
+
+(defface popup-face
+  '((t (:inherit default :background "lightgray" :foreground "black")))
+  "Face for popup."
+  :group 'popup)
+
+(defface popup-summary-face
+  '((t (:inherit popup-face :foreground "dimgray")))
+  "Face for popup summary."
+  :group 'popup)
+
+(defface popup-scroll-bar-foreground-face
+  '((t (:background "black")))
+  "Foreground face for scroll-bar."
+  :group 'popup)
+
+(defface popup-scroll-bar-background-face
+  '((t (:background "gray")))
+  "Background face for scroll-bar."
+  :group 'popup)
+
+(defvar popup-instances nil
+  "Popup instances.")
+
+(defvar popup-scroll-bar-foreground-char
+  (propertize " " 'face 'popup-scroll-bar-foreground-face)
+  "Foreground character for scroll-bar.")
+
+(defvar popup-scroll-bar-background-char
+  (propertize " " 'face 'popup-scroll-bar-background-face)
+  "Background character for scroll-bar.")
+
+(cl-defstruct popup
+  point row column width height min-height direction overlays keymap
+  parent depth
+  face mouse-face selection-face summary-face
+  margin-left margin-right margin-left-cancel scroll-bar symbol
+  cursor offset scroll-top current-height list newlines
+  pattern original-list invis-overlays)
+
+(defun popup-item-propertize (item &rest properties)
+  "Same as `propertize' except that this avoids overriding
+existed value with `nil' property."
+  (cl-loop for (k v) on properties by 'cddr
+           if v append (list k v) into props
+           finally return
+           (apply 'propertize
+                  (popup-x-to-string item)
+                  props)))
+
+(defun popup-item-property (item property)
+  "Same as `get-text-property' except that this returns nil if
+ITEM is not string."
+  (if (stringp item)
+      (get-text-property 0 property item)))
+
+(cl-defun popup-make-item (name
+                           &key
+                           value
+                           face
+                           mouse-face
+                           selection-face
+                           sublist
+                           document
+                           symbol
+                           summary)
+  "Utility function to make popup item. See also
+`popup-item-propertize'."
+  (popup-item-propertize name
+                         'value value
+                         'popup-face face
+                         'popup-mouse-face mouse-face
+                         'selection-face selection-face
+                         'document document
+                         'symbol symbol
+                         'summary summary
+                         'sublist sublist))
+
+(defsubst popup-item-value (item)               (popup-item-property item 'value))
+(defsubst popup-item-value-or-self (item)       (or (popup-item-value item) item))
+(defsubst popup-item-face (item)                (popup-item-property item 'popup-face))
+(defsubst popup-item-mouse-face (item)          (popup-item-property item 'popup-mouse-face))
+(defsubst popup-item-selection-face (item)      (popup-item-property item 'selection-face))
+(defsubst popup-item-document (item)            (popup-item-property item 'document))
+(defsubst popup-item-summary (item)             (popup-item-property item 'summary))
+(defsubst popup-item-symbol (item)              (popup-item-property item 'symbol))
+(defsubst popup-item-sublist (item)             (popup-item-property item 'sublist))
+
+(defun popup-item-documentation (item)
+  (let ((doc (popup-item-document item)))
+    (if (functionp doc)
+        (setq doc (funcall doc (popup-item-value-or-self item))))
+    doc))
+
+(defun popup-item-show-help-1 (item)
+  (let ((doc (popup-item-documentation item)))
+    (when doc
+      (with-current-buffer (get-buffer-create " *Popup Help*")
+        (erase-buffer)
+        (insert doc)
+        (goto-char (point-min))
+        (display-buffer (current-buffer)))
+      t)))
+
+(defun popup-item-show-help-with-event-loop (item)
+  (save-window-excursion
+    (when (popup-item-show-help-1 item)
+      (cl-loop do (clear-this-command-keys)
+               for key = (read-key-sequence-vector nil)
+               do
+               (cl-case (key-binding key)
+                 (scroll-other-window
+                  (scroll-other-window))
+                 (scroll-other-window-down
+                  (scroll-other-window-down nil))
+                 (otherwise
+                  (setq unread-command-events (append key unread-command-events))
+                  (cl-return)))))))
+
+(defun popup-item-show-help (item &optional persist)
+  "Display the documentation of ITEM with `display-buffer'. If
+PERSIST is nil, the documentation buffer will be closed
+automatically, meaning interal event loop ensures the buffer to
+be closed. Otherwise, the buffer will be just displayed as
+usual."
+  (when item
+    (if (not persist)
+        (popup-item-show-help-with-event-loop item)
+      (popup-item-show-help-1 item))))
+
+(defun popup-set-list (popup list)
+  (popup-set-filtered-list popup list)
+  (setf (popup-pattern popup) nil)
+  (setf (popup-original-list popup) list))
+
+(defun popup-set-filtered-list (popup list)
+  (let ((offset
+         (if (> (popup-direction popup) 0)
+             0
+           (max (- (popup-height popup) (length list)) 0))))
+    (setf (popup-list popup) list
+          (popup-offset popup) offset)))
+
+(defun popup-selected-item (popup)
+  (nth (popup-cursor popup) (popup-list popup)))
+
+(defun popup-selected-line (popup)
+  (- (popup-cursor popup) (popup-scroll-top popup)))
+
+(defun popup-line-overlay (popup line)
+  (aref (popup-overlays popup) line))
+
+(defun popup-selected-line-overlay (popup)
+  (popup-line-overlay popup (popup-selected-line popup)))
+
+(defun popup-hide-line (popup line)
+  (let ((overlay (popup-line-overlay popup line)))
+    (overlay-put overlay 'display nil)
+    (overlay-put overlay 'after-string nil)))
+
+(defun popup-line-hidden-p (popup line)
+  (let ((overlay (popup-line-overlay popup line)))
+    (and (eq (overlay-get overlay 'display) nil)
+         (eq (overlay-get overlay 'after-string) nil))))
+
+(cl-defun popup-set-line-item (popup
+                               line
+                               &key
+                               item
+                               face
+                               mouse-face
+                               margin-left
+                               margin-right
+                               scroll-bar-char
+                               symbol
+                               summary
+                               summary-face
+                               keymap)
+  (let* ((overlay (popup-line-overlay popup line))
+         (content (popup-create-line-string popup (popup-x-to-string item)
+                                            :margin-left margin-left
+                                            :margin-right margin-right
+                                            :symbol symbol
+                                            :summary summary
+                                            :summary-face summary-face))
+         (start 0)
+         (prefix (overlay-get overlay 'prefix))
+         (postfix (overlay-get overlay 'postfix))
+         end)
+    (put-text-property 0 (length content) 'popup-item item content)
+    (put-text-property 0 (length content) 'keymap keymap content)
+    ;; Overlap face properties
+    (when (get-text-property start 'face content)
+      (setq start (next-single-property-change start 'face content)))
+    (while (and start (setq end (next-single-property-change start 'face content)))
+      (put-text-property start end 'face face content)
+      (setq start (next-single-property-change end 'face content)))
+    (when start
+      (put-text-property start (length content) 'face face content))
+    (when mouse-face
+      (put-text-property 0 (length content) 'mouse-face mouse-face content))
+    (let ((prop (if (overlay-get overlay 'dangle)
+                    'after-string
+                  'display)))
+      (overlay-put overlay
+                   prop
+                   (concat prefix
+                           content
+                           scroll-bar-char
+                           postfix)))))
+
+(cl-defun popup-create-line-string (popup
+                                    string
+                                    &key
+                                    margin-left
+                                    margin-right
+                                    symbol
+                                    summary
+                                    summary-face)
+  (let* ((popup-width (popup-width popup))
+         (summary-width (string-width summary))
+         (content-width (max
+                         (min popup-width (string-width string))
+                         (- popup-width
+                            (if (> summary-width 0)
+                                (+ summary-width 2)
+                              0))))
+         (string (car (popup-substring-by-width string content-width)))
+         (string-width (string-width string))
+         (spacing (max (- popup-width string-width summary-width)
+                       (if (> popup-width string-width) 1 0)))
+         (truncated-summary
+          (car (popup-substring-by-width
+                summary (max (- popup-width string-width spacing) 0)))))
+    (when summary-face
+      (put-text-property 0 (length truncated-summary)
+                         'face summary-face truncated-summary))
+    (concat margin-left
+            string
+            (make-string spacing ? )
+            truncated-summary
+            symbol
+            margin-right)))
+
+(defun popup-live-p (popup)
+  "Return non-nil if POPUP is alive."
+  (and popup (popup-overlays popup) t))
+
+(defun popup-child-point (popup &optional offset)
+  (overlay-end
+   (popup-line-overlay
+    popup
+    (or offset
+        (popup-selected-line popup)))))
+
+(defun popup-calculate-direction (height row)
+  "Return a proper direction when displaying a popup on this
+window. HEIGHT is the a height of the popup, and ROW is a line
+number at the point."
+  (let* ((remaining-rows (- (max 1 (- (window-text-height)
+                                      (if mode-line-format 1 0)
+                                      (if header-line-format 1 0)))
+                            (count-lines (window-start) (point))))
+         (enough-space-above (> row height))
+         (enough-space-below (<= height remaining-rows)))
+    (if (and enough-space-above
+             (not enough-space-below))
+        -1
+      1)))
+
+(cl-defun popup-create (point
+                        width
+                        height
+                        &key
+                        min-height
+                        max-width
+                        around
+                        (face 'popup-face)
+                        mouse-face
+                        (selection-face face)
+                        (summary-face 'popup-summary-face)
+                        scroll-bar
+                        margin-left
+                        margin-right
+                        symbol
+                        parent
+                        parent-offset
+                        keymap)
+  "Create a popup instance at POINT with WIDTH and HEIGHT.
+
+MIN-HEIGHT is a minimal height of the popup. The default value is
+0.
+
+MAX-WIDTH is the maximum width of the popup. The default value is
+nil (no limit). If a floating point, the value refers to the ratio of
+the window. If an integer, limit is in characters.
+
+If AROUND is non-nil, the popup will be displayed around the
+point but not at the point.
+
+FACE is a background face of the popup. The default value is POPUP-FACE.
+
+SELECTION-FACE is a foreground (selection) face of the popup The
+default value is POPUP-FACE.
+
+If SCROLL-BAR is non-nil, the popup will have a scroll bar at the
+right.
+
+If MARGIN-LEFT is non-nil, the popup will have a margin at the
+left.
+
+If MARGIN-RIGHT is non-nil, the popup will have a margin at the
+right.
+
+SYMBOL is a single character which indicates a kind of the item.
+
+PARENT is a parent popup instance. If PARENT is omitted, the
+popup will be a root instance.
+
+PARENT-OFFSET is a row offset from the parent popup.
+
+KEYMAP is a keymap that will be put on the popup contents."
+  (or margin-left (setq margin-left 0))
+  (or margin-right (setq margin-right 0))
+  (unless point
+    (setq point
+          (if parent (popup-child-point parent parent-offset) (point))))
+  (when max-width
+    (setq width (min width (popup-calculate-max-width max-width))))
+  (save-excursion
+    (goto-char point)
+    (let* ((col-row (posn-col-row (posn-at-point)))
+           (row (cdr col-row))
+           (column (car col-row))
+           (overlays (make-vector height nil))
+           (popup-width (+ width
+                           (if scroll-bar 1 0)
+                           margin-left
+                           margin-right
+                           (if symbol 2 0)))
+           margin-left-cancel
+           (window (selected-window))
+           (window-start (window-start))
+           (window-hscroll (window-hscroll))
+           (window-width (window-width))
+           (right (+ column popup-width))
+           (overflow (and (> right window-width)
+                          (>= right popup-width)))
+           (foldable (and (null parent)
+                          (>= column popup-width)))
+           (direction (or
+                       ;; Currently the direction of cascade popup won't be changed
+                       (and parent (popup-direction parent))
+
+                       ;; Calculate direction
+                       (popup-calculate-direction height row)))
+           (depth (if parent (1+ (popup-depth parent)) 0))
+           (newlines (max 0 (+ (- height (count-lines point (point-max))) (if around 1 0))))
+           invis-overlays
+           current-column)
+      ;; Case: no newlines at the end of the buffer
+      (when (> newlines 0)
+        (popup-save-buffer-state
+          (goto-char (point-max))
+          (insert (make-string newlines ?\n))))
+
+      ;; Case: the popup overflows
+      (if overflow
+          (if foldable
+              (progn
+                (cl-decf column (- popup-width margin-left margin-right))
+                (unless around (move-to-column column)))
+            (when (not truncate-lines)
+              ;; Truncate.
+              (let ((d (1+ (- popup-width (- window-width column)))))
+                (cl-decf popup-width d)
+                (cl-decf width d)))
+            (cl-decf column margin-left))
+        (cl-decf column margin-left))
+
+      ;; Case: no space at the left
+      (when (and (null parent)
+                 (< column 0))
+        ;; Cancel margin left
+        (setq column 0)
+        (cl-decf popup-width margin-left)
+        (setq margin-left-cancel t))
+
+      (dotimes (i height)
+        (let (overlay begin w (dangle t) (prefix "") (postfix ""))
+          (when around
+            (popup-vertical-motion column direction))
+          (cl-loop for ov in (overlays-in (save-excursion
+                                            (beginning-of-visual-line)
+                                            (point))
+                                          (save-excursion
+                                            (end-of-visual-line)
+                                            (point)))
+                   when (and (not (overlay-get ov 'popup))
+                             (not (overlay-get ov 'popup-item))
+                             (or (overlay-get ov 'invisible)
+                                 (overlay-get ov 'display)))
+                   do (progn
+                        (push (list ov (overlay-get ov 'display)) invis-overlays)
+                        (overlay-put ov 'display "")))
+          (setq around t)
+          (setq current-column (car (posn-col-row (posn-at-point))))
+
+          (when (< current-column column)
+            ;; Extend short buffer lines by popup prefix (line of spaces)
+            (setq prefix (make-string
+                          (+ (if (= current-column 0)
+                                 (- window-hscroll current-column)
+                               0)
+                             (- column current-column))
+                          ? )))
+
+          (setq begin (point))
+          (setq w (+ popup-width (length prefix)))
+          (while (and (not (eolp)) (> w 0))
+            (setq dangle nil)
+            (cl-decf w (char-width (char-after)))
+            (forward-char))
+          (if (< w 0)
+              (setq postfix (make-string (- w) ? )))
+
+          (setq overlay (make-overlay begin (point)))
+          (overlay-put overlay 'popup t)
+          (overlay-put overlay 'window window)
+          (overlay-put overlay 'dangle dangle)
+          (overlay-put overlay 'prefix prefix)
+          (overlay-put overlay 'postfix postfix)
+          (overlay-put overlay 'width width)
+          (aset overlays
+                (if (> direction 0) i (- height i 1))
+                overlay)))
+      (cl-loop for p from (- 10000 (* depth 1000))
+               for overlay in (nreverse (append overlays nil))
+               do (overlay-put overlay 'priority p))
+      (let ((it (make-popup :point point
+                            :row row
+                            :column column
+                            :width width
+                            :height height
+                            :min-height min-height
+                            :direction direction
+                            :parent parent
+                            :depth depth
+                            :face face
+                            :mouse-face mouse-face
+                            :selection-face selection-face
+                            :summary-face summary-face
+                            :margin-left margin-left
+                            :margin-right margin-right
+                            :margin-left-cancel margin-left-cancel
+                            :scroll-bar scroll-bar
+                            :symbol symbol
+                            :cursor 0
+                            :offset 0
+                            :scroll-top 0
+                            :current-height 0
+                            :list nil
+                            :newlines newlines
+                            :overlays overlays
+                            :invis-overlays invis-overlays
+                            :keymap keymap)))
+        (push it popup-instances)
+        it))))
+
+(defun popup-delete (popup)
+  "Delete POPUP instance."
+  (when (popup-live-p popup)
+    (popup-hide popup)
+    (mapc 'delete-overlay (popup-overlays popup))
+    (setf (popup-overlays popup) nil)
+    (setq popup-instances (delq popup popup-instances))
+    ;; Restore newlines state
+    (let ((newlines (popup-newlines popup)))
+      (when (> newlines 0)
+        (popup-save-buffer-state
+          (goto-char (point-max))
+          (dotimes (i newlines)
+            (if (and (char-before)
+                     (= (char-before) ?\n))
+                (delete-char -1)))))))
+  nil)
+
+(defun popup-draw (popup)
+  "Draw POPUP."
+  (cl-loop for (ov olddisplay) in (popup-invis-overlays popup)
+           do (overlay-put ov 'display ""))
+
+  (cl-loop with height = (popup-height popup)
+           with min-height = (popup-min-height popup)
+           with popup-face = (popup-face popup)
+           with mouse-face = (popup-mouse-face popup)
+           with selection-face = (popup-selection-face popup)
+           with summary-face-0 = (popup-summary-face popup)
+           with list = (popup-list popup)
+           with length = (length list)
+           with thum-size = (max (/ (* height height) (max length 1)) 1)
+           with page-size = (/ (+ 0.0 (max length 1)) height)
+           with scroll-bar = (popup-scroll-bar popup)
+           with margin-left = (make-string (if (popup-margin-left-cancel popup) 0 (popup-margin-left popup)) ? )
+           with margin-right = (make-string (popup-margin-right popup) ? )
+           with symbol = (popup-symbol popup)
+           with cursor = (popup-cursor popup)
+           with scroll-top = (popup-scroll-top popup)
+           with offset = (popup-offset popup)
+           with keymap = (popup-keymap popup)
+           for o from offset
+           for i from scroll-top
+           while (< o height)
+           for item in (nthcdr scroll-top list)
+           for page-index = (* thum-size (/ o thum-size))
+           for face = (if (= i cursor)
+                          (or (popup-item-selection-face item) selection-face)
+                        (or (popup-item-face item) popup-face))
+           for summary-face = (unless (= i cursor) summary-face-0)
+           for empty-char = (propertize " " 'face face)
+           for scroll-bar-char = (if scroll-bar
+                                     (cond
+                                      ((and (not (eq scroll-bar :always))
+                                            (<= page-size 1))
+                                       empty-char)
+                                      ((and (> page-size 1)
+                                            (>= cursor (* page-index page-size))
+                                            (< cursor (* (+ page-index thum-size) page-size)))
+                                       popup-scroll-bar-foreground-char)
+                                      (t
+                                       popup-scroll-bar-background-char))
+                                   "")
+           for sym = (if symbol
+                         (concat " " (or (popup-item-symbol item) " "))
+                       "")
+           for summary = (or (popup-item-summary item) "")
+
+           do
+           ;; Show line and set item to the line
+           (popup-set-line-item popup o
+                                :item item
+                                :face face
+                                :mouse-face mouse-face
+                                :margin-left margin-left
+                                :margin-right margin-right
+                                :scroll-bar-char scroll-bar-char
+                                :symbol sym
+                                :summary summary
+                                :summary-face summary-face
+                                :keymap keymap)
+
+           finally
+           ;; Remember current height
+           (setf (popup-current-height popup) (- o offset))
+
+           ;; Hide remaining lines
+           (let ((scroll-bar-char (if scroll-bar (propertize " " 'face popup-face) ""))
+                 (symbol (if symbol " " "")))
+             (if (> (popup-direction popup) 0)
+                 (progn
+                   (when min-height
+                     (while (< o min-height)
+                       (popup-set-line-item popup o
+                                            :item ""
+                                            :face popup-face
+                                            :margin-left margin-left
+                                            :margin-right margin-right
+                                            :scroll-bar-char scroll-bar-char
+                                            :symbol symbol
+                                            :summary "")
+                       (cl-incf o)))
+                   (while (< o height)
+                     (popup-hide-line popup o)
+                     (cl-incf o)))
+               (cl-loop with h = (if min-height (- height min-height) offset)
+                        for o from 0 below offset
+                        if (< o h)
+                        do (popup-hide-line popup o)
+                        if (>= o h)
+                        do (popup-set-line-item popup o
+                                                :item ""
+                                                :face popup-face
+                                                :margin-left margin-left
+                                                :margin-right margin-right
+                                                :scroll-bar-char scroll-bar-char
+                                                :symbol symbol
+                                                :summary ""))))))
+
+(defun popup-hide (popup)
+  "Hide POPUP."
+  (cl-loop for (ov olddisplay) in (popup-invis-overlays popup)
+           do (overlay-put ov 'display olddisplay))
+  (dotimes (i (popup-height popup))
+    (popup-hide-line popup i)))
+
+(defun popup-hidden-p (popup)
+  "Return non-nil if POPUP is hidden."
+  (let ((hidden t))
+    (when (popup-live-p popup)
+      (dotimes (i (popup-height popup))
+        (unless (popup-line-hidden-p popup i)
+          (setq hidden nil))))
+    hidden))
+
+(defun popup-jump (popup cursor)
+  "Jump to a position specified by CURSOR of POPUP and draw."
+  (let ((scroll-top (popup-scroll-top popup)))
+    ;; Do not change page as much as possible.
+    (unless (and (<= scroll-top cursor)
+                 (< cursor (+ scroll-top (popup-height popup))))
+      (setf (popup-scroll-top popup) cursor))
+    (setf (popup-cursor popup) cursor)
+    (popup-draw popup)))
+
+(defun popup-select (popup i)
+  "Select the item at I of POPUP and draw."
+  (setq i (+ i (popup-offset popup)))
+  (when (and (<= 0 i) (< i (popup-height popup)))
+    (setf (popup-cursor popup) i)
+    (popup-draw popup)
+    t))
+
+(defun popup-next (popup)
+  "Select the next item of POPUP and draw."
+  (let ((height (popup-height popup))
+        (cursor (1+ (popup-cursor popup)))
+        (scroll-top (popup-scroll-top popup))
+        (length (length (popup-list popup))))
+    (cond
+     ((>= cursor length)
+      ;; Back to first page
+      (setq cursor 0
+            scroll-top 0))
+     ((= cursor (+ scroll-top height))
+      ;; Go to next page
+      (setq scroll-top (min (1+ scroll-top) (max (- length height) 0)))))
+    (setf (popup-cursor popup) cursor
+          (popup-scroll-top popup) scroll-top)
+    (popup-draw popup)))
+
+(defun popup-previous (popup)
+  "Select the previous item of POPUP and draw."
+  (let ((height (popup-height popup))
+        (cursor (1- (popup-cursor popup)))
+        (scroll-top (popup-scroll-top popup))
+        (length (length (popup-list popup))))
+    (cond
+     ((< cursor 0)
+      ;; Go to last page
+      (setq cursor (1- length)
+            scroll-top (max (- length height) 0)))
+     ((= cursor (1- scroll-top))
+      ;; Go to previous page
+      (cl-decf scroll-top)))
+    (setf (popup-cursor popup) cursor
+          (popup-scroll-top popup) scroll-top)
+    (popup-draw popup)))
+
+(defun popup-page-next (popup)
+  "Select next item of POPUP per `popup-height' range.
+Pages down through POPUP."
+  (dotimes (counter (1- (popup-height popup)))
+    (popup-next popup)))
+
+(defun popup-page-previous (popup)
+  "Select previous item of POPUP per `popup-height' range.
+Pages up through POPUP."
+  (dotimes (counter (1- (popup-height popup)))
+    (popup-previous popup)))
+
+(defun popup-scroll-down (popup &optional n)
+  "Scroll down N of POPUP and draw."
+  (let ((scroll-top (min (+ (popup-scroll-top popup) (or n 1))
+                         (- (length (popup-list popup)) (popup-height popup)))))
+    (setf (popup-cursor popup) scroll-top
+          (popup-scroll-top popup) scroll-top)
+    (popup-draw popup)))
+
+(defun popup-scroll-up (popup &optional n)
+  "Scroll up N of POPUP and draw."
+  (let ((scroll-top (max (- (popup-scroll-top popup) (or n 1))
+                         0)))
+    (setf (popup-cursor popup) scroll-top
+          (popup-scroll-top popup) scroll-top)
+    (popup-draw popup)))
+
+
+
+;;; Popup Incremental Search
+
+(defface popup-isearch-match
+  '((t (:inherit default :background "sky blue")))
+  "Popup isearch match face."
+  :group 'popup)
+
+(defvar popup-isearch-cursor-color "blue")
+
+(defvar popup-isearch-keymap
+  (let ((map (make-sparse-keymap)))
+    ;;(define-key map "\r"        'popup-isearch-done)
+    (define-key map "\C-g"      'popup-isearch-cancel)
+    (define-key map "\C-b"      'popup-isearch-close)
+    (define-key map [left]      'popup-isearch-close)
+    (define-key map "\C-h"      'popup-isearch-delete)
+    (define-key map (kbd "DEL") 'popup-isearch-delete)
+    (define-key map (kbd "C-y") 'popup-isearch-yank)
+    map))
+
+(defvar popup-menu-show-quick-help-function 'popup-menu-show-quick-help
+  "Function used for showing quick help by `popup-menu*'.")
+
+(defcustom popup-isearch-regexp-builder-function #'regexp-quote
+  "Function used to construct a regexp from a pattern. You may for instance
+  provide a function that replaces spaces by '.+' if you like helm or ivy style
+  of completion."
+  :type 'function)
+
+(defsubst popup-isearch-char-p (char)
+  (and (integerp char)
+       (<= 32 char)
+       (<= char 126)))
+
+(defun popup-isearch-filter-list (pattern list)
+  (cl-loop with regexp = (funcall popup-isearch-regexp-builder-function pattern)
+           for item in list
+           do
+           (unless (stringp item)
+             (setq item (popup-item-propertize (popup-x-to-string item)
+                                               'value item)))
+           if (string-match regexp item)
+           collect
+           (let ((beg (match-beginning 0))
+                 (end (match-end 0)))
+             (alter-text-property 0 (length item) 'face
+                                  (lambda (prop)
+                                    (unless (eq prop 'popup-isearch-match)
+                                      prop))
+                                  item)
+             (put-text-property beg end
+                                'face 'popup-isearch-match
+                                item)
+             item)))
+
+(defun popup-isearch-prompt (popup pattern)
+  (format "Pattern: %s" (if (= (length (popup-list popup)) 0)
+                            (propertize pattern 'face 'isearch-fail)
+                          pattern)))
+
+(defun popup-isearch-update (popup filter pattern &optional callback)
+  (setf (popup-cursor popup) 0
+        (popup-scroll-top popup) 0
+        (popup-pattern popup) pattern)
+  (let ((list (funcall filter pattern (popup-original-list popup))))
+    (popup-set-filtered-list popup list)
+    (if callback
+        (funcall callback list)))
+  (popup-draw popup))
+
+(cl-defun popup-isearch (popup
+                         &key
+                         (filter 'popup-isearch-filter-list)
+                         (cursor-color popup-isearch-cursor-color)
+                         (keymap popup-isearch-keymap)
+                         callback
+                         help-delay)
+  "Start isearch on POPUP. This function is synchronized, meaning
+event loop waits for quiting of isearch.
+
+FILTER is function with two argumenst to perform popup items filtering.
+
+CURSOR-COLOR is a cursor color during isearch. The default value
+is `popup-isearch-cursor-color'.
+
+KEYMAP is a keymap which is used when processing events during
+event loop. The default value is `popup-isearch-keymap'.
+
+CALLBACK is a function taking one argument. `popup-isearch' calls
+CALLBACK, if specified, after isearch finished or isearch
+canceled. The arguments is whole filtered list of items.
+
+HELP-DELAY is a delay of displaying helps."
+  (let ((list (popup-original-list popup))
+        (pattern (or (popup-pattern popup) ""))
+        (old-cursor-color (frame-parameter (selected-frame) 'cursor-color))
+        prompt key binding)
+    (unwind-protect
+        (cl-block nil
+          (if cursor-color
+              (set-cursor-color cursor-color))
+          (while t
+            (setq prompt (popup-isearch-prompt popup pattern))
+            (setq key (popup-menu-read-key-sequence keymap prompt help-delay))
+            (if (null key)
+                (unless (funcall popup-menu-show-quick-help-function popup nil :prompt prompt)
+                  (clear-this-command-keys)
+                  (push (read-event prompt) unread-command-events))
+              (setq binding (lookup-key keymap key))
+              (cond
+               ((and (stringp key)
+                     (popup-isearch-char-p (aref key 0)))
+                (setq pattern (concat pattern key)))
+               ((eq binding 'popup-isearch-done)
+                (cl-return nil))
+               ((eq binding 'popup-isearch-cancel)
+                (popup-isearch-update popup filter "" callback)
+                (cl-return t))
+               ((eq binding 'popup-isearch-close)
+                (popup-isearch-update popup filter "" callback)
+                (setq unread-command-events
+                      (append (listify-key-sequence key) unread-command-events))
+                (cl-return nil))
+               ((eq binding 'popup-isearch-delete)
+                (if (> (length pattern) 0)
+                    (setq pattern (substring pattern 0 (1- (length pattern))))))
+               ((eq binding 'popup-isearch-yank)
+                (popup-isearch-update popup filter (car kill-ring) callback)
+                (cl-return nil))
+               (t
+                (setq unread-command-events
+                      (append (listify-key-sequence key) unread-command-events))
+                (cl-return nil)))
+              (popup-isearch-update popup filter pattern callback))))
+      (if old-cursor-color
+          (set-cursor-color old-cursor-color)))))
+
+
+
+;;; Popup Tip
+
+(defface popup-tip-face
+  '((t (:background "khaki1" :foreground "black")))
+  "Face for popup tip."
+  :group 'popup)
+
+(defvar popup-tip-max-width 80)
+
+(cl-defun popup-tip (string
+                     &key
+                     point
+                     (around t)
+                     width
+                     (height 15)
+                     min-height
+                     max-width
+                     truncate
+                     margin
+                     margin-left
+                     margin-right
+                     scroll-bar
+                     parent
+                     parent-offset
+                     nowait
+                     nostrip
+                     prompt
+                     &aux tip lines)
+  "Show a tooltip of STRING at POINT. This function is
+synchronized unless NOWAIT specified. Almost all arguments are
+the same as in `popup-create', except for TRUNCATE, NOWAIT, and
+PROMPT.
+
+If TRUNCATE is non-nil, the tooltip can be truncated.
+
+If NOWAIT is non-nil, this function immediately returns the
+tooltip instance without entering event loop.
+
+If `NOSTRIP` is non-nil, `STRING` properties are not stripped.
+
+PROMPT is a prompt string when reading events during event loop."
+  (if (bufferp string)
+      (setq string (with-current-buffer string (buffer-string))))
+
+  (unless nostrip
+    ;; TODO strip text (mainly face) properties
+    (setq string (substring-no-properties string)))
+
+  (and (eq margin t) (setq margin 1))
+  (or margin-left (setq margin-left margin))
+  (or margin-right (setq margin-right margin))
+
+  (let ((it (popup-fill-string string width popup-tip-max-width)))
+    (setq width (car it)
+          lines (cdr it)))
+
+  (setq tip (popup-create point width height
+                          :min-height min-height
+                          :max-width max-width
+                          :around around
+                          :margin-left margin-left
+                          :margin-right margin-right
+                          :scroll-bar scroll-bar
+                          :face 'popup-tip-face
+                          :parent parent
+                          :parent-offset parent-offset))
+
+  (unwind-protect
+      (when (> (popup-width tip) 0)                   ; not to be corrupted
+        (when (and (not (eq width (popup-width tip))) ; truncated
+                   (not truncate))
+          ;; Refill once again to lines be fitted to popup width
+          (setq width (popup-width tip))
+          (setq lines (cdr (popup-fill-string string width width))))
+
+        (popup-set-list tip lines)
+        (popup-draw tip)
+        (if nowait
+            tip
+          (clear-this-command-keys)
+          (push (read-event prompt) unread-command-events)
+          t))
+    (unless nowait
+      (popup-delete tip))))
+
+
+
+;;; Popup Menu
+
+(defface popup-menu-face
+  '((t (:inherit popup-face)))
+  "Face for popup menu."
+  :group 'popup)
+
+(defface popup-menu-mouse-face
+  '((t (:background "blue" :foreground "white")))
+  "Face for popup menu."
+  :group 'popup)
+
+(defface popup-menu-selection-face
+  '((t (:inherit default :background "steelblue" :foreground "white")))
+  "Face for popup menu selection."
+  :group 'popup)
+
+(defface popup-menu-summary-face
+  '((t (:inherit popup-summary-face)))
+  "Face for popup summary."
+  :group 'popup)
+
+(defvar popup-menu-show-tip-function 'popup-tip
+  "Function used for showing tooltip by `popup-menu-show-quick-help'.")
+
+(defun popup-menu-show-help (menu &optional persist item)
+  (popup-item-show-help (or item (popup-selected-item menu)) persist))
+
+(defun popup-menu-documentation (menu &optional item)
+  (popup-item-documentation (or item (popup-selected-item menu))))
+
+(defun popup-menu-show-quick-help (menu &optional item &rest args)
+  (let* ((point (plist-get args :point))
+         (height (or (plist-get args :height) (popup-height menu)))
+         (min-height (min height (popup-current-height menu)))
+         (around nil)
+         (parent-offset (popup-offset menu))
+         (doc (popup-menu-documentation menu item)))
+    (when (stringp doc)
+      (if (popup-hidden-p menu)
+          (setq around t
+                menu nil
+                parent-offset nil)
+        (setq point nil))
+      (let ((popup-use-optimized-column-computation nil)) ; To avoid wrong positioning
+        (apply popup-menu-show-tip-function
+               doc
+               :point point
+               :height height
+               :min-height min-height
+               :around around
+               :parent menu
+               :parent-offset parent-offset
+               args)))))
+
+(defun popup-menu-item-of-mouse-event (event)
+  (when (and (consp event)
+             (memq (cl-first event) '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5)))
+    (let* ((position (cl-second event))
+           (object (elt position 4)))
+      (when (consp object)
+        (get-text-property (cdr object) 'popup-item (car object))))))
+
+(defun popup-menu-read-key-sequence (keymap &optional prompt timeout)
+  (catch 'timeout
+    (let ((timer (and timeout
+                      (run-with-timer timeout nil
+                                      (lambda ()
+                                        (if (zerop (length (this-command-keys)))
+                                            (throw 'timeout nil))))))
+          (old-global-map (current-global-map))
+          (temp-global-map (make-sparse-keymap))
+          (overriding-terminal-local-map (make-sparse-keymap)))
+      (substitute-key-definition 'keyboard-quit 'keyboard-quit
+                                 temp-global-map old-global-map)
+      (define-key temp-global-map [menu-bar] (lookup-key old-global-map [menu-bar]))
+      (define-key temp-global-map [tool-bar] (lookup-key old-global-map [tool-bar]))
+      (set-keymap-parent overriding-terminal-local-map keymap)
+      (if (current-local-map)
+          (define-key overriding-terminal-local-map [menu-bar]
+            (lookup-key (current-local-map) [menu-bar])))
+      (unwind-protect
+          (progn
+            (use-global-map temp-global-map)
+            (clear-this-command-keys)
+            (with-temp-message prompt
+              (read-key-sequence nil)))
+        (use-global-map old-global-map)
+        (if timer (cancel-timer timer))))))
+
+(defun popup-menu-fallback (event default))
+
+(cl-defun popup-menu-event-loop (menu
+                                 keymap
+                                 fallback
+                                 &key
+                                 prompt
+                                 help-delay
+                                 isearch
+                                 isearch-filter
+                                 isearch-cursor-color
+                                 isearch-keymap
+                                 isearch-callback
+                                 &aux key binding)
+  (cl-block nil
+    (while (popup-live-p menu)
+      (and isearch
+           (popup-isearch menu
+                          :filter isearch-filter
+                          :cursor-color isearch-cursor-color
+                          :keymap isearch-keymap
+                          :callback isearch-callback
+                          :help-delay help-delay)
+           (keyboard-quit))
+      (setq key (popup-menu-read-key-sequence keymap prompt help-delay))
+      (setq binding (and key (lookup-key keymap key)))
+      (cond
+       ((or (null key) (zerop (length key)))
+        (unless (funcall popup-menu-show-quick-help-function menu nil :prompt prompt)
+          (clear-this-command-keys)
+          (push (read-event prompt) unread-command-events)))
+       ((eq (lookup-key (current-global-map) key) 'keyboard-quit)
+        (keyboard-quit)
+        (cl-return))
+       ((eq binding 'popup-close)
+        (if (popup-parent menu)
+            (cl-return)))
+       ((memq binding '(popup-select popup-open))
+        (let* ((item (or (popup-menu-item-of-mouse-event (elt key 0))
+                         (popup-selected-item menu)))
+               (index (cl-position item (popup-list menu)))
+               (sublist (popup-item-sublist item)))
+          (unless index (cl-return))
+          (if sublist
+              (popup-aif (let (popup-use-optimized-column-computation)
+                           (popup-cascade-menu sublist
+                                               :around nil
+                                               :margin-left (popup-margin-left menu)
+                                               :margin-right (popup-margin-right menu)
+                                               :scroll-bar (popup-scroll-bar menu)
+                                               :parent menu
+                                               :parent-offset index
+                                               :help-delay help-delay
+                                               :isearch isearch
+                                               :isearch-filter isearch-filter
+                                               :isearch-cursor-color isearch-cursor-color
+                                               :isearch-keymap isearch-keymap
+                                               :isearch-callback isearch-callback))
+                  (and it (cl-return it)))
+            (if (eq binding 'popup-select)
+                (cl-return (popup-item-value-or-self item))))))
+       ((eq binding 'popup-next)
+        (popup-next menu))
+       ((eq binding 'popup-previous)
+        (popup-previous menu))
+       ((eq binding 'popup-page-next)
+        (popup-page-next menu))
+       ((eq binding 'popup-page-previous)
+        (popup-page-previous menu))
+       ((eq binding 'popup-help)
+        (popup-menu-show-help menu))
+       ((eq binding 'popup-isearch)
+        (popup-isearch menu
+                       :filter isearch-filter
+                       :cursor-color isearch-cursor-color
+                       :keymap isearch-keymap
+                       :callback isearch-callback
+                       :help-delay help-delay))
+       ((commandp binding)
+        (call-interactively binding))
+       (t
+        (funcall fallback key (key-binding key)))))))
+
+(defun popup-preferred-width (list)
+  "Return the preferred width to show LIST beautifully."
+  (cl-loop with tab-width = 4
+           for item in list
+           for summary = (popup-item-summary item)
+           maximize (string-width (popup-x-to-string item)) into width
+           if (stringp summary)
+           maximize (+ (string-width summary) 2) into summary-width
+           finally return
+           (let ((total (+ (or width 0) (or summary-width 0))))
+             (* (ceiling (/ total 10.0)) 10))))
+
+(defvar popup-menu-keymap
+  (let ((map (make-sparse-keymap)))
+    (define-key map "\r"        'popup-select)
+    (define-key map "\C-f"      'popup-open)
+    (define-key map [right]     'popup-open)
+    (define-key map "\C-b"      'popup-close)
+    (define-key map [left]      'popup-close)
+
+    (define-key map "\C-n"      'popup-next)
+    (define-key map [down]      'popup-next)
+    (define-key map "\C-p"      'popup-previous)
+    (define-key map [up]        'popup-previous)
+
+    (define-key map [next]      'popup-page-next)
+    (define-key map [prior]     'popup-page-previous)
+
+    (define-key map [f1]        'popup-help)
+    (define-key map (kbd "\C-?") 'popup-help)
+
+    (define-key map "\C-s"      'popup-isearch)
+
+    (define-key map [mouse-1]   'popup-select)
+    (define-key map [mouse-4]   'popup-previous)
+    (define-key map [mouse-5]   'popup-next)
+    map))
+
+(cl-defun popup-menu* (list
+                       &key
+                       point
+                       (around t)
+                       (width (popup-preferred-width list))
+                       (height 15)
+                       max-width
+                       margin
+                       margin-left
+                       margin-right
+                       scroll-bar
+                       symbol
+                       parent
+                       parent-offset
+                       cursor
+                       (keymap popup-menu-keymap)
+                       (fallback 'popup-menu-fallback)
+                       help-delay
+                       nowait
+                       prompt
+                       isearch
+                       (isearch-filter 'popup-isearch-filter-list)
+                       (isearch-cursor-color popup-isearch-cursor-color)
+                       (isearch-keymap popup-isearch-keymap)
+                       isearch-callback
+                       initial-index
+                       &aux menu event)
+  "Show a popup menu of LIST at POINT. This function returns a
+value of the selected item. Almost all arguments are the same as in
+`popup-create', except for KEYMAP, FALLBACK, HELP-DELAY, PROMPT,
+ISEARCH, ISEARCH-FILTER, ISEARCH-CURSOR-COLOR, ISEARCH-KEYMAP, and
+ISEARCH-CALLBACK.
+
+If KEYMAP is a keymap which is used when processing events during
+event loop.
+
+If FALLBACK is a function taking two arguments; a key and a
+command. FALLBACK is called when no special operation is found on
+the key. The default value is `popup-menu-fallback', which does
+nothing.
+
+HELP-DELAY is a delay of displaying helps.
+
+If NOWAIT is non-nil, this function immediately returns the menu
+instance without entering event loop.
+
+PROMPT is a prompt string when reading events during event loop.
+
+If ISEARCH is non-nil, do isearch as soon as displaying the popup
+menu.
+
+ISEARCH-FILTER is a filtering function taking two arguments:
+search pattern and list of items. Returns a list of matching items.
+
+ISEARCH-CURSOR-COLOR is a cursor color during isearch. The
+default value is `popup-isearch-cursor-color'.
+
+ISEARCH-KEYMAP is a keymap which is used when processing events
+during event loop. The default value is `popup-isearch-keymap'.
+
+ISEARCH-CALLBACK is a function taking one argument.  `popup-menu'
+calls ISEARCH-CALLBACK, if specified, after isearch finished or
+isearch canceled. The arguments is whole filtered list of items.
+
+If `INITIAL-INDEX' is non-nil, this is an initial index value for
+`popup-select'. Only positive integer is valid."
+  (and (eq margin t) (setq margin 1))
+  (or margin-left (setq margin-left margin))
+  (or margin-right (setq margin-right margin))
+  (if (and scroll-bar
+           (integerp margin-right)
+           (> margin-right 0))
+      ;; Make scroll-bar space as margin-right
+      (cl-decf margin-right))
+  (setq menu (popup-create point width height
+                           :max-width max-width
+                           :around around
+                           :face 'popup-menu-face
+                           :mouse-face 'popup-menu-mouse-face
+                           :selection-face 'popup-menu-selection-face
+                           :summary-face 'popup-menu-summary-face
+                           :margin-left margin-left
+                           :margin-right margin-right
+                           :scroll-bar scroll-bar
+                           :symbol symbol
+                           :parent parent
+                           :parent-offset parent-offset))
+  (unwind-protect
+      (progn
+        (popup-set-list menu list)
+        (if cursor
+            (popup-jump menu cursor)
+          (popup-draw menu))
+        (when initial-index
+          (dotimes (_i (min (- (length list) 1) initial-index))
+            (popup-next menu)))
+        (if nowait
+            menu
+          (popup-menu-event-loop menu keymap fallback
+                                 :prompt prompt
+                                 :help-delay help-delay
+                                 :isearch isearch
+                                 :isearch-filter isearch-filter
+                                 :isearch-cursor-color isearch-cursor-color
+                                 :isearch-keymap isearch-keymap
+                                 :isearch-callback isearch-callback)))
+    (unless nowait
+      (popup-delete menu))))
+
+(defun popup-cascade-menu (list &rest args)
+  "Same as `popup-menu' except that an element of LIST can be
+also a sub-menu if the element is a cons cell formed (ITEM
+. SUBLIST) where ITEM is an usual item and SUBLIST is a list of
+the sub menu."
+  (apply 'popup-menu*
+         (mapcar (lambda (item)
+                   (if (consp item)
+                       (popup-make-item (car item)
+                                        :sublist (cdr item)
+                                        :symbol ">")
+                     item))
+                 list)
+         :symbol t
+         args))
+
+(provide 'popup)
+;;; popup.el ends here
diff --git a/lisp/popwin.el b/lisp/popwin.el
new file mode 100644
index 00000000..4ca726fa
--- /dev/null
+++ b/lisp/popwin.el
@@ -0,0 +1,1118 @@
+;;; popwin.el --- Popup Window Manager.
+
+;; Copyright (C) 2011-2015  Tomohiro Matsuyama
+
+;; Author: Tomohiro Matsuyama 
+;; Keywords: convenience
+;; Package-Version: 20200122.1440
+;; Package-Commit: d69dca5c9ec4b08f5268ff2d6b5097618d4082d7
+;; Version: 1.0.0
+
+;; 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 .
+
+;;; Commentary:
+
+;; Popwin makes you free from the hell of annoying buffers such like
+;; *Help*, *Completions*, *compilation*, and etc.
+;;
+;; To use popwin, just add the following code into your .emacs:
+;;
+;;     (require 'popwin)
+;;     (popwin-mode 1)
+;;
+;; Then try to show some buffer, for example *Help* or
+;; *Completeions*.  Unlike standard behavior, their buffers may be
+;; shown in a popup window at the bottom of the frame.  And you can
+;; close the popup window seamlessly by typing C-g or selecting other
+;; windows.
+;;
+;; `popwin:display-buffer' displays special buffers in a popup window
+;; and displays normal buffers as unsual.  Special buffers are
+;; specified in `popwin:special-display-config', which tells popwin
+;; how to display such buffers.  See docstring of
+;; `popwin:special-display-config' for more information.
+;;
+;; The default width/height/position of popup window can be changed by
+;; setting `popwin:popup-window-width', `popwin:popup-window-height',
+;; and `popwin:popup-window-position'.  You can also change the
+;; behavior for a specific buffer.  See docstring of
+;; `popwin:special-display-config'.
+;;
+;; If you want to use some useful commands such like
+;; `popwin:popup-buffer' and `popwin:find-file' easily.  You may bind
+;; `popwin:keymap' to `C-z', for example, like:
+;;
+;;     (global-set-key (kbd "C-z") popwin:keymap)
+;;
+;; See also `popwin:keymap' documentation.
+;;
+;; Enjoy!
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defconst popwin:version "1.0.0")
+
+
+
+;;; Utility
+
+(defun popwin:listify (object)
+  "Return a singleton list of OBJECT if OBJECT is an atom, otherwise OBJECT itself."
+  (if (atom object) (list object) object))
+
+(defun popwin:subsitute-in-tree (map tree)
+  "Not documented (MAP) (TREE)."
+  (if (consp tree)
+      (cons (popwin:subsitute-in-tree map (car tree))
+            (popwin:subsitute-in-tree map (cdr tree)))
+    (or (cdr (assq tree map)) tree)))
+
+(defun popwin:get-buffer (buffer-or-name &optional if-not-found)
+  "Return a buffer named BUFFER-OR-NAME or BUFFER-OR-NAME itself \
+if BUFFER-OR-NAME is a buffer.  If BUFFER-OR-NAME is a string and
+such a buffer named BUFFER-OR-NAME not found, a new buffer will
+be returned when IF-NOT-FOUND is :create, or an error reported
+when IF-NOT-FOUND is :error.  The default of value of IF-NOT-FOUND
+is :error."
+  (ecase (or if-not-found :error)
+    (:create
+     (get-buffer-create buffer-or-name))
+    (:error
+     (or (get-buffer buffer-or-name)
+         (error "No buffer named %s" buffer-or-name)))))
+
+(defun popwin:switch-to-buffer (buffer-or-name &optional norecord)
+  "Call `switch-to-buffer' forcing BUFFER-OR-NAME be displayed in the \
+selected window.  NORECORD is the same as `switch-to-buffer' NORECORD."
+  (with-no-warnings
+    (if (>= emacs-major-version 24)
+        (switch-to-buffer buffer-or-name norecord t)
+      (switch-to-buffer buffer-or-name norecord))))
+
+(defun popwin:select-window (window &optional norecord)
+  "Call `select-window' (WINDOW) with saving the current buffer.
+NORECORD is the same as `switch-to-buffer' NORECORD."
+  (save-current-buffer
+    (select-window window norecord)))
+
+(defun popwin:buried-buffer-p (buffer)
+  "Return t if BUFFER might be thought of as a buried buffer."
+  (eq (car (last (buffer-list))) buffer))
+
+(defun popwin:window-point (window)
+  "Return `window-point' of WINDOW.
+If WINDOW is currently selected, then return buffer-point instead."
+  (if (eq (selected-window) window)
+      (with-current-buffer (window-buffer window)
+        (point))
+    (window-point window)))
+
+(defun popwin:window-deletable-p (window)
+  "Return t if WINDOW is deletable, meaning that WINDOW is alive \
+and not a minibuffer's window, plus there is two or more windows."
+  (and (window-live-p window)
+       (not (window-minibuffer-p window))
+       (not (one-window-p))))
+
+(defmacro popwin:save-selected-window (&rest body)
+  "Evaluate BODY saving the selected window."
+  `(with-selected-window (selected-window) ,@body))
+
+(defun popwin:minibuffer-window-selected-p ()
+  "Return t if minibuffer window is selected."
+  (minibuffer-window-active-p (selected-window)))
+
+(defun popwin:last-selected-window ()
+  "Return currently selected window or lastly selected window if \
+minibuffer window is selected."
+  (if (popwin:minibuffer-window-selected-p)
+      (minibuffer-selected-window)
+    (selected-window)))
+
+
+
+;;; Common
+
+(defvar popwin:debug nil)
+
+(defvar popwin:dummy-buffer nil)
+
+(defun popwin:dummy-buffer ()
+  "Not documented."
+  (if (buffer-live-p popwin:dummy-buffer)
+      popwin:dummy-buffer
+    (setq popwin:dummy-buffer (get-buffer-create " *popwin-dummy*"))))
+
+(defun popwin:kill-dummy-buffer ()
+  "Not documented."
+  (when (buffer-live-p popwin:dummy-buffer)
+    (kill-buffer popwin:dummy-buffer))
+  (setq popwin:dummy-buffer nil))
+
+(defun popwin:window-trailing-edge-adjustable-p (window)
+  "Return t if a trailing edge of WINDOW is adjustable."
+  (let ((next-window (next-window window)))
+    (and (not (eq next-window (frame-first-window)))
+         (not (eq (window-buffer next-window)
+                  (popwin:dummy-buffer))))))
+
+(defun* popwin:adjust-window-edges (window
+                                    edges
+                                    &optional
+                                    (hfactor 1)
+                                    (vfactor 1))
+  "Adjust edges of WINDOW to EDGES accoring to horizontal factor
+HFACTOR, and vertical factor VFACTOR."
+  (when (popwin:window-trailing-edge-adjustable-p window)
+    (destructuring-bind ((left top right bottom)
+                         (cur-left cur-top cur-right cur-bottom))
+        (list edges (window-edges window))
+      (let ((hdelta (floor (- (* (- right left) hfactor) (- cur-right cur-left))))
+            (vdelta (floor (- (* (- bottom top) vfactor) (- cur-bottom cur-top)))))
+        (ignore-errors
+          (adjust-window-trailing-edge window hdelta t))
+        (ignore-errors
+          (adjust-window-trailing-edge window vdelta nil))))))
+
+(defun popwin:window-config-tree-1 (node)
+  "Not documented (NODE)."
+  (if (windowp node)
+      (list 'window
+            node
+            (window-buffer node)
+            (popwin:window-point node)
+            (window-start node)
+            (window-edges node)
+            (eq (selected-window) node)
+            (window-dedicated-p node))
+    (destructuring-bind (dir edges . windows) node
+      (append (list dir edges)
+              (loop for window in windows
+                    unless (and (windowp window)
+                                (window-parameter window 'window-side))
+                    collect (popwin:window-config-tree-1 window))))))
+
+(defun popwin:window-config-tree ()
+  "Return `window-tree' with replacing window values in the tree \
+with persistent representations."
+  (destructuring-bind (root mini)
+      (window-tree)
+    (list (popwin:window-config-tree-1 root) mini)))
+
+(defun popwin:replicate-window-config (window node hfactor vfactor)
+  "Replicate NODE of window configuration on WINDOW with \
+horizontal factor HFACTOR, and vertical factor VFACTOR.  The
+return value is a association list of mapping from old-window to
+new-window."
+  (if (eq (car node) 'window)
+      (destructuring-bind (old-win buffer point start edges selected dedicated)
+          (cdr node)
+        (set-window-dedicated-p window nil)
+        (popwin:adjust-window-edges window edges hfactor vfactor)
+        (with-selected-window window
+          (popwin:switch-to-buffer buffer t))
+        (when selected
+          (popwin:select-window window))
+        (set-window-point window point)
+        (set-window-start window start t)
+        (when dedicated
+          (set-window-dedicated-p window t))
+        `((,old-win . ,window)))
+    (destructuring-bind (dir edges . windows) node
+      (loop while windows
+            for sub-node = (pop windows)
+            for win = window then next-win
+            for next-win = (and windows (split-window win nil (not dir)))
+            append (popwin:replicate-window-config win sub-node hfactor vfactor)))))
+
+(defun popwin:restore-window-outline (node outline)
+  "Restore window outline accoding to the structures of NODE \
+which is a node of `window-tree' and OUTLINE which is a node of
+`popwin:window-config-tree'."
+  (cond
+   ((and (windowp node)
+         (eq (car outline) 'window))
+    ;; same window
+    (destructuring-bind (old-win buffer point start edges selected dedicated)
+        (cdr outline)
+      (popwin:adjust-window-edges node edges)
+      (when (and (eq (window-buffer node) buffer)
+                 (eq (popwin:window-point node) point))
+        (set-window-start node start))))
+   ((or (windowp node)
+        (not (eq (car node) (car outline))))
+    ;; different structure
+    ;; nothing to do
+    )
+   (t
+    (let ((child-nodes (cddr node))
+          (child-outlines (cddr outline)))
+      (when (eq (length child-nodes) (length child-outlines))
+        ;; same structure
+        (loop for child-node in child-nodes
+              for child-outline in child-outlines
+              do (popwin:restore-window-outline child-node child-outline)))))))
+
+(defun popwin:position-horizontal-p (position)
+  "Return t if POSITION is hozirontal."
+  (and (memq position '(left :left right :right)) t))
+
+(defun popwin:position-vertical-p (position)
+  "Return t if POSITION is vertical."
+  (and (memq position '(top :top bottom :bottom)) t))
+
+(defun popwin:create-popup-window-1 (window size position)
+  "Create a new window with SIZE at POSITION of WINDOW.
+The return value is a list of a master window and the popup window."
+  (let ((width (window-width window))
+        (height (window-height window)))
+    (ecase position
+      ((left :left)
+       (list (split-window window size t)
+             window))
+      ((top :top)
+       (list (split-window window size nil)
+             window))
+      ((right :right)
+       (list window
+             (split-window window (- width size) t)))
+      ((bottom :bottom)
+       (list window
+             (split-window window (- height size) nil))))))
+
+(defun* popwin:create-popup-window (&optional (size 15) (position 'bottom) (adjust t))
+  "Create a popup window with SIZE on the frame.  If SIZE
+is integer, the size of the popup window will be SIZE. If SIZE is
+float, the size of popup window will be a multiplier of SIZE and
+frame-size. can be an integer and a float. If ADJUST is t, all of
+windows will be adjusted to fit the frame. POSITION must be one
+of (left top right bottom). The return value is a pair of a
+master window and the popup window. To close the popup window
+properly, get `current-window-configuration' before calling this
+function, and call `set-window-configuration' with the
+window-configuration."
+  (let* ((root (car (popwin:window-config-tree)))
+         (root-win (popwin:last-selected-window))
+         (hfactor 1)
+         (vfactor 1))
+    (popwin:save-selected-window
+     (delete-other-windows root-win))
+    (let ((root-width (window-width root-win))
+          (root-height (window-height root-win)))
+      (when adjust
+        (if (floatp size)
+            (if (popwin:position-horizontal-p position)
+                (setq hfactor (- 1.0 size)
+                      size (round (* root-width size)))
+              (setq vfactor (- 1.0 size)
+                    size (round (* root-height size))))
+          (if (popwin:position-horizontal-p position)
+              (setq hfactor (/ (float (- root-width size)) root-width))
+            (setq vfactor (/ (float (- root-height size)) root-height)))))
+      (destructuring-bind (master-win popup-win)
+          (popwin:create-popup-window-1 root-win size position)
+        ;; Mark popup-win being a popup window.
+        (with-selected-window popup-win
+          (popwin:switch-to-buffer (popwin:dummy-buffer) t))
+        (let ((win-map (popwin:replicate-window-config master-win root hfactor vfactor)))
+          (list master-win popup-win win-map))))))
+
+
+
+;;; Common User Interface
+
+(defgroup popwin nil
+  "Popup Window Manager."
+  :group 'convenience
+  :prefix "popwin:")
+
+(defcustom popwin:popup-window-position 'bottom
+  "Default popup window position.
+This must be one of (left top right bottom)."
+  :type 'symbol
+  :group 'popwin)
+
+(defcustom popwin:popup-window-width 30
+  "Default popup window width.
+If `popwin:popup-window-position' is top or bottom, this configuration
+will be ignored.  If this variable is float, the popup window width will
+be a multiplier of the value and frame-size."
+  :type 'number
+  :group 'popwin)
+
+(defcustom popwin:popup-window-height 15
+  "Default popup window height.
+If `popwin:popup-window-position' is left or right, this configuration
+will be ignored.  If this variable is float, the popup window height will
+be a multiplier of the value and frame-size."
+  :type 'number
+  :group 'popwin)
+
+(defcustom popwin:reuse-window 'current
+  "Non-nil means `popwin:display-buffer' will not popup the visible buffer.
+The value is same as a second argument of `get-buffer-window', except `current'
+means the selected frame."
+  :type 'symbol
+  :group 'popwin)
+
+(defcustom popwin:adjust-other-windows t
+  "Non-nil means all of other windows will be adjusted to fit the \
+frame when a popup window is shown."
+  :type 'boolean
+  :group 'popwin)
+
+(defvar popwin:context-stack nil)
+
+(defvar popwin:popup-window nil
+  "Main popup window instance.")
+
+(defvar popwin:popup-buffer nil
+  "Buffer of currently shown in the popup window.")
+
+(defvar popwin:popup-last-config nil
+  "Arguments to `popwin:popup-buffer' of last call.")
+
+;; Deprecated
+(defvar popwin:master-window nil
+  "Master window of a popup window.")
+
+(defvar popwin:focus-window nil
+  "Focused window which is used to check whether or not to close the popup window.")
+
+(defvar popwin:selected-window nil
+  "Last selected window when the popup window is shown.")
+
+(defvar popwin:popup-window-dedicated-p nil
+  "Non-nil means the popup window is dedicated to the original popup buffer.")
+
+(defvar popwin:popup-window-stuck-p nil
+  "Non-nil means the popup window has been stuck.")
+
+(defvar popwin:window-outline nil
+  "Original window outline which is obtained by `popwin:window-config-tree'.")
+
+(defvar popwin:window-map nil
+  "Mapping from old windows to new windows.")
+
+(defvar popwin:window-config nil
+  "An original window configuration for restoreing.")
+
+(defvar popwin:close-popup-window-timer nil
+  "Timer of closing the popup window.")
+
+(defvar popwin:close-popup-window-timer-interval 0.05
+  "Interval of `popwin:close-popup-window-timer'.")
+
+(defvar popwin:before-popup-hook nil)
+
+(defvar popwin:after-popup-hook nil)
+
+(symbol-macrolet ((context-vars '(popwin:popup-window
+                                  popwin:popup-buffer
+                                  popwin:master-window
+                                  popwin:focus-window
+                                  popwin:selected-window
+                                  popwin:popup-window-dedicated-p
+                                  popwin:popup-window-stuck-p
+                                  popwin:window-outline
+                                  popwin:window-map)))
+  (defun popwin:valid-context-p (context)
+    (window-live-p (plist-get context 'popwin:popup-window)))
+
+  (defun popwin:current-context ()
+    (loop for var in context-vars
+          collect var
+          collect (symbol-value var)))
+
+  (defun popwin:use-context (context)
+    (loop for var = (pop context)
+          for val = (pop context)
+          while var
+          do (set var val)))
+
+  (defun popwin:push-context ()
+    (push (popwin:current-context) popwin:context-stack))
+
+  (defun popwin:pop-context ()
+    (popwin:use-context (pop popwin:context-stack)))
+
+  (defun* popwin:find-context-for-buffer (buffer &key valid-only)
+    (loop with stack = popwin:context-stack
+          for context = (pop stack)
+          while context
+          if (and (eq buffer (plist-get context 'popwin:popup-buffer))
+                  (or (not valid-only)
+                      (popwin:valid-context-p context)))
+          return (list context stack))))
+
+(defun popwin:popup-window-live-p ()
+  "Return t if `popwin:popup-window' is alive."
+  (window-live-p popwin:popup-window))
+
+(defun* popwin:update-window-reference (symbol
+                                        &key
+                                        (map popwin:window-map)
+                                        safe
+                                        recursive)
+  (unless (and safe (not (boundp symbol)))
+    (let ((value (symbol-value symbol)))
+      (set symbol
+           (if recursive
+               (popwin:subsitute-in-tree map value)
+             (or (cdr (assq value map)) value))))))
+
+(defun popwin:start-close-popup-window-timer ()
+  "Not documented."
+  (or popwin:close-popup-window-timer
+      (setq popwin:close-popup-window-timer
+            (run-with-idle-timer popwin:close-popup-window-timer-interval
+                                 popwin:close-popup-window-timer-interval
+                                 'popwin:close-popup-window-timer))))
+
+(defun popwin:stop-close-popup-window-timer ()
+  "Not documented."
+  (when popwin:close-popup-window-timer
+    (cancel-timer popwin:close-popup-window-timer)
+    (setq popwin:close-popup-window-timer nil)))
+
+(defun popwin:close-popup-window-timer ()
+  "Not documented."
+  (condition-case var
+      (popwin:close-popup-window-if-necessary)
+    (error
+     (message "popwin:close-popup-window-timer: error: %s" var)
+     (when popwin:debug (backtrace)))))
+
+(defun popwin:close-popup-window (&optional keep-selected)
+  "Close the popup window and restore to the previous window configuration.
+If KEEP-SELECTED is non-nil, the lastly selected window will not be selected."
+  (interactive)
+  (when popwin:popup-window
+    (unwind-protect
+        (progn
+          (when (popwin:window-deletable-p popwin:popup-window)
+            (delete-window popwin:popup-window))
+          (popwin:restore-window-outline (car (window-tree)) popwin:window-outline)
+          ;; Call `redisplay' here so `window-start' could be set
+          ;; prior to the point change of the master buffer.
+          (redisplay)
+          (when (and (not keep-selected)
+                     (window-live-p popwin:selected-window))
+            (select-window popwin:selected-window)))
+      (popwin:pop-context)
+      ;; Cleanup if no context left.
+      (when (null popwin:context-stack)
+        (popwin:kill-dummy-buffer)
+        (popwin:stop-close-popup-window-timer)))))
+
+(defun popwin:close-popup-window-if-necessary ()
+  "Close the popup window if necessary.
+The all situations where the popup window will be closed are followings:
+
+* `C-g' has been pressed.
+* The popup buffer has been killed.
+* The popup buffer has been buried.
+* The popup buffer has been changed if the popup window is
+  dedicated to the buffer.
+* Another window has been selected."
+  (when popwin:popup-window
+    (let* ((window (selected-window))
+           (window-point (popwin:window-point window))
+           (window-buffer (window-buffer window))
+           (minibuf-window-p (window-minibuffer-p window))
+           (reading-from-minibuf
+            (and minibuf-window-p
+                 (minibuffer-prompt)
+                 t))
+           (quit-requested
+            (and (eq last-command 'keyboard-quit)
+                 (eq last-command-event ?\C-g)))
+           (other-window-selected
+            (and (not (eq window popwin:focus-window))
+                 (not (eq window popwin:popup-window))))
+           (orig-this-command this-command)
+           (popup-buffer-alive
+            (buffer-live-p popwin:popup-buffer))
+           (popup-buffer-buried
+            (popwin:buried-buffer-p popwin:popup-buffer))
+           (popup-buffer-changed-despite-of-dedicated
+            (and popwin:popup-window-dedicated-p
+                 (not popwin:popup-window-stuck-p)
+                 (or (not other-window-selected)
+                     (not reading-from-minibuf))
+                 (buffer-live-p window-buffer)
+                 (not (eq popwin:popup-buffer window-buffer))))
+           (popup-window-alive (popwin:popup-window-live-p)))
+      (when (or quit-requested
+                (not popup-buffer-alive)
+                popup-buffer-buried
+                popup-buffer-changed-despite-of-dedicated
+                (not popup-window-alive)
+                (and other-window-selected
+                     (not minibuf-window-p)
+                     (not popwin:popup-window-stuck-p)))
+        (when popwin:debug
+          (message (concat "popwin: CLOSE:\n"
+                           "  quit-requested = %s\n"
+                           "  popup-buffer-alive = %s\n"
+                           "  popup-buffer-buried = %s\n"
+                           "  popup-buffer-changed-despite-of-dedicated = %s\n"
+                           "  popup-window-alive = %s\n"
+                           "  (selected-window) = %s\n"
+                           "  popwin:focus-window = %s\n"
+                           "  popwin:popup-window = %s\n"
+                           "  other-window-selected = %s\n"
+                           "  minibuf-window-p = %s\n"
+                           "  popwin:popup-window-stuck-p = %s")
+                   quit-requested
+                   popup-buffer-alive
+                   popup-buffer-buried
+                   popup-buffer-changed-despite-of-dedicated
+                   popup-window-alive
+                   window
+                   popwin:focus-window
+                   popwin:popup-window
+                   other-window-selected
+                   minibuf-window-p
+                   popwin:popup-window-stuck-p))
+        (when (and quit-requested
+                   (null orig-this-command))
+          (setq this-command 'popwin:close-popup-window)
+          (run-hooks 'pre-command-hook))
+        (cond
+         ((and quit-requested
+               (null orig-this-command)
+               popwin:window-config)
+          (set-window-configuration popwin:window-config)
+          (setq popwin:window-config nil))
+         (reading-from-minibuf
+          (popwin:close-popup-window)
+          (select-window (minibuffer-window)))
+         (t
+          (popwin:close-popup-window
+           (and other-window-selected
+                (and popup-buffer-alive
+                     (not popup-buffer-buried))))
+          (when popup-buffer-changed-despite-of-dedicated
+            (popwin:switch-to-buffer window-buffer)
+            (goto-char window-point))))
+        (when (and quit-requested
+                   (null orig-this-command))
+          (run-hooks 'post-command-hook)
+          (setq last-command 'popwin:close-popup-window))))))
+
+;;;###autoload
+(defun* popwin:popup-buffer (buffer
+                             &key
+                             (width popwin:popup-window-width)
+                             (height popwin:popup-window-height)
+                             (position popwin:popup-window-position)
+                             noselect
+                             dedicated
+                             stick
+                             tail)
+  "Show BUFFER in a popup window and return the popup window. If
+NOSELECT is non-nil, the popup window will not be selected. If
+STICK is non-nil, the popup window will be stuck. If TAIL is
+non-nil, the popup window will show the last contents. Calling
+`popwin:popup-buffer' during `popwin:popup-buffer' is allowed. In
+that case, the buffer of the popup window will be replaced with
+BUFFER."
+  (interactive "BPopup buffer:\n")
+  (setq buffer (get-buffer buffer))
+  (popwin:push-context)
+  (run-hooks 'popwin:before-popup-hook)
+  (multiple-value-bind (context context-stack)
+      (popwin:find-context-for-buffer buffer :valid-only t)
+    (if context
+        (progn
+          (popwin:use-context context)
+          (setq popwin:context-stack context-stack))
+      (let ((win-outline (car (popwin:window-config-tree))))
+        (destructuring-bind (master-win popup-win win-map)
+            (let ((size (if (popwin:position-horizontal-p position) width height))
+                  (adjust popwin:adjust-other-windows))
+              (popwin:create-popup-window size position adjust))
+          (setq popwin:popup-window popup-win
+                popwin:master-window master-win
+                popwin:window-outline win-outline
+                popwin:window-map win-map
+                popwin:window-config nil
+                popwin:selected-window (selected-window)))
+        (popwin:update-window-reference 'popwin:context-stack :recursive t)
+        (popwin:start-close-popup-window-timer))
+      (with-selected-window popwin:popup-window
+        (popwin:switch-to-buffer buffer)
+        (when tail
+          (set-window-point popwin:popup-window (point-max))
+          (recenter -2)))
+      (setq popwin:popup-buffer buffer
+            popwin:popup-last-config (list buffer
+                                           :width width :height height :position position
+                                           :noselect noselect :dedicated dedicated
+                                           :stick stick :tail tail)
+            popwin:popup-window-dedicated-p dedicated
+            popwin:popup-window-stuck-p stick)))
+  (if noselect
+      (setq popwin:focus-window popwin:selected-window)
+    (setq popwin:focus-window popwin:popup-window)
+    (select-window popwin:popup-window))
+  (run-hooks 'popwin:after-popup-hook)
+  popwin:popup-window)
+
+(defun popwin:popup-last-buffer (&optional noselect)
+  "Show the last popup buffer with the same configuration.
+If NOSELECT is non-nil, the popup window will not be selected."
+  (interactive "P")
+  (if popwin:popup-last-config
+      (if noselect
+          (destructuring-bind (buffer . keyargs) popwin:popup-last-config
+            (apply 'popwin:popup-buffer buffer :noselect t keyargs))
+        (apply 'popwin:popup-buffer popwin:popup-last-config))
+    (error "No popup buffer ever")))
+(defalias 'popwin:display-last-buffer 'popwin:popup-last-buffer)
+
+(defun popwin:select-popup-window ()
+  "Select the currently shown popup window."
+  (interactive)
+  (if (popwin:popup-window-live-p)
+      (select-window popwin:popup-window)
+    (error "No popup window displayed")))
+
+(defun popwin:stick-popup-window ()
+  "Stick the currently shown popup window.
+The popup window can be closed by `popwin:close-popup-window'."
+  (interactive)
+  (if (popwin:popup-window-live-p)
+      (progn
+        (setq popwin:popup-window-stuck-p t)
+        (message "Popup window stuck"))
+    (error "No popup window displayed")))
+
+
+
+;;; Special Display
+
+(defmacro popwin:without-special-displaying (&rest body)
+  "Evaluate BODY without special displaying."
+  (if (boundp 'display-buffer-alist)
+      `(with-no-warnings
+         (let ((display-buffer-function nil)
+               (display-buffer-alist
+                (remove '(popwin:display-buffer-condition
+                          popwin:display-buffer-action)
+                        display-buffer-alist)))
+           ,@body))
+    `(with-no-warnings (let ((display-buffer-function nil)) ,@body))))
+
+(defcustom popwin:special-display-config
+  '(;; Emacs
+    ("*Miniedit Help*" :noselect t)
+    help-mode
+    (completion-list-mode :noselect t)
+    (compilation-mode :noselect t)
+    (grep-mode :noselect t)
+    (occur-mode :noselect t)
+    ("*Pp Macroexpand Output*" :noselect t)
+    "*Shell Command Output*"
+    ;; VC
+    "*vc-diff*"
+    "*vc-change-log*"
+    ;; Undo-Tree
+    (" *undo-tree*" :width 60 :position right)
+    ;; Anything
+    ("^\\*anything.*\\*$" :regexp t)
+    ;; SLIME
+    "*slime-apropos*"
+    "*slime-macroexpansion*"
+    "*slime-description*"
+    ("*slime-compilation*" :noselect t)
+    "*slime-xref*"
+    (sldb-mode :stick t)
+    slime-repl-mode
+    slime-connection-list-mode)
+  "Configuration of special displaying buffer for `popwin:display-buffer' and \
+`popwin:special-display-popup-window'.  The value is a list of
+CONFIG as a form of (PATTERN . KEYWORDS) where PATTERN is a
+pattern of specifying buffer and KEYWORDS is a list of a pair of
+key and value.  PATTERN is in general a buffer name, a symbol
+specifying `major-mode' of buffer, or a predicate function which
+takes one argument: the buffer.  If CONFIG is a string or a
+symbol, PATTERN will be CONFIG and KEYWORDS will be
+empty.  Available keywords are following:
+
+  regexp: If the value is non-nil, PATTERN will be used as regexp
+    to matching buffer.
+
+  width, height: Specify width or height of the popup window.  If
+    no size specified, `popwin:popup-window-width' or
+    `popwin:popup-window-height' will be used.  See also position
+    keyword.
+
+  position: The value must be one of (left top right bottom).  The
+    popup window will shown at the position of the frame.  If no
+    position specified, `popwin:popup-window-position' will be
+    used.
+
+  noselect: If the value is non-nil, the popup window will not be
+    selected when it is shown.
+
+  dedicated: If the value is non-nil, the popup window will be
+    dedicated to the original popup buffer.  In this case, when
+    another buffer is selected in the popup window, the popup
+    window will be closed immedicately and the selected buffer
+    will be shown on the previously selected window.
+
+  stick: If the value is non-nil, the popup window will be stuck
+    when it is shown.
+
+  tail: If the value is non-nil, the popup window will show the
+    last contents.
+
+Examples: With '(\"*scratch*\" :height 30 :position top),
+*scratch* buffer will be shown at the top of the frame with
+height 30. With '(dired-mode :width 80 :position left), dired
+buffers will be shown at the left of the frame with width 80."
+  :type '(repeat
+          (cons :tag "Config"
+                (choice :tag "Pattern"
+                        (string :tag "Buffer Name")
+                        (symbol :tag "Major Mode"))
+                (plist :tag "Keywords"
+                       :value (:regexp nil) ; BUG? need default value
+                       :options
+                       ((:regexp (boolean :tag "On/Off"))
+                        (:width (choice :tag "Width"
+                                        (integer :tag "Width")
+                                        (float :tag "Width (%)")))
+                        (:height (choice :tag "Height"
+                                         (integer :tag "Height")
+                                         (float :tag "Height (%)")))
+                        (:position (choice :tag "Position"
+                                           (const :tag "Bottom" bottom)
+                                           (const :tag "Top" top)
+                                           (const :tag "Left" left)
+                                           (const :tag "Right" right)))
+                        (:noselect (boolean :tag "On/Off"))
+                        (:dedicated (boolean :tag "On/Off"))
+                        (:stick (boolean :tag "On/Off"))
+                        (:tail (boolean :tag "On/Off"))))))
+  :get (lambda (symbol)
+         (mapcar (lambda (element)
+                   (if (consp element)
+                       element
+                     (list element)))
+                 (default-value symbol)))
+  :group 'popwin)
+
+(defun popwin:apply-display-buffer (function buffer &optional not-this-window)
+  "Call FUNCTION on BUFFER without special displaying."
+  (popwin:without-special-displaying
+   (let ((same-window
+          (or (same-window-p (buffer-name buffer))
+              (and (>= emacs-major-version 24)
+                   (boundp 'action)
+                   (consp action)
+                   (eq (car action) 'display-buffer-same-window)))))
+     ;; Close the popup window here so that the popup window won't to
+     ;; be splitted.
+     (when (and (eq (selected-window) popwin:popup-window)
+                (not same-window))
+       (popwin:close-popup-window)))
+   (if (and (>= emacs-major-version 24)
+            (boundp 'action)
+            (boundp 'frame))
+       ;; Use variables ACTION and FRAME which are formal parameters
+       ;; of DISPLAY-BUFFER.
+       ;;
+       ;; TODO: use display-buffer-alist instead of
+       ;; display-buffer-function.
+       (funcall function buffer action frame)
+     (funcall function buffer not-this-window))))
+
+(defun popwin:original-display-buffer (buffer &optional not-this-window)
+  "Call `display-buffer' on BUFFER without special displaying."
+  (popwin:apply-display-buffer 'display-buffer buffer not-this-window))
+
+(defun popwin:original-pop-to-buffer (buffer &optional not-this-window)
+  "Call `pop-to-buffer' on BUFFER without special displaying."
+  (popwin:apply-display-buffer 'pop-to-buffer buffer not-this-window))
+
+(defun popwin:original-display-last-buffer ()
+  "Call `display-buffer' for the last popup buffer without special displaying."
+  (interactive)
+  (if popwin:popup-last-config
+      (popwin:original-display-buffer (car popwin:popup-last-config))
+    (error "No popup buffer ever")))
+
+(defun popwin:switch-to-last-buffer ()
+  "Switch to the last popup buffer."
+  (interactive)
+  (if popwin:popup-last-config
+      (popwin:apply-display-buffer
+       (lambda (buffer &rest ignore) (switch-to-buffer buffer))
+       (car popwin:popup-last-config))
+    (error "No popup buffer ever")))
+
+(defun popwin:original-pop-to-last-buffer ()
+  "Call `pop-to-buffer' for the last popup buffer without special displaying."
+  (interactive)
+  (if popwin:popup-last-config
+      (popwin:original-pop-to-buffer (car popwin:popup-last-config))
+    (error "No popup buffer ever")))
+
+(defun popwin:reuse-window-p (buffer-or-name not-this-window)
+  "Return t if a window showing BUFFER-OR-NAME exists and should be used displaying the buffer."
+  (and popwin:reuse-window
+       (let ((window (get-buffer-window buffer-or-name
+                                        (if (eq popwin:reuse-window 'current)
+                                            nil
+                                          popwin:reuse-window))))
+         (and (not (null window))
+              (not (eq window (if not-this-window (selected-window))))))))
+
+(defun* popwin:match-config (buffer)
+  (when (stringp buffer) (setq buffer (get-buffer buffer)))
+  (loop with name = (buffer-name buffer)
+        with mode = (buffer-local-value 'major-mode buffer)
+        for config in popwin:special-display-config
+        for (pattern . keywords) = (popwin:listify config)
+        if (cond ((eq pattern t) t)
+                 ((and (stringp pattern) (plist-get keywords :regexp))
+                  (string-match pattern name))
+                 ((stringp pattern)
+                  (string= pattern name))
+                 ((symbolp pattern)
+                  (eq pattern mode))
+                 ((functionp pattern)
+                  (funcall pattern buffer))
+                 (t (error "Invalid pattern: %s" pattern)))
+        return (cons pattern keywords)))
+
+(defun* popwin:display-buffer-1 (buffer-or-name
+                                 &key
+                                 default-config-keywords
+                                 (if-buffer-not-found :create)
+                                 if-config-not-found)
+  "Display BUFFER-OR-NAME, if possible, in a popup
+window. Otherwise call IF-CONFIG-NOT-FOUND with BUFFER-OR-NAME if
+the value is a function. If IF-CONFIG-NOT-FOUND is nil,
+`popwin:popup-buffer' will be called. IF-BUFFER-NOT-FOUND
+indicates what happens when there is no such buffers. If the
+value is :create, create a new buffer named BUFFER-OR-NAME. If
+the value is :error, report an error. The default value
+is :create. DEFAULT-CONFIG-KEYWORDS is a property list which
+specifies default values of the config."
+  (let* ((buffer (popwin:get-buffer buffer-or-name if-buffer-not-found))
+         (pattern-and-keywords (popwin:match-config buffer)))
+    (unless pattern-and-keywords
+      (if if-config-not-found
+          (return-from popwin:display-buffer-1
+            (funcall if-config-not-found buffer))
+        (setq pattern-and-keywords '(t))))
+    (destructuring-bind (&key regexp width height position noselect dedicated stick tail)
+        (append (cdr pattern-and-keywords) default-config-keywords)
+      (popwin:popup-buffer buffer
+                           :width (or width popwin:popup-window-width)
+                           :height (or height popwin:popup-window-height)
+                           :position (or position popwin:popup-window-position)
+                           :noselect (or (popwin:minibuffer-window-selected-p) noselect)
+                           :dedicated dedicated
+                           :stick stick
+                           :tail tail))))
+
+;;;###autoload
+(defun popwin:display-buffer (buffer-or-name &optional not-this-window)
+  "Display BUFFER-OR-NAME, if possible, in a popup window, or as usual.
+This function can be used as a value of
+`display-buffer-function'."
+  (interactive "BDisplay buffer:\n")
+  (if (popwin:reuse-window-p buffer-or-name not-this-window)
+      ;; Call `display-buffer' for reuse.
+      (popwin:original-display-buffer buffer-or-name not-this-window)
+    (popwin:display-buffer-1
+     buffer-or-name
+     :if-config-not-found
+     (unless (with-no-warnings
+               ;; FIXME: emacs bug?
+               (called-interactively-p))
+       (lambda (buffer)
+         (popwin:original-display-buffer buffer not-this-window))))))
+
+(defun popwin:special-display-popup-window (buffer &rest ignore)
+  "Obsolete (BUFFER) (IGNORE)."
+  (popwin:display-buffer-1 buffer))
+
+(defun* popwin:pop-to-buffer-1 (buffer
+                                &key
+                                default-config-keywords
+                                other-window
+                                norecord)
+  (popwin:display-buffer-1 buffer
+                           :default-config-keywords default-config-keywords
+                           :if-config-not-found
+                           (lambda (buffer)
+                             (pop-to-buffer buffer other-window norecord))))
+
+;;;###autoload
+(defun popwin:pop-to-buffer (buffer &optional other-window norecord)
+  "Same as `pop-to-buffer' except that this function will use \
+`popwin:display-buffer-1' instead of `display-buffer'.  BUFFER,
+OTHER-WINDOW amd NORECORD are the same arguments."
+  (interactive (list (read-buffer "Pop to buffer: " (other-buffer))
+                     (if current-prefix-arg t)))
+  (popwin:pop-to-buffer-1 buffer
+                          :other-window other-window
+                          :norecord norecord))
+
+
+
+;;; Universal Display
+
+(defcustom popwin:universal-display-config '(t)
+  "Same as `popwin:special-display-config' except that this will \
+be used for `popwin:universal-display'."
+  :type 'list
+  :group 'popwin)
+
+;;;###autoload
+(defun popwin:universal-display ()
+  "Call the following command interactively with letting \
+`popwin:special-display-config' be `popwin:universal-display-config'.
+This will be useful when displaying buffers in popup windows temporarily."
+  (interactive)
+  (let ((command (key-binding (read-key-sequence "" t)))
+        (popwin:special-display-config popwin:universal-display-config))
+    (call-interactively command)))
+
+
+
+;;; Extensions
+
+;;;###autoload
+(defun popwin:one-window ()
+  "Delete other window than the popup window. C-g restores the original \
+window configuration."
+  (interactive)
+  (setq popwin:window-config (current-window-configuration))
+  (delete-other-windows))
+
+;;;###autoload
+(defun popwin:popup-buffer-tail (&rest same-as-popwin:popup-buffer)
+  "Same as `popwin:popup-buffer' except that the buffer will be \
+`recenter'ed at the bottom."
+  (interactive "bPopup buffer:\n")
+  (destructuring-bind (buffer . keyargs) same-as-popwin:popup-buffer
+    (apply 'popwin:popup-buffer buffer :tail t keyargs)))
+
+;;;###autoload
+(defun popwin:find-file (filename &optional wildcards)
+  "Edit file FILENAME with popup window by `popwin:popup-buffer'."
+  (interactive
+   (find-file-read-args "Find file in popup window: "
+                        (when (fboundp 'confirm-nonexistent-file-or-buffer)
+                          (confirm-nonexistent-file-or-buffer))))
+  (popwin:popup-buffer (find-file-noselect filename wildcards)))
+
+;;;###autoload
+(defun popwin:find-file-tail (file &optional wildcard)
+  "Edit file FILENAME with popup window by `popwin:popup-buffer-tail'."
+  (interactive
+   (find-file-read-args "Find file in popup window: "
+                        (when (fboundp 'confirm-nonexistent-file-or-buffer)
+                          (confirm-nonexistent-file-or-buffer))))
+  (popwin:popup-buffer-tail (find-file-noselect file wildcard)))
+
+;;;###autoload
+(defun popwin:messages ()
+  "Display *Messages* buffer in a popup window."
+  (interactive)
+  (popwin:popup-buffer-tail "*Messages*"))
+
+
+
+;;; Minor Mode
+
+(defun popwin:display-buffer-condition (buffer action)
+  "Not documented (BUFFER) (ACTION)."
+  (and (popwin:match-config buffer) t))
+
+(defun popwin:display-buffer-action (buffer alist)
+  "Not documented (BUFFER) (ALIST)."
+  (let ((not-this-window (plist-get 'inhibit-same-window alist)))
+    (popwin:display-buffer buffer not-this-window)))
+
+;;;###autoload
+(define-minor-mode popwin-mode
+  "Minor mode for `popwin-mode'."
+  :init-value nil
+  :global t
+  (if (boundp 'display-buffer-alist)
+      (let ((pair '(popwin:display-buffer-condition popwin:display-buffer-action)))
+        (if popwin-mode
+          (push pair display-buffer-alist)
+          (setq display-buffer-alist (delete pair display-buffer-alist))))
+    (with-no-warnings
+      (unless (or (null display-buffer-function)
+                  (eq display-buffer-function 'popwin:display-buffer))
+        (warn "Overwriting display-buffer-function variable to enable/disable popwin-mode"))
+      (setq display-buffer-function (if popwin-mode 'popwin:display-buffer nil)))))
+
+
+
+;;; Keymaps
+
+(defvar popwin:keymap
+  (let ((map (make-sparse-keymap)))
+    (define-key map "b"    'popwin:popup-buffer)
+    (define-key map "l"    'popwin:popup-last-buffer)
+    (define-key map "o"    'popwin:display-buffer)
+    (define-key map "\C-b" 'popwin:switch-to-last-buffer)
+    (define-key map "\C-p" 'popwin:original-pop-to-last-buffer)
+    (define-key map "\C-o" 'popwin:original-display-last-buffer)
+    (define-key map " "    'popwin:select-popup-window)
+    (define-key map "s"    'popwin:stick-popup-window)
+    (define-key map "0"    'popwin:close-popup-window)
+    (define-key map "f"    'popwin:find-file)
+    (define-key map "\C-f" 'popwin:find-file)
+    (define-key map "e"    'popwin:messages)
+    (define-key map "\C-u" 'popwin:universal-display)
+    (define-key map "1"    'popwin:one-window)
+
+    map)
+  "Default keymap for popwin commands.  Use like:
+\(global-set-key (kbd \"C-z\") popwin:keymap\)
+
+Keymap:
+
+| Key    | Command                               |
+|--------+---------------------------------------|
+| b      | popwin:popup-buffer                   |
+| l      | popwin:popup-last-buffer              |
+| o      | popwin:display-buffer                 |
+| C-b    | popwin:switch-to-last-buffer          |
+| C-p    | popwin:original-pop-to-last-buffer    |
+| C-o    | popwin:original-display-last-buffer   |
+| SPC    | popwin:select-popup-window            |
+| s      | popwin:stick-popup-window             |
+| 0      | popwin:close-popup-window             |
+| f, C-f | popwin:find-file                      |
+| e      | popwin:messages                       |
+| C-u    | popwin:universal-display              |
+| 1      | popwin:one-window                     |")
+
+(provide 'popwin)
+;;; popwin.el ends here
diff --git a/lisp/pos-tip.el b/lisp/pos-tip.el
new file mode 100644
index 00000000..190a4018
--- /dev/null
+++ b/lisp/pos-tip.el
@@ -0,0 +1,982 @@
+;;; pos-tip.el --- Show tooltip at point -*- coding: utf-8 -*-
+
+;; Copyright (C) 2010 S. Irie
+
+;; Author: S. Irie
+;; Maintainer: S. Irie
+;; Keywords: Tooltip
+;; Package-Version: 20191227.1356
+;; Package-Commit: 179cc126b363f72ca12fab1e0dc462ce0ee79742
+
+(defconst pos-tip-version "0.4.6")
+
+;; 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 2, or
+;; (at your option) any later version.
+
+;; It 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, write to the Free
+;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+;; MA  02110-1301 USA
+
+;;; Commentary:
+
+;; The standard library tooltip.el provides the function for displaying
+;; a tooltip at mouse position which allows users to easily show it.
+;; However, locating tooltip at arbitrary buffer position in window
+;; is not easy. This program provides such function to be used by other
+;; frontend programs.
+
+;; This program is tested on GNU Emacs 22, 23 under X window system and
+;; Emacs 23 for MS-Windows.
+
+;;
+;; Installation:
+;;
+;; First, save this file as pos-tip.el and byte-compile in
+;; a directory that is listed in load-path.
+;;
+;; Put the following in your .emacs file:
+;;
+;;   (require 'pos-tip)
+;;
+;; To use the full features of this program on MS-Windows,
+;; put the additional setting in .emacs file:
+;;
+;;   (pos-tip-w32-max-width-height)   ; Maximize frame temporarily
+;;
+;; or
+;;
+;;   (pos-tip-w32-max-width-height t) ; Keep frame maximized
+
+;;
+;; Examples:
+;;
+;; We can display a tooltip at the current position by the following:
+;;
+;;   (pos-tip-show "foo bar")
+;;
+;; If you'd like to specify the tooltip color, use an expression as:
+;;
+;;   (pos-tip-show "foo bar" '("white" . "red"))
+;;
+;; Here, "white" and "red" are the foreground color and background
+;; color, respectively.
+
+
+;;; History:
+;; 2013-07-16  P. Kalinowski
+;;         * Adjusted `pos-tip-show' to correctly set tooltip text foreground
+;;           color when using custom color themes.
+;;         * Version 0.4.6
+;;
+;; 2010-09-27  S. Irie
+;;         * Simplified implementation of `pos-tip-window-system'
+;;         * Version 0.4.5
+;;
+;; 2010-08-20  S. Irie
+;;         * Changed to use `window-line-height' to calculate tooltip position
+;;         * Changed `pos-tip-string-width-height' to ignore last empty line
+;;         * Version 0.4.4
+;;
+;; 2010-07-25  S. Irie
+;;         * Bug fix
+;;         * Version 0.4.3
+;;
+;; 2010-06-09  S. Irie
+;;         * Bug fix
+;;         * Version 0.4.2
+;;
+;; 2010-06-04  S. Irie
+;;         * Added support for text-scale-mode
+;;         * Version 0.4.1
+;;
+;; 2010-05-04  S. Irie
+;;         * Added functions:
+;;             `pos-tip-x-display-width', `pos-tip-x-display-height'
+;;             `pos-tip-normalize-natnum', `pos-tip-frame-relative-position'
+;;         * Fixed the supports for multi-displays and multi-frames
+;;         * Version 0.4.0
+;;
+;; 2010-04-29  S. Irie
+;;         * Modified to avoid byte-compile warning
+;;         * Bug fix
+;;         * Version 0.3.6
+;;
+;; 2010-04-29  S. Irie
+;;         * Renamed argument MAX-HEIGHT of `pos-tip-fill-string' to MAX-ROWS
+;;         * Modified old FSF address
+;;         * Version 0.3.5
+;;
+;; 2010-04-29  S. Irie
+;;         * Modified `pos-tip-show' to truncate string exceeding display size
+;;         * Added function `pos-tip-truncate-string'
+;;         * Added optional argument MAX-ROWS to `pos-tip-split-string'
+;;         * Added optional argument MAX-HEIGHT to `pos-tip-fill-string'
+;;         * Version 0.3.4
+;;
+;; 2010-04-16  S. Irie
+;;         * Changed `pos-tip-show' not to fill paragraph unless exceeding WIDTH
+;;         * Version 0.3.3
+;;
+;; 2010-04-08  S. Irie
+;;         * Bug fix
+;;         * Version 0.3.2
+;;
+;; 2010-03-31  S. Irie
+;;         * Bug fix
+;;         * Version 0.3.1
+;;
+;; 2010-03-30  S. Irie
+;;         * Added support for MS-Windows
+;;         * Added option `pos-tip-use-relative-coordinates'
+;;         * Bug fixes
+;;         * Version 0.3.0
+;;
+;; 2010-03-23  S. Irie
+;;         * Changed argument WORD-WRAP to JUSTIFY
+;;         * Added optional argument SQUEEZE
+;;         * Added function `pos-tip-fill-string'
+;;         * Added option `pos-tip-tab-width' used to expand tab characters
+;;         * Bug fixes
+;;         * Version 0.2.0
+;;
+;; 2010-03-22  S. Irie
+;;         * Added optional argument WORD-WRAP to `pos-tip-split-string'
+;;         * Changed `pos-tip-show' to perform word wrap or kinsoku shori
+;;         * Version 0.1.8
+;;
+;; 2010-03-20  S. Irie
+;;         * Added optional argument DY
+;;         * Bug fix
+;;         * Modified docstrings
+;;         * Version 0.1.7
+;;
+;; 2010-03-18  S. Irie
+;;         * Added/modified docstrings
+;;         * Changed working buffer name to " *xwininfo*"
+;;         * Version 0.1.6
+;;
+;; 2010-03-17  S. Irie
+;;         * Fixed typos in docstrings
+;;         * Version 0.1.5
+;;
+;; 2010-03-16  S. Irie
+;;         * Added support for multi-display environment
+;;         * Bug fix
+;;         * Version 0.1.4
+;;
+;; 2010-03-16  S. Irie
+;;         * Bug fix
+;;         * Changed calculation for `x-max-tooltip-size'
+;;         * Modified docstring
+;;         * Version 0.1.3
+;;
+;; 2010-03-11  S. Irie
+;;         * Modified commentary
+;;         * Version 0.1.2
+;;
+;; 2010-03-11  S. Irie
+;;         * Re-implemented `pos-tip-string-width-height'
+;;         * Added indicator variable `pos-tip-upperside-p'
+;;         * Version 0.1.1
+;;
+;; 2010-03-09  S. Irie
+;;         * Re-implemented `pos-tip-show' (*incompatibly changed*)
+;;             - Use frame default font
+;;             - Automatically calculate tooltip pixel size
+;;             - Added optional arguments: TIP-COLOR, MAX-WIDTH
+;;         * Added utility functions:
+;;             `pos-tip-split-string', `pos-tip-string-width-height'
+;;         * Bug fixes
+;;         * Version 0.1.0
+;;
+;; 2010-03-08  S. Irie
+;;         * Added optional argument DX
+;;         * Version 0.0.4
+;;
+;; 2010-03-08  S. Irie
+;;         * Bug fix
+;;         * Version 0.0.3
+;;
+;; 2010-03-08  S. Irie
+;;         * Modified to move out mouse pointer
+;;         * Version 0.0.2
+;;
+;; 2010-03-07  S. Irie
+;;         * First release
+;;         * Version 0.0.1
+
+;; ToDo:
+
+;;; Code:
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Settings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgroup pos-tip nil
+  "Show tooltip at point"
+  :group 'faces
+  :prefix "pos-tip-")
+
+(defcustom pos-tip-border-width 1
+  "Outer border width of pos-tip's tooltip."
+  :type 'integer
+  :group 'pos-tip)
+
+(defcustom pos-tip-internal-border-width 2
+  "Text margin of pos-tip's tooltip."
+  :type 'integer
+  :group 'pos-tip)
+
+(defcustom pos-tip-foreground-color nil
+  "Default foreground color of pos-tip's tooltip.
+When `nil', look up the foreground color of the `tooltip' face."
+  :type '(choice (const :tag "Default" nil)
+                 string)
+  :group 'pos-tip)
+
+(defcustom pos-tip-background-color nil
+  "Default background color of pos-tip's tooltip.
+When `nil', look up the background color of the `tooltip' face."
+  :type '(choice (const :tag "Default" nil)
+                 string)
+  :group 'pos-tip)
+
+(defcustom pos-tip-tab-width nil
+  "Tab width used for `pos-tip-split-string' and `pos-tip-fill-string'
+to expand tab characters. nil means use default value of `tab-width'."
+  :type '(choice (const :tag "Default" nil)
+                 integer)
+  :group 'pos-tip)
+
+(defcustom pos-tip-use-relative-coordinates nil
+  "Non-nil means tooltip location is calculated as a coordinates
+relative to the top left corner of frame. In this case the tooltip
+will always be displayed within the frame.
+
+Note that this variable is automatically set to non-nil if absolute
+coordinates can't be obtained by `pos-tip-compute-pixel-position'."
+  :type 'boolean
+  :group 'pos-tip)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun pos-tip-window-system (&optional frame)
+  "The name of the window system that FRAME is displaying through.
+The value is a symbol---for instance, 'x' for X windows.
+The value is nil if Emacs is using a text-only terminal.
+
+FRAME defaults to the currently selected frame."
+  (let ((type (framep (or frame (selected-frame)))))
+    (if type
+	(and (not (eq type t))
+	     type)
+      (signal 'wrong-type-argument (list 'framep frame)))))
+
+(defun pos-tip-normalize-natnum (object &optional n)
+  "Return a Nth power of 2 if OBJECT is a positive integer.
+Otherwise return 0. Omitting N means return 1 for a positive integer."
+  (ash (if (and (natnump object) (> object 0)) 1 0)
+       (or n 0)))
+
+(defvar pos-tip-saved-frame-coordinates '(0 . 0)
+  "The latest result of `pos-tip-frame-top-left-coordinates'.")
+
+(defvar pos-tip-frame-offset nil
+  "The latest result of `pos-tip-calibrate-frame-offset'. This value
+is used for non-X graphical environment.")
+
+(defvar pos-tip-frame-offset-array [nil nil nil nil]
+  "Array of the results of `pos-tip-calibrate-frame-offset'. They are
+recorded only when `pos-tip-frame-top-left-coordinates' is called for a
+non-X but graphical frame.
+
+The 2nd and 4th elements are the values for frames having a menu bar.
+The 3rd and 4th elements are the values for frames having a tool bar.")
+
+(defun pos-tip-frame-top-left-coordinates (&optional frame)
+  "Return the pixel coordinates of FRAME as a cons cell (LEFT . TOP),
+which are relative to top left corner of screen.
+
+Return nil if failing to acquire the coordinates.
+
+If FRAME is omitted, use selected-frame.
+
+Users can also get the frame coordinates by referring the variable
+`pos-tip-saved-frame-coordinates' just after calling this function."
+  (let ((winsys (pos-tip-window-system frame)))
+    (cond
+     ((null winsys)
+      (error "text-only frame: %S" frame))
+     ((eq winsys 'x)
+      (condition-case nil
+	  (with-current-buffer (get-buffer-create " *xwininfo*")
+	    (let ((case-fold-search nil))
+	      (buffer-disable-undo)
+	      (erase-buffer)
+	      (call-process shell-file-name nil t nil shell-command-switch
+			    (format "xwininfo -display %s -id %s"
+				    (frame-parameter frame 'display)
+				    (frame-parameter frame 'window-id)))
+	      (goto-char (point-min))
+	      (search-forward "\n  Absolute")
+	      (setq pos-tip-saved-frame-coordinates
+		    (cons (string-to-number (buffer-substring-no-properties
+					     (search-forward "X: ")
+					     (line-end-position)))
+			  (string-to-number (buffer-substring-no-properties
+					     (search-forward "Y: ")
+					     (line-end-position)))))))
+	(error nil)))
+     (t
+      (let* ((index (+ (pos-tip-normalize-natnum
+			(frame-parameter frame 'menu-bar-lines) 0)
+		       (pos-tip-normalize-natnum
+			(frame-parameter frame 'tool-bar-lines) 1)))
+	     (offset (or (aref pos-tip-frame-offset-array index)
+			 (aset pos-tip-frame-offset-array index
+			       (pos-tip-calibrate-frame-offset frame)))))
+	(if offset
+	    (setq pos-tip-saved-frame-coordinates
+		  (cons (+ (eval (frame-parameter frame 'left))
+			   (car offset))
+			(+ (eval (frame-parameter frame 'top))
+			   (cdr offset))))))))))
+
+(defun pos-tip-frame-relative-position
+  (frame1 frame2 &optional w32-frame frame-coord1 frame-coord2)
+  "Return the pixel coordinates of FRAME1 relative to FRAME2
+as a cons cell (LEFT . TOP).
+
+W32-FRAME non-nil means both of frames are under `w32' window system.
+
+FRAME-COORD1 and FRAME-COORD2, if given, specify the absolute
+coordinates of FRAME1 and FRAME2, respectively, which make the
+calculations faster if the frames have different heights of menu bars
+and tool bars."
+  (if (and (eq (pos-tip-normalize-natnum
+		(frame-parameter frame1 'menu-bar-lines))
+	       (pos-tip-normalize-natnum
+		(frame-parameter frame2 'menu-bar-lines)))
+	   (or w32-frame
+	       (eq (pos-tip-normalize-natnum
+		    (frame-parameter frame1 'tool-bar-lines))
+		   (pos-tip-normalize-natnum
+		    (frame-parameter frame2 'tool-bar-lines)))))
+      (cons (- (eval (frame-parameter frame1 'left))
+	       (eval (frame-parameter frame2 'left)))
+	    (- (eval (frame-parameter frame1 'top))
+	       (eval (frame-parameter frame2 'top))))
+    (unless frame-coord1
+      (setq frame-coord1 (let (pos-tip-saved-frame-coordinates)
+			   (pos-tip-frame-top-left-coordinates frame1))))
+    (unless frame-coord2
+      (setq frame-coord2 (let (pos-tip-saved-frame-coordinates)
+			   (pos-tip-frame-top-left-coordinates frame2))))
+    (cons (- (car frame-coord1) (car frame-coord2))
+	  (- (cdr frame-coord1) (cdr frame-coord2)))))
+
+(defvar pos-tip-upperside-p nil
+  "Non-nil indicates the latest result of `pos-tip-compute-pixel-position'
+was upper than the location specified by the arguments.")
+
+(defvar pos-tip-w32-saved-max-width-height nil
+  "Display pixel size effective for showing tooltip in MS-Windows desktop.
+This doesn't include the taskbar area, so isn't same as actual display size.")
+
+(defun pos-tip-compute-pixel-position
+  (&optional pos window pixel-width pixel-height frame-coordinates dx dy)
+  "Return pixel position of POS in WINDOW like (X . Y), which indicates
+the absolute or relative coordinates of bottom left corner of the object.
+
+Omitting POS and WINDOW means use current position and selected window,
+respectively.
+
+If PIXEL-WIDTH and PIXEL-HEIGHT are given, this function assumes these
+values as the size of small window like tooltip which is located around the
+object at POS. These values are used to adjust the location in order that
+the tooltip won't disappear by sticking out of the display. By referring
+the variable `pos-tip-upperside-p' after calling this function, user can
+examine whether the tooltip will be located above the specified position.
+
+If FRAME-COORDINATES is omitted or nil, automatically obtain the absolute
+coordinates of the top left corner of frame which WINDOW is on. Here,
+`top left corner of frame' represents the origin of `window-pixel-edges'
+and its coordinates are essential for calculating the return value as
+absolute coordinates. If a cons cell like (LEFT . TOP), specifies the
+frame absolute location and makes the calculation slightly faster, but can
+be used only when it's clear that frame is in the specified position. Users
+can get the latest values of frame coordinates for using in the next call
+by referring the variable `pos-tip-saved-frame-coordinates' just after
+calling this function. Otherwise, FRAME-COORDINATES `relative' means return
+pixel coordinates of the object relative to the top left corner of the frame.
+This is the same effect as `pos-tip-use-relative-coordinates' is non-nil.
+
+DX specifies horizontal offset in pixel.
+
+DY specifies vertical offset in pixel. This makes the calculations done
+without considering the height of object at POS, so the object might be
+hidden by the tooltip."
+  (let* ((frame (window-frame (or window (selected-window))))
+	 (w32-frame (eq (pos-tip-window-system frame) 'w32))
+	 (relative (or pos-tip-use-relative-coordinates
+		       (eq frame-coordinates 'relative)
+		       (and w32-frame
+			    (null pos-tip-w32-saved-max-width-height))))
+	 (frame-coord (or (and relative '(0 . 0))
+			  frame-coordinates
+			  (pos-tip-frame-top-left-coordinates frame)
+			  (progn
+			    (setq relative t
+				  pos-tip-use-relative-coordinates t)
+			  '(0 . 0))))
+	 (posn (posn-at-point (or pos (window-point window)) window))
+	 (line (cdr (posn-actual-col-row posn)))
+	 (line-height (and line
+			   (or (window-line-height line window)
+			       (and (redisplay t)
+				    (window-line-height line window)))))
+	 (x-y (or (posn-x-y posn)
+		  (let ((geom (pos-visible-in-window-p
+			       (or pos (window-point window)) window t)))
+		    (and geom (cons (car geom) (cadr geom))))
+		  '(0 . 0)))
+	 (x (+ (car frame-coord)
+	       (car (window-inside-pixel-edges window))
+	       (car x-y)
+	       (or dx 0)))
+	 (y0 (+ (cdr frame-coord)
+		(cadr (window-pixel-edges window))
+		(or (nth 2 line-height) (cdr x-y))))
+	 (y (+ y0
+	       (or dy
+		   (car line-height)
+		   (with-current-buffer (window-buffer window)
+		     (cond
+		      ;; `posn-object-width-height' returns an incorrect value
+		      ;; when the header line is displayed (Emacs bug #4426).
+		      ((and posn
+			    (null header-line-format))
+		       (cdr (posn-object-width-height posn)))
+		      ((and (bound-and-true-p text-scale-mode)
+			    (not (zerop (with-no-warnings
+					  text-scale-mode-amount))))
+		       (round (* (frame-char-height frame)
+				 (with-no-warnings
+				   (expt text-scale-mode-step
+					 text-scale-mode-amount)))))
+		      (t
+		       (frame-char-height frame)))))))
+	 xmax ymax)
+    (cond
+     (relative
+      (setq xmax (frame-pixel-width frame)
+	    ymax (frame-pixel-height frame)))
+     (w32-frame
+      (setq xmax (car pos-tip-w32-saved-max-width-height)
+	    ymax (cdr pos-tip-w32-saved-max-width-height)))
+     (t
+      (setq xmax (x-display-pixel-width frame)
+	    ymax (x-display-pixel-height frame))))
+    (setq pos-tip-upperside-p (> (+ y (or pixel-height 0))
+				 ymax))
+    (cons (max 0 (min x (- xmax (or pixel-width 0))))
+	  (max 0 (if pos-tip-upperside-p
+		     (- (if dy ymax y0) (or pixel-height 0))
+		   y)))))
+
+(defun pos-tip-cancel-timer ()
+  "Cancel timeout of tooltip."
+  (mapc (lambda (timer)
+	  (if (eq (aref timer 5) 'x-hide-tip)
+	      (cancel-timer timer)))
+	timer-list))
+
+(defun pos-tip-avoid-mouse (left right top bottom &optional frame)
+  "Move out mouse pointer if it is inside region (LEFT RIGHT TOP BOTTOM)
+in FRAME. Return new mouse position like (FRAME . (X . Y))."
+  (unless frame
+    (setq frame (selected-frame)))
+  (let* ((mpos (with-selected-window (frame-selected-window frame)
+		 (mouse-pixel-position)))
+	 (mframe (pop mpos))
+	 (mx (car mpos))
+	 (my (cdr mpos)))
+    (when (and (eq mframe frame)
+	       (numberp mx))
+      (let* ((large-number (+ (frame-pixel-width frame) (frame-pixel-height frame)))
+	     (dl (if (> left 2)
+		     (1+ (- mx left))
+		   large-number))
+	     (dr (if (< (1+ right) (frame-pixel-width frame))
+		     (- right mx)
+		   large-number))
+	     (dt (if (> top 2)
+		     (1+ (- my top))
+		   large-number))
+	     (db (if (< (1+ bottom) (frame-pixel-height frame))
+		     (- bottom my)
+		   large-number))
+	     (d (min dl dr dt db)))
+	(when (> d -2)
+	  (cond
+	   ((= d dl)
+	    (setq mx (- left 2)))
+	   ((= d dr)
+	    (setq mx (1+ right)))
+	   ((= d dt)
+	    (setq my (- top 2)))
+	   (t
+	    (setq my (1+ bottom))))
+	  (set-mouse-pixel-position frame mx my)
+	  (sit-for 0.0001))))
+    (cons mframe (and mpos (cons mx my)))))
+
+(defun pos-tip-compute-foreground-color (tip-color)
+  "Compute the foreground color to use for tooltip.
+
+TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR).
+If it is nil, use `pos-tip-foreground-color' or the foreground color of the
+`tooltip' face."
+  (or (and (facep tip-color)
+           (face-attribute tip-color :foreground))
+      (car-safe tip-color)
+      pos-tip-foreground-color
+      (face-foreground 'tooltip)))
+
+(defun pos-tip-compute-background-color (tip-color)
+  "Compute the background color to use for tooltip.
+
+TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR).
+If it is nil, use `pos-tip-background-color' or the background color of the
+`tooltip' face."
+  (or (and (facep tip-color)
+           (face-attribute tip-color :background))
+      (cdr-safe tip-color)
+      pos-tip-background-color
+      (face-background 'tooltip)))
+
+(defun pos-tip-show-no-propertize
+  (string &optional tip-color pos window timeout pixel-width pixel-height frame-coordinates dx dy)
+  "Show STRING in a tooltip at POS in WINDOW.
+Analogous to `pos-tip-show' except don't propertize STRING by `pos-tip' face.
+
+PIXEL-WIDTH and PIXEL-HEIGHT specify the size of tooltip, if given. These
+are used to adjust the tooltip position in order that it doesn't disappear by
+sticking out of the display, and also used to prevent it from vanishing by
+overlapping with mouse pointer.
+
+Note that this function itself doesn't calculate tooltip size because the
+character width and height specified by faces are unknown. So users should
+calculate PIXEL-WIDTH and PIXEL-HEIGHT by using `pos-tip-tooltip-width' and
+`pos-tip-tooltip-height', or use `pos-tip-show' instead, which can
+automatically calculate tooltip size.
+
+See `pos-tip-show' for details.
+
+Example:
+
+\(defface my-tooltip
+  '((t
+     :background \"gray85\"
+     :foreground \"black\"
+     :inherit variable-pitch))
+  \"Face for my tooltip.\")
+
+\(defface my-tooltip-highlight
+  '((t
+     :background \"blue\"
+     :foreground \"white\"
+     :inherit my-tooltip))
+  \"Face for my tooltip highlighted.\")
+
+\(let ((str (propertize \" foo \\n bar \\n baz \" 'face 'my-tooltip)))
+  (put-text-property 6 11 'face 'my-tooltip-highlight str)
+  (pos-tip-show-no-propertize str 'my-tooltip))"
+  (unless window
+    (setq window (selected-window)))
+  (let* ((frame (window-frame window))
+	 (winsys (pos-tip-window-system frame))
+	 (x-frame (eq winsys 'x))
+	 (w32-frame (eq winsys 'w32))
+	 (relative (or pos-tip-use-relative-coordinates
+		       (eq frame-coordinates 'relative)
+		       (and w32-frame
+			    (null pos-tip-w32-saved-max-width-height))))
+	 (x-y (prog1
+		  (pos-tip-compute-pixel-position pos window
+						  pixel-width pixel-height
+						  frame-coordinates dx dy)
+		(if pos-tip-use-relative-coordinates
+		    (setq relative t))))
+	 (ax (car x-y))
+	 (ay (cdr x-y))
+	 (rx (if relative ax (- ax (car pos-tip-saved-frame-coordinates))))
+	 (ry (if relative ay (- ay (cdr pos-tip-saved-frame-coordinates))))
+	 (retval (cons rx ry))
+	 (fg (pos-tip-compute-foreground-color tip-color))
+	 (bg (pos-tip-compute-background-color tip-color))
+	 (use-dxdy (or relative
+		       (not x-frame)))
+	 (spacing (frame-parameter frame 'line-spacing))
+	 (border (ash (+ pos-tip-border-width
+			 pos-tip-internal-border-width)
+		      1))
+	 (x-max-tooltip-size
+	  (cons (+ (if x-frame 1 0)
+		   (/ (- (or pixel-width
+			     (cond
+			      (relative
+			       (frame-pixel-width frame))
+			      (w32-frame
+			       (car pos-tip-w32-saved-max-width-height))
+			      (t
+			       (x-display-pixel-width frame))))
+			 border)
+		      (frame-char-width frame)))
+		(/ (- (or pixel-height
+			  (x-display-pixel-height frame))
+		      border)
+		   (frame-char-height frame))))
+	 (x-gtk-use-system-tooltips nil) ; Don't use Gtk+ tooltip in Emacs 24
+	 (mpos (with-selected-window window (mouse-pixel-position)))
+	 (mframe (car mpos))
+	 default-frame-alist)
+    (if (or relative
+	    (and use-dxdy
+		 (null (cadr mpos))))
+	(unless (and (cadr mpos)
+		     (eq mframe frame))
+	  (let* ((edges (window-inside-pixel-edges (cadr (window-list frame))))
+		 (mx (ash (+ (pop edges) (cadr edges)) -1))
+		 (my (ash (+ (pop edges) (cadr edges)) -1)))
+	    (setq mframe frame)
+	    (set-mouse-pixel-position mframe mx my)
+	    (sit-for 0.0001)))
+      (when (and (cadr mpos)
+		 (not (eq mframe frame)))
+	(let ((rel-coord (pos-tip-frame-relative-position frame mframe w32-frame
+							  frame-coordinates)))
+	  (setq rx (+ rx (car rel-coord))
+		ry (+ ry (cdr rel-coord))))))
+    (and pixel-width pixel-height
+	 (setq mpos (pos-tip-avoid-mouse rx (+ rx pixel-width
+					       (if w32-frame 3 0))
+					 ry (+ ry pixel-height)
+					 mframe)))
+    (x-show-tip string mframe
+		`((border-width . ,pos-tip-border-width)
+		  (internal-border-width . ,pos-tip-internal-border-width)
+		  ,@(and (not use-dxdy) `((left . ,ax)
+					  (top . ,ay)))
+		  (font . ,(frame-parameter frame 'font))
+		  ,@(and spacing `((line-spacing . ,spacing)))
+		  ,@(and (stringp fg) `((foreground-color . ,fg)))
+		  ,@(and (stringp bg) `((background-color . ,bg))))
+		(and timeout (> timeout 0) timeout)
+		(and use-dxdy (- rx (cadr mpos)))
+		(and use-dxdy (- ry (cddr mpos))))
+    (if (and timeout (<= timeout 0))
+	(pos-tip-cancel-timer))
+    retval))
+
+(defun pos-tip-split-string (string &optional width margin justify squeeze max-rows)
+  "Split STRING into fixed width strings. Return a list of these strings.
+
+WIDTH specifies the width of filling each paragraph. WIDTH nil means use
+the width of currently selected frame. Note that this function doesn't add any
+padding characters at the end of each row.
+
+MARGIN, if non-nil, specifies left margin width which is the number of spece
+characters to add at the beginning of each row.
+
+The optional fourth argument JUSTIFY specifies which kind of justification
+to do: `full', `left', `right', `center', or `none'. A value of t means handle
+each paragraph as specified by its text properties. Omitting JUSTIFY means
+don't perform justification, word wrap and kinsoku shori (禁則処理).
+
+SQUEEZE nil means leave whitespaces other than line breaks untouched.
+
+MAX-ROWS, if given, specifies maximum number of elements of return value.
+The elements exceeding this number are discarded."
+  (with-temp-buffer
+    (let* ((tab-width (or pos-tip-tab-width tab-width))
+	   (fill-column (or width (frame-width)))
+	   (left-margin (or margin 0))
+	   (kinsoku-limit 1)
+	   indent-tabs-mode
+	   row rows)
+      (insert string)
+      (untabify (point-min) (point-max))
+      (if justify
+	  (fill-region (point-min) (point-max) justify (not squeeze))
+	(setq margin (make-string left-margin ?\s)))
+      (goto-char (point-min))
+      (while (prog2
+		 (let ((line (buffer-substring
+			      (point) (progn (end-of-line) (point)))))
+		   (if justify
+		       (push line rows)
+		     (while (progn
+			      (setq line (concat margin line)
+				    row (truncate-string-to-width line fill-column))
+			      (push row rows)
+			      (if (not (= (length row) (length line)))
+				  (setq line (substring line (length row))))))))
+		 (< (point) (point-max))
+	       (beginning-of-line 2)))
+      (nreverse (if max-rows
+		    (last rows max-rows)
+		  rows)))))
+
+(defun pos-tip-fill-string (string &optional width margin justify squeeze max-rows)
+  "Fill each of the paragraphs in STRING.
+
+WIDTH specifies the width of filling each paragraph. WIDTH nil means use
+the width of currently selected frame. Note that this function doesn't add any
+padding characters at the end of each row.
+
+MARGIN, if non-nil, specifies left margin width which is the number of spece
+characters to add at the beginning of each row.
+
+The optional fourth argument JUSTIFY specifies which kind of justification
+to do: `full', `left', `right', `center', or `none'. A value of t means handle
+each paragraph as specified by its text properties. Omitting JUSTIFY means
+don't perform justification, word wrap and kinsoku shori (禁則処理).
+
+SQUEEZE nil means leave whitespaces other than line breaks untouched.
+
+MAX-ROWS, if given, specifies maximum number of rows. The rows exceeding
+this number are discarded."
+  (if justify
+      (with-temp-buffer
+	(let* ((tab-width (or pos-tip-tab-width tab-width))
+	       (fill-column (or width (frame-width)))
+	       (left-margin (or margin 0))
+	       (kinsoku-limit 1)
+	       indent-tabs-mode)
+	  (insert string)
+	  (untabify (point-min) (point-max))
+	  (fill-region (point-min) (point-max) justify (not squeeze))
+	  (if max-rows
+	      (buffer-substring (goto-char (point-min))
+				(line-end-position max-rows))
+	    (buffer-string))))
+    (mapconcat 'identity
+	       (pos-tip-split-string string width margin nil nil max-rows)
+	       "\n")))
+
+(defun pos-tip-truncate-string (string width height)
+  "Truncate each line of STRING to WIDTH and discard lines exceeding HEIGHT."
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (let ((nrow 0)
+	  rows)
+      (while (and (< nrow height)
+		  (prog2
+		      (push (truncate-string-to-width
+			     (buffer-substring (point) (progn (end-of-line) (point)))
+			     width)
+			    rows)
+		      (< (point) (point-max))
+		    (beginning-of-line 2)
+		    (setq nrow (1+ nrow)))))
+      (mapconcat 'identity (nreverse rows) "\n"))))
+
+(defun pos-tip-string-width-height (string)
+  "Count columns and rows of STRING. Return a cons cell like (WIDTH . HEIGHT).
+The last empty line of STRING is ignored.
+
+Example:
+
+\(pos-tip-string-width-height \"abc\\nあいう\\n123\")
+;; => (6 . 3)"
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (end-of-line)
+    (let ((width (current-column))
+	  (height (if (eq (char-before (point-max)) ?\n) 0 1)))
+      (while (< (point) (point-max))
+	(end-of-line 2)
+	(setq width (max (current-column) width)
+	      height (1+ height)))
+      (cons width height))))
+
+(defun pos-tip-x-display-width (&optional frame)
+  "Return maximum column number in tooltip which occupies the full width
+of display. Omitting FRAME means use display that selected frame is in."
+  (1+ (/ (x-display-pixel-width frame) (frame-char-width frame))))
+
+(defun pos-tip-x-display-height (&optional frame)
+  "Return maximum row number in tooltip which occupies the full height
+of display. Omitting FRAME means use display that selected frame is in."
+  (1+ (/ (x-display-pixel-height frame) (frame-char-height frame))))
+
+(defun pos-tip-tooltip-width (width char-width)
+  "Calculate tooltip pixel width."
+  (+ (* width char-width)
+     (ash (+ pos-tip-border-width
+	     pos-tip-internal-border-width)
+	  1)))
+
+(defun pos-tip-tooltip-height (height char-height &optional frame)
+  "Calculate tooltip pixel height."
+  (let ((spacing (or (default-value 'line-spacing)
+		     (frame-parameter frame 'line-spacing))))
+    (+ (* height (+ char-height
+		    (cond
+		     ((integerp spacing)
+		      spacing)
+		     ((floatp spacing)
+		      (truncate (* (frame-char-height frame)
+				   spacing)))
+		     (t 0))))
+       (ash (+ pos-tip-border-width
+	       pos-tip-internal-border-width)
+	    1))))
+
+(defun pos-tip-show
+  (string &optional tip-color pos window timeout width frame-coordinates dx dy)
+  "Show STRING in a tooltip, which is a small X window, at POS in WINDOW
+using frame's default font with TIP-COLOR.
+
+Return pixel position of tooltip relative to top left corner of frame as
+a cons cell like (X . Y).
+
+TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR)
+used to specify *only* foreground-color and background-color of tooltip. If
+omitted, use `pos-tip-foreground-color' and `pos-tip-background-color' or the
+foreground and background color of the `tooltip' face instead.
+
+Omitting POS and WINDOW means use current position and selected window,
+respectively.
+
+Automatically hide the tooltip after TIMEOUT seconds. Omitting TIMEOUT means
+use the default timeout of 5 seconds. Non-positive TIMEOUT means don't hide
+tooltip automatically.
+
+WIDTH, if non-nil, specifies the width of filling each paragraph.
+
+If FRAME-COORDINATES is omitted or nil, automatically obtain the absolute
+coordinates of the top left corner of frame which WINDOW is on. Here,
+`top left corner of frame' represents the origin of `window-pixel-edges'
+and its coordinates are essential for calculating the absolute coordinates
+of the tooltip. If a cons cell like (LEFT . TOP), specifies the frame
+absolute location and makes the calculation slightly faster, but can be
+used only when it's clear that frame is in the specified position. Users
+can get the latest values of frame coordinates for using in the next call
+by referring the variable `pos-tip-saved-frame-coordinates' just after
+calling this function. Otherwise, FRAME-COORDINATES `relative' means use
+the pixel coordinates relative to the top left corner of the frame for
+displaying the tooltip. This is the same effect as
+`pos-tip-use-relative-coordinates' is non-nil.
+
+DX specifies horizontal offset in pixel.
+
+DY specifies vertical offset in pixel. This makes the calculations done
+without considering the height of object at POS, so the object might be
+hidden by the tooltip.
+
+See also `pos-tip-show-no-propertize'."
+  (unless window
+    (setq window (selected-window)))
+  (let* ((frame (window-frame window))
+	 (max-width (pos-tip-x-display-width frame))
+	 (max-height (pos-tip-x-display-height frame))
+	 (w-h (pos-tip-string-width-height string))
+         (fg (pos-tip-compute-foreground-color tip-color))
+         (bg (pos-tip-compute-background-color tip-color))
+         (frame-font (find-font (font-spec :name (frame-parameter frame 'font))))
+         (tip-face-attrs (list :font frame-font :foreground fg :background bg)))
+    (cond
+     ((and width
+	   (> (car w-h) width))
+      (setq string (pos-tip-fill-string string width nil 'none nil max-height)
+	    w-h (pos-tip-string-width-height string)))
+     ((or (> (car w-h) max-width)
+	  (> (cdr w-h) max-height))
+      (setq string (pos-tip-truncate-string string max-width max-height)
+	    w-h (pos-tip-string-width-height string))))
+    (pos-tip-show-no-propertize
+     (propertize string 'face tip-face-attrs)
+     tip-color pos window timeout
+     (pos-tip-tooltip-width (car w-h) (frame-char-width frame))
+     (pos-tip-tooltip-height (cdr w-h) (frame-char-height frame) frame)
+     frame-coordinates dx dy)))
+
+(defalias 'pos-tip-hide 'x-hide-tip
+  "Hide pos-tip's tooltip.")
+
+(defun pos-tip-calibrate-frame-offset (&optional frame)
+  "Return coordinates of FRAME origin relative to the top left corner of
+the FRAME extent, like (LEFT . TOP). The return value is recorded to
+`pos-tip-frame-offset'.
+
+Note that this function doesn't correctly work for X frame and Emacs 22."
+  (setq pos-tip-frame-offset nil)
+  (let* ((window (frame-first-window frame))
+	 (delete-frame-functions
+	  '((lambda (frame)
+	      (if (equal (frame-parameter frame 'name) "tooltip")
+		  (setq pos-tip-frame-offset
+			(cons (eval (frame-parameter frame 'left))
+			      (eval (frame-parameter frame 'top))))))))
+	 (pos-tip-border-width 0)
+	 (pos-tip-internal-border-width 1)
+	 (rpos (pos-tip-show ""
+			     `(nil . ,(frame-parameter frame 'background-color))
+			     (window-start window) window
+			     nil nil 'relative nil 0)))
+    (sit-for 0)
+    (pos-tip-hide)
+    (and pos-tip-frame-offset
+	 (setq pos-tip-frame-offset
+	       (cons (- (car pos-tip-frame-offset)
+			(car rpos)
+			(eval (frame-parameter frame 'left)))
+		     (- (cdr pos-tip-frame-offset)
+			(cdr rpos)
+			(eval (frame-parameter frame 'top))))))))
+
+(defun pos-tip-w32-max-width-height (&optional keep-maximize)
+  "Maximize the currently selected frame temporarily and set
+`pos-tip-w32-saved-max-width-height' the effective display size in order
+to become possible to calculate the absolute location of tooltip.
+
+KEEP-MAXIMIZE non-nil means leave the frame maximized.
+
+Note that this function is usable only in Emacs 23 for MS-Windows."
+  (interactive)
+  (unless (eq window-system 'w32)
+    (error "`pos-tip-w32-max-width-height' can be used only in w32 frame."))
+  ;; Maximize frame
+  (with-no-warnings (w32-send-sys-command 61488))
+  (sit-for 0)
+  (let ((offset (pos-tip-calibrate-frame-offset)))
+    (prog1
+	(setq pos-tip-w32-saved-max-width-height
+	      (cons (frame-pixel-width)
+		    (+ (frame-pixel-height)
+		       (- (cdr offset) (car offset)))))
+      (if (called-interactively-p 'interactive)
+	  (message "%S" pos-tip-w32-saved-max-width-height))
+      (unless keep-maximize
+	;; Restore frame
+	(with-no-warnings (w32-send-sys-command 61728))))))
+
+
+(provide 'pos-tip)
+
+;;;
+;;; pos-tip.el ends here
diff --git a/lisp/powershell.el b/lisp/powershell.el
new file mode 100644
index 00000000..91ce5454
--- /dev/null
+++ b/lisp/powershell.el
@@ -0,0 +1,1386 @@
+;;; powershell.el --- Mode for editing PowerShell scripts  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2009, 2010 Frédéric Perrin
+;; Copyright (C) 2012 Richard Bielawski rbielaws-at-i1-dot-net
+;;               http://www.emacswiki.org/emacs/Rick_Bielawski
+
+;; Author: Frédéric Perrin 
+;; URL: http://github.com/jschaf/powershell.el
+;; Package-Version: 20190421.2038
+;; Version: 0.3
+;; Package-Requires: ((emacs "24"))
+;; Keywords: powershell, languages
+
+;; 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 of the License,
+;; or (at your option) any later version.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see .
+
+;;; Installation:
+
+;; Place powershell.el on your `load-path' by adding the following
+;; code to your `user-init-file', which is usually ~/.emacs.d/init.el
+;; or ~/.emacs.
+;;
+;; (add-to-list 'load-path "~/path/to/powershell")
+;;
+
+;;; Commentary:
+
+;; powershell.el is a combination of powershell.el by Dino Chiesa
+;;  and powershell-mode.el by Frédéric Perrin
+;; and Richard Bielawski.  Joe Schafer combined the work into a single
+;; file.
+
+;;; Frédéric Perrin Comments:
+;;
+;; The original powershell-mode.el was written from scratch, without
+;; using Vivek Sharma's code: it had issues I wanted to correct, but
+;; unfortunately there were no licence indication, and Vivek didn't
+;; answered my mails.
+;;
+;;; Rick Bielawski Comments 2012/09/28:
+;;
+;; On March 31, 2012 Frédéric gave me permission to take over support
+;; for powershell-mode.el.  I've added support for multi-line comments
+;; and here-strings as well as enhancement/features such as: Functions
+;; to quote, unquote and escape a selection, and one to wrap a
+;; selection in $().  Meanwhile I hope I didn't break anything.
+;;
+;; Joe Schafer Comments 2013-06-06:
+;;
+;; I combined powershell.el and powershell-mode.el.  Since
+;; powershell.el was licensed with the new BSD license I combined the
+;; two files using the more restrictive license, the GPL.  I also
+;; cleaned up the documentation and reorganized some of the code.
+
+;;; Updates:
+
+;; 2012/10/01 Fixed several bugs in highlighting variables and types.
+;;            Renamed some variables to be more descriptive.
+;; 2012/10/02 Enhanced PowerShell-mode indenting & syntax table.
+;;            Fixed dangling parens and re-indented the elisp itself.
+;; 2012/10/05 Added eldoc support.  Fixed bug where indent could loop.
+;;            See comment below on how to generate powershell-eldoc.el
+;; 2013/06/06 Merged powershell.el and powershell-mode.el
+
+;;; Code:
+
+(eval-when-compile (require 'thingatpt))
+(require 'shell)
+(require 'compile)
+
+;;;###autoload
+(add-to-list 'auto-mode-alist '("\\.ps[dm]?1\\'" . powershell-mode))
+
+
+;; User Variables
+
+(defgroup powershell nil
+  "Customization of PowerShell mode."
+  :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
+  :group 'languages)
+
+(defcustom powershell-indent 4
+  "Amount of horizontal space to indent.
+After, for instance, an opening brace"
+  :type 'integer
+  :group 'powershell)
+
+(defcustom powershell-continuation-indent 2
+  "Amount of horizontal space to indent a continuation line."
+  :type 'integer
+  :group 'powershell)
+
+(defcustom powershell-continued-regexp  ".*\\(|[\\t ]*\\|`\\)$"
+  "Regexp matching a continued line.
+Ending either with an explicit backtick, or with a pipe."
+  :type 'integer
+  :group 'powershell)
+
+;; Note: There are no explicit references to the variable
+;; `explicit-powershell.exe-args'.  It is used implicitly by M-x shell
+;; when the shell is `powershell.exe'.  See
+;; http://blogs.msdn.com/b/dotnetinterop/archive/2008/04/10/run-powershell-as-a-shell-within-emacs.aspx
+;; for details.
+(defcustom explicit-powershell.exe-args '("-Command" "-" )
+  "Args passed to inferior shell by \\[shell], if the shell is powershell.exe.
+Value is a list of strings, which may be nil."
+  :type '(repeat (string :tag "Argument"))
+  :group 'powershell)
+
+(defun powershell-continuation-line-p ()
+  "Return t is the current line is a continuation line.
+The current line is a continued line when the previous line ends
+with a backtick or a pipe"
+  (interactive)
+  (save-excursion
+    (forward-line -1)
+    (looking-at powershell-continued-regexp)))
+
+;; Rick added significant complexity to Frédéric's original version
+(defun powershell-indent-line-amount ()
+  "Return the column to which the current line ought to be indented."
+  (interactive)
+  (save-excursion
+    (beginning-of-line)
+    (if (powershell-continuation-line-p)
+        ;; on a continuation line (i.e. prior line ends with backtick
+        ;; or pipe), indent relative to the continued line.
+        (progn
+          (while (and (not (bobp))(powershell-continuation-line-p))
+            (forward-line -1))
+          (+ (current-indentation) powershell-continuation-indent))
+      ;; otherwise, indent relative to the block's opening char ([{
+      ;; \\s- includes newline, which make the line right before closing paren not indented
+      (let ((closing-paren (looking-at "[ \t]*\\s)"))
+            new-indent
+            block-open-line)
+        (condition-case nil
+            (progn
+              (backward-up-list)   ;when at top level, throw to no-indent
+              (setq block-open-line (line-number-at-pos))
+              ;; We're in a block, calculate/return indent amount.
+              (if (not (looking-at "\\s(\\s-*\\(#.*\\)?$"))
+                  ;; code (not comments) follow the block open so
+                  ;; vertically align the block with the code.
+                  (if closing-paren
+                      ;; closing indent = open
+                      (setq new-indent (current-column))
+                    ;; block indent = first line of code
+                    (forward-char)
+                    (skip-syntax-forward " ")
+                    (setq new-indent (current-column)))
+                ;; otherwise block open is at eol so indent is relative to
+                ;; bol or another block open on the same line.
+                (if closing-paren       ; this sets the default indent
+                    (setq new-indent (current-indentation))
+                  (setq new-indent (+ powershell-indent (current-indentation))))
+                ;; now see if the block is nested on the same line
+                (when (condition-case nil
+                          (progn
+                            (backward-up-list)
+                            (= block-open-line (line-number-at-pos)))
+                        (scan-error nil))
+                  (forward-char)
+                  (skip-syntax-forward " ")
+                  (if closing-paren
+                      (setq new-indent (current-column))
+                    (setq new-indent (+ powershell-indent (current-column))))))
+              new-indent)
+          (scan-error ;; most likely, we are at the top-level
+           0))))))
+
+(defun powershell-indent-line ()
+  "Indent the current line of powershell mode.
+Leave the point in place if it is inside the meat of the line"
+  (interactive)
+  (let ((savep (> (current-column) (current-indentation)))
+        (amount (powershell-indent-line-amount)))
+    (if savep
+        (save-excursion (indent-line-to amount))
+      (indent-line-to amount))))
+
+(defun powershell-quote-selection (beg end)
+  "Quotes the selection between BEG and END.
+Quotes with single quotes and doubles embedded single quotes."
+  (interactive `(,(region-beginning) ,(region-end)))
+  (if (not mark-active)
+      (error "Command requires a marked region"))
+  (goto-char beg)
+  (while (re-search-forward "'" end t)
+    (replace-match "''")(setq end (1+ end)))
+  (goto-char beg)
+  (insert "'")
+  (setq end (1+ end))
+  (goto-char end)
+  (insert "'"))
+
+(defun powershell-unquote-selection (beg end)
+  "Unquotes the selected text between BEG and END.
+Remove doubled single quotes as we go."
+  (interactive `(,(region-beginning) ,(region-end)))
+  (if (not mark-active)
+      (error "Command requires a marked region"))
+  (goto-char beg)
+  (cond ((looking-at "'")
+         (goto-char end)
+         (when (looking-back "'" nil)
+           (delete-char -1)
+           (setq end (1- end))
+           (goto-char beg)
+           (delete-char 1)
+           (setq end (1- end))
+           (while (search-forward "'" end t)
+             (delete-char -1)
+             (forward-char)
+             (setq end (1- end)))))
+        ((looking-at "\"")
+         (goto-char end)
+         (when (looking-back "\"" nil)
+           (delete-char -1)
+           (setq end (1- end))
+           (goto-char beg)
+           (delete-char 1)
+           (setq end (1- end))
+           (while (search-forward "\"" end t)
+             (delete-char -1)
+             (forward-char)
+             (setq end (1- end)))
+           (while (search-forward "`" end t)
+             (delete-char -1)
+             (forward-char)
+             (setq end (1- end)))))
+        (t (error "Must select quoted text exactly"))))
+
+(defun powershell-escape-selection (beg end)
+  "Escape variables between BEG and END.
+Also extend existing escapes."
+  (interactive `(,(region-beginning) ,(region-end)))
+  (if (not mark-active)
+      (error "Command requires a marked region"))
+  (goto-char beg)
+  (while (re-search-forward "`" end t)
+    (replace-match "```")(setq end (+ end 2)))
+  (goto-char beg)
+  (while (re-search-forward "\\(?:\\=\\|[^`]\\)[$]" end t)
+    (goto-char (car (cdr (match-data))))
+    (backward-char)
+    (insert "`")
+    (forward-char)
+    (setq end (1+ end))))
+
+(defun powershell-doublequote-selection (beg end)
+  "Quotes the text between BEG and END with double quotes.
+Embedded quotes are doubled."
+  (interactive `(,(region-beginning) ,(region-end)))
+  (if (not mark-active)
+      (error "Command requires a marked region"))
+  (goto-char beg)
+  (while (re-search-forward "\"" end t)
+    (replace-match "\"\"")(setq end (1+ end)))
+  (goto-char beg)
+  (while (re-search-forward "`'" end t)
+    (replace-match "```")(setq end (+ 2 end)))
+  (goto-char beg)
+  (insert "\"")
+  (setq end (1+ end))
+  (goto-char end)
+  (insert "\""))
+
+(defun powershell-dollarparen-selection (beg end)
+  "Wraps the text between BEG and END with $().
+The point is moved to the closing paren."
+  (interactive `(,(region-beginning) ,(region-end)))
+  (if (not mark-active)
+      (error "Command requires a marked region"))
+  (save-excursion
+    (goto-char end)
+    (insert ")")
+    (goto-char beg)
+    (insert "$("))
+  (forward-char))
+
+(defun powershell-regexp-to-regex (beg end)
+  "Turn the text between BEG and END into a regex.
+The text is assumed to be `regexp-opt' output."
+  (interactive `(,(region-beginning) ,(region-end)))
+  (if (not mark-active)
+      (error "Command requires a marked region"))
+  (save-restriction
+    (narrow-to-region beg end)
+    (goto-char (point-min))
+    (while (re-search-forward "\\\\(" nil t)
+      (replace-match "("))
+    (goto-char (point-min))
+    (while (re-search-forward "\\\\)" nil t)
+      (replace-match ")"))
+    (goto-char (point-min))
+    (while (re-search-forward "\\\\|" nil t)
+      (replace-match "|"))))
+
+
+;; Taken from About_Keywords
+(defvar powershell-keywords
+  (concat "\\_<"
+          (regexp-opt
+           '("begin" "break" "catch" "class" "continue" "data" "define" "do" "default"
+             "dynamicparam" "else" "elseif" "end" "enum" "exit" "filter" "finally"
+             "for" "foreach" "from" "function" "hidden" "if" "in" "param" "process"
+             "return" "static" "switch" "throw" "trap" "try" "until" "using" "var" "where" "while"
+             ;; Questionable, specific to workflow sessions
+             "inlinescript")
+           t)
+          "\\_>")
+  "PowerShell keywords.")
+
+;; Taken from About_Comparison_Operators and some questionable sources :-)
+(defvar powershell-operators
+  (concat "\\_<"
+          (regexp-opt
+           '("-eq" "-ne" "-gt" "-ge" "-lt" "-le"
+             ;; case sensitive versions
+             "-ceq" "-cne" "-cgt" "-cge" "-clt" "-cle"
+             ;; explicitly case insensitive
+             "-ieq" "-ine" "-igt" "-ige" "-ilt" "-ile"
+             "-band" "-bor" "-bxor" "-bnot"
+             "-and" "-or" "-xor" "-not" "!"
+             "-like" "-notlike" "-clike" "-cnotlike" "-ilike" "-inotlike"
+             "-match" "-notmatch" "-cmatch" "-cnotmatch" "-imatch" "-inotmatch"
+             "-contains" "-notcontains" "-ccontains" "-cnotcontains"
+             "-icontains" "-inotcontains"
+             "-replace" "-creplace" "-ireplace"
+             "-is" "-isnot" "-as" "-f"
+             "-in" "-cin" "-iin" "-notin" "-cnotin" "-inotin"
+             "-split" "-csplit" "-isplit"
+             "-join"
+             "-shl" "-shr"
+             ;; Questionable --> specific to certain contexts
+             "-casesensitive" "-wildcard" "-regex" "-exact" ;specific to case
+             "-begin" "-process" "-end" ;specific to scriptblock
+             ) t)
+          "\\_>")
+  "PowerShell operators.")
+
+(defvar powershell-scope-names
+  '("global"   "local"    "private"  "script"   )
+  "Names of scopes in PowerShell mode.")
+
+(defvar powershell-variable-drive-names
+  (append '("env" "function" "variable" "alias" "hklm" "hkcu" "wsman") powershell-scope-names)
+  "Names of scopes in PowerShell mode.")
+
+(defconst powershell-variables-regexp
+  ;; There are 2 syntaxes detected: ${[scope:]name} and $[scope:]name
+  ;; Match 0 is the entire variable name.
+  ;; Match 1 is scope when the former syntax is found.
+  ;; Match 2 is scope when the latter syntax is found.
+  (concat
+   "\\_<$\\(?:{\\(?:" (regexp-opt powershell-variable-drive-names t)
+   ":\\)?[^}]+}\\|"
+   "\\(?:" (regexp-opt powershell-variable-drive-names t)
+   ":\\)?[a-zA-Z0-9_]+\\_>\\)")
+  "Identifies legal powershell variable names.")
+
+(defconst powershell-function-names-regex
+  ;; Syntax detected is [scope:]verb-noun
+  ;; Match 0 is the entire name.
+  ;; Match 1 is the scope if any.
+  ;; Match 2 is the function name (which must exist)
+  (concat
+   "\\_<\\(?:" (regexp-opt powershell-scope-names t) ":\\)?"
+   "\\([A-Z][a-zA-Z0-9]*-[A-Z0-9][a-zA-Z0-9]*\\)\\_>")
+  "Identifies legal function & filter names.")
+
+(defconst powershell-object-types-regexp
+  ;; Syntax is \[name[.name]\] (where the escaped []s are literal)
+  ;; Only Match 0 is returned.
+  "\\[\\(?:[a-zA-Z_][a-zA-Z0-9]*\\)\\(?:\\.[a-zA-Z_][a-zA-Z0-9]*\\)*\\]"
+  "Identifies object type references.  I.E. [object.data.type] syntax.")
+
+(defconst powershell-function-switch-names-regexp
+  ;; Only Match 0 is returned.
+  "\\_<-[a-zA-Z][a-zA-Z0-9]*\\_>"
+  "Identifies function parameter names of the form -xxxx.")
+
+;; Taken from Get-Variable on a fresh shell, merged with man
+;; about_automatic_variables
+(defvar powershell-builtin-variables-regexp
+  (regexp-opt
+   '("$"                              "?"
+     "^"                              "_"
+     "args"                           "ConsoleFileName"
+     "Error"                          "Event"
+     "EventArgs"
+     "EventSubscriber"                "ExecutionContext"
+     "false"                          "Foreach"
+     "HOME"                           "Host"
+     "input"                          "lsCoreCLR"
+     "lsLinux"                        "lsMacOS"
+     "lsWindows"                      "LASTEXITCODE"
+     "Matches"                        "MyInvocation"
+     "NestedPromptLevel"              "null"
+     "PID"                            "PROFILE"
+     "PSBoundParameters"              "PSCmdlet"
+     "PSCommandPath"
+     "PSCulture"                      "PSDebugContext"
+     "PSHOME"                         "PSITEM"
+     "PSScriptRoot"                   "PSSenderInfo"
+     "PSUICulture"                    "PSVersionTable"
+     "PWD"                            "ReportErrorShowExceptionClass"
+     "ReportErrorShowInnerException"  "ReportErrorShowSource"
+     "ReportErrorShowStackTrace"      "Sender"
+     "ShellId"                        "SourceArgs"
+     "SourceEventArgs"                "StackTrace"
+     "this"                           "true"                           ) t)
+  "The names of the built-in PowerShell variables.
+They are highlighted differently from the other variables.")
+
+(defvar powershell-config-variables-regexp
+  (regexp-opt
+   '("ConfirmPreference"           "DebugPreference"
+     "ErrorActionPreference"       "ErrorView"
+     "FormatEnumerationLimit"      "InformationPreference"
+     "LogCommandHealthEvent"
+     "LogCommandLifecycleEvent"    "LogEngineHealthEvent"
+     "LogEngineLifecycleEvent"     "LogProviderHealthEvent"
+     "LogProviderLifecycleEvent"   "MaximumAliasCount"
+     "MaximumDriveCount"           "MaximumErrorCount"
+     "MaximumFunctionCount"        "MaximumHistoryCount"
+     "MaximumVariableCount"        "OFS"
+     "OutputEncoding"              "ProgressPreference"
+     "PSDefaultParameterValues"    "PSEmailServer"
+     "PSModuleAutoLoadingPreference" "PSSessionApplicationName"
+     "PSSessionConfigurationName"  "PSSessionOption"
+     "VerbosePreference"           "WarningPreference"
+     "WhatIfPreference"            ) t)
+  "Names of variables that configure powershell features.")
+
+
+(defun powershell-find-syntactic-comments (limit)
+  "Find PowerShell comment begin and comment end characters.
+Returns match 1 and match 2 for <# #> comment sequences respectively.
+Returns match 3 and optionally match 4 for #/eol comments.
+Match 4 is returned only if eol is found before LIMIT"
+  (when (search-forward "#" limit t)
+    (cond
+     ((looking-back "<#" nil)
+      (set-match-data (list (match-beginning 0) (1+ (match-beginning 0))
+                            (match-beginning 0) (1+ (match-beginning 0)))))
+     ((looking-at ">")
+      (set-match-data (list (match-beginning 0) (match-end 0)
+                            nil nil
+                            (match-beginning 0) (match-end 0)))
+      (forward-char))
+     (t
+      (let ((start (point)))
+        (if (search-forward "\n" limit t)
+            (set-match-data (list (1- start) (match-end 0)
+                                  nil nil nil nil
+                                  (1- start) start
+                                  (match-beginning 0) (match-end 0)))
+          (set-match-data (list start (match-end 0)
+                                nil nil nil nil
+                                (1- start) start))))))
+    t))
+
+(defun powershell-find-syntactic-quotes (limit)
+  "Find PowerShell hear string begin and end sequences upto LIMIT.
+Returns match 1 and match 2 for @' '@ sequences respectively.
+Returns match 3 and match 4 for @\" \"@ sequences respectively."
+  (when (search-forward "@" limit t)
+    (cond
+     ((looking-at "'$")
+      (set-match-data (list (match-beginning 0) (1+ (match-beginning 0))
+                            (match-beginning 0) (1+ (match-beginning 0))))
+      (forward-char))
+     ((looking-back "^'@" nil)
+      (set-match-data (list (1- (match-end 0)) (match-end 0)
+                            nil nil
+                            (1- (match-end 0)) (match-end 0))))
+     ((looking-at "\"$")
+      (set-match-data (list (match-beginning 0) (1+ (match-beginning 0))
+                            nil nil
+                            nil nil
+                            (match-beginning 0) (1+ (match-beginning 0))))
+      (forward-char))
+     ((looking-back "^\"@" nil)
+      (set-match-data (list (1- (match-end 0)) (match-end 0)
+                            nil nil
+                            nil nil
+                            nil nil
+                            (1- (match-end 0)) (match-end 0)))))
+    t))
+(defvar powershell-font-lock-syntactic-keywords
+  `((powershell-find-syntactic-comments (1 "!" t t) (2 "!" t t)
+                                        (3 "<" t t) (4 ">" t t))
+    (powershell-find-syntactic-quotes (1 "|" t t) (2 "|" t t)
+                                      (3 "|" t t) (4 "|" t t)))
+  "A list of regexp's or functions.
+Used to add `syntax-table' properties to
+characters that can't be set by the `syntax-table' alone.")
+
+
+(defvar powershell-font-lock-keywords-1
+  `( ;; Type annotations
+    (,powershell-object-types-regexp . font-lock-type-face)
+    ;; syntaxic keywords
+    (,powershell-keywords . font-lock-keyword-face)
+    ;; operators
+    (,powershell-operators . font-lock-builtin-face)
+    ;; the REQUIRES mark
+    ("^#\\(REQUIRES\\)" 1 font-lock-warning-face t))
+  "Keywords for the first level of font-locking in PowerShell mode.")
+
+(defvar powershell-font-lock-keywords-2
+  (append
+   powershell-font-lock-keywords-1
+   `( ;; Built-in variables
+     (,(concat "\\$\\(" powershell-builtin-variables-regexp "\\)\\>")
+      0 font-lock-builtin-face t)
+     (,(concat "\\$\\(" powershell-config-variables-regexp "\\)\\>")
+      0 font-lock-builtin-face t)))
+  "Keywords for the second level of font-locking in PowerShell mode.")
+
+(defvar powershell-font-lock-keywords-3
+  (append
+   powershell-font-lock-keywords-2
+   `( ;; user variables
+     (,powershell-variables-regexp
+      (0 font-lock-variable-name-face)
+      (1 (cons font-lock-type-face '(underline)) t t)
+      (2 (cons font-lock-type-face '(underline)) t t))
+     ;; function argument names
+     (,powershell-function-switch-names-regexp
+      (0 font-lock-reference-face)
+      (1 (cons font-lock-type-face '(underline)) t t)
+      (2 (cons font-lock-type-face '(underline)) t t))
+     ;; function names
+     (,powershell-function-names-regex
+      (0 font-lock-function-name-face)
+      (1 (cons font-lock-type-face '(underline)) t t))))
+  "Keywords for the maximum level of font-locking in PowerShell mode.")
+
+
+(defun powershell-setup-font-lock ()
+  "Set up the buffer local value for `font-lock-defaults'."
+  ;; I use font-lock-syntactic-keywords to set some properties and I
+  ;; don't want them ignored.
+  (set (make-local-variable 'parse-sexp-lookup-properties) t)
+  ;; This is where all the font-lock stuff actually gets set up.  Once
+  ;; font-lock-defaults has its value, setting font-lock-mode true should
+  ;; cause all your syntax highlighting dreams to come true.
+  (setq font-lock-defaults
+        ;; The first value is all the keyword expressions.
+        '((powershell-font-lock-keywords-1
+           powershell-font-lock-keywords-2
+           powershell-font-lock-keywords-3)
+          ;; keywords-only means no strings or comments get fontified
+          nil
+          ;; case-fold (t ignores case)
+          t
+          ;; syntax-alist nothing special here
+          nil
+          ;; syntax-begin - no function defined to move outside syntactic block
+          nil
+          ;; font-lock-syntactic-keywords
+          ;; takes (matcher (match syntax override lexmatch) ...)...
+          (font-lock-syntactic-keywords
+           . powershell-font-lock-syntactic-keywords))))
+
+(defvar powershell-mode-syntax-table
+  (let ((powershell-mode-syntax-table (make-syntax-table)))
+    (modify-syntax-entry ?$  "_" powershell-mode-syntax-table)
+    (modify-syntax-entry ?:  "_" powershell-mode-syntax-table)
+    (modify-syntax-entry ?-  "_" powershell-mode-syntax-table)
+    (modify-syntax-entry ?^  "_" powershell-mode-syntax-table)
+    (modify-syntax-entry ?\\ "_" powershell-mode-syntax-table)
+    (modify-syntax-entry ?\{ "(}" powershell-mode-syntax-table)
+    (modify-syntax-entry ?\} "){" powershell-mode-syntax-table)
+    (modify-syntax-entry ?\[ "(]" powershell-mode-syntax-table)
+    (modify-syntax-entry ?\] ")[" powershell-mode-syntax-table)
+    (modify-syntax-entry ?\( "()" powershell-mode-syntax-table)
+    (modify-syntax-entry ?\) ")(" powershell-mode-syntax-table)
+    (modify-syntax-entry ?` "\\" powershell-mode-syntax-table)
+    (modify-syntax-entry ?_  "w" powershell-mode-syntax-table)
+    (modify-syntax-entry ?=  "." powershell-mode-syntax-table)
+    (modify-syntax-entry ?|  "." powershell-mode-syntax-table)
+    (modify-syntax-entry ?+  "." powershell-mode-syntax-table)
+    (modify-syntax-entry ?*  "." powershell-mode-syntax-table)
+    (modify-syntax-entry ?/  "." powershell-mode-syntax-table)
+    (modify-syntax-entry ?' "\"" powershell-mode-syntax-table)
+    (modify-syntax-entry ?#  "<" powershell-mode-syntax-table)
+    powershell-mode-syntax-table)
+  "Syntax for PowerShell major mode.")
+
+(defvar powershell-mode-map
+  (let ((powershell-mode-map (make-keymap)))
+    ;;    (define-key powershell-mode-map "\r" 'powershell-indent-line)
+    (define-key powershell-mode-map (kbd "M-\"")
+      'powershell-doublequote-selection)
+    (define-key powershell-mode-map (kbd "M-'") 'powershell-quote-selection)
+    (define-key powershell-mode-map (kbd "C-'") 'powershell-unquote-selection)
+    (define-key powershell-mode-map (kbd "C-\"") 'powershell-unquote-selection)
+    (define-key powershell-mode-map (kbd "M-`") 'powershell-escape-selection)
+    (define-key powershell-mode-map (kbd "C-$")
+      'powershell-dollarparen-selection)
+    powershell-mode-map)
+  "Keymap for PS major mode.")
+
+(defun powershell-setup-menu ()
+  "Add a menu of PowerShell specific functions to the menu bar."
+  (define-key (current-local-map) [menu-bar powershell-menu]
+    (cons "PowerShell" (make-sparse-keymap "PowerShell")))
+  (define-key (current-local-map) [menu-bar powershell-menu doublequote]
+    '(menu-item "DoubleQuote Selection" powershell-doublequote-selection
+                :key-sequence(kbd "M-\"")
+                :help
+                "DoubleQuotes the selection escaping embedded double quotes"))
+  (define-key (current-local-map) [menu-bar powershell-menu quote]
+    '(menu-item "SingleQuote Selection" powershell-quote-selection
+                :key-sequence (kbd "M-'")
+                :help
+                "SingleQuotes the selection escaping embedded single quotes"))
+  (define-key (current-local-map) [menu-bar powershell-menu unquote]
+    '(menu-item "UnQuote Selection" powershell-unquote-selection
+                :key-sequence (kbd "C-'")
+                :help "Un-Quotes the selection un-escaping any escaped quotes"))
+  (define-key (current-local-map) [menu-bar powershell-menu escape]
+    '(menu-item "Escape Selection" powershell-escape-selection
+                :key-sequence (kbd "M-`")
+                :help (concat "Escapes variables in the selection"
+                              " and extends existing escapes.")))
+  (define-key (current-local-map) [menu-bar powershell-menu dollarparen]
+    '(menu-item "DollarParen Selection" powershell-dollarparen-selection
+                :key-sequence (kbd "C-$")
+                :help "Wraps the selection in $()")))
+
+
+;;; Eldoc support
+
+(defcustom powershell-eldoc-def-files nil
+  "List of files containing function help strings used by function `eldoc-mode'.
+These are the strings function `eldoc-mode' displays as help for
+functions near point.  The format of the file must be exactly as
+follows or who knows what happens.
+
+   (set (intern \"\" powershell-eldoc-obarray) \"\")
+   (set (intern \"\" powershell-eldoc-obarray) \"\")
+...
+
+Where  is the name of the function to which  applies.
+       is the string to display when point is near ."
+  :type '(repeat string)
+  :group 'powershell)
+
+(defvar powershell-eldoc-obarray ()
+  "Array for file entries by the function `eldoc'.
+`powershell-eldoc-def-files' entries are added into this array.")
+
+(defun powershell-eldoc-function ()
+  "Return a documentation string appropriate for the current context or nil."
+  (let ((word (thing-at-point 'symbol)))
+    (if word
+        (eval (intern-soft word powershell-eldoc-obarray)))))
+
+(defun powershell-setup-eldoc ()
+  "Load the function documentation for use with eldoc."
+  (when (not (null powershell-eldoc-def-files))
+    (set (make-local-variable 'eldoc-documentation-function)
+         'powershell-eldoc-function)
+    (unless (vectorp powershell-eldoc-obarray)
+      (setq powershell-eldoc-obarray (make-vector 41 0))
+      (condition-case var (mapc 'load powershell-eldoc-def-files)
+        (error (message "*** powershell-setup-eldoc ERROR *** %s" var))))))
+;;; Note: You can create quite a bit of help with these commands:
+;;
+;; function Get-Signature ($Cmd) {
+;;   if ($Cmd -is [Management.Automation.PSMethod]) {
+;;     $List = @($Cmd)}
+;;   elseif ($Cmd -isnot [string]) {
+;;     throw ("Get-Signature {|}`n" +
+;;            "'$Cmd' is not a method or command")}
+;;     else {$List = @(Get-Command $Cmd -ErrorAction SilentlyContinue)}
+;;   if (!$List[0] ) {
+;;     throw "Command '$Cmd' not found"}
+;;   foreach ($O in $List) {
+;;     switch -regex ($O.GetType().Name) {
+;;       'AliasInfo' {
+;;         Get-Signature ($O.Definition)}
+;;       '(Cmdlet|ExternalScript)Info' {
+;;         $O.Definition}          # not sure what to do with ExternalScript
+;;       'F(unction|ilter)Info'{
+;;         if ($O.Definition -match '^param *\(') {
+;;           $t = [Management.Automation.PSParser]::tokenize($O.Definition,
+;;                                                           [ref]$null)
+;;           $c = 1;$i = 1
+;;           while($c -and $i++ -lt $t.count) {
+;;             switch ($t[$i].Type.ToString()) {
+;;               GroupStart {$c++}
+;;               GroupEnd   {$c--}}}
+;;           $O.Definition.substring(0,$t[$i].start + 1)} #needs parsing
+;;         else {$O.Name}}
+;;       'PSMethod' {
+;;         foreach ($t in @($O.OverloadDefinitions)) {
+;;           while (($b=$t.IndexOf('`1[[')) -ge 0) {
+;;             $t=$t.remove($b,$t.IndexOf(']]')-$b+2)}
+;;             $t}}}}}
+;; get-command|
+;;   ?{$_.CommandType -ne 'Alias' -and $_.Name -notlike '*:'}|
+;;   %{$_.Name}|
+;;   sort|
+;;   %{("(set (intern ""$($_.Replace('\','\\'))"" powershell-eldoc-obarray)" +
+;;      " ""$(Get-Signature $_|%{$_.Replace('\','\\').Replace('"','\"')})"")"
+;;     ).Replace("`r`n"")",""")")} > .\powershell-eldoc.el
+
+
+(defvar powershell-imenu-expression
+  `(("Functions" ,(concat "function " powershell-function-names-regex) 2)
+    ("Filters" ,(concat "filter " powershell-function-names-regex) 2)
+    ("Top variables"
+     , (concat "^\\(" powershell-object-types-regexp "\\)?\\("
+               powershell-variables-regexp "\\)\\s-*=")
+     2))
+  "List of regexps matching important expressions, for speebar & imenu.")
+
+(defun powershell-setup-imenu ()
+  "Install `powershell-imenu-expression'."
+  (when (require 'imenu nil t)
+    ;; imenu doc says these are buffer-local by default
+    (setq imenu-generic-expression powershell-imenu-expression)
+    (setq imenu-case-fold-search nil)
+    (imenu-add-menubar-index)))
+
+(defun powershell-setup-speedbar ()
+  "Install `speedbar-add-supported-extension'."
+  (when (require 'speedbar nil t)
+    (speedbar-add-supported-extension ".ps1?")))
+
+;; A better command would be something like "powershell.exe -NoLogo
+;; -NonInteractive -Command & (buffer-file-name)". But it will just
+;; sit there waiting...  The following will only work when .ps1 files
+;; are associated with powershell.exe. And if they don't contain spaces.
+(defvar powershell-compile-command
+  '(buffer-file-name)
+  "Default command used to invoke a powershell script.")
+
+;; The column number will be off whenever tabs are used. Since this is
+;; the default in this mode, we will not capture the column number.
+(setq compilation-error-regexp-alist
+      (cons '("At \\(.*\\):\\([0-9]+\\) char:\\([0-9]+\\)" 1 2)
+            compilation-error-regexp-alist))
+
+
+(add-hook 'powershell-mode-hook #'imenu-add-menubar-index)
+
+;;;###autoload
+(define-derived-mode powershell-mode prog-mode "PS"
+  "Major mode for editing PowerShell scripts.
+
+\\{powershell-mode-map}
+Entry to this mode calls the value of `powershell-mode-hook' if
+that value is non-nil."
+  (powershell-setup-font-lock)
+  (setq-local indent-line-function 'powershell-indent-line)
+  (setq-local compile-command powershell-compile-command)
+  (setq-local comment-start "#")
+  (setq-local comment-start-skip "#+\\s*")
+  (setq-local parse-sexp-ignore-comments t)
+  ;; Support electric-pair-mode
+  (setq-local electric-indent-chars
+              (append "{}():;," electric-indent-chars))
+  (powershell-setup-imenu)
+  (powershell-setup-speedbar)
+  (powershell-setup-menu)
+  (powershell-setup-eldoc))
+
+;;; PowerShell inferior mode
+
+;;; Code:
+(defcustom powershell-location-of-exe
+   (or (executable-find "powershell") (executable-find "pwsh"))
+  "A string, providing the location of the powershell executable."
+  :group 'powershell)
+
+(defcustom powershell-log-level 3
+  "The current log level for powershell internal operations.
+0 = NONE, 1 = Info, 2 = VERBOSE, 3 = DEBUG."
+  :group 'powershell)
+
+(defcustom powershell-squish-results-of-silent-commands t
+"The function `powershell-invoke-command-silently' returns the results
+of a command in a string.  PowerShell by default, inserts newlines when
+the output exceeds the configured width of the powershell virtual
+window. In some cases callers might want to get the results with the
+newlines and formatting removed. Set this to true, to do that."
+:group 'powershell)
+
+(defvar powershell-prompt-regex  "PS [^#$%>]+> "
+  "Regexp to match the powershell prompt.
+powershell.el uses this regex to determine when a command has
+completed.  Therefore, you need to set this appropriately if you
+explicitly change the prompt function in powershell.  Any value
+should include a trailing space, if the powershell prompt uses a
+trailing space, but should not include a trailing newline.
+
+The default value will match the default PowerShell prompt.")
+
+(defvar powershell-command-reply nil
+  "The reply of powershell commands.
+This is retained for housekeeping purposes.")
+
+(defvar powershell--max-window-width  0
+  "The maximum width of a powershell window.
+You shouldn't need to ever set this.  It gets set automatically,
+once, when the powershell starts up.")
+
+(defvar powershell-command-timeout-seconds 12
+  "The timeout for a powershell command.
+powershell.el will wait this long before giving up.")
+
+(defvar powershell--need-rawui-resize t
+  "No need to fuss with this.  It's intended for internal use
+only.  It gets set when powershell needs to be informed that
+emacs has resized its window.")
+
+(defconst powershell--find-max-window-width-command
+  (concat
+  "function _Emacs_GetMaxPhsWindowSize"
+  " {"
+  " $rawui = (Get-Host).UI.RawUI;"
+  " $mpws_exists = ($rawui | Get-Member | Where-Object"
+  " {$_.Name -eq \"MaxPhysicalWindowSize\"});"
+  " if ($mpws_exists -eq $null) {"
+  " 210"
+  " } else {"
+  " $rawui.MaxPhysicalWindowSize.Width"
+  " }"
+  " };"
+  " _Emacs_GetMaxPhsWindowSize")
+  "The powershell logic to determine the max physical window width.")
+
+(defconst powershell--set-window-width-fn-name  "_Emacs_SetWindowWidth"
+  "The name of the function this mode defines in PowerShell to
+set the window width. Intended for internal use only.")
+
+(defconst powershell--text-of-set-window-width-ps-function
+  ;; see
+  ;; http://blogs.msdn.com/lior/archive/2009/05/27/ResizePowerShellConsoleWindow.aspx
+  ;;
+  ;; When making the console window narrower, you mus set the window
+  ;; size first. When making the console window wider, you must set the
+  ;; buffer size first.
+
+    (concat  "function " powershell--set-window-width-fn-name
+             "([string] $pswidth)"
+             " {"
+             " $rawui = (Get-Host).UI.RawUI;"
+             " $bufsize = $rawui.BufferSize;"
+             " $winsize = $rawui.WindowSize;"
+             " $cwidth = $winsize.Width;"
+             " $winsize.Width = $pswidth;"
+             " $bufsize.Width = $pswidth;"
+             " if ($cwidth -lt $pswidth) {"
+             " $rawui.BufferSize = $bufsize;"
+             " $rawui.WindowSize = $winsize;"
+             " }"
+             " elseif ($cwidth -gt $pswidth) {"
+             " $rawui.WindowSize = $winsize;"
+             " $rawui.BufferSize = $bufsize;"
+             " };"
+             " Set-Variable -name rawui -value $null;"
+             " Set-Variable -name winsize -value $null;"
+             " Set-Variable -name bufsize -value $null;"
+             " Set-Variable -name cwidth -value $null;"
+             " }")
+
+    "The text of the powershell function that will be used at runtime to
+set the width of the virtual Window in PowerShell, as the Emacs window
+gets resized.")
+
+(defun powershell-log (level text &rest args)
+  "Log a message at level LEVEL.
+If LEVEL is higher than `powershell-log-level', the message is
+ignored.  Otherwise, it is printed using `message'.
+TEXT is a format control string, and the remaining arguments ARGS
+are the string substitutions (see `format')."
+  (if (<= level powershell-log-level)
+      (let* ((msg (apply 'format text args)))
+        (message "%s" msg))))
+
+;; (defun dino-powershell-complete (arg)
+;; "do powershell completion on the given STRING. Pop up a buffer
+;; with the completion list."
+;;   (interactive
+;;    (list (read-no-blanks-input "\
+;; Stub to complete: ")))
+
+;;   (let ((proc
+;;          (get-buffer-process (current-buffer))))
+;;    (comint-proc-query proc (concat "Get-Command " arg "*\n"))
+;;    )
+;; )
+
+;; (defun dino-powershell-cmd-complete ()
+;;   "try to get powershell completion to work."
+;;   (interactive)
+;;   (let ((proc
+;;          (get-buffer-process (current-buffer))))
+;; ;;   (comint-proc-query proc "Get-a\t")
+;; ;;   (comint-simple-send proc "Get-a\t")
+;;        (comint-send-string proc "Get-a\t\n")
+;; ;;   (process-send-eof)
+;;    )
+;; )
+
+(defun powershell--define-set-window-width-function (proc)
+  "Sends a function definition to the PowerShell instance
+identified by PROC.  The function sets the window width of the
+PowerShell virtual window.  Later, the function will be called
+when the width of the emacs window changes."
+    (if proc
+        (progn
+          ;;process-send-string
+          (comint-simple-send
+           proc
+           powershell--text-of-set-window-width-ps-function))))
+
+(defun powershell--get-max-window-width  (buffer-name)
+  "Gets the maximum width of the virtual window for PowerShell running
+in the buffer with name BUFFER-NAME.
+
+In PowerShell 1.0, the maximum WindowSize.Width for
+PowerShell is 210, hardcoded, I believe. In PowerShell 2.0, the max
+windowsize.Width is provided in the RawUI.MaxPhysicalWindowSize
+property.
+
+This function does the right thing, and sets the buffer-local
+`powershell--max-window-width' variable with the correct value."
+  (let ((proc (get-buffer-process buffer-name)))
+
+    (if proc
+        (with-current-buffer buffer-name
+          (powershell-invoke-command-silently
+           proc
+           powershell--find-max-window-width-command
+           0.90)
+
+          ;; store the retrieved width
+          (setq powershell--max-window-width
+                (if (and (not (null powershell-command-reply))
+                         (string-match
+                          "\\([1-9][0-9]*\\)[ \t\f\v\n]+"
+                          powershell-command-reply))
+                    (string-to-number (match-string 1 powershell-command-reply))
+                  200)))))) ;; could go to 210, but let's use 200 to be safe
+
+(defun powershell--set-window-width (proc)
+  "Run the PowerShell function that sets the RawUI width
+appropriately for a PowerShell shell.
+
+This is necessary to get powershell to do the right thing, as far
+as text formatting, when the emacs window gets resized.
+
+The function gets defined in powershell upon powershell startup."
+  (let ((ps-width
+         (number-to-string (min powershell--max-window-width (window-width)))))
+    (progn
+      ;;(process-send-string
+      (comint-simple-send
+       proc
+       (concat powershell--set-window-width-fn-name
+               "('" ps-width "')")))))
+
+;;;###autoload
+(defun powershell (&optional buffer prompt-string)
+  "Run an inferior PowerShell.
+If BUFFER is non-nil, use it to hold the powershell
+process.  Defaults to *PowerShell*.
+
+Interactively, a prefix arg means to prompt for BUFFER.
+
+If BUFFER exists but the shell process is not running, it makes a
+new shell.
+
+If BUFFER exists and the shell process is running, just switch to
+BUFFER.
+
+If PROMPT-STRING is non-nil, sets the prompt to the given value.
+
+See the help for `shell' for more details.  \(Type
+\\[describe-mode] in the shell buffer for a list of commands.)"
+  (interactive
+   (list
+    (and current-prefix-arg
+         (read-buffer "Shell buffer: "
+                      (generate-new-buffer-name "*PowerShell*")))))
+
+  (setq buffer (get-buffer-create (or buffer "*PowerShell*")))
+  (powershell-log 1 "powershell starting up...in buffer %s" (buffer-name buffer))
+  (let ((explicit-shell-file-name (if (eq system-type 'cygwin)
+				      (cygwin-convert-file-name-from-windows powershell-location-of-exe)
+				    powershell-location-of-exe)))
+    ;; set arguments for the powershell exe.
+    ;; Does this need to be tunable?
+
+    (shell buffer))
+
+  ;; (powershell--get-max-window-width "*PowerShell*")
+  ;; (powershell-invoke-command-silently (get-buffer-process "*csdeshell*")
+  ;; "[Ionic.Csde.Utilities]::Version()" 2.9)
+
+  ;;  (comint-simple-send (get-buffer-process "*csdeshell*") "prompt\n")
+
+  (let ((proc (get-buffer-process buffer)))
+
+    (make-local-variable 'powershell-prompt-regex)
+    (make-local-variable 'powershell-command-reply)
+    (make-local-variable 'powershell--max-window-width)
+    (make-local-variable 'powershell-command-timeout-seconds)
+    (make-local-variable 'powershell-squish-results-of-silent-commands)
+    (make-local-variable 'powershell--need-rawui-resize)
+    (make-local-variable 'comint-prompt-read-only)
+
+    ;; disallow backspace over the prompt:
+    (setq comint-prompt-read-only t)
+
+    ;; We need to tell powershell how wide the emacs window is, because
+    ;; powershell pads its output to the width it thinks its window is.
+    ;;
+    ;; The way it's done: every time the width of the emacs window changes, we
+    ;; set a flag. Then, before sending a powershell command that is
+    ;; typed into the buffer, to the actual powershell process, we check
+    ;; that flag.  If it is set, we  resize the powershell window appropriately,
+    ;; before sending the command.
+
+    ;; If we didn't do this, powershell output would get wrapped at a
+    ;; column width that would be different than the emacs buffer width,
+    ;; and everything would look ugly.
+
+    ;; get the maximum width for powershell - can't go beyond this
+    (powershell--get-max-window-width buffer)
+
+    ;; define the function for use within powershell to resize the window
+    (powershell--define-set-window-width-function proc)
+
+    ;; add the hook that sets the flag
+    (add-hook 'window-size-change-functions
+              '(lambda (&optional x)
+                 (setq powershell--need-rawui-resize t)))
+
+    ;; set the flag so we resize properly the first time.
+    (setq powershell--need-rawui-resize t)
+
+    (if prompt-string
+        (progn
+          ;; This sets up a prompt for the PowerShell.  The prompt is
+          ;; important because later, after sending a command to the
+          ;; shell, the scanning logic that grabs the output looks for
+          ;; the prompt string to determine that the output is complete.
+          (comint-simple-send
+           proc
+           (concat "function prompt { '" prompt-string "' }"))
+
+          (setq powershell-prompt-regex prompt-string)))
+
+    ;; hook the kill-buffer action so we can kill the inferior process?
+    (add-hook 'kill-buffer-hook 'powershell-delete-process)
+
+    ;; wrap the comint-input-sender with a PS version
+    ;; must do this after launching the shell!
+    (make-local-variable 'comint-input-sender)
+    (setq comint-input-sender 'powershell-simple-send)
+
+    ;; set a preoutput filter for powershell.  This will trim newlines
+    ;; after the prompt.
+    (add-hook 'comint-preoutput-filter-functions
+              'powershell-preoutput-filter-for-prompt)
+
+    ;; send a carriage-return  (get the prompt)
+    (comint-send-input)
+    (accept-process-output proc))
+
+  ;; The launch hooks for powershell has not (yet?) been implemented
+  ;;(run-hooks 'powershell-launch-hook)
+
+  ;; return the buffer created
+  buffer)
+
+;; +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
+;; Using powershell on emacs23, I get an error:
+;;
+;;    ansi-color-process-output: Marker does not point anywhere
+;;
+;; Here's what's happening.
+;;
+;; In order to be able to read the output from powershell, this shell
+;; starts powershell.exe in "interactive mode", using the -i
+;; option. This which has the curious side-effect of turning off the
+;; prompt in powershell. Normally powershell will return its results,
+;; then emit a prompt to indicate that it is ready for more input.  In
+;; interactive mode it doesn't emit the prompt.  To work around this,
+;; this code (powershell.el) sends an explicit `prompt` command after
+;; sending any user-entered command to powershell. This tells powershell
+;; to explicitly return the prompt, after the results of the prior
+;; command. The prompt then shows up in the powershell buffer.  Lovely.
+;;
+;; But, `ansi-color-apply-on-region` gets called after every command
+;; gets sent to powershell. It gets called with args `(begin end)`,
+;; which are both markers. Turns out the very first time this fn is
+;; called, the position for the begin marker is nil.
+;;
+;; `ansi-color-apply-on-region` calls `(goto-char begin)` (effectively),
+;; and when the position on the marker is nil, the call errors with
+;; "Marker does not point anywhere."
+;;
+;; The following advice suppresses the call to
+;; `ansi-color-apply-on-region` when the begin marker points
+;; nowhere.
+(defadvice ansi-color-apply-on-region (around
+                                       powershell-throttle-ansi-colorizing
+                                       (begin end)
+                                       compile)
+  (progn
+    (let ((start-pos (marker-position begin)))
+    (cond
+     (start-pos
+      (progn
+        ad-do-it))))))
+
+(defun powershell--silent-cmd-filter (process result)
+"A process filter that captures output from a shell and stores it
+to `powershell-command-reply', rather than allowing the output to
+be displayed in the shell buffer.
+
+This function is intended for internal use only."
+  (let ((end-of-result
+         (string-match (concat ".*\n\\(" powershell-prompt-regex "\\)[ \n]*\\'")
+                       result)))
+    (if (and end-of-result (numberp end-of-result))
+
+        (progn
+          ;; Store everything except the follow-on prompt.
+          ;; The result probably includes a final newline!
+          (setq result (substring result 0 (match-beginning 1)))
+
+          (if powershell-squish-results-of-silent-commands
+              (setq result
+                    (replace-regexp-in-string "\n" "" result)))
+
+          (setq powershell-command-reply
+                (concat powershell-command-reply result)))
+
+      (progn
+        (if powershell-squish-results-of-silent-commands
+              (setq result
+                    (replace-regexp-in-string "\n" "" result)))
+
+        (setq powershell-command-reply
+              (concat powershell-command-reply result))
+
+        ;; recurse.  For very very long output, the recursion can
+        ;; cause stack overflow. Careful!
+        (accept-process-output process powershell-command-timeout-seconds)))))
+
+(defun powershell-invoke-command-silently (proc command
+                                                &optional timeout-seconds)
+  "In the PowerShell instance PROC, invoke COMMAND silently.
+Neither the COMMAND is echoed nor the results to the associated
+buffer.  Use TIMEOUT-SECONDS as the timeout, waiting for a
+response.  The COMMAND should be a string, and need not be
+terminated with a newline.
+
+This is helpful when, for example, doing setup work. Or other sneaky
+stuff, such as resetting the size of the PowerShell virtual window.
+
+Returns the result of the command, a string, without the follow-on
+command prompt.  The result will probably end in a newline. This result
+is also stored in the buffer-local variable `powershell-command-reply'.
+
+In some cases the result can be prepended with the command prompt, as
+when, for example, several commands have been send in succession and the
+results of the prior command were not fully processed by the application.
+
+If a PowerShell buffer is not the current buffer, this function
+should be invoked within a call to `with-current-buffer' or
+similar in order to insure that the buffer-local values of
+`powershell-command-reply', `powershell-prompt-regex', and
+`powershell-command-timeout-seconds' are used.
+
+Example:
+
+    (with-current-buffer powershell-buffer-name
+      (powershell-invoke-command-silently
+       proc
+       command-string
+       1.90))"
+
+  (let ((old-timeout powershell-command-timeout-seconds)
+        (original-filter (process-filter proc)))
+
+    (setq powershell-command-reply nil)
+
+    (if timeout-seconds
+        (setq powershell-command-timeout-seconds timeout-seconds))
+
+    (set-process-filter proc 'powershell--silent-cmd-filter)
+
+    ;; Send the command plus the "prompt" command.  The filter
+    ;; will know the command is finished when it sees the command
+    ;; prompt.
+    ;;
+    (process-send-string proc (concat command "\nprompt\n"))
+
+    (accept-process-output proc powershell-command-timeout-seconds)
+
+    ;; output of the command is now available in powershell-command-reply
+
+    ;; Trim prompt from the beginning of the output.
+    ;; this can happen for the first command through
+    ;; the shell.  I think there's a race condition.
+    (if (and powershell-command-reply
+             (string-match (concat "^" powershell-prompt-regex "\\(.*\\)\\'")
+                           powershell-command-reply))
+        (setq powershell-command-reply
+              (substring powershell-command-reply
+                         (match-beginning 1)
+                         (match-end 1))))
+
+    ;; restore the original filter
+    (set-process-filter proc original-filter)
+
+    ;; restore the original timeout
+    (if timeout-seconds
+        (setq powershell-command-timeout-seconds old-timeout))
+
+    ;; the result:
+    powershell-command-reply))
+
+(defun powershell-delete-process (&optional proc)
+  "Delete the current buffer process or PROC."
+  (or proc
+      (setq proc (get-buffer-process (current-buffer))))
+  (and (processp proc)
+       (delete-process proc)))
+
+(defun powershell-preoutput-filter-for-prompt (string)
+  "Trim the newline from STRING, the prompt that we get back from
+powershell.  This fn is set into the preoutput filters, so the
+newline is trimmed before being put into the output buffer."
+   (if (string-match (concat powershell-prompt-regex "\n\\'") string)
+       (substring string 0 -1) ;; remove newline
+     string))
+
+(defun powershell-simple-send (proc string)
+  "Override of the comint-simple-send function, with logic
+specifically designed for powershell.  This just sends STRING,
+plus the prompt command.
+
+When running as an inferior shell with stdin/stdout redirected,
+powershell is in noninteractive mode. This means no prompts get
+emitted when a PS command completes. This makes it difficult for
+a comint mode to determine when the command has completed.
+Therefore, we send an explicit request for the prompt, after
+sending the actual (primary) command. When the primary command
+completes, PowerShell then responds to the \"prompt\" command,
+and emits the prompt.
+
+This insures we get and display the prompt."
+  ;; Tell PowerShell to resize its virtual window, if necessary. We do
+  ;; this by calling a resize function in the PowerShell, before sending
+  ;; the user-entered command to the shell.
+  ;;
+  ;; PowerShell keeps track of its \"console\", and formats its output
+  ;; according to the width it thinks it is using.  This is true even when
+  ;; powershell is invoked with the - argument, which tells it to use
+  ;; stdin as input.
+
+  ;; Therefore, if the user has resized the emacs window since the last
+  ;; PowerShell command, we need to tell PowerShell to change the size
+  ;; of its virtual window. Calling that function does not change the
+  ;; size of a window that is visible on screen - it only changes the
+  ;; size of the virtual window that PowerShell thinks it is using.  We
+  ;; do that by invoking the PowerShell function that this module
+  ;; defined for that purpose.
+  ;;
+  (if powershell--need-rawui-resize
+      (progn
+        (powershell--set-window-width proc)
+        (setq powershell--need-rawui-resize nil)))
+  (comint-simple-send proc (concat string "\n"))
+  (comint-simple-send proc "prompt\n"))
+
+;; Notes on TAB for completion.
+;; -------------------------------------------------------
+;; Emacs calls comint-dynamic-complete when the TAB key is pressed in a shell.
+;; This is set up in shell-mode-map.
+;;
+;; comint-dynamic-complete calls the functions in
+;; comint-dynamic-complete-functions, until one of them returns
+;; non-nil.
+;;
+;; comint-dynamic-complete-functions is a good thing to set in the mode hook.
+;;
+;; The default value for that var in a powershell shell is:
+;; (comint-replace-by-expanded-history
+;;    shell-dynamic-complete-environment-variable
+;;    shell-dynamic-complete-command
+;;    shell-replace-by-expanded-directory
+;;    comint-dynamic-complete-filename)
+
+;; (defun powershell-dynamic-complete-command ()
+;;   "Dynamically complete the command at point.  This function is
+;; similar to `comint-dynamic-complete-filename', except that it
+;; searches the commands from powershell and then the `exec-path'
+;; (minus the trailing Emacs library path) for completion candidates.
+
+;; Completion is dependent on the value of
+;; `shell-completion-execonly', plus those that effect file
+;; completion.  See `powershell-dynamic-complete-as-command'.
+
+;; Returns t if successful."
+;;   (interactive)
+;;   (let ((filename (comint-match-partial-filename)))
+;;     (if (and filename
+;;              (save-match-data (not (string-match "[~/]" filename)))
+;;              (eq (match-beginning 0)
+;;                  (save-excursion (shell-backward-command 1) (point))))
+;;         (prog2 (message "Completing command name...")
+;;             (powershell-dynamic-complete-as-command)))))
+
+;; (defun powershell-dynamic-complete-as-command ()
+;;   "Dynamically complete at point as a command.
+;; See `shell-dynamic-complete-filename'.  Returns t if successful."
+;;   (let* ((filename (or (comint-match-partial-filename) ""))
+;;          (filenondir (file-name-nondirectory filename))
+;;          (path-dirs (cdr (reverse exec-path)))
+;;          (cwd (file-name-as-directory (expand-file-name default-directory)))
+;;          (ignored-extensions
+;;           (and comint-completion-fignore
+;;                (mapconcat (function (lambda (x) (concat (regexp-quote x) "$")))
+;;                           comint-completion-fignore "\\|")))
+;;          (dir "") (comps-in-dir ())
+;;          (file "") (abs-file-name "") (completions ()))
+
+;;     ;; Go thru each cmd in powershell's lexicon, finding completions.
+
+;;     ;; Go thru each dir in the search path, finding completions.
+;;     (while path-dirs
+;;       (setq dir (file-name-as-directory (comint-directory (or (car path-dirs) ".")))
+;;             comps-in-dir (and (file-accessible-directory-p dir)
+;;                               (file-name-all-completions filenondir dir)))
+;;       ;; Go thru each completion found, to see whether it should be used.
+;;       (while comps-in-dir
+;;         (setq file (car comps-in-dir)
+;;               abs-file-name (concat dir file))
+;;         (if (and (not (member file completions))
+;;                  (not (and ignored-extensions
+;;                            (string-match ignored-extensions file)))
+;;                  (or (string-equal dir cwd)
+;;                      (not (file-directory-p abs-file-name)))
+;;                  (or (null shell-completion-execonly)
+;;                      (file-executable-p abs-file-name)))
+;;             (setq completions (cons file completions)))
+;;         (setq comps-in-dir (cdr comps-in-dir)))
+;;       (setq path-dirs (cdr path-dirs)))
+;;     ;; OK, we've got a list of completions.
+;;     (let ((success (let ((comint-completion-addsuffix nil))
+;;                      (comint-dynamic-simple-complete filenondir completions))))
+;;       (if (and (memq success '(sole shortest)) comint-completion-addsuffix
+;;                (not (file-directory-p (comint-match-partial-filename))))
+;;           (insert " "))
+;;       success)))
+
+(provide 'powershell)
+
+;;; powershell.el ends here
diff --git a/lisp/pythonic.el b/lisp/pythonic.el
new file mode 100644
index 00000000..be993bbe
--- /dev/null
+++ b/lisp/pythonic.el
@@ -0,0 +1,310 @@
+;;; pythonic.el --- Utility functions for writing pythonic emacs package.  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015-2019 by Artem Malyshev
+
+;; Author: Artem Malyshev 
+;; URL: https://github.com/proofit404/pythonic
+;; Package-Version: 20200304.1901
+;; Package-Commit: f577f155fb0c6e57b3ff82447ac25dcb3ca0080f
+;; Version: 0.1.1
+;; Package-Requires: ((emacs "25.1") (s "1.9") (f "0.17.2"))
+
+;; 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 .
+
+;;; Commentary:
+
+;; See the README for more details.
+
+;;; Code:
+
+(require 'python)
+(require 'cl-lib)
+(require 'tramp)
+(require 's)
+(require 'f)
+
+(defgroup pythonic nil
+  "Utility functions for writing pythonic emacs package."
+  :group 'python)
+
+
+;;; Connection predicates.
+
+(defun pythonic-local-p ()
+  "Determine local virtual environment."
+  (not (pythonic-remote-p)))
+
+(defun pythonic-remote-p ()
+  "Determine remote virtual environment."
+  (and (tramp-tramp-file-p (pythonic-aliased-path default-directory))
+       t))
+
+(defun pythonic-remote-docker-p ()
+  "Determine docker remote virtual environment."
+  (and (pythonic-remote-p)
+       (s-equals-p (pythonic-remote-method) "docker")))
+
+(defun pythonic-remote-ssh-p ()
+  "Determine ssh remote virtual environment."
+  (and (pythonic-remote-p)
+       (s-equals-p (pythonic-remote-method) "ssh")))
+
+(defun pythonic-remote-vagrant-p ()
+  "Determine vagrant remote virtual environment."
+  (and (pythonic-remote-p)
+       (s-equals-p (pythonic-remote-host) "localhost")
+       (s-equals-p (pythonic-remote-user) "vagrant")))
+
+
+;;; Connection properties.
+
+(defun pythonic-remote-method ()
+  "Get tramp method of the connection to the remote python interpreter."
+  (tramp-file-name-method (tramp-dissect-file-name (pythonic-aliased-path default-directory))))
+
+(defun pythonic-remote-user ()
+  "Get user of the connection to the remote python interpreter."
+  (tramp-file-name-user (tramp-dissect-file-name (pythonic-aliased-path default-directory))))
+
+(defun pythonic-remote-host ()
+  "Get host of the connection to the remote python interpreter."
+  (let ((hostname (tramp-file-name-host (tramp-dissect-file-name (pythonic-aliased-path default-directory)))))
+    (replace-regexp-in-string "#.*\\'" "" hostname)))
+
+(defun pythonic-remote-port ()
+  "Get port of the connection to the remote python interpreter."
+  (let ((port (tramp-file-name-port (tramp-dissect-file-name (pythonic-aliased-path default-directory)))))
+    ;; In Emacs 25, `tramp-file-name-port' returns number,
+    ;; in Emacs 26, it returns string. This condition makes them compatible.
+    (if (stringp port)
+        (string-to-number port)
+      port)))
+
+
+;;; File names.
+
+(defvar pythonic-directory-aliases nil)
+
+(defun pythonic-aliased-path (path)
+  "Get aliased PATH."
+  (let ((alias-tuple (cl-find-if
+                      (lambda (it)
+                        (or (f-same-p (car it) path)
+                            (f-ancestor-of-p (car it) path)))
+                      pythonic-directory-aliases)))
+    (if (null alias-tuple)
+        path
+      (f-join (cadr alias-tuple)
+              (f-relative path (car alias-tuple))))))
+
+(defun pythonic-unaliased-path (alias)
+  "Get real path from ALIAS."
+  (let ((alias-tuple (cl-find-if
+                      (lambda (it)
+                        (or (f-same-p (cadr it) alias)
+                            (f-ancestor-of-p (cadr it) alias)))
+                      pythonic-directory-aliases)))
+    (if (null alias-tuple)
+        alias
+      (f-join (car alias-tuple)
+              (f-relative alias (cadr alias-tuple))))))
+
+(defun pythonic-has-alias-p (path)
+  "Check if given PATH has alias."
+  (not (null (cl-find-if
+              (lambda (it)
+                (or (f-same-p (car it) path)
+                    (f-ancestor-of-p (car it) path)))
+              pythonic-directory-aliases))))
+
+(defun pythonic-python-readable-file-name (filename)
+  "Emacs to Python FILENAME conversion.
+Take FILENAME from the perspective of the localhost and translate
+it to the FILENAME Python process can read.  Python can be
+running locally or remotely.  FILENAME can have local or tramp
+format.  Result will have local format."
+  (let ((alias (pythonic-aliased-path (expand-file-name filename))))
+    (if (tramp-tramp-file-p alias)
+        (tramp-file-name-localname (tramp-dissect-file-name alias))
+      alias)))
+
+(defun pythonic-emacs-readable-file-name (filename)
+  "Python to Emacs FILENAME conversion.
+Take FILENAME from the perspective of the python interpreter and
+translate it to the FILENAME Emacs `find-file' command can
+understand.  Python can be running locally or remotely.  FILENAME
+should have local format.  Result can have local or tramp
+format."
+  (when (tramp-tramp-file-p filename)
+    (error "%s can not be tramp path" filename))
+  (if (pythonic-remote-p)
+      (let* ((directory (pythonic-aliased-path default-directory))
+             (connection (substring directory 0
+                                    (- (length directory)
+                                       (length (tramp-file-name-localname (tramp-dissect-file-name directory)))))))
+        (pythonic-unaliased-path (concat connection filename)))
+    filename))
+
+
+;;; Docker Compose.
+
+(defcustom pythonic-docker-compose-filename "docker-compose.yml"
+  "File name of the docker-compose project file."
+  :type 'string
+  :safe 'stringp)
+
+(defcustom pythonic-docker-compose-service-name nil
+  "Name of the default service to execute commands."
+  :type 'string
+  :safe 'stringp)
+
+(defvar pythonic-read-docker-compose-file-code "
+from __future__ import print_function
+import json, sys, yaml
+print(json.dumps(yaml.safe_load(open(sys.argv[-1], 'r'))))
+")
+
+(defun pythonic-get-docker-compose-project ()
+  "Get directory where `pythonic-docker-compose-filename' is present."
+  (let ((project (locate-dominating-file default-directory pythonic-docker-compose-filename)))
+    (when project
+      (f-full project))))
+
+(defun pythonic-get-docker-compose-filename (project)
+  "Get full path to the docker-compose PROJECT configuration file."
+  (f-join project pythonic-docker-compose-filename))
+
+(defun pythonic-read-docker-compose-file (filename)
+  "Read docker-compose project configuration FILENAME."
+  (let ((json-key-type 'string)
+        (json-array-type 'list))
+    (json-read-from-string
+     (with-output-to-string
+       (with-current-buffer
+           standard-output
+         (call-process "python" nil t nil "-c" pythonic-read-docker-compose-file-code filename))))))
+
+(defun pythonic-get-docker-compose-volumes (struct)
+  "Get docker volume list from the compose STRUCT."
+  (let (volumes)
+    (dolist (service (cdr (assoc "services" struct)))
+      (dolist (volume (cdr (assoc "volumes" service)))
+        (when (s-starts-with-p "." volume)
+          (push (cons (car service) (s-split ":" volume)) volumes))))
+    volumes))
+
+(defun pythonic-get-docker-compose-container (filename service)
+  "Get container name from the FILENAME project for SERVICE name."
+  (s-trim
+   ;; FIXME:
+   ;;
+   ;; It is possible to have many running containers for given
+   ;; service.
+   ;;
+   ;; Use container name, not the hash.  This way we can survive
+   ;; service recreation.
+   (with-output-to-string
+     (with-current-buffer
+         standard-output
+       (call-process "docker-compose" nil t nil
+                     "--file" filename "ps" "--quiet" service)))))
+
+(defun pythonic-set-docker-compose-alias ()
+  "Build alias string for current docker-compose project."
+  (hack-dir-local-variables-non-file-buffer)
+  (unless
+      (or (tramp-tramp-file-p default-directory)
+          (pythonic-has-alias-p default-directory))
+    (let ((project (pythonic-get-docker-compose-project)))
+      (when project
+        (let* ((filename (pythonic-get-docker-compose-filename project))
+               (struct (pythonic-read-docker-compose-file filename))
+               (volumes (pythonic-get-docker-compose-volumes struct))
+               ;; FIXME: Each service can have many volumes.  It
+               ;; should appears once in the selection and all volumes
+               ;; should be added to the alias list.
+               (volume (if (< 1 (length volumes))
+                             (assoc
+                              (if pythonic-docker-compose-service-name
+                                  pythonic-docker-compose-service-name
+                                (completing-read "Service: " (mapcar #'car volumes) nil t))
+                              volumes)
+                         (car volumes)))
+               (service (car volume))
+               (sub-project (f-join project (cadr volume)))
+               (mount (caddr volume))
+               (container (pythonic-get-docker-compose-container filename service))
+               ;; FIXME: Get actual user for the connection string.
+               (connection (format "/docker:root@%s:%s" container mount))
+               (alias (list sub-project connection)))
+          (unless (s-blank-p container)
+            (push alias pythonic-directory-aliases))
+          alias)))))
+
+
+;;; Processes.
+
+(defvar pythonic-interpreter python-shell-interpreter
+  "Interpreter to use for pythonic process calls.")
+
+(cl-defun pythonic-call-process (&key file buffer display args cwd)
+  "Pythonic wrapper around `call-process'.
+
+FILE is the input file. BUFFER is the output destination. DISPLAY
+specifies to redisplay BUFFER on new output. ARGS is the list of
+
+arguments passed to `call-process'. CWD will be working directory
+for running process."
+  (let ((default-directory (pythonic-aliased-path (or cwd default-directory))))
+    (python-shell-with-environment
+      (apply #'process-file pythonic-interpreter file buffer display args))))
+
+(cl-defun pythonic-start-process (&key process buffer args cwd filter sentinel (query-on-exit t))
+  "Pythonic wrapper around `start-process'.
+
+PROCESS is a name of the created process. BUFFER is a output
+destination. ARGS are the list of args passed to
+`start-process'. CWD will be working directory for running
+process.  FILTER must be a symbol of process filter function if
+necessary.  SENTINEL must be a symbol of process sentinel
+function if necessary.  QUERY-ON-EXIT will be corresponding
+process flag."
+  (let ((default-directory (pythonic-aliased-path (or cwd default-directory))))
+    (python-shell-with-environment
+      (let ((process (apply #'start-file-process process buffer pythonic-interpreter args)))
+        (when filter
+          (set-process-filter process filter))
+        (when sentinel
+          (set-process-sentinel process sentinel))
+        (set-process-query-on-exit-flag process query-on-exit)
+        process))))
+
+
+;;; Commands.
+
+;;;###autoload
+(defun pythonic-activate (virtualenv)
+  "Activate python VIRTUALENV."
+  (interactive "DEnv: ")
+  (setq python-shell-virtualenv-root (pythonic-python-readable-file-name virtualenv)))
+
+;;;###autoload
+(defun pythonic-deactivate ()
+  "Deactivate python virtual environment."
+  (interactive)
+  (setq python-shell-virtualenv-root nil))
+
+(provide 'pythonic)
+
+;;; pythonic.el ends here
diff --git a/lisp/rainbow-mode.el b/lisp/rainbow-mode.el
new file mode 100644
index 00000000..ed2c7d25
--- /dev/null
+++ b/lisp/rainbow-mode.el
@@ -0,0 +1,1373 @@
+;;; rainbow-mode.el --- Colorize color names in buffers
+
+;; Copyright (C) 2010-2019 Free Software Foundation, Inc
+
+;; Author: Julien Danjou 
+;; Keywords: faces
+;; Version: 1.0.4
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 Emacs 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 GNU Emacs.  If not, see .
+
+;;; Commentary:
+;;
+;; This minor mode sets background color to strings that match color
+;; names, e.g. #0000ff is displayed in white with a blue background.
+;;
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'regexp-opt)
+(require 'faces)
+(require 'color)
+
+(unless (require 'xterm-color nil t)
+  (require 'ansi-color))
+
+(defgroup rainbow nil
+  "Show color strings with a background color."
+  :tag "Rainbow"
+  :group 'help)
+
+;;; Hexadecimal colors
+
+(defvar rainbow-hexadecimal-colors-font-lock-keywords
+  '(("[^&]\\(#\\(?:[0-9a-fA-F]\\{3\\}\\)+\\{1,4\\}\\)"
+     (1 (rainbow-colorize-itself 1)))
+    ("^\\(#\\(?:[0-9a-fA-F]\\{3\\}\\)+\\{1,4\\}\\)"
+     (0 (rainbow-colorize-itself)))
+    ("[Rr][Gg][Bb]:[0-9a-fA-F]\\{1,4\\}/[0-9a-fA-F]\\{1,4\\}/[0-9a-fA-F]\\{1,4\\}"
+     (0 (rainbow-colorize-itself)))
+    ("[Rr][Gg][Bb][Ii]:[0-9.]+/[0-9.]+/[0-9.]+"
+     (0 (rainbow-colorize-itself)))
+    ("\\(?:[Cc][Ii][Ee]\\(?:[Xx][Yy][Zz]\\|[Uu][Vv][Yy]\\|[Xx][Yy][Yy]\\|[Ll][Aa][Bb]\\|[Ll][Uu][Vv]\\)\\|[Tt][Ee][Kk][Hh][Vv][Cc]\\):[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?/[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?/[+-]?[0-9.]+\\(?:[Ee][+-]?[0-9]+\\)?"
+     (0 (rainbow-colorize-itself))))
+  "Font-lock keywords to add for hexadecimal colors.")
+
+;;; rgb() colors
+
+(defvar rainbow-html-rgb-colors-font-lock-keywords
+  '(("rgb(\s*\\([0-9]\\{1,3\\}\\(?:\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*)"
+     (0 (rainbow-colorize-rgb)))
+    ("rgba(\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\\.[0-9]\\)?\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+     (0 (rainbow-colorize-rgb)))
+    ("hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)"
+     (0 (rainbow-colorize-hsl)))
+    ("hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)"
+     (0 (rainbow-colorize-hsl))))
+  "Font-lock keywords to add for RGB colors.")
+
+;;; HTML colors
+
+(defvar rainbow-html-colors-font-lock-keywords nil
+  "Font-lock keywords to add for HTML colors.")
+(make-variable-buffer-local 'rainbow-html-colors-font-lock-keywords)
+
+(defcustom rainbow-html-colors-alist
+  '(("AliceBlue" . "#F0F8FF")
+    ("AntiqueWhite" . "#FAEBD7")
+    ("Aqua" . "#00FFFF")
+    ("Aquamarine" . "#7FFFD4")
+    ("Azure" . "#F0FFFF")
+    ("Beige" . "#F5F5DC")
+    ("Bisque" . "#FFE4C4")
+    ("Black" . "#000000")
+    ("BlanchedAlmond" . "#FFEBCD")
+    ("Blue" . "#0000FF")
+    ("BlueViolet" . "#8A2BE2")
+    ("Brown" . "#A52A2A")
+    ("BurlyWood" . "#DEB887")
+    ("CadetBlue" . "#5F9EA0")
+    ("Chartreuse" . "#7FFF00")
+    ("Chocolate" . "#D2691E")
+    ("Coral" . "#FF7F50")
+    ("CornflowerBlue" . "#6495ED")
+    ("Cornsilk" . "#FFF8DC")
+    ("Crimson" . "#DC143C")
+    ("Cyan" . "#00FFFF")
+    ("DarkBlue" . "#00008B")
+    ("DarkCyan" . "#008B8B")
+    ("DarkGoldenRod" . "#B8860B")
+    ("DarkGray" . "#A9A9A9")
+    ("DarkGrey" . "#A9A9A9")
+    ("DarkGreen" . "#006400")
+    ("DarkKhaki" . "#BDB76B")
+    ("DarkMagenta" . "#8B008B")
+    ("DarkOliveGreen" . "#556B2F")
+    ("Darkorange" . "#FF8C00")
+    ("DarkOrchid" . "#9932CC")
+    ("DarkRed" . "#8B0000")
+    ("DarkSalmon" . "#E9967A")
+    ("DarkSeaGreen" . "#8FBC8F")
+    ("DarkSlateBlue" . "#483D8B")
+    ("DarkSlateGray" . "#2F4F4F")
+    ("DarkSlateGrey" . "#2F4F4F")
+    ("DarkTurquoise" . "#00CED1")
+    ("DarkViolet" . "#9400D3")
+    ("DeepPink" . "#FF1493")
+    ("DeepSkyBlue" . "#00BFFF")
+    ("DimGray" . "#696969")
+    ("DimGrey" . "#696969")
+    ("DodgerBlue" . "#1E90FF")
+    ("FireBrick" . "#B22222")
+    ("FloralWhite" . "#FFFAF0")
+    ("ForestGreen" . "#228B22")
+    ("Fuchsia" . "#FF00FF")
+    ("Gainsboro" . "#DCDCDC")
+    ("GhostWhite" . "#F8F8FF")
+    ("Gold" . "#FFD700")
+    ("GoldenRod" . "#DAA520")
+    ("Gray" . "#808080")
+    ("Grey" . "#808080")
+    ("Green" . "#008000")
+    ("GreenYellow" . "#ADFF2F")
+    ("HoneyDew" . "#F0FFF0")
+    ("HotPink" . "#FF69B4")
+    ("IndianRed" . "#CD5C5C")
+    ("Indigo" . "#4B0082")
+    ("Ivory" . "#FFFFF0")
+    ("Khaki" . "#F0E68C")
+    ("Lavender" . "#E6E6FA")
+    ("LavenderBlush" . "#FFF0F5")
+    ("LawnGreen" . "#7CFC00")
+    ("LemonChiffon" . "#FFFACD")
+    ("LightBlue" . "#ADD8E6")
+    ("LightCoral" . "#F08080")
+    ("LightCyan" . "#E0FFFF")
+    ("LightGoldenRodYellow" . "#FAFAD2")
+    ("LightGray" . "#D3D3D3")
+    ("LightGrey" . "#D3D3D3")
+    ("LightGreen" . "#90EE90")
+    ("LightPink" . "#FFB6C1")
+    ("LightSalmon" . "#FFA07A")
+    ("LightSeaGreen" . "#20B2AA")
+    ("LightSkyBlue" . "#87CEFA")
+    ("LightSlateGray" . "#778899")
+    ("LightSlateGrey" . "#778899")
+    ("LightSteelBlue" . "#B0C4DE")
+    ("LightYellow" . "#FFFFE0")
+    ("Lime" . "#00FF00")
+    ("LimeGreen" . "#32CD32")
+    ("Linen" . "#FAF0E6")
+    ("Magenta" . "#FF00FF")
+    ("Maroon" . "#800000")
+    ("MediumAquaMarine" . "#66CDAA")
+    ("MediumBlue" . "#0000CD")
+    ("MediumOrchid" . "#BA55D3")
+    ("MediumPurple" . "#9370D8")
+    ("MediumSeaGreen" . "#3CB371")
+    ("MediumSlateBlue" . "#7B68EE")
+    ("MediumSpringGreen" . "#00FA9A")
+    ("MediumTurquoise" . "#48D1CC")
+    ("MediumVioletRed" . "#C71585")
+    ("MidnightBlue" . "#191970")
+    ("MintCream" . "#F5FFFA")
+    ("MistyRose" . "#FFE4E1")
+    ("Moccasin" . "#FFE4B5")
+    ("NavajoWhite" . "#FFDEAD")
+    ("Navy" . "#000080")
+    ("OldLace" . "#FDF5E6")
+    ("Olive" . "#808000")
+    ("OliveDrab" . "#6B8E23")
+    ("Orange" . "#FFA500")
+    ("OrangeRed" . "#FF4500")
+    ("Orchid" . "#DA70D6")
+    ("PaleGoldenRod" . "#EEE8AA")
+    ("PaleGreen" . "#98FB98")
+    ("PaleTurquoise" . "#AFEEEE")
+    ("PaleVioletRed" . "#D87093")
+    ("PapayaWhip" . "#FFEFD5")
+    ("PeachPuff" . "#FFDAB9")
+    ("Peru" . "#CD853F")
+    ("Pink" . "#FFC0CB")
+    ("Plum" . "#DDA0DD")
+    ("PowderBlue" . "#B0E0E6")
+    ("Purple" . "#800080")
+    ("Red" . "#FF0000")
+    ("RosyBrown" . "#BC8F8F")
+    ("RoyalBlue" . "#4169E1")
+    ("SaddleBrown" . "#8B4513")
+    ("Salmon" . "#FA8072")
+    ("SandyBrown" . "#F4A460")
+    ("SeaGreen" . "#2E8B57")
+    ("SeaShell" . "#FFF5EE")
+    ("Sienna" . "#A0522D")
+    ("Silver" . "#C0C0C0")
+    ("SkyBlue" . "#87CEEB")
+    ("SlateBlue" . "#6A5ACD")
+    ("SlateGray" . "#708090")
+    ("SlateGrey" . "#708090")
+    ("Snow" . "#FFFAFA")
+    ("SpringGreen" . "#00FF7F")
+    ("SteelBlue" . "#4682B4")
+    ("Tan" . "#D2B48C")
+    ("Teal" . "#008080")
+    ("Thistle" . "#D8BFD8")
+    ("Tomato" . "#FF6347")
+    ("Turquoise" . "#40E0D0")
+    ("Violet" . "#EE82EE")
+    ("Wheat" . "#F5DEB3")
+    ("White" . "#FFFFFF")
+    ("WhiteSmoke" . "#F5F5F5")
+    ("Yellow" . "#FFFF00")
+    ("YellowGreen" . "#9ACD32"))
+  "Alist of HTML colors.
+Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR)."
+  :type 'alist
+  :group 'rainbow)
+
+(defcustom rainbow-html-colors-major-mode-list
+  '(html-mode css-mode php-mode nxml-mode xml-mode)
+  "List of major mode where HTML colors are enabled when
+`rainbow-html-colors' is set to auto."
+  :type '(repeat (symbol :tag "Major-Mode"))
+  :group 'rainbow)
+
+(defcustom rainbow-html-colors 'auto
+  "When to enable HTML colors.
+If set to t, the HTML colors will be enabled.  If set to nil, the
+HTML colors will not be enabled.  If set to auto, the HTML colors
+will be enabled if a major mode has been detected from the
+`rainbow-html-colors-major-mode-list'."
+  :type '(choice (symbol :tag "enable in certain modes" auto)
+                 (symbol :tag "enable globally" t)
+                 (symbol :tag "disable" nil))
+  :group 'rainbow)
+
+;;; X colors
+
+(defvar rainbow-x-colors-font-lock-keywords
+  `((,(regexp-opt (x-defined-colors) 'words)
+     (0 (rainbow-colorize-itself))))
+  "Font-lock keywords to add for X colors.")
+
+(defcustom rainbow-x-colors-major-mode-list
+  '(emacs-lisp-mode lisp-interaction-mode c-mode c++-mode java-mode)
+  "List of major mode where X colors are enabled when
+`rainbow-x-colors' is set to auto."
+  :type '(repeat (symbol :tag "Major-Mode"))
+  :group 'rainbow)
+
+(defcustom rainbow-x-colors 'auto
+  "When to enable X colors.
+If set to t, the X colors will be enabled.  If set to nil, the
+X colors will not be enabled.  If set to auto, the X colors
+will be enabled if a major mode has been detected from the
+`rainbow-x-colors-major-mode-list'."
+  :type '(choice (symbol :tag "enable in certain modes" auto)
+                 (symbol :tag "enable globally" t)
+                 (symbol :tag "disable" nil))
+  :group 'rainbow)
+
+;;; LaTeX colors
+
+(defvar rainbow-latex-rgb-colors-font-lock-keywords
+  '(("{rgb}{\\([0-9.]+\\),\s*\\([0-9.]+\\),\s*\\([0-9.]+\\)}"
+     (0 (rainbow-colorize-rgb-float)))
+    ("{RGB}{\\([0-9]\\{1,3\\}\\),\s*\\([0-9]\\{1,3\\}\\),\s*\\([0-9]\\{1,3\\}\\)}"
+     (0 (rainbow-colorize-rgb)))
+    ("{HTML}{\\([0-9A-Fa-f]\\{6\\}\\)}"
+     (0 (rainbow-colorize-hexadecimal-without-sharp))))
+  "Font-lock keywords to add for LaTeX colors.")
+
+(defcustom rainbow-latex-colors-major-mode-list
+  '(latex-mode)
+  "List of major mode where LaTeX colors are enabled when
+`rainbow-x-colors' is set to auto."
+  :type '(repeat (symbol :tag "Major-Mode"))
+  :group 'rainbow)
+
+(defcustom rainbow-latex-colors 'auto
+  "When to enable LaTeX colors.
+If set to t, the LaTeX colors will be enabled. If set to nil, the
+LaTeX colors will not be enabled.  If set to auto, the LaTeX colors
+will be enabled if a major mode has been detected from the
+`rainbow-latex-colors-major-mode-list'."
+  :type '(choice (symbol :tag "enable in certain modes" auto)
+                 (symbol :tag "enable globally" t)
+                 (symbol :tag "disable" nil))
+  :group 'rainbow)
+
+;;; Shell colors
+
+(defvar rainbow-ansi-colors-font-lock-keywords
+  '(("\\(\\\\[eE]\\|\\\\033\\|\\\\x1[bB]\\|\033\\)\\[\\([0-9;]*m\\)"
+     (0 (rainbow-colorize-ansi))))
+  "Font-lock keywords to add for ANSI colors.")
+
+(defcustom rainbow-ansi-colors-major-mode-list
+  '(sh-mode c-mode c++-mode)
+  "List of major mode where ANSI colors are enabled when
+`rainbow-ansi-colors' is set to auto."
+  :type '(repeat (symbol :tag "Major-Mode"))
+  :group 'rainbow)
+
+(defcustom rainbow-ansi-colors 'auto
+  "When to enable ANSI colors.
+If set to t, the ANSI colors will be enabled. If set to nil, the
+ANSI colors will not be enabled.  If set to auto, the ANSI colors
+will be enabled if a major mode has been detected from the
+`rainbow-ansi-colors-major-mode-list'."
+  :type '(choice (symbol :tag "enable in certain modes" auto)
+                 (symbol :tag "enable globally" t)
+                 (symbol :tag "disable" nil))
+  :group 'rainbow)
+
+;;; R colors
+
+(defvar rainbow-r-colors-font-lock-keywords nil
+  "Font-lock keywords to add for R colors.")
+(make-variable-buffer-local 'rainbow-r-colors-font-lock-keywords)
+
+;; use the following code to generate the list in R
+;; output_colors <- function(colors) {for(color in colors) {col <- col2rgb(color); cat(sprintf("(\"%s\" . \"#%02X%02X%02X\")\n",color,col[1],col[2],col[3]));}}
+;; output_colors(colors())
+(defcustom rainbow-r-colors-alist
+  '(("white" . "#FFFFFF")
+    ("aliceblue" . "#F0F8FF")
+    ("antiquewhite" . "#FAEBD7")
+    ("antiquewhite1" . "#FFEFDB")
+    ("antiquewhite2" . "#EEDFCC")
+    ("antiquewhite3" . "#CDC0B0")
+    ("antiquewhite4" . "#8B8378")
+    ("aquamarine" . "#7FFFD4")
+    ("aquamarine1" . "#7FFFD4")
+    ("aquamarine2" . "#76EEC6")
+    ("aquamarine3" . "#66CDAA")
+    ("aquamarine4" . "#458B74")
+    ("azure" . "#F0FFFF")
+    ("azure1" . "#F0FFFF")
+    ("azure2" . "#E0EEEE")
+    ("azure3" . "#C1CDCD")
+    ("azure4" . "#838B8B")
+    ("beige" . "#F5F5DC")
+    ("bisque" . "#FFE4C4")
+    ("bisque1" . "#FFE4C4")
+    ("bisque2" . "#EED5B7")
+    ("bisque3" . "#CDB79E")
+    ("bisque4" . "#8B7D6B")
+    ("black" . "#000000")
+    ("blanchedalmond" . "#FFEBCD")
+    ("blue" . "#0000FF")
+    ("blue1" . "#0000FF")
+    ("blue2" . "#0000EE")
+    ("blue3" . "#0000CD")
+    ("blue4" . "#00008B")
+    ("blueviolet" . "#8A2BE2")
+    ("brown" . "#A52A2A")
+    ("brown1" . "#FF4040")
+    ("brown2" . "#EE3B3B")
+    ("brown3" . "#CD3333")
+    ("brown4" . "#8B2323")
+    ("burlywood" . "#DEB887")
+    ("burlywood1" . "#FFD39B")
+    ("burlywood2" . "#EEC591")
+    ("burlywood3" . "#CDAA7D")
+    ("burlywood4" . "#8B7355")
+    ("cadetblue" . "#5F9EA0")
+    ("cadetblue1" . "#98F5FF")
+    ("cadetblue2" . "#8EE5EE")
+    ("cadetblue3" . "#7AC5CD")
+    ("cadetblue4" . "#53868B")
+    ("chartreuse" . "#7FFF00")
+    ("chartreuse1" . "#7FFF00")
+    ("chartreuse2" . "#76EE00")
+    ("chartreuse3" . "#66CD00")
+    ("chartreuse4" . "#458B00")
+    ("chocolate" . "#D2691E")
+    ("chocolate1" . "#FF7F24")
+    ("chocolate2" . "#EE7621")
+    ("chocolate3" . "#CD661D")
+    ("chocolate4" . "#8B4513")
+    ("coral" . "#FF7F50")
+    ("coral1" . "#FF7256")
+    ("coral2" . "#EE6A50")
+    ("coral3" . "#CD5B45")
+    ("coral4" . "#8B3E2F")
+    ("cornflowerblue" . "#6495ED")
+    ("cornsilk" . "#FFF8DC")
+    ("cornsilk1" . "#FFF8DC")
+    ("cornsilk2" . "#EEE8CD")
+    ("cornsilk3" . "#CDC8B1")
+    ("cornsilk4" . "#8B8878")
+    ("cyan" . "#00FFFF")
+    ("cyan1" . "#00FFFF")
+    ("cyan2" . "#00EEEE")
+    ("cyan3" . "#00CDCD")
+    ("cyan4" . "#008B8B")
+    ("darkblue" . "#00008B")
+    ("darkcyan" . "#008B8B")
+    ("darkgoldenrod" . "#B8860B")
+    ("darkgoldenrod1" . "#FFB90F")
+    ("darkgoldenrod2" . "#EEAD0E")
+    ("darkgoldenrod3" . "#CD950C")
+    ("darkgoldenrod4" . "#8B6508")
+    ("darkgray" . "#A9A9A9")
+    ("darkgreen" . "#006400")
+    ("darkgrey" . "#A9A9A9")
+    ("darkkhaki" . "#BDB76B")
+    ("darkmagenta" . "#8B008B")
+    ("darkolivegreen" . "#556B2F")
+    ("darkolivegreen1" . "#CAFF70")
+    ("darkolivegreen2" . "#BCEE68")
+    ("darkolivegreen3" . "#A2CD5A")
+    ("darkolivegreen4" . "#6E8B3D")
+    ("darkorange" . "#FF8C00")
+    ("darkorange1" . "#FF7F00")
+    ("darkorange2" . "#EE7600")
+    ("darkorange3" . "#CD6600")
+    ("darkorange4" . "#8B4500")
+    ("darkorchid" . "#9932CC")
+    ("darkorchid1" . "#BF3EFF")
+    ("darkorchid2" . "#B23AEE")
+    ("darkorchid3" . "#9A32CD")
+    ("darkorchid4" . "#68228B")
+    ("darkred" . "#8B0000")
+    ("darksalmon" . "#E9967A")
+    ("darkseagreen" . "#8FBC8F")
+    ("darkseagreen1" . "#C1FFC1")
+    ("darkseagreen2" . "#B4EEB4")
+    ("darkseagreen3" . "#9BCD9B")
+    ("darkseagreen4" . "#698B69")
+    ("darkslateblue" . "#483D8B")
+    ("darkslategray" . "#2F4F4F")
+    ("darkslategray1" . "#97FFFF")
+    ("darkslategray2" . "#8DEEEE")
+    ("darkslategray3" . "#79CDCD")
+    ("darkslategray4" . "#528B8B")
+    ("darkslategrey" . "#2F4F4F")
+    ("darkturquoise" . "#00CED1")
+    ("darkviolet" . "#9400D3")
+    ("deeppink" . "#FF1493")
+    ("deeppink1" . "#FF1493")
+    ("deeppink2" . "#EE1289")
+    ("deeppink3" . "#CD1076")
+    ("deeppink4" . "#8B0A50")
+    ("deepskyblue" . "#00BFFF")
+    ("deepskyblue1" . "#00BFFF")
+    ("deepskyblue2" . "#00B2EE")
+    ("deepskyblue3" . "#009ACD")
+    ("deepskyblue4" . "#00688B")
+    ("dimgray" . "#696969")
+    ("dimgrey" . "#696969")
+    ("dodgerblue" . "#1E90FF")
+    ("dodgerblue1" . "#1E90FF")
+    ("dodgerblue2" . "#1C86EE")
+    ("dodgerblue3" . "#1874CD")
+    ("dodgerblue4" . "#104E8B")
+    ("firebrick" . "#B22222")
+    ("firebrick1" . "#FF3030")
+    ("firebrick2" . "#EE2C2C")
+    ("firebrick3" . "#CD2626")
+    ("firebrick4" . "#8B1A1A")
+    ("floralwhite" . "#FFFAF0")
+    ("forestgreen" . "#228B22")
+    ("gainsboro" . "#DCDCDC")
+    ("ghostwhite" . "#F8F8FF")
+    ("gold" . "#FFD700")
+    ("gold1" . "#FFD700")
+    ("gold2" . "#EEC900")
+    ("gold3" . "#CDAD00")
+    ("gold4" . "#8B7500")
+    ("goldenrod" . "#DAA520")
+    ("goldenrod1" . "#FFC125")
+    ("goldenrod2" . "#EEB422")
+    ("goldenrod3" . "#CD9B1D")
+    ("goldenrod4" . "#8B6914")
+    ("gray" . "#BEBEBE")
+    ("gray0" . "#000000")
+    ("gray1" . "#030303")
+    ("gray2" . "#050505")
+    ("gray3" . "#080808")
+    ("gray4" . "#0A0A0A")
+    ("gray5" . "#0D0D0D")
+    ("gray6" . "#0F0F0F")
+    ("gray7" . "#121212")
+    ("gray8" . "#141414")
+    ("gray9" . "#171717")
+    ("gray10" . "#1A1A1A")
+    ("gray11" . "#1C1C1C")
+    ("gray12" . "#1F1F1F")
+    ("gray13" . "#212121")
+    ("gray14" . "#242424")
+    ("gray15" . "#262626")
+    ("gray16" . "#292929")
+    ("gray17" . "#2B2B2B")
+    ("gray18" . "#2E2E2E")
+    ("gray19" . "#303030")
+    ("gray20" . "#333333")
+    ("gray21" . "#363636")
+    ("gray22" . "#383838")
+    ("gray23" . "#3B3B3B")
+    ("gray24" . "#3D3D3D")
+    ("gray25" . "#404040")
+    ("gray26" . "#424242")
+    ("gray27" . "#454545")
+    ("gray28" . "#474747")
+    ("gray29" . "#4A4A4A")
+    ("gray30" . "#4D4D4D")
+    ("gray31" . "#4F4F4F")
+    ("gray32" . "#525252")
+    ("gray33" . "#545454")
+    ("gray34" . "#575757")
+    ("gray35" . "#595959")
+    ("gray36" . "#5C5C5C")
+    ("gray37" . "#5E5E5E")
+    ("gray38" . "#616161")
+    ("gray39" . "#636363")
+    ("gray40" . "#666666")
+    ("gray41" . "#696969")
+    ("gray42" . "#6B6B6B")
+    ("gray43" . "#6E6E6E")
+    ("gray44" . "#707070")
+    ("gray45" . "#737373")
+    ("gray46" . "#757575")
+    ("gray47" . "#787878")
+    ("gray48" . "#7A7A7A")
+    ("gray49" . "#7D7D7D")
+    ("gray50" . "#7F7F7F")
+    ("gray51" . "#828282")
+    ("gray52" . "#858585")
+    ("gray53" . "#878787")
+    ("gray54" . "#8A8A8A")
+    ("gray55" . "#8C8C8C")
+    ("gray56" . "#8F8F8F")
+    ("gray57" . "#919191")
+    ("gray58" . "#949494")
+    ("gray59" . "#969696")
+    ("gray60" . "#999999")
+    ("gray61" . "#9C9C9C")
+    ("gray62" . "#9E9E9E")
+    ("gray63" . "#A1A1A1")
+    ("gray64" . "#A3A3A3")
+    ("gray65" . "#A6A6A6")
+    ("gray66" . "#A8A8A8")
+    ("gray67" . "#ABABAB")
+    ("gray68" . "#ADADAD")
+    ("gray69" . "#B0B0B0")
+    ("gray70" . "#B3B3B3")
+    ("gray71" . "#B5B5B5")
+    ("gray72" . "#B8B8B8")
+    ("gray73" . "#BABABA")
+    ("gray74" . "#BDBDBD")
+    ("gray75" . "#BFBFBF")
+    ("gray76" . "#C2C2C2")
+    ("gray77" . "#C4C4C4")
+    ("gray78" . "#C7C7C7")
+    ("gray79" . "#C9C9C9")
+    ("gray80" . "#CCCCCC")
+    ("gray81" . "#CFCFCF")
+    ("gray82" . "#D1D1D1")
+    ("gray83" . "#D4D4D4")
+    ("gray84" . "#D6D6D6")
+    ("gray85" . "#D9D9D9")
+    ("gray86" . "#DBDBDB")
+    ("gray87" . "#DEDEDE")
+    ("gray88" . "#E0E0E0")
+    ("gray89" . "#E3E3E3")
+    ("gray90" . "#E5E5E5")
+    ("gray91" . "#E8E8E8")
+    ("gray92" . "#EBEBEB")
+    ("gray93" . "#EDEDED")
+    ("gray94" . "#F0F0F0")
+    ("gray95" . "#F2F2F2")
+    ("gray96" . "#F5F5F5")
+    ("gray97" . "#F7F7F7")
+    ("gray98" . "#FAFAFA")
+    ("gray99" . "#FCFCFC")
+    ("gray100" . "#FFFFFF")
+    ("green" . "#00FF00")
+    ("green1" . "#00FF00")
+    ("green2" . "#00EE00")
+    ("green3" . "#00CD00")
+    ("green4" . "#008B00")
+    ("greenyellow" . "#ADFF2F")
+    ("grey" . "#BEBEBE")
+    ("grey0" . "#000000")
+    ("grey1" . "#030303")
+    ("grey2" . "#050505")
+    ("grey3" . "#080808")
+    ("grey4" . "#0A0A0A")
+    ("grey5" . "#0D0D0D")
+    ("grey6" . "#0F0F0F")
+    ("grey7" . "#121212")
+    ("grey8" . "#141414")
+    ("grey9" . "#171717")
+    ("grey10" . "#1A1A1A")
+    ("grey11" . "#1C1C1C")
+    ("grey12" . "#1F1F1F")
+    ("grey13" . "#212121")
+    ("grey14" . "#242424")
+    ("grey15" . "#262626")
+    ("grey16" . "#292929")
+    ("grey17" . "#2B2B2B")
+    ("grey18" . "#2E2E2E")
+    ("grey19" . "#303030")
+    ("grey20" . "#333333")
+    ("grey21" . "#363636")
+    ("grey22" . "#383838")
+    ("grey23" . "#3B3B3B")
+    ("grey24" . "#3D3D3D")
+    ("grey25" . "#404040")
+    ("grey26" . "#424242")
+    ("grey27" . "#454545")
+    ("grey28" . "#474747")
+    ("grey29" . "#4A4A4A")
+    ("grey30" . "#4D4D4D")
+    ("grey31" . "#4F4F4F")
+    ("grey32" . "#525252")
+    ("grey33" . "#545454")
+    ("grey34" . "#575757")
+    ("grey35" . "#595959")
+    ("grey36" . "#5C5C5C")
+    ("grey37" . "#5E5E5E")
+    ("grey38" . "#616161")
+    ("grey39" . "#636363")
+    ("grey40" . "#666666")
+    ("grey41" . "#696969")
+    ("grey42" . "#6B6B6B")
+    ("grey43" . "#6E6E6E")
+    ("grey44" . "#707070")
+    ("grey45" . "#737373")
+    ("grey46" . "#757575")
+    ("grey47" . "#787878")
+    ("grey48" . "#7A7A7A")
+    ("grey49" . "#7D7D7D")
+    ("grey50" . "#7F7F7F")
+    ("grey51" . "#828282")
+    ("grey52" . "#858585")
+    ("grey53" . "#878787")
+    ("grey54" . "#8A8A8A")
+    ("grey55" . "#8C8C8C")
+    ("grey56" . "#8F8F8F")
+    ("grey57" . "#919191")
+    ("grey58" . "#949494")
+    ("grey59" . "#969696")
+    ("grey60" . "#999999")
+    ("grey61" . "#9C9C9C")
+    ("grey62" . "#9E9E9E")
+    ("grey63" . "#A1A1A1")
+    ("grey64" . "#A3A3A3")
+    ("grey65" . "#A6A6A6")
+    ("grey66" . "#A8A8A8")
+    ("grey67" . "#ABABAB")
+    ("grey68" . "#ADADAD")
+    ("grey69" . "#B0B0B0")
+    ("grey70" . "#B3B3B3")
+    ("grey71" . "#B5B5B5")
+    ("grey72" . "#B8B8B8")
+    ("grey73" . "#BABABA")
+    ("grey74" . "#BDBDBD")
+    ("grey75" . "#BFBFBF")
+    ("grey76" . "#C2C2C2")
+    ("grey77" . "#C4C4C4")
+    ("grey78" . "#C7C7C7")
+    ("grey79" . "#C9C9C9")
+    ("grey80" . "#CCCCCC")
+    ("grey81" . "#CFCFCF")
+    ("grey82" . "#D1D1D1")
+    ("grey83" . "#D4D4D4")
+    ("grey84" . "#D6D6D6")
+    ("grey85" . "#D9D9D9")
+    ("grey86" . "#DBDBDB")
+    ("grey87" . "#DEDEDE")
+    ("grey88" . "#E0E0E0")
+    ("grey89" . "#E3E3E3")
+    ("grey90" . "#E5E5E5")
+    ("grey91" . "#E8E8E8")
+    ("grey92" . "#EBEBEB")
+    ("grey93" . "#EDEDED")
+    ("grey94" . "#F0F0F0")
+    ("grey95" . "#F2F2F2")
+    ("grey96" . "#F5F5F5")
+    ("grey97" . "#F7F7F7")
+    ("grey98" . "#FAFAFA")
+    ("grey99" . "#FCFCFC")
+    ("grey100" . "#FFFFFF")
+    ("honeydew" . "#F0FFF0")
+    ("honeydew1" . "#F0FFF0")
+    ("honeydew2" . "#E0EEE0")
+    ("honeydew3" . "#C1CDC1")
+    ("honeydew4" . "#838B83")
+    ("hotpink" . "#FF69B4")
+    ("hotpink1" . "#FF6EB4")
+    ("hotpink2" . "#EE6AA7")
+    ("hotpink3" . "#CD6090")
+    ("hotpink4" . "#8B3A62")
+    ("indianred" . "#CD5C5C")
+    ("indianred1" . "#FF6A6A")
+    ("indianred2" . "#EE6363")
+    ("indianred3" . "#CD5555")
+    ("indianred4" . "#8B3A3A")
+    ("ivory" . "#FFFFF0")
+    ("ivory1" . "#FFFFF0")
+    ("ivory2" . "#EEEEE0")
+    ("ivory3" . "#CDCDC1")
+    ("ivory4" . "#8B8B83")
+    ("khaki" . "#F0E68C")
+    ("khaki1" . "#FFF68F")
+    ("khaki2" . "#EEE685")
+    ("khaki3" . "#CDC673")
+    ("khaki4" . "#8B864E")
+    ("lavender" . "#E6E6FA")
+    ("lavenderblush" . "#FFF0F5")
+    ("lavenderblush1" . "#FFF0F5")
+    ("lavenderblush2" . "#EEE0E5")
+    ("lavenderblush3" . "#CDC1C5")
+    ("lavenderblush4" . "#8B8386")
+    ("lawngreen" . "#7CFC00")
+    ("lemonchiffon" . "#FFFACD")
+    ("lemonchiffon1" . "#FFFACD")
+    ("lemonchiffon2" . "#EEE9BF")
+    ("lemonchiffon3" . "#CDC9A5")
+    ("lemonchiffon4" . "#8B8970")
+    ("lightblue" . "#ADD8E6")
+    ("lightblue1" . "#BFEFFF")
+    ("lightblue2" . "#B2DFEE")
+    ("lightblue3" . "#9AC0CD")
+    ("lightblue4" . "#68838B")
+    ("lightcoral" . "#F08080")
+    ("lightcyan" . "#E0FFFF")
+    ("lightcyan1" . "#E0FFFF")
+    ("lightcyan2" . "#D1EEEE")
+    ("lightcyan3" . "#B4CDCD")
+    ("lightcyan4" . "#7A8B8B")
+    ("lightgoldenrod" . "#EEDD82")
+    ("lightgoldenrod1" . "#FFEC8B")
+    ("lightgoldenrod2" . "#EEDC82")
+    ("lightgoldenrod3" . "#CDBE70")
+    ("lightgoldenrod4" . "#8B814C")
+    ("lightgoldenrodyellow" . "#FAFAD2")
+    ("lightgray" . "#D3D3D3")
+    ("lightgreen" . "#90EE90")
+    ("lightgrey" . "#D3D3D3")
+    ("lightpink" . "#FFB6C1")
+    ("lightpink1" . "#FFAEB9")
+    ("lightpink2" . "#EEA2AD")
+    ("lightpink3" . "#CD8C95")
+    ("lightpink4" . "#8B5F65")
+    ("lightsalmon" . "#FFA07A")
+    ("lightsalmon1" . "#FFA07A")
+    ("lightsalmon2" . "#EE9572")
+    ("lightsalmon3" . "#CD8162")
+    ("lightsalmon4" . "#8B5742")
+    ("lightseagreen" . "#20B2AA")
+    ("lightskyblue" . "#87CEFA")
+    ("lightskyblue1" . "#B0E2FF")
+    ("lightskyblue2" . "#A4D3EE")
+    ("lightskyblue3" . "#8DB6CD")
+    ("lightskyblue4" . "#607B8B")
+    ("lightslateblue" . "#8470FF")
+    ("lightslategray" . "#778899")
+    ("lightslategrey" . "#778899")
+    ("lightsteelblue" . "#B0C4DE")
+    ("lightsteelblue1" . "#CAE1FF")
+    ("lightsteelblue2" . "#BCD2EE")
+    ("lightsteelblue3" . "#A2B5CD")
+    ("lightsteelblue4" . "#6E7B8B")
+    ("lightyellow" . "#FFFFE0")
+    ("lightyellow1" . "#FFFFE0")
+    ("lightyellow2" . "#EEEED1")
+    ("lightyellow3" . "#CDCDB4")
+    ("lightyellow4" . "#8B8B7A")
+    ("limegreen" . "#32CD32")
+    ("linen" . "#FAF0E6")
+    ("magenta" . "#FF00FF")
+    ("magenta1" . "#FF00FF")
+    ("magenta2" . "#EE00EE")
+    ("magenta3" . "#CD00CD")
+    ("magenta4" . "#8B008B")
+    ("maroon" . "#B03060")
+    ("maroon1" . "#FF34B3")
+    ("maroon2" . "#EE30A7")
+    ("maroon3" . "#CD2990")
+    ("maroon4" . "#8B1C62")
+    ("mediumaquamarine" . "#66CDAA")
+    ("mediumblue" . "#0000CD")
+    ("mediumorchid" . "#BA55D3")
+    ("mediumorchid1" . "#E066FF")
+    ("mediumorchid2" . "#D15FEE")
+    ("mediumorchid3" . "#B452CD")
+    ("mediumorchid4" . "#7A378B")
+    ("mediumpurple" . "#9370DB")
+    ("mediumpurple1" . "#AB82FF")
+    ("mediumpurple2" . "#9F79EE")
+    ("mediumpurple3" . "#8968CD")
+    ("mediumpurple4" . "#5D478B")
+    ("mediumseagreen" . "#3CB371")
+    ("mediumslateblue" . "#7B68EE")
+    ("mediumspringgreen" . "#00FA9A")
+    ("mediumturquoise" . "#48D1CC")
+    ("mediumvioletred" . "#C71585")
+    ("midnightblue" . "#191970")
+    ("mintcream" . "#F5FFFA")
+    ("mistyrose" . "#FFE4E1")
+    ("mistyrose1" . "#FFE4E1")
+    ("mistyrose2" . "#EED5D2")
+    ("mistyrose3" . "#CDB7B5")
+    ("mistyrose4" . "#8B7D7B")
+    ("moccasin" . "#FFE4B5")
+    ("navajowhite" . "#FFDEAD")
+    ("navajowhite1" . "#FFDEAD")
+    ("navajowhite2" . "#EECFA1")
+    ("navajowhite3" . "#CDB38B")
+    ("navajowhite4" . "#8B795E")
+    ("navy" . "#000080")
+    ("navyblue" . "#000080")
+    ("oldlace" . "#FDF5E6")
+    ("olivedrab" . "#6B8E23")
+    ("olivedrab1" . "#C0FF3E")
+    ("olivedrab2" . "#B3EE3A")
+    ("olivedrab3" . "#9ACD32")
+    ("olivedrab4" . "#698B22")
+    ("orange" . "#FFA500")
+    ("orange1" . "#FFA500")
+    ("orange2" . "#EE9A00")
+    ("orange3" . "#CD8500")
+    ("orange4" . "#8B5A00")
+    ("orangered" . "#FF4500")
+    ("orangered1" . "#FF4500")
+    ("orangered2" . "#EE4000")
+    ("orangered3" . "#CD3700")
+    ("orangered4" . "#8B2500")
+    ("orchid" . "#DA70D6")
+    ("orchid1" . "#FF83FA")
+    ("orchid2" . "#EE7AE9")
+    ("orchid3" . "#CD69C9")
+    ("orchid4" . "#8B4789")
+    ("palegoldenrod" . "#EEE8AA")
+    ("palegreen" . "#98FB98")
+    ("palegreen1" . "#9AFF9A")
+    ("palegreen2" . "#90EE90")
+    ("palegreen3" . "#7CCD7C")
+    ("palegreen4" . "#548B54")
+    ("paleturquoise" . "#AFEEEE")
+    ("paleturquoise1" . "#BBFFFF")
+    ("paleturquoise2" . "#AEEEEE")
+    ("paleturquoise3" . "#96CDCD")
+    ("paleturquoise4" . "#668B8B")
+    ("palevioletred" . "#DB7093")
+    ("palevioletred1" . "#FF82AB")
+    ("palevioletred2" . "#EE799F")
+    ("palevioletred3" . "#CD6889")
+    ("palevioletred4" . "#8B475D")
+    ("papayawhip" . "#FFEFD5")
+    ("peachpuff" . "#FFDAB9")
+    ("peachpuff1" . "#FFDAB9")
+    ("peachpuff2" . "#EECBAD")
+    ("peachpuff3" . "#CDAF95")
+    ("peachpuff4" . "#8B7765")
+    ("peru" . "#CD853F")
+    ("pink" . "#FFC0CB")
+    ("pink1" . "#FFB5C5")
+    ("pink2" . "#EEA9B8")
+    ("pink3" . "#CD919E")
+    ("pink4" . "#8B636C")
+    ("plum" . "#DDA0DD")
+    ("plum1" . "#FFBBFF")
+    ("plum2" . "#EEAEEE")
+    ("plum3" . "#CD96CD")
+    ("plum4" . "#8B668B")
+    ("powderblue" . "#B0E0E6")
+    ("purple" . "#A020F0")
+    ("purple1" . "#9B30FF")
+    ("purple2" . "#912CEE")
+    ("purple3" . "#7D26CD")
+    ("purple4" . "#551A8B")
+    ("red" . "#FF0000")
+    ("red1" . "#FF0000")
+    ("red2" . "#EE0000")
+    ("red3" . "#CD0000")
+    ("red4" . "#8B0000")
+    ("rosybrown" . "#BC8F8F")
+    ("rosybrown1" . "#FFC1C1")
+    ("rosybrown2" . "#EEB4B4")
+    ("rosybrown3" . "#CD9B9B")
+    ("rosybrown4" . "#8B6969")
+    ("royalblue" . "#4169E1")
+    ("royalblue1" . "#4876FF")
+    ("royalblue2" . "#436EEE")
+    ("royalblue3" . "#3A5FCD")
+    ("royalblue4" . "#27408B")
+    ("saddlebrown" . "#8B4513")
+    ("salmon" . "#FA8072")
+    ("salmon1" . "#FF8C69")
+    ("salmon2" . "#EE8262")
+    ("salmon3" . "#CD7054")
+    ("salmon4" . "#8B4C39")
+    ("sandybrown" . "#F4A460")
+    ("seagreen" . "#2E8B57")
+    ("seagreen1" . "#54FF9F")
+    ("seagreen2" . "#4EEE94")
+    ("seagreen3" . "#43CD80")
+    ("seagreen4" . "#2E8B57")
+    ("seashell" . "#FFF5EE")
+    ("seashell1" . "#FFF5EE")
+    ("seashell2" . "#EEE5DE")
+    ("seashell3" . "#CDC5BF")
+    ("seashell4" . "#8B8682")
+    ("sienna" . "#A0522D")
+    ("sienna1" . "#FF8247")
+    ("sienna2" . "#EE7942")
+    ("sienna3" . "#CD6839")
+    ("sienna4" . "#8B4726")
+    ("skyblue" . "#87CEEB")
+    ("skyblue1" . "#87CEFF")
+    ("skyblue2" . "#7EC0EE")
+    ("skyblue3" . "#6CA6CD")
+    ("skyblue4" . "#4A708B")
+    ("slateblue" . "#6A5ACD")
+    ("slateblue1" . "#836FFF")
+    ("slateblue2" . "#7A67EE")
+    ("slateblue3" . "#6959CD")
+    ("slateblue4" . "#473C8B")
+    ("slategray" . "#708090")
+    ("slategray1" . "#C6E2FF")
+    ("slategray2" . "#B9D3EE")
+    ("slategray3" . "#9FB6CD")
+    ("slategray4" . "#6C7B8B")
+    ("slategrey" . "#708090")
+    ("snow" . "#FFFAFA")
+    ("snow1" . "#FFFAFA")
+    ("snow2" . "#EEE9E9")
+    ("snow3" . "#CDC9C9")
+    ("snow4" . "#8B8989")
+    ("springgreen" . "#00FF7F")
+    ("springgreen1" . "#00FF7F")
+    ("springgreen2" . "#00EE76")
+    ("springgreen3" . "#00CD66")
+    ("springgreen4" . "#008B45")
+    ("steelblue" . "#4682B4")
+    ("steelblue1" . "#63B8FF")
+    ("steelblue2" . "#5CACEE")
+    ("steelblue3" . "#4F94CD")
+    ("steelblue4" . "#36648B")
+    ("tan" . "#D2B48C")
+    ("tan1" . "#FFA54F")
+    ("tan2" . "#EE9A49")
+    ("tan3" . "#CD853F")
+    ("tan4" . "#8B5A2B")
+    ("thistle" . "#D8BFD8")
+    ("thistle1" . "#FFE1FF")
+    ("thistle2" . "#EED2EE")
+    ("thistle3" . "#CDB5CD")
+    ("thistle4" . "#8B7B8B")
+    ("tomato" . "#FF6347")
+    ("tomato1" . "#FF6347")
+    ("tomato2" . "#EE5C42")
+    ("tomato3" . "#CD4F39")
+    ("tomato4" . "#8B3626")
+    ("turquoise" . "#40E0D0")
+    ("turquoise1" . "#00F5FF")
+    ("turquoise2" . "#00E5EE")
+    ("turquoise3" . "#00C5CD")
+    ("turquoise4" . "#00868B")
+    ("violet" . "#EE82EE")
+    ("violetred" . "#D02090")
+    ("violetred1" . "#FF3E96")
+    ("violetred2" . "#EE3A8C")
+    ("violetred3" . "#CD3278")
+    ("violetred4" . "#8B2252")
+    ("wheat" . "#F5DEB3")
+    ("wheat1" . "#FFE7BA")
+    ("wheat2" . "#EED8AE")
+    ("wheat3" . "#CDBA96")
+    ("wheat4" . "#8B7E66")
+    ("whitesmoke" . "#F5F5F5")
+    ("yellow" . "#FFFF00")
+    ("yellow1" . "#FFFF00")
+    ("yellow2" . "#EEEE00")
+    ("yellow3" . "#CDCD00")
+    ("yellow4" . "#8B8B00")
+    ("yellowgreen" . "#9ACD32"))
+  "Alist of R colors.
+Each entry should have the form (COLOR-NAME . HEXADECIMAL-COLOR)."
+  :type 'alist
+  :group 'rainbow)
+
+(defcustom rainbow-r-colors-major-mode-list
+  '(ess-mode)
+  "List of major mode where R colors are enabled when
+`rainbow-r-colors' is set to auto."
+  :type '(repeat (symbol :tag "Major-Mode"))
+  :group 'rainbow)
+
+(defcustom rainbow-r-colors 'auto
+  "When to enable R colors.
+If set to t, the R colors will be enabled.  If set to nil, the
+R colors will not be enabled.  If set to auto, the R colors
+will be enabled if a major mode has been detected from the
+`rainbow-r-colors-major-mode-list'."
+  :type '(choice (symbol :tag "enable in certain modes" auto)
+                 (symbol :tag "enable globally" t)
+                 (symbol :tag "disable" nil))
+  :group 'rainbow)
+
+;;; Functions
+
+(defun rainbow-colorize-match (color &optional match)
+  "Return a matched string propertized with a face whose
+background is COLOR. The foreground is computed using
+`rainbow-color-luminance', and is either white or black."
+  (let ((match (or match 0)))
+    (put-text-property
+     (match-beginning match) (match-end match)
+     'face `((:foreground ,(if (> 0.5 (rainbow-x-color-luminance color))
+                               "white" "black"))
+             (:background ,color)))))
+
+(defun rainbow-colorize-itself (&optional match)
+  "Colorize a match with itself."
+  (rainbow-colorize-match (match-string-no-properties (or match 0)) match))
+
+(defun rainbow-colorize-hexadecimal-without-sharp ()
+  "Colorize an hexadecimal colors and prepend # to it."
+  (rainbow-colorize-match (concat "#" (match-string-no-properties 1))))
+
+(defun rainbow-colorize-by-assoc (assoc-list)
+  "Colorize a match with its association from ASSOC-LIST."
+  (rainbow-colorize-match (cdr (assoc-string (match-string-no-properties 0)
+                                             assoc-list t))))
+
+(defun rainbow-rgb-relative-to-absolute (number)
+  "Convert a relative NUMBER to absolute. If NUMBER is absolute, return NUMBER.
+This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\".
+If the percentage value is above 100, it's converted to 100."
+  (let ((string-length (- (length number) 1)))
+    ;; Is this a number with %?
+    (if (eq (elt number string-length) ?%)
+        (/ (* (min (string-to-number (substring number 0 string-length)) 100) 255) 100)
+      (string-to-number number))))
+
+(defun rainbow-colorize-hsl ()
+  "Colorize a match with itself."
+  (let ((h (/ (string-to-number (match-string-no-properties 1)) 360.0))
+        (s (/ (string-to-number (match-string-no-properties 2)) 100.0))
+        (l (/ (string-to-number (match-string-no-properties 3)) 100.0)))
+    (rainbow-colorize-match
+     (cl-destructuring-bind (r g b)
+         (color-hsl-to-rgb h s l)
+       (format "#%02X%02X%02X" (* r 255) (* g 255) (* b 255))))))
+
+(defun rainbow-colorize-rgb ()
+  "Colorize a match with itself."
+  (let ((r (rainbow-rgb-relative-to-absolute (match-string-no-properties 1)))
+        (g (rainbow-rgb-relative-to-absolute (match-string-no-properties 2)))
+        (b (rainbow-rgb-relative-to-absolute (match-string-no-properties 3))))
+    (rainbow-colorize-match (format "#%02X%02X%02X" r g b))))
+
+(defun rainbow-colorize-rgb-float ()
+  "Colorize a match with itself, with relative value."
+  (let ((r (* (string-to-number (match-string-no-properties 1)) 255.0))
+        (g (* (string-to-number (match-string-no-properties 2)) 255.0))
+        (b (* (string-to-number (match-string-no-properties 3)) 255.0)))
+    (rainbow-colorize-match (format "#%02X%02X%02X" r g b))))
+
+(defvar ansi-color-context)
+(defvar xterm-color-current)
+
+(defun rainbow-colorize-ansi ()
+  "Return a matched string propertized with ansi color face."
+  (let ((xterm-color? (featurep 'xterm-color))
+        (string (match-string-no-properties 0))
+        color)
+    (save-match-data
+      (let* ((replaced (concat
+                        (replace-regexp-in-string
+                         "^\\(\\\\[eE]\\|\\\\033\\|\\\\x1[bB]\\)"
+                         "\033" string) "x"))
+             xterm-color-current
+             ansi-color-context
+             (applied (funcall (if xterm-color?
+                                   'xterm-color-filter
+                                 'ansi-color-apply)
+                               replaced))
+             (face-property (get-text-property
+                             0
+                             (if xterm-color? 'face 'font-lock-face)
+                             applied)))
+        (unless (listp (or (car-safe face-property) face-property))
+          (setq face-property (list face-property)))
+        (setq color (funcall (if xterm-color? 'cadr 'cdr)
+                             (or (assq (if xterm-color?
+                                           :foreground
+                                         'foreground-color)
+                                       face-property)
+                                 (assq (if xterm-color?
+                                           :background
+                                         'background-color)
+                                       face-property))))))
+    (when color
+      (rainbow-colorize-match color))))
+
+(defun rainbow-color-luminance (red green blue)
+  "Calculate the relative luminance of color composed of RED, GREEN and BLUE.
+Return a value between 0 and 1."
+  (/ (+ (* .2126 red) (* .7152 green) (* .0722 blue)) 255))
+
+(defun rainbow-x-color-luminance (color)
+  "Calculate the relative luminance of a color string (e.g. \"#ffaa00\", \"blue\").
+Return a value between 0 and 1."
+  (let* ((values (x-color-values color))
+         (r (/ (car values) 256.0))
+         (g (/ (cadr values) 256.0))
+         (b (/ (caddr values) 256.0)))
+    (rainbow-color-luminance r g b)))
+
+;;; Mode
+
+(defun rainbow-turn-on ()
+  "Turn on rainbow-mode."
+  (font-lock-add-keywords nil
+                          rainbow-hexadecimal-colors-font-lock-keywords
+                          t)
+  ;; Activate X colors?
+  (when (or (eq rainbow-x-colors t)
+            (and (eq rainbow-x-colors 'auto)
+                 (memq major-mode rainbow-x-colors-major-mode-list)))
+    (font-lock-add-keywords nil
+                            rainbow-x-colors-font-lock-keywords
+                            t))
+  ;; Activate LaTeX colors?
+  (when (or (eq rainbow-latex-colors t)
+            (and (eq rainbow-latex-colors 'auto)
+                 (memq major-mode rainbow-latex-colors-major-mode-list)))
+    (font-lock-add-keywords nil
+                            rainbow-latex-rgb-colors-font-lock-keywords
+                            t))
+  ;; Activate ANSI colors?
+  (when (or (eq rainbow-ansi-colors t)
+            (and (eq rainbow-ansi-colors 'auto)
+                 (memq major-mode rainbow-ansi-colors-major-mode-list)))
+    (font-lock-add-keywords nil
+                            rainbow-ansi-colors-font-lock-keywords
+                            t))
+  ;; Activate HTML colors?
+  (when (or (eq rainbow-html-colors t)
+            (and (eq rainbow-html-colors 'auto)
+                 (memq major-mode rainbow-html-colors-major-mode-list)))
+    (setq rainbow-html-colors-font-lock-keywords
+          `((,(regexp-opt (mapcar 'car rainbow-html-colors-alist) 'words)
+             (0 (rainbow-colorize-by-assoc rainbow-html-colors-alist)))))
+    (font-lock-add-keywords nil
+                            `(,@rainbow-html-colors-font-lock-keywords
+                              ,@rainbow-html-rgb-colors-font-lock-keywords)
+                            t))
+  ;; Activate R colors?
+  (when (or (eq rainbow-r-colors t)
+            (and (eq rainbow-r-colors 'auto)
+                 (memq major-mode rainbow-r-colors-major-mode-list)))
+    (setq rainbow-r-colors-font-lock-keywords
+          `((,(regexp-opt (mapcar 'car rainbow-r-colors-alist) 'words)
+             (0 (rainbow-colorize-by-assoc rainbow-r-colors-alist)))))
+    (font-lock-add-keywords nil
+                            rainbow-r-colors-font-lock-keywords
+                            t)))
+
+(defun rainbow-turn-off ()
+  "Turn off rainbow-mode."
+  (font-lock-remove-keywords
+   nil
+   `(,@rainbow-hexadecimal-colors-font-lock-keywords
+     ,@rainbow-x-colors-font-lock-keywords
+     ,@rainbow-latex-rgb-colors-font-lock-keywords
+     ,@rainbow-r-colors-font-lock-keywords
+     ,@rainbow-html-colors-font-lock-keywords
+     ,@rainbow-html-rgb-colors-font-lock-keywords)))
+
+(defvar rainbow-keywords-hook nil
+  "Hook used to add additional font-lock keywords.
+This hook is called by `rainbow-mode' before it re-enables
+`font-lock-mode'.  Hook functions must only add additional
+keywords when `rainbow-mode' is non-nil.  When that is nil,
+then they must remove those additional keywords again.")
+
+;;;###autoload
+(define-minor-mode rainbow-mode
+  "Colorize strings that represent colors.
+This will fontify with colors the string like \"#aabbcc\" or \"blue\"."
+  :lighter " Rbow"
+  (if rainbow-mode
+      (rainbow-turn-on)
+    (rainbow-turn-off))
+  ;; We cannot use `rainbow-mode-hook' because this has
+  ;; to be done before `font-lock-mode' is re-enabled.
+  (run-hooks 'rainbow-keywords-hook)
+  ;; Call `font-lock-mode' to refresh the buffer when used
+  ;; e.g. interactively.
+  (font-lock-mode 1))
+
+;;;; ChangeLog:
+
+;; 2020-03-30  Julien Danjou  
+;; 
+;; 	fix(rainbow-mode): fix typo in docstring
+;; 
+;; 	Thanks Bauke Jan Douma 
+;; 
+;; 2019-12-23  Julien Danjou  
+;; 
+;; 	Release rainbow-mode 1.0.3
+;; 
+;; 	* Use cl-lib instead of cl
+;; 
+;; 	  As of Emacs 27.1 `cl' is officially deprecated.
+;; 
+;; 	  `cl' was only required for `multiple-value-bind' and using that was
+;; 	 conceptually wrong to begin with: `color-hsl-to-rgb' does NOT return
+;; 	three
+;; 	 values; it returns one value which happens to consist of three
+;; 	components and
+;; 	 any one of these components by itself is meaningless. Now we use
+;; 	 `cl-destructuring-bind', which does not have the same connotation.
+;; 
+;; 	* rainbow-keywords-hook: New hook run by rainbow-mode
+;; 
+;; 	* rainbow-mode: Remove unnecessary progn
+;; 	 Also improve a contained comment.
+;; 
+;; 	Thanks Jonas Bernoulli 
+;; 
+;; 2019-11-25  Julien Danjou  
+;; 
+;; 	Release rainbow-mode 1.0.2
+;; 
+;; 2019-11-25  Julien Danjou  
+;; 
+;; 	Fix a off-by-one error and some wording in rainbow-mode
+;; 
+;; 	* packages/rainbow-mode/rainbow-mode.el (rainbow-color-luminance): Fix a 
+;; 	off-by-one error and wording.
+;; 	(rainbow-x-color-luminance): Fix wording.
+;; 
+;; 	Thanks Peder Stray.
+;; 
+;; 2018-05-21  Julien Danjou  
+;; 
+;; 	* rainbow-mode/rainbow-mode.el: do not fail if face-property is a symbol
+;; 
+;; 	It turns out there are cases when `face-property' can be just a symbol
+;; 	and we need to protect our selves from that, i.e. `car' should not fail.
+;; 	Hence,
+;; 	`car-safe' is there and if it's `nil', then fall back to `face-property'
+;; 	as is.
+;; 
+;; 	See https://github.com/tarsius/hl-todo/issues/17
+;; 
+;; 2018-03-26  Julien Danjou  
+;; 
+;; 	rainbow-mode: release 1.0
+;; 
+;; 2018-03-26  Jonas Bernoulli  
+;; 
+;; 	Allow outline-minor-mode to find section headings
+;; 
+;; 2018-03-26  Jonas Bernoulli  
+;; 
+;; 	Set type of customizable options
+;; 
+;; 2018-03-26  Jonas Bernoulli  
+;; 
+;; 	Enforce use of spaces for indentation
+;; 
+;; 	Also untabify some code added by a contributor who, unlike you, has not
+;; 	globally set `indent-tabs-mode' to nil.
+;; 
+;; 2017-05-29  Julien Danjou  
+;; 
+;; 	Fix `rainbow-color-luminance' docstring
+;; 
+;; 2015-10-12  Julien Danjou  
+;; 
+;; 	rainbow: add font-lock at the end
+;; 
+;; 	See https://github.com/fxbois/web-mode/issues/612
+;; 
+;; 2015-03-06  Julien Danjou  
+;; 
+;; 	rainbow: fix font-lock-mode refresh
+;; 
+;; 2014-10-15  Stefan Monnier  
+;; 
+;; 	* packages/rainbow-mode/rainbow-mode.el (ansi-color-context)
+;; 	(xterm-color-current): Declare.
+;; 
+;; 2014-09-07  Julien Danjou  
+;; 
+;; 	rainbow-mode: support float in CSS and limit to 100%
+;; 
+;; 2013-08-05  Julien Danjou  
+;; 
+;; 	rainbow-mode: 0.9, allow spaces in LaTeX colors
+;; 
+;; 2013-05-03  Julien Danjou  
+;; 
+;; 	rainbow-mode: add support for R, bump version to 0.8
+;; 
+;; 	Signed-off-by: Julien Danjou 
+;; 
+;; 2013-02-26  Julien Danjou  
+;; 
+;; 	rainbow-mode: version 0.7
+;; 
+;; 	* rainbow-mode.el: don't activate font-lock-mode
+;; 
+;; 2012-12-11  Julien Danjou  
+;; 
+;; 	* rainbow-mode: update to 0.6, add support for ANSI coloring
+;; 
+;; 2012-11-26  Julien Danjou  
+;; 
+;; 	rainbow-mode: fix some LaTex docstrings
+;; 
+;; 2012-11-14  Julien Danjou  
+;; 
+;; 	rainbow-mode: version 0.5
+;; 
+;; 	* rainbow-mode.el: fix syntax error on
+;; 	 `rainbow-hexadecimal-colors-font-lock-keywords'.
+;; 
+;; 2012-11-09  Julien Danjou  
+;; 
+;; 	rainbow-mode: version 0.4
+;; 
+;; 	* rainbow-mode.el: Use functions from color package to colorize HSL
+;; 	rather
+;; 	 than our own copy.
+;; 
+;; 2012-11-09  Julien Danjou  
+;; 
+;; 	rainbow-mode 0.3
+;; 
+;; 	* rainbow-mode.el: avoid colorizing HTML entities
+;; 
+;; 2011-09-23  Julien Danjou  
+;; 
+;; 	Update rainbow-mode to version 0.2
+;; 
+;; 2011-07-01  Chong Yidong  
+;; 
+;; 	Give every package its own directory in packages/ including single-file
+;; 	packages.
+;; 
+
+
+(provide 'rainbow-mode)
+
+;; Local Variables:
+;; indent-tabs-mode: nil
+;; End:
+;;; rainbow-mode.el ends here
diff --git a/lisp/restart-emacs.el b/lisp/restart-emacs.el
new file mode 100644
index 00000000..08cd30e6
--- /dev/null
+++ b/lisp/restart-emacs.el
@@ -0,0 +1,425 @@
+;;; restart-emacs.el --- Restart emacs from within emacs  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015-2017  Iqbal Ansari
+
+;; Author: Iqbal Ansari 
+;; Keywords: convenience
+;; Package-Version: 20180601.1031
+;; URL: https://github.com/iqbalansari/restart-emacs
+;; Version: 0.1.1
+
+;; 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 .
+
+;;; Commentary:
+
+;; This package provides a simple command to restart Emacs from within Emacs
+
+
+
+;;; Code:
+
+(require 'server)
+(require 'desktop)
+
+;; Making the byte compiler happy
+(declare-function w32-shell-execute "w32fns.c")
+
+
+
+;; Customizations
+
+(defgroup restart-emacs nil
+  "Customization options for restart-emacs"
+  :group 'tools
+  :prefix "restart-emacs-")
+
+(defcustom restart-emacs-daemon-with-tty-frames-p nil
+  "Restart Emacs daemon even if it has tty frames.
+
+Currently `restart-emacs' cannot restore such frames, it just
+notifies the user once the daemon has restarted"
+  :type 'boolean
+  :group 'restart-emacs)
+
+(defcustom restart-emacs-restore-frames nil
+  "Attempt to restore frames on Emacs restart.
+
+Please note this functionality works only on Emacs 24.4 and later, since the
+earlier versions did not ship with the frameset library which is used to restore
+the frames.  This variable is ignored while restarting daemon since frames are
+restored unconditionally while restarting daemon mode."
+  :type 'boolean
+  :group 'restart-emacs)
+
+
+
+;; Compatibility functions
+
+(defun restart-emacs--string-join (strings &optional separator)
+  "Join all STRINGS using SEPARATOR.
+
+This function is available on Emacs v24.4 and higher, it has been
+backported here for compatibility with older Emacsen."
+  (if (fboundp 'string-join)
+      (apply #'string-join (list strings separator))
+    (mapconcat 'identity strings separator)))
+
+(defun restart-emacs--user-error (format &rest args)
+  "Signal a `user-error' if available otherwise signal a generic `error'.
+
+FORMAT and ARGS correspond to STRING and OBJECTS arguments to `format'."
+  (if (fboundp 'user-error)
+      (apply #'user-error format args)
+    (apply #'error format args)))
+
+
+
+;; Core functions
+
+(defvar restart-emacs--args nil
+  "The arguments with which to restart Emacs is bound dynamically.")
+
+(defun restart-emacs--get-emacs-binary ()
+  "Get absolute path to binary of currently running Emacs.
+
+On Windows get path to runemacs.exe if possible."
+  (let ((emacs-binary-path (expand-file-name invocation-name invocation-directory))
+        (runemacs-binary-path (when (memq system-type '(windows-nt ms-dos))
+                                (expand-file-name "runemacs.exe" invocation-directory))))
+    (if (and runemacs-binary-path (file-exists-p runemacs-binary-path))
+        runemacs-binary-path
+      emacs-binary-path)))
+
+(defun restart-emacs--record-tty-file (current &rest ignored)
+  "Save the buffer which is being currently selected in the frame.
+
+This function is used as a filter for tty frames in `frameset-filter-alist'.
+See `frameset-filter-alist' for explanation of CURRENT and rest of the
+parameters.  IGNORED are ignored."
+  (when (processp (cdr current))
+    (let ((window (frame-selected-window (process-get (cdr current) 'frame))))
+      (cons 'restart-emacs-file (buffer-file-name (window-buffer window))))))
+
+(defun restart-emacs--notify-connection-instructions (tty filename)
+  "Print instructions on the given TTY about connecting to the daemon.
+
+It prints the complete command line invocation that can be used connect to the
+newly restarted daemon, FILENAME is the path to the the file that was selected
+in the frame that was open on this tty before the daemon restarted."
+  (with-temp-file tty
+    (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir))
+           (server-file (expand-file-name server-name server-dir))
+           (emacsclient-path (expand-file-name "emacsclient" invocation-directory))
+           (quoted-server-file (shell-quote-argument server-file))
+           (quoted-emacsclient-path (shell-quote-argument emacsclient-path))
+           (message (if filename
+                        (format "Emacs daemon restarted! Use '%s -nw -s %s %s' to reconnect to it"
+                                quoted-emacsclient-path
+                                quoted-server-file
+                                (shell-quote-argument filename))
+                      (format "Emacs daemon restarted! Use '%s -nw -s %s' to reconnect to it"
+                              quoted-emacsclient-path
+                              quoted-server-file))))
+      (insert message))))
+
+(defun restart-emacs--frameset-tty-filter (tty filtered parameters saving)
+  "Restore the TTY from saved frameset.
+
+This does not actually restore anything rather it simply notifies the user on
+tty the instructions to reconnect to the daemon and then invokes the default
+filter for ttys (`frameset-filter-tty-to-GUI')
+
+See the documentation for `frameset-filter-alist' to understand FILTERED,
+PARAMETERS and SAVING."
+  (when (cdr tty)
+    (run-at-time 0.5
+                 nil
+                 (apply-partially 'restart-emacs--notify-connection-instructions
+                                  (cdr tty)
+                                  (cdr (assoc 'restart-emacs-file filtered)))))
+  (frameset-filter-tty-to-GUI tty filtered parameters saving))
+
+(defun restart-emacs--restore-frames-using-desktop (file)
+  "Restore the frames using the desktop FILE."
+  ;; We let-bind a bunch of variables from desktop mode to make sure
+  ;; the changes done while restoring from the desktop file are not
+  ;; leaked into normal functioning of the desktop-mode
+  (let* (desktop-file-modtime
+         (desktop-dirname (file-name-directory file))
+         (desktop-base-file-name (file-name-base file))
+         (desktop-base-lock-name (concat desktop-base-file-name ".lock"))
+         (desktop-restore-reuses-frames nil)
+         ;; Add filter for tty frames, the filter simply logs a message on
+         ;; the parent ttys of the frame
+         (frameset-filter-alist (append '((tty . restart-emacs--frameset-tty-filter))
+                                        frameset-filter-alist))
+         ;; Disable prompts for safe variables during restoration
+         (enable-local-variables :safe)
+         ;; We mock these two functions while restoring frames
+         ;; Calls to `display-color-p' blocks Emacs in daemon mode (possibly)
+         ;; because the call fails
+         (display-color-p (symbol-function 'display-color-p))
+         ;; We mock `display-graphic-p' since desktop mode has changed to
+         ;; not restore frames when we are not on graphic display
+         ;; TODO: Report Emacs bug
+         (display-graphic-p (symbol-function 'display-graphic-p)))
+    (unwind-protect
+        (progn
+          ;; TODO: The following might break things
+	  (when (daemonp)
+	    (fset 'display-color-p (lambda (&rest ignored) t))
+	    (fset 'display-graphic-p (lambda (&rest ignored) t)))
+          (desktop-read desktop-dirname)
+          (desktop-release-lock desktop-dirname))
+      ;; Restore display-color-p's definition
+      (fset 'display-color-p display-color-p)
+      ;; Restore display-graphic-p's definition
+      (fset 'display-graphic-p display-graphic-p)
+      ;; Cleanup the files
+      (ignore-errors (delete-file (desktop-full-file-name)))
+      (ignore-errors (delete-file (desktop-full-lock-name))))))
+
+(defun restart-emacs--save-frames-using-desktop ()
+  "Save current frames to a file and return the full path to the file."
+  (let* (desktop-file-modtime
+         (desktop-base-file-name (make-temp-name "restart-emacs-desktop"))
+         (desktop-dirname temporary-file-directory)
+         (desktop-restore-eager t)
+         ;; For tty frames record the currently selected file
+         (frameset-filter-alist (append '((client . restart-emacs--record-tty-file))
+                                        frameset-filter-alist)))
+    (desktop-save temporary-file-directory t t)
+    (expand-file-name desktop-base-file-name desktop-dirname)))
+
+(defun restart-emacs--frame-restore-args ()
+  "Get the arguments for restoring frames."
+  ;; frameset was not available on old versions
+  (when (and (locate-library "frameset")
+             ;; If user has enabled desktop-save-mode leave him alone unless she
+             ;; is restarting the daemon since right now Emacs does not restore
+             ;; the frames in daemon mode. Also ignore the `restart-emacs-restore-frames'
+             ;; configuration since restarting the daemon without restoring frames
+             ;; doesn't really help
+             (or (daemonp)
+                 (and restart-emacs-restore-frames
+                      (not (bound-and-true-p desktop-save-mode)))))
+    (list "--restart-emacs-desktop"
+          (restart-emacs--save-frames-using-desktop))))
+
+(defun restart-emacs--start-gui-using-sh (&optional args)
+  "Start GUI version of Emacs using sh.
+
+ARGS is the list arguments with which Emacs should be started"
+  (call-process "sh" nil
+                0 nil
+                "-c" (format "%s %s &"
+                             (shell-quote-argument (restart-emacs--get-emacs-binary))
+                             (restart-emacs--string-join (mapcar #'shell-quote-argument
+                                                                 args)
+                                                         " "))))
+
+(defun restart-emacs--start-gui-on-windows (&optional args)
+  "Start GUI version of Emacs on windows.
+
+ARGS is the list arguments with which Emacs should be started"
+  (w32-shell-execute "open"
+                     (restart-emacs--get-emacs-binary)
+                     (restart-emacs--string-join args " ")))
+
+(defun restart-emacs--start-emacs-in-terminal (&optional args)
+  "Start Emacs in current terminal.
+
+ARGS is the list arguments with which Emacs should be started.  This requires a
+shell with `fg' command and `;' construct.  This has been tested to work with
+sh, bash, zsh, fish, csh and tcsh shells"
+  (suspend-emacs (format "fg ; %s %s -nw"
+                         (shell-quote-argument (restart-emacs--get-emacs-binary))
+                         (restart-emacs--string-join (mapcar #'shell-quote-argument
+                                                             args)
+                                                     " "))))
+
+(defun restart-emacs--daemon-using-sh (&optional args)
+  "Restart Emacs daemon with the provided ARGS.
+
+This function makes sure the new Emacs instance uses the same server-name as the
+current instance"
+  (call-process "sh" nil
+                0 nil
+                "-c" (format "%s --daemon=%s %s &"
+                             (shell-quote-argument (restart-emacs--get-emacs-binary))
+                             server-name
+                             (restart-emacs--string-join (mapcar #'shell-quote-argument args)
+                                                         " "))))
+
+(defun restart-emacs--daemon-on-windows (&optional args)
+  "Restart Emacs daemon with the provided ARGS.
+
+This function makes sure the new Emacs instance uses the same server-name as the
+current instance
+
+TODO: Not tested yet"
+  (w32-shell-execute "open"
+                     (restart-emacs--get-emacs-binary)
+                     (restart-emacs--string-join (cons (concat "--daemon=" server-name)
+                                                       args)
+                                                 " ")))
+
+(defun restart-emacs--ensure-can-restart ()
+  "Ensure we can restart Emacs on current platform."
+  (when (and (not (display-graphic-p))
+             (memq system-type '(windows-nt ms-dos)))
+    (restart-emacs--user-error (format "Cannot restart Emacs running in terminal on system of type `%s'" system-type)))
+
+  (when (and (daemonp)
+             (not (locate-library "frameset")))
+    (restart-emacs--user-error "Cannot restart Emacs daemon on versions before 24.4"))
+
+  (when (and (daemonp)
+             (delq nil (mapcar (lambda (frame)
+                                 (frame-parameter frame 'tty))
+                               (frame-list)))
+             (not restart-emacs-daemon-with-tty-frames-p)
+             (not (yes-or-no-p "Current Emacs daemon has tty frames, `restart-emacs' cannot restore them, continue anyway? ")))
+    (restart-emacs--user-error "Current Emacs daemon has tty frames, aborting `restart-emacs'.
+Set `restart-emacs-with-tty-frames-p' to non-nil to restart Emacs irrespective of tty frames")))
+
+(defun restart-emacs--launch-other-emacs (arguments)
+  "Launch another Emacs session with ARGUMENTS according to current platform."
+  (apply (cond ((daemonp) (if (memq system-type '(windows-nt ms-dos))
+                              #'restart-emacs--daemon-on-windows
+                            #'restart-emacs--daemon-using-sh))
+
+               ((display-graphic-p) (if (memq system-type '(windows-nt ms-dos))
+                                        #'restart-emacs--start-gui-on-windows
+                                      #'restart-emacs--start-gui-using-sh))
+
+               (t (if (memq system-type '(windows-nt ms-dos))
+                      ;; This should not happen since we check this before triggering a restart
+                      (restart-emacs--user-error "Cannot restart Emacs running in a windows terminal")
+                    #'restart-emacs--start-emacs-in-terminal)))
+         ;; Since this function is called in `kill-emacs-hook' it cannot accept
+         ;; direct arguments the arguments are let-bound instead
+         (list arguments)))
+
+(defun restart-emacs--translate-prefix-to-args (prefix)
+  "Translate the given PREFIX to arguments to be passed to Emacs.
+
+It does the following translation
+            `C-u' => --debug-init
+      `C-u' `C-u' => -Q
+`C-u' `C-u' `C-u' => Reads the argument from the user in raw form"
+  (cond ((equal prefix '(4)) '("--debug-init"))
+        ((equal prefix '(16)) '("-Q"))
+        ((equal prefix '(64)) (split-string (read-string "Arguments to start Emacs with (separated by space): ")
+                                            " "))))
+
+(defun restart-emacs--guess-startup-directory-using-proc ()
+  "Get the startup directory of current Emacs session from /proc."
+  (when (file-exists-p (format "/proc/%d/cwd" (emacs-pid)))
+    (file-chase-links (format "/proc/%d/cwd" (emacs-pid)))))
+
+(defun restart-emacs--guess-startup-directory-using-lsof ()
+  "Get the startup directory of the current Emacs session using the `lsof' program."
+  (when (executable-find "lsof")
+    (let* ((default-directory "/")
+           (lsof-op (shell-command-to-string (format "lsof -d cwd -a -Fn -p %d"
+                                                     (emacs-pid))))
+           (raw-cwd (car (last (split-string lsof-op "\n" t))))
+           (cwd (substring raw-cwd 1)))
+      (when (< 0 (length cwd))
+        cwd))))
+
+(defun restart-emacs--guess-startup-directory-using-buffers ()
+  "Guess the startup directory for current Emacs session from some buffer.
+
+This tries to get Emacs startup directory from the *Messages* or *scratch*
+buffer, needless to say this would be wrong if the user has killed and recreated
+these buffers."
+  (or (and (get-buffer "*Messages*")
+           (with-current-buffer "*Messages*" default-directory))
+      (and (get-buffer "*scratch*")
+           (with-current-buffer "*scratch*" default-directory))))
+
+(defun restart-emacs--guess-startup-directory-from-env ()
+  "Guess the startup directory for current Emacs session from USERPROFILE or HOME."
+  (or (getenv "HOME")
+      (getenv "USERPROFILE")))
+
+(defun restart-emacs--guess-startup-directory ()
+  "Guess the directory the new Emacs instance should start from.
+
+On Linux it figures out the startup directory by reading /proc entry for current
+Emacs instance.  Otherwise it falls back to guessing the startup directory by
+reading `default-directory' of *Messages* or *scratch* buffers falling back to
+the HOME or USERPROFILE (only applicable on Window) environment variable and
+finally just using whatever is the current `default-directory'."
+  (or (restart-emacs--guess-startup-directory-using-proc)
+      (restart-emacs--guess-startup-directory-using-lsof)
+      (restart-emacs--guess-startup-directory-using-buffers)
+      (restart-emacs--guess-startup-directory-from-env)
+      default-directory))
+
+
+
+;; User interface
+
+;;;###autoload
+(defun restart-emacs-handle-command-line-args (&rest ignored)
+  "Handle the --restart-emacs-desktop command line argument.
+
+The value of the argument is the desktop file from which the frames should be
+restored.  IGNORED are ignored."
+  (restart-emacs--restore-frames-using-desktop (pop command-line-args-left)))
+
+;;;###autoload
+(add-to-list 'command-switch-alist '("--restart-emacs-desktop" . restart-emacs-handle-command-line-args))
+
+;;;###autoload
+(defun restart-emacs (&optional args)
+  "Restart Emacs.
+
+When called interactively ARGS is interpreted as follows
+
+- with a single `universal-argument' (`C-u') Emacs is restarted
+  with `--debug-init' flag
+- with two `universal-argument' (`C-u') Emacs is restarted with
+  `-Q' flag
+- with three `universal-argument' (`C-u') the user prompted for
+  the arguments
+
+When called non-interactively ARGS should be a list of arguments
+with which Emacs should be restarted."
+  (interactive "P")
+  ;; Do not trigger a restart unless we are sure, we can restart emacs
+  (restart-emacs--ensure-can-restart)
+  ;; We need the new emacs to be spawned after all kill-emacs-hooks
+  ;; have been processed and there is nothing interesting left
+  (let* ((default-directory (restart-emacs--guess-startup-directory))
+         (translated-args (if (called-interactively-p 'any)
+                              (restart-emacs--translate-prefix-to-args args)
+                            args))
+         (restart-args (append translated-args
+                               ;; When Emacs is started with a -Q
+                               ;; restart-emacs's autoloads would not be present
+                               ;; causing the the --restart-emacs-desktop
+                               ;; argument to be unhandled
+                               (unless (member "-Q" translated-args)
+                                 (restart-emacs--frame-restore-args))))
+         (kill-emacs-hook (append kill-emacs-hook
+                                  (list (apply-partially #'restart-emacs--launch-other-emacs
+                                                         restart-args)))))
+    (save-buffers-kill-emacs)))
+
+(provide 'restart-emacs)
+;;; restart-emacs.el ends here
diff --git a/lisp/s.el b/lisp/s.el
new file mode 100644
index 00000000..d8e359a1
--- /dev/null
+++ b/lisp/s.el
@@ -0,0 +1,747 @@
+;;; s.el --- The long lost Emacs string manipulation library.
+
+;; Copyright (C) 2012-2015 Magnar Sveen
+
+;; Author: Magnar Sveen 
+;; Version: 1.12.0
+;; Package-Version: 20180406.808
+;; Keywords: strings
+
+;; 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 .
+
+;;; Commentary:
+
+;; The long lost Emacs string manipulation library.
+;;
+;; See documentation on https://github.com/magnars/s.el#functions
+
+;;; Code:
+
+;; Silence byte-compiler
+(defvar ucs-normalize-combining-chars)  ; Defined in `ucs-normalize'
+(autoload 'slot-value "eieio")
+
+(defun s-trim-left (s)
+  "Remove whitespace at the beginning of S."
+  (declare (pure t) (side-effect-free t))
+  (save-match-data
+    (if (string-match "\\`[ \t\n\r]+" s)
+        (replace-match "" t t s)
+      s)))
+
+(defun s-trim-right (s)
+  "Remove whitespace at the end of S."
+  (save-match-data
+    (declare (pure t) (side-effect-free t))
+    (if (string-match "[ \t\n\r]+\\'" s)
+        (replace-match "" t t s)
+      s)))
+
+(defun s-trim (s)
+  "Remove whitespace at the beginning and end of S."
+  (declare (pure t) (side-effect-free t))
+  (s-trim-left (s-trim-right s)))
+
+(defun s-collapse-whitespace (s)
+  "Convert all adjacent whitespace characters to a single space."
+  (declare (pure t) (side-effect-free t))
+  (replace-regexp-in-string "[ \t\n\r]+" " " s))
+
+(defun s-split (separator s &optional omit-nulls)
+  "Split S into substrings bounded by matches for regexp SEPARATOR.
+If OMIT-NULLS is non-nil, zero-length substrings are omitted.
+
+This is a simple wrapper around the built-in `split-string'."
+  (declare (side-effect-free t))
+  (save-match-data
+    (split-string s separator omit-nulls)))
+
+(defun s-split-up-to (separator s n &optional omit-nulls)
+  "Split S up to N times into substrings bounded by matches for regexp SEPARATOR.
+
+If OMIT-NULLS is non-nil, zero-length substrings are omitted.
+
+See also `s-split'."
+  (declare (side-effect-free t))
+  (save-match-data
+    (let ((op 0)
+          (r nil))
+      (with-temp-buffer
+        (insert s)
+        (setq op (goto-char (point-min)))
+        (while (and (re-search-forward separator nil t)
+                    (< 0 n))
+          (let ((sub (buffer-substring op (match-beginning 0))))
+            (unless (and omit-nulls
+                         (equal sub ""))
+              (push sub r)))
+          (setq op (goto-char (match-end 0)))
+          (setq n (1- n)))
+        (let ((sub (buffer-substring op (point-max))))
+          (unless (and omit-nulls
+                       (equal sub ""))
+            (push sub r))))
+      (nreverse r))))
+
+(defun s-lines (s)
+  "Splits S into a list of strings on newline characters."
+  (declare (pure t) (side-effect-free t))
+  (s-split "\\(\r\n\\|[\n\r]\\)" s))
+
+(defun s-join (separator strings)
+  "Join all the strings in STRINGS with SEPARATOR in between."
+  (declare (pure t) (side-effect-free t))
+  (mapconcat 'identity strings separator))
+
+(defun s-concat (&rest strings)
+  "Join all the string arguments into one string."
+  (declare (pure t) (side-effect-free t))
+  (apply 'concat strings))
+
+(defun s-prepend (prefix s)
+  "Concatenate PREFIX and S."
+  (declare (pure t) (side-effect-free t))
+  (concat prefix s))
+
+(defun s-append (suffix s)
+  "Concatenate S and SUFFIX."
+  (declare (pure t) (side-effect-free t))
+  (concat s suffix))
+
+(defun s-repeat (num s)
+  "Make a string of S repeated NUM times."
+  (declare (pure t) (side-effect-free t))
+  (let (ss)
+    (while (> num 0)
+      (setq ss (cons s ss))
+      (setq num (1- num)))
+    (apply 'concat ss)))
+
+(defun s-chop-suffix (suffix s)
+  "Remove SUFFIX if it is at end of S."
+  (declare (pure t) (side-effect-free t))
+  (let ((pos (- (length suffix))))
+    (if (and (>= (length s) (length suffix))
+             (string= suffix (substring s pos)))
+        (substring s 0 pos)
+      s)))
+
+(defun s-chop-suffixes (suffixes s)
+  "Remove SUFFIXES one by one in order, if they are at the end of S."
+  (declare (pure t) (side-effect-free t))
+  (while suffixes
+    (setq s (s-chop-suffix (car suffixes) s))
+    (setq suffixes (cdr suffixes)))
+  s)
+
+(defun s-chop-prefix (prefix s)
+  "Remove PREFIX if it is at the start of S."
+  (declare (pure t) (side-effect-free t))
+  (let ((pos (length prefix)))
+    (if (and (>= (length s) (length prefix))
+             (string= prefix (substring s 0 pos)))
+        (substring s pos)
+      s)))
+
+(defun s-chop-prefixes (prefixes s)
+  "Remove PREFIXES one by one in order, if they are at the start of S."
+  (declare (pure t) (side-effect-free t))
+  (while prefixes
+    (setq s (s-chop-prefix (car prefixes) s))
+    (setq prefixes (cdr prefixes)))
+  s)
+
+(defun s-shared-start (s1 s2)
+  "Returns the longest prefix S1 and S2 have in common."
+  (declare (pure t) (side-effect-free t))
+  (let ((search-length (min (length s1) (length s2)))
+        (i 0))
+    (while (and (< i search-length)
+                (= (aref s1 i) (aref s2 i)))
+      (setq i (1+ i)))
+    (substring s1 0 i)))
+
+(defun s-shared-end (s1 s2)
+  "Returns the longest suffix S1 and S2 have in common."
+  (declare (pure t) (side-effect-free t))
+  (let* ((l1 (length s1))
+         (l2 (length s2))
+         (search-length (min l1 l2))
+         (i 0))
+    (while (and (< i search-length)
+                (= (aref s1 (- l1 i 1)) (aref s2 (- l2 i 1))))
+      (setq i (1+ i)))
+    ;; If I is 0, then it means that there's no common suffix between
+    ;; S1 and S2.
+    ;;
+    ;; However, since (substring s (- 0)) will return the whole
+    ;; string, `s-shared-end' should simply return the empty string
+    ;; when I is 0.
+    (if (zerop i)
+        ""
+      (substring s1 (- i)))))
+
+(defun s-chomp (s)
+  "Remove one trailing `\\n`, `\\r` or `\\r\\n` from S."
+  (declare (pure t) (side-effect-free t))
+  (s-chop-suffixes '("\n" "\r") s))
+
+(defun s-truncate (len s &optional ellipsis)
+  "If S is longer than LEN, cut it down and add ELLIPSIS to the end.
+
+The resulting string, including ellipsis, will be LEN characters
+long.
+
+When not specified, ELLIPSIS defaults to ‘...’."
+  (declare (pure t) (side-effect-free t))
+  (unless ellipsis
+    (setq ellipsis "..."))
+  (if (> (length s) len)
+      (format "%s%s" (substring s 0 (- len (length ellipsis))) ellipsis)
+    s))
+
+(defun s-word-wrap (len s)
+  "If S is longer than LEN, wrap the words with newlines."
+  (declare (side-effect-free t))
+  (save-match-data
+    (with-temp-buffer
+      (insert s)
+      (let ((fill-column len))
+        (fill-region (point-min) (point-max)))
+      (buffer-substring (point-min) (point-max)))))
+
+(defun s-center (len s)
+  "If S is shorter than LEN, pad it with spaces so it is centered."
+  (declare (pure t) (side-effect-free t))
+  (let ((extra (max 0 (- len (length s)))))
+    (concat
+     (make-string (ceiling extra 2) ? )
+     s
+     (make-string (floor extra 2) ? ))))
+
+(defun s-pad-left (len padding s)
+  "If S is shorter than LEN, pad it with PADDING on the left."
+  (declare (pure t) (side-effect-free t))
+  (let ((extra (max 0 (- len (length s)))))
+    (concat (make-string extra (string-to-char padding))
+            s)))
+
+(defun s-pad-right (len padding s)
+  "If S is shorter than LEN, pad it with PADDING on the right."
+  (declare (pure t) (side-effect-free t))
+  (let ((extra (max 0 (- len (length s)))))
+    (concat s
+            (make-string extra (string-to-char padding)))))
+
+(defun s-left (len s)
+  "Returns up to the LEN first chars of S."
+  (declare (pure t) (side-effect-free t))
+  (if (> (length s) len)
+      (substring s 0 len)
+    s))
+
+(defun s-right (len s)
+  "Returns up to the LEN last chars of S."
+  (declare (pure t) (side-effect-free t))
+  (let ((l (length s)))
+    (if (> l len)
+        (substring s (- l len) l)
+      s)))
+
+(defun s-ends-with? (suffix s &optional ignore-case)
+  "Does S end with SUFFIX?
+
+If IGNORE-CASE is non-nil, the comparison is done without paying
+attention to case differences.
+
+Alias: `s-suffix?'"
+  (declare (pure t) (side-effect-free t))
+  (let ((start-pos (- (length s) (length suffix))))
+    (and (>= start-pos 0)
+         (eq t (compare-strings suffix nil nil
+                                s start-pos nil ignore-case)))))
+
+(defun s-starts-with? (prefix s &optional ignore-case)
+  "Does S start with PREFIX?
+
+If IGNORE-CASE is non-nil, the comparison is done without paying
+attention to case differences.
+
+Alias: `s-prefix?'. This is a simple wrapper around the built-in
+`string-prefix-p'."
+  (declare (pure t) (side-effect-free t))
+  (string-prefix-p prefix s ignore-case))
+
+(defun s--truthy? (val)
+  (declare (pure t) (side-effect-free t))
+  (not (null val)))
+
+(defun s-contains? (needle s &optional ignore-case)
+  "Does S contain NEEDLE?
+
+If IGNORE-CASE is non-nil, the comparison is done without paying
+attention to case differences."
+  (declare (pure t) (side-effect-free t))
+  (let ((case-fold-search ignore-case))
+    (s--truthy? (string-match-p (regexp-quote needle) s))))
+
+(defun s-equals? (s1 s2)
+  "Is S1 equal to S2?
+
+This is a simple wrapper around the built-in `string-equal'."
+  (declare (pure t) (side-effect-free t))
+  (string-equal s1 s2))
+
+(defun s-less? (s1 s2)
+  "Is S1 less than S2?
+
+This is a simple wrapper around the built-in `string-lessp'."
+  (declare (pure t) (side-effect-free t))
+  (string-lessp s1 s2))
+
+(defun s-matches? (regexp s &optional start)
+  "Does REGEXP match S?
+If START is non-nil the search starts at that index.
+
+This is a simple wrapper around the built-in `string-match-p'."
+  (declare (side-effect-free t))
+  (s--truthy? (string-match-p regexp s start)))
+
+(defun s-blank? (s)
+  "Is S nil or the empty string?"
+  (declare (pure t) (side-effect-free t))
+  (or (null s) (string= "" s)))
+
+(defun s-blank-str? (s)
+  "Is S nil or the empty string or string only contains whitespace?"
+  (declare (pure t) (side-effect-free t))
+  (or (s-blank? s) (s-blank? (s-trim s))))
+
+(defun s-present? (s)
+  "Is S anything but nil or the empty string?"
+  (declare (pure t) (side-effect-free t))
+  (not (s-blank? s)))
+
+(defun s-presence (s)
+  "Return S if it's `s-present?', otherwise return nil."
+  (declare (pure t) (side-effect-free t))
+  (and (s-present? s) s))
+
+(defun s-lowercase? (s)
+  "Are all the letters in S in lower case?"
+  (declare (side-effect-free t))
+  (let ((case-fold-search nil))
+    (not (string-match-p "[[:upper:]]" s))))
+
+(defun s-uppercase? (s)
+  "Are all the letters in S in upper case?"
+  (declare (side-effect-free t))
+  (let ((case-fold-search nil))
+    (not (string-match-p "[[:lower:]]" s))))
+
+(defun s-mixedcase? (s)
+  "Are there both lower case and upper case letters in S?"
+  (let ((case-fold-search nil))
+    (s--truthy?
+     (and (string-match-p "[[:lower:]]" s)
+          (string-match-p "[[:upper:]]" s)))))
+
+(defun s-capitalized? (s)
+  "In S, is the first letter upper case, and all other letters lower case?"
+  (declare (side-effect-free t))
+  (let ((case-fold-search nil))
+    (s--truthy?
+     (string-match-p "^[[:upper:]][^[:upper:]]*$" s))))
+
+(defun s-numeric? (s)
+  "Is S a number?"
+  (declare (pure t) (side-effect-free t))
+  (s--truthy?
+   (string-match-p "^[0-9]+$" s)))
+
+(defun s-replace (old new s)
+  "Replaces OLD with NEW in S."
+  (declare (pure t) (side-effect-free t))
+  (replace-regexp-in-string (regexp-quote old) new s t t))
+
+(defalias 's-replace-regexp 'replace-regexp-in-string)
+
+(defun s--aget (alist key)
+  (declare (pure t) (side-effect-free t))
+  (cdr (assoc-string key alist)))
+
+(defun s-replace-all (replacements s)
+  "REPLACEMENTS is a list of cons-cells. Each `car` is replaced with `cdr` in S."
+  (declare (pure t) (side-effect-free t))
+  (replace-regexp-in-string (regexp-opt (mapcar 'car replacements))
+                            (lambda (it) (s--aget replacements it))
+                            s t t))
+
+(defun s-downcase (s)
+  "Convert S to lower case.
+
+This is a simple wrapper around the built-in `downcase'."
+  (declare (side-effect-free t))
+  (downcase s))
+
+(defun s-upcase (s)
+  "Convert S to upper case.
+
+This is a simple wrapper around the built-in `upcase'."
+  (declare (side-effect-free t))
+  (upcase s))
+
+(defun s-capitalize (s)
+  "Convert the first word's first character to upper case and the rest to lower case in S."
+  (declare (side-effect-free t))
+  (concat (upcase (substring s 0 1)) (downcase (substring s 1))))
+
+(defun s-titleize (s)
+  "Convert each word's first character to upper case and the rest to lower case in S.
+
+This is a simple wrapper around the built-in `capitalize'."
+  (declare (side-effect-free t))
+  (capitalize s))
+
+(defmacro s-with (s form &rest more)
+  "Threads S through the forms. Inserts S as the last item
+in the first form, making a list of it if it is not a list
+already. If there are more forms, inserts the first form as the
+last item in second form, etc."
+  (declare (debug (form &rest [&or (function &rest form) fboundp])))
+  (if (null more)
+      (if (listp form)
+          `(,(car form) ,@(cdr form) ,s)
+        (list form s))
+    `(s-with (s-with ,s ,form) ,@more)))
+
+(put 's-with 'lisp-indent-function 1)
+
+(defun s-index-of (needle s &optional ignore-case)
+  "Returns first index of NEEDLE in S, or nil.
+
+If IGNORE-CASE is non-nil, the comparison is done without paying
+attention to case differences."
+  (declare (pure t) (side-effect-free t))
+  (let ((case-fold-search ignore-case))
+    (string-match-p (regexp-quote needle) s)))
+
+(defun s-reverse (s)
+  "Return the reverse of S."
+  (declare (pure t) (side-effect-free t))
+  (save-match-data
+    (if (multibyte-string-p s)
+        (let ((input (string-to-list s))
+              output)
+          (require 'ucs-normalize)
+          (while input
+            ;; Handle entire grapheme cluster as a single unit
+            (let ((grapheme (list (pop input))))
+              (while (memql (car input) ucs-normalize-combining-chars)
+                (push (pop input) grapheme))
+              (setq output (nconc (nreverse grapheme) output))))
+          (concat output))
+      (concat (nreverse (string-to-list s))))))
+
+(defun s-match-strings-all (regex string)
+  "Return a list of matches for REGEX in STRING.
+
+Each element itself is a list of matches, as per
+`match-string'. Multiple matches at the same position will be
+ignored after the first."
+  (declare (side-effect-free t))
+  (save-match-data
+    (let ((all-strings ())
+          (i 0))
+      (while (and (< i (length string))
+                  (string-match regex string i))
+        (setq i (1+ (match-beginning 0)))
+        (let (strings
+              (num-matches (/ (length (match-data)) 2))
+              (match 0))
+          (while (/= match num-matches)
+            (push (match-string match string) strings)
+            (setq match (1+ match)))
+          (push (nreverse strings) all-strings)))
+      (nreverse all-strings))))
+
+(defun s-matched-positions-all (regexp string &optional subexp-depth)
+  "Return a list of matched positions for REGEXP in STRING.
+SUBEXP-DEPTH is 0 by default."
+  (declare (side-effect-free t))
+  (if (null subexp-depth)
+      (setq subexp-depth 0))
+  (save-match-data
+    (let ((pos 0) result)
+      (while (and (string-match regexp string pos)
+                  (< pos (length string)))
+        (let ((m (match-end subexp-depth)))
+          (push (cons (match-beginning subexp-depth) (match-end subexp-depth)) result)
+          (setq pos (match-end 0))))
+      (nreverse result))))
+
+(defun s-match (regexp s &optional start)
+  "When the given expression matches the string, this function returns a list
+of the whole matching string and a string for each matched subexpressions.
+If it did not match the returned value is an empty list (nil).
+
+When START is non-nil the search will start at that index."
+  (declare (side-effect-free t))
+  (save-match-data
+    (if (string-match regexp s start)
+        (let ((match-data-list (match-data))
+              result)
+          (while match-data-list
+            (let* ((beg (car match-data-list))
+                   (end (cadr match-data-list))
+                   (subs (if (and beg end) (substring s beg end) nil)))
+              (setq result (cons subs result))
+              (setq match-data-list
+                    (cddr match-data-list))))
+          (nreverse result)))))
+
+(defun s-slice-at (regexp s)
+  "Slices S up at every index matching REGEXP."
+  (declare (side-effect-free t))
+  (if (= 0 (length s)) (list "")
+    (save-match-data
+      (let (i)
+        (setq i (string-match regexp s 1))
+        (if i
+            (cons (substring s 0 i)
+                  (s-slice-at regexp (substring s i)))
+          (list s))))))
+
+(defun s-split-words (s)
+  "Split S into list of words."
+  (declare (side-effect-free t))
+  (s-split
+   "[^[:word:]0-9]+"
+   (let ((case-fold-search nil))
+     (replace-regexp-in-string
+      "\\([[:lower:]]\\)\\([[:upper:]]\\)" "\\1 \\2"
+      (replace-regexp-in-string "\\([[:upper:]]\\)\\([[:upper:]][0-9[:lower:]]\\)" "\\1 \\2" s)))
+   t))
+
+(defun s--mapcar-head (fn-head fn-rest list)
+  "Like MAPCAR, but applies a different function to the first element."
+  (if list
+      (cons (funcall fn-head (car list)) (mapcar fn-rest (cdr list)))))
+
+(defun s-lower-camel-case (s)
+  "Convert S to lowerCamelCase."
+  (declare (side-effect-free t))
+  (s-join "" (s--mapcar-head 'downcase 'capitalize (s-split-words s))))
+
+(defun s-upper-camel-case (s)
+  "Convert S to UpperCamelCase."
+  (declare (side-effect-free t))
+  (s-join "" (mapcar 'capitalize (s-split-words s))))
+
+(defun s-snake-case (s)
+  "Convert S to snake_case."
+  (declare (side-effect-free t))
+  (s-join "_" (mapcar 'downcase (s-split-words s))))
+
+(defun s-dashed-words (s)
+  "Convert S to dashed-words."
+  (declare (side-effect-free t))
+  (s-join "-" (mapcar 'downcase (s-split-words s))))
+
+(defun s-capitalized-words (s)
+  "Convert S to Capitalized words."
+  (declare (side-effect-free t))
+  (let ((words (s-split-words s)))
+    (s-join " " (cons (capitalize (car words)) (mapcar 'downcase (cdr words))))))
+
+(defun s-titleized-words (s)
+  "Convert S to Titleized Words."
+  (declare (side-effect-free t))
+  (s-join " " (mapcar 's-titleize (s-split-words s))))
+
+(defun s-word-initials (s)
+  "Convert S to its initials."
+  (declare (side-effect-free t))
+  (s-join "" (mapcar (lambda (ss) (substring ss 0 1))
+                     (s-split-words s))))
+
+;; Errors for s-format
+(progn
+  (put 's-format-resolve
+       'error-conditions
+       '(error s-format s-format-resolve))
+  (put 's-format-resolve
+       'error-message
+       "Cannot resolve a template to values"))
+
+(defun s-format (template replacer &optional extra)
+  "Format TEMPLATE with the function REPLACER.
+
+REPLACER takes an argument of the format variable and optionally
+an extra argument which is the EXTRA value from the call to
+`s-format'.
+
+Several standard `s-format' helper functions are recognized and
+adapted for this:
+
+    (s-format \"${name}\" 'gethash hash-table)
+    (s-format \"${name}\" 'aget alist)
+    (s-format \"$0\" 'elt sequence)
+
+The REPLACER function may be used to do any other kind of
+transformation."
+  (let ((saved-match-data (match-data)))
+    (unwind-protect
+        (replace-regexp-in-string
+         "\\$\\({\\([^}]+\\)}\\|[0-9]+\\)"
+         (lambda (md)
+           (let ((var
+                  (let ((m (match-string 2 md)))
+                    (if m m
+                      (string-to-number (match-string 1 md)))))
+                 (replacer-match-data (match-data)))
+             (unwind-protect
+                 (let ((v
+                        (cond
+                         ((eq replacer 'gethash)
+                          (funcall replacer var extra))
+                         ((eq replacer 'aget)
+                          (funcall 's--aget extra var))
+                         ((eq replacer 'elt)
+                          (funcall replacer extra var))
+                         ((eq replacer 'oref)
+                          (funcall #'slot-value extra (intern var)))
+                         (t
+                          (set-match-data saved-match-data)
+                          (if extra
+                              (funcall replacer var extra)
+                            (funcall replacer var))))))
+                   (if v (format "%s" v) (signal 's-format-resolve md)))
+               (set-match-data replacer-match-data)))) template
+               ;; Need literal to make sure it works
+               t t)
+      (set-match-data saved-match-data))))
+
+(defvar s-lex-value-as-lisp nil
+  "If `t' interpolate lisp values as lisp.
+
+`s-lex-format' inserts values with (format \"%S\").")
+
+(defun s-lex-fmt|expand (fmt)
+  "Expand FMT into lisp."
+  (declare (side-effect-free t))
+  (list 's-format fmt (quote 'aget)
+        (append '(list)
+                (mapcar
+                 (lambda (matches)
+                   (list
+                    'cons
+                    (cadr matches)
+                    `(format
+                      (if s-lex-value-as-lisp "%S" "%s")
+                      ,(intern (cadr matches)))))
+                 (s-match-strings-all "${\\([^}]+\\)}" fmt)))))
+
+(defmacro s-lex-format (format-str)
+  "`s-format` with the current environment.
+
+FORMAT-STR may use the `s-format' variable reference to refer to
+any variable:
+
+ (let ((x 1))
+   (s-lex-format \"x is: ${x}\"))
+
+The values of the variables are interpolated with \"%s\" unless
+the variable `s-lex-value-as-lisp' is `t' and then they are
+interpolated with \"%S\"."
+  (declare (debug (form)))
+  (s-lex-fmt|expand format-str))
+
+(defun s-count-matches (regexp s &optional start end)
+  "Count occurrences of `regexp' in `s'.
+
+`start', inclusive, and `end', exclusive, delimit the part of `s' to
+match.  `start' and `end' are both indexed starting at 1; the initial
+character in `s' is index 1.
+
+This function starts looking for the next match from the end of the
+previous match.  Hence, it ignores matches that overlap a previously
+found match.  To count overlapping matches, use
+`s-count-matches-all'."
+  (declare (side-effect-free t))
+  (save-match-data
+    (with-temp-buffer
+      (insert s)
+      (goto-char (point-min))
+      (count-matches regexp (or start 1) (or end (point-max))))))
+
+(defun s-count-matches-all (regexp s &optional start end)
+  "Count occurrences of `regexp' in `s'.
+
+`start', inclusive, and `end', exclusive, delimit the part of `s' to
+match.  `start' and `end' are both indexed starting at 1; the initial
+character in `s' is index 1.
+
+This function starts looking for the next match from the second
+character of the previous match.  Hence, it counts matches that
+overlap a previously found match.  To ignore matches that overlap a
+previously found match, use `s-count-matches'."
+  (declare (side-effect-free t))
+  (let* ((anchored-regexp (format "^%s" regexp))
+         (match-count 0)
+         (i 0)
+         (narrowed-s (substring s
+                                (when start (1- start))
+                                (when end (1- end)))))
+    (save-match-data
+      (while (< i (length narrowed-s))
+        (when (s-matches? anchored-regexp (substring narrowed-s i))
+          (setq match-count (1+ match-count)))
+        (setq i (1+ i))))
+    match-count))
+
+(defun s-wrap (s prefix &optional suffix)
+  "Wrap string S with PREFIX and optionally SUFFIX.
+
+Return string S with PREFIX prepended.  If SUFFIX is present, it
+is appended, otherwise PREFIX is used as both prefix and
+suffix."
+  (declare (pure t) (side-effect-free t))
+  (concat prefix s (or suffix prefix)))
+
+
+;;; Aliases
+
+(defalias 's-blank-p 's-blank?)
+(defalias 's-blank-str-p 's-blank-str?)
+(defalias 's-capitalized-p 's-capitalized?)
+(defalias 's-contains-p 's-contains?)
+(defalias 's-ends-with-p 's-ends-with?)
+(defalias 's-equals-p 's-equals?)
+(defalias 's-less-p 's-less?)
+(defalias 's-lowercase-p 's-lowercase?)
+(defalias 's-matches-p 's-matches?)
+(defalias 's-mixedcase-p 's-mixedcase?)
+(defalias 's-numeric-p 's-numeric?)
+(defalias 's-prefix-p 's-starts-with?)
+(defalias 's-prefix? 's-starts-with?)
+(defalias 's-present-p 's-present?)
+(defalias 's-starts-with-p 's-starts-with?)
+(defalias 's-suffix-p 's-ends-with?)
+(defalias 's-suffix? 's-ends-with?)
+(defalias 's-uppercase-p 's-uppercase?)
+
+
+(provide 's)
+;;; s.el ends here
diff --git a/lisp/sphinx-doc.el b/lisp/sphinx-doc.el
new file mode 100644
index 00000000..6519cd24
--- /dev/null
+++ b/lisp/sphinx-doc.el
@@ -0,0 +1,455 @@
+;;; sphinx-doc.el --- Sphinx friendly docstrings for Python functions
+
+;; Copyright (c) 2013 
+
+;; Author: Vineet Naik 
+;; URL: https://github.com/naiquevin/sphinx-doc.el
+;; Package-Version: 20160116.1117
+;; Version: 0.3.0
+;; Keywords: Sphinx, Python
+;; Package-Requires: ((s "1.9.0") (cl-lib "0.5") (dash "2.10.0"))
+
+;; This program is *not* a part of emacs and is provided under the MIT
+;; License (MIT) 
+;;
+;; Copyright (c) 2013 
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;; Commentary:
+;;
+;; This file provides a minor mode for inserting docstring skeleton
+;; for Python functions and methods.  The structure of the docstring is
+;; as per the requirements of the Sphinx documentation generator
+;; 
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'dash)
+(require 's)
+
+
+(defun sphinx-doc-current-line ()
+  "Return current line as string."
+  (buffer-substring-no-properties (point-at-bol) (point-at-eol)))
+
+
+;; regular expression to identify a valid function definition in
+;; python and match it's name and arguments
+(defconst sphinx-doc-fun-regex "^ *def \\([a-zA-Z0-9_]+\\)(\\(\\(?:.\\|\n\\)*\\)):$")
+
+;; regexes for beginning and end of python function definitions
+(defconst sphinx-doc-fun-beg-regex "def")
+(defconst sphinx-doc-fun-end-regex ":\\(?:\n\\)?")
+
+;; Variations for some field keys recognized by Sphinx
+(defconst sphinx-doc-param-variants '("param" "parameter" "arg" "argument"
+                                      "key" "keyword"))
+(defconst sphinx-doc-raises-variants '("raises" "raise" "except" "exception"))
+(defconst sphinx-doc-returns-variants '("returns" "return"))
+
+(defvar sphinx-doc-python-indent)
+
+;; struct definitions
+
+(cl-defstruct sphinx-doc-arg
+  name      ; name of the arg
+  default)  ; optional default value if specified
+
+
+(cl-defstruct sphinx-doc-fndef
+  name  ; name of the function
+  args) ; list of arg objects
+
+
+(cl-defstruct sphinx-doc-field
+  key        ; one of the allowed field name keyword
+  type       ; optional datatype
+  arg        ; optional argument
+  (desc "")) ; description
+
+;; Note about various types of reST fields recognized by Sphinx and
+;; how they are represented using the `sphinx-doc-field` struct
+;; above. The `key` should be non-nil in all since that's how they are
+;; identified:
+;;
+;; 1. param: All params must have a valid `arg` whereas `type` is
+;;           optional and `desc` will initially be an empty string
+;; 2. type: Must have valid `arg`
+;; 3. rtype: Must NOT have `type` or `arg`
+;; 4. returns: Must NOT have `type` or `arg`
+;; 5. raises: Must have a valid `arg`
+;;
+;; See Also: http://sphinx-doc.org/domains.html#info-field-lists
+
+
+(cl-defstruct sphinx-doc-doc
+  (summary "FIXME! briefly describe function") ; summary line that fits on the first line
+  before-fields                                ; list of comments before fields
+  after-fields                                 ; list of comments after fields
+  fields)                                      ; list of field objects
+
+
+(defun sphinx-doc-str->arg (s)
+  "Build an arg object from string S."
+  (let ((parts (mapcar #'s-trim (split-string s "="))))
+    (if (cdr parts)
+        (make-sphinx-doc-arg :name (car parts)
+                             :default (cadr parts))
+      (make-sphinx-doc-arg :name (car parts)))))
+
+
+(defun sphinx-doc-fndef->doc (f)
+  "Build a doc object solely from fndef F."
+  (make-sphinx-doc-doc
+   :fields (append
+            (mapcar (lambda (a)
+                      (make-sphinx-doc-field
+                       :key "param"
+                       :arg (sphinx-doc-arg-name a)))
+                    (sphinx-doc-fndef-args f))
+            (list (make-sphinx-doc-field :key "returns")
+                  (make-sphinx-doc-field :key "rtype")))))
+
+
+(defun sphinx-doc-fun-args (argstrs)
+  "Extract list of arg objects from string ARGSTRS.
+ARGSTRS is the string representing function definition in Python.
+Note that the arguments self, *args and **kwargs are ignored."
+  (when (not (string= argstrs ""))
+    (mapcar #'sphinx-doc-str->arg
+            (-filter
+             (lambda (str)
+               (and (not (string= (substring str 0 1) "*"))
+                    (not (string= str "self"))))
+             (mapcar #'s-trim
+                     (split-string argstrs ","))))))
+
+
+(defun sphinx-doc-str->fndef (s)
+  "Build a fndef object from string S.
+S is a string representation of the python function definition
+Returns nil if string is not a function definition."
+  (when (string-match sphinx-doc-fun-regex s)
+    (make-sphinx-doc-fndef
+     :name (match-string 1 s)
+     :args (sphinx-doc-fun-args (match-string 2 s)))))
+
+
+(defun sphinx-doc-field->str (f)
+  "Convert a field object F to it's string representation."
+  (cond ((and (stringp (sphinx-doc-field-arg f))
+              (stringp (sphinx-doc-field-type f)))
+         (s-format ":${key} ${type} ${arg}: ${desc}"
+                   'aget
+                   `(("key" . ,(sphinx-doc-field-key f))
+                     ("type" . ,(sphinx-doc-field-type f))
+                     ("arg" . ,(sphinx-doc-field-arg f))
+                     ("desc" . ,(sphinx-doc-field-desc f)))))
+        ((stringp (sphinx-doc-field-arg f))
+         (s-format ":${key} ${arg}: ${desc}"
+                   'aget
+                   `(("key" . ,(sphinx-doc-field-key f))
+                     ("arg" . ,(sphinx-doc-field-arg f))
+                     ("desc" . ,(sphinx-doc-field-desc f)))))
+        (t (s-format ":${key}: ${desc}"
+                     'aget
+                     `(("key" . ,(sphinx-doc-field-key f))
+                       ("desc" . ,(sphinx-doc-field-desc f)))))))
+
+
+(defun sphinx-doc-doc->str (ds)
+  "Convert a doc object DS into string representation."
+  (s-join
+   "\n"
+   (-filter
+    (lambda (x) (not (equal x nil)))
+    (list (s-format "\"\"\"$0\n" 'elt (list (sphinx-doc-doc-summary ds)))
+          (when (and (sphinx-doc-doc-before-fields ds)
+                     (not (string= (sphinx-doc-doc-before-fields ds) "")))
+            (concat (sphinx-doc-doc-before-fields ds) "\n"))
+          (s-join "\n" (mapcar #'sphinx-doc-field->str
+                               (sphinx-doc-doc-fields ds)))
+          ""
+          (when (and (sphinx-doc-doc-after-fields ds)
+                     (not (string= (sphinx-doc-doc-after-fields ds) "")))
+            (concat (sphinx-doc-doc-after-fields ds) "\n"))
+          "\"\"\""))))
+
+
+(defun sphinx-doc-parse (docstr indent)
+  "Parse docstring DOCSTR into it's equivalent doc object.
+INDENT is the current indentation level of the Python function."
+  (let* ((lines (mapcar (lambda (line)
+                          (s-chop-prefix (make-string indent 32) line))
+                        (split-string docstr "\n")))
+         (paras (sphinx-doc-lines->paras lines))
+         (field-para? #'(lambda (p) (s-starts-with? ":" (car p))))
+         (comment? #'(lambda (p) (not (funcall field-para? p)))))
+    (progn
+      (make-sphinx-doc-doc
+       :summary (caar paras)
+       :before-fields (sphinx-doc-paras->str
+                       (-take-while comment? (cdr paras)))
+       :after-fields (sphinx-doc-paras->str
+                      (cdr (-drop-while comment? (cdr paras))))
+       :fields (sphinx-doc-parse-fields
+                (car (-filter field-para? paras)))))))
+
+
+(defun sphinx-doc-paras->str (paras)
+  "Convert PARAS to string.
+PARAS are list of paragraphs (which in turn are list of lines).
+This is done by adding a newline between two lines of each para
+and a blank line between each para."
+  (s-join
+   ""
+   (apply #'append
+          (-interpose '("\n\n")
+                      (mapcar (lambda (p)
+                                (-interpose "\n" p))
+                              paras)))))
+
+
+(defun sphinx-doc-lines->paras (lines)
+  "Group LINES which are list of strings into paragraphs."
+  (reverse
+   (mapcar
+    #'reverse
+    (car
+     (cl-reduce (lambda (acc x)
+                  (let ((paras (car acc))
+                        (prev-blank? (cdr acc)))
+                    (cond ((string= x "") (cons paras t))
+                          (prev-blank? (cons (cons (list x) paras) nil))
+                          (t (cons (cons (cons x (car paras)) (cdr paras)) nil)))))
+                (cdr lines)
+                :initial-value (cons (list (list (car lines))) nil))))))
+
+
+(defun sphinx-doc-str->field (s)
+  "Parse a single field into field object.
+Argument S represents a single field in the fields paragraph of
+the docstring."
+  (cond ((string-match "^:\\([a-z]+\\) \\([a-z.]+\\) \\([a-zA-Z0-9_]+\\):\s?\\(.*\\(?:\n\s*.*\\)*\\)$" s)
+         (make-sphinx-doc-field :key (match-string 1 s)
+                                :type (match-string 2 s)
+                                :arg (match-string 3 s)
+                                :desc (match-string 4 s)))
+        ((string-match "^:\\([a-z]+\\) \\([a-zA-Z0-9_]+\\):\s?\\(.*\\(?:\n\s*.*\\)*\\)$" s)
+         (make-sphinx-doc-field :key (match-string 1 s)
+                                :arg (match-string 2 s)
+                                :desc (match-string 3 s)))
+        ((string-match "^:\\([a-z]+\\):\s?\\(.*\\(?:\n\s*.*\\)*\\)$" s)
+         (make-sphinx-doc-field :key (match-string 1 s)
+                                :desc (match-string 2 s)))))
+
+
+(defun sphinx-doc-parse-fields (fields-para)
+  "Parse FIELDS-PARA into list of field objects.
+FIELDS-PARA is the fields section of the docstring."
+  (when fields-para
+    (mapcar #'sphinx-doc-str->field
+            (mapcar (lambda (s)
+                      (if (s-starts-with? ":" s) s (concat ":" s)))
+                    (split-string (s-join "\n" fields-para) "\n:")))))
+
+
+(defun sphinx-doc-merge-docs (old new)
+  "Merge OLD and NEW doc objects.
+Effectively, only the fields field of new doc are merged whereas
+the remaining fields of the old object stay as they are."
+  (make-sphinx-doc-doc
+   :summary (sphinx-doc-doc-summary old)
+   :before-fields (sphinx-doc-doc-before-fields old)
+   :after-fields (sphinx-doc-doc-after-fields old)
+   :fields (sphinx-doc-merge-fields
+            (sphinx-doc-doc-fields old)
+            (sphinx-doc-doc-fields new))))
+
+
+(defun sphinx-doc-select-fields (keys fields)
+  "Return subset of fields with select keys.
+KEYS is a list of strings and FIELDS is a list of field objects."
+  (-filter (lambda (f)
+             (member (sphinx-doc-field-key f) keys))
+           fields))
+
+
+(defun sphinx-doc-field-map (fields)
+  "Create a mapping of field arg with the field for all FIELDS."
+  (mapcar (lambda (f) (cons (sphinx-doc-field-arg f) f)) fields))
+
+
+(defun sphinx-doc-field-map-get (key mapping)
+  "Return the value in the field mapping for the key or nil.
+KEY is a string and MAPPING is an associative list."
+  (cdr (assoc key mapping)))
+
+
+(defun sphinx-doc-merge-fields (old new)
+  "Merge old and new fields together.
+OLD is the list of old field objects, NEW is the list of new
+field objects."
+  (let ((param-map (sphinx-doc-field-map
+                    (sphinx-doc-select-fields sphinx-doc-param-variants old)))
+        (type-map (sphinx-doc-field-map
+                   (sphinx-doc-select-fields '("type") old)))
+        (fixed-fields (sphinx-doc-select-fields
+                       (cons "rtype" (append sphinx-doc-returns-variants
+                                             sphinx-doc-raises-variants))
+                       old)))
+    (append (-mapcat
+             (lambda (f)
+               (let* ((key (sphinx-doc-field-arg f))
+                      (param (sphinx-doc-field-map-get key param-map))
+                      (type (sphinx-doc-field-map-get key type-map)))
+                 (cond ((and param type) (list param type))
+                       (param (list param))
+                       (t (list f)))))
+             (sphinx-doc-select-fields sphinx-doc-param-variants new))
+            fixed-fields)))
+
+
+;; Note: Following few functions (those using `save-excursion`) must
+;; be invoked only when the cursor is on the function definition line.
+
+(defun sphinx-doc-get-region (srch-beg srch-end)
+  "Return the beginning and end points of a region by searching.
+SRCH-BEG and SRCH-END are the chars to search for."
+  (save-excursion
+    (search-forward-regexp srch-beg)
+    (let ((beg (point)))
+      (search-forward-regexp srch-end)
+      (vector beg (point)))))
+
+
+(defun sphinx-doc-current-indent ()
+  "Return the indentation level of the current line.
+ie. by how many number of spaces the current line is indented"
+  (save-excursion
+    (let ((bti (progn (back-to-indentation) (point)))
+          (bol (progn (beginning-of-line) (point))))
+      (- bti bol))))
+
+
+(defun sphinx-doc-fndef-str ()
+  "Return the Python function definition as a string."
+  (save-excursion
+    (let ((ps (sphinx-doc-get-region sphinx-doc-fun-beg-regex
+                                     sphinx-doc-fun-end-regex)))
+      (buffer-substring-no-properties (- (elt ps 0) 3) (- (elt ps 1) 1)))))
+
+
+(defun sphinx-doc-exists? ()
+  "Return whether the docstring already exists for a function."
+  (save-excursion
+    (search-forward-regexp sphinx-doc-fun-end-regex)
+    (s-starts-with? "\"\"\"" (s-trim (sphinx-doc-current-line)))))
+
+
+(defun sphinx-doc-existing ()
+  "Return docstring of the function if it exists else nil."
+  (when (sphinx-doc-exists?)
+    (let* ((ps (sphinx-doc-get-region "\"\"\"" "\"\"\""))
+           (docstr (buffer-substring-no-properties (elt ps 0)
+                                                   (- (elt ps 1) 3)))
+           (indent (save-excursion
+                     (search-forward-regexp sphinx-doc-fun-end-regex)
+                     (sphinx-doc-current-indent))))
+      (sphinx-doc-parse docstr indent))))
+
+
+(defun sphinx-doc-kill-old-doc (indent)
+  "Kill the old docstring for the current Python function.
+INDENT is an integer representing the number of spaces the
+function body is indented from the beginning of the line"
+  (save-excursion
+    (let ((ps (sphinx-doc-get-region "\"\"\"" "\"\"\"\\(?:\n\\)?")))
+      (kill-region (- (elt ps 0) 3) (+ (elt ps 1) indent)))))
+
+
+(defun sphinx-doc-insert-doc (doc)
+  "Insert the DOC as string for the current Python function."
+  (save-excursion
+    (search-forward-regexp sphinx-doc-fun-end-regex)
+    (forward-line -1)
+    (move-end-of-line nil)
+    (newline-and-indent)
+    (insert (sphinx-doc-doc->str doc))))
+
+
+(defun sphinx-doc-indent-doc (indent)
+  "Indent docstring for the current function.
+INDENT is the level of indentation"
+  (save-excursion
+    (let ((ps (sphinx-doc-get-region "\"\"\"" "\"\"\"")))
+      (indent-rigidly (elt ps 0) (elt ps 1) indent))))
+
+
+(defun sphinx-doc ()
+  "Insert docstring for the Python function definition at point.
+This is an interactive function and the docstring generated is as
+per the requirement of Sphinx documentation generator."
+  (interactive)
+  (if (string= (thing-at-point 'word) "def")
+      (back-to-indentation)
+    (search-backward-regexp sphinx-doc-fun-beg-regex))
+  (let ((fd (sphinx-doc-str->fndef (sphinx-doc-fndef-str))))
+    (if fd
+        (let ((indent (+ (sphinx-doc-current-indent) sphinx-doc-python-indent))
+              (old-ds (sphinx-doc-existing))
+              (new-ds (sphinx-doc-fndef->doc fd)))
+          (progn
+            (when old-ds (sphinx-doc-kill-old-doc indent))
+            (sphinx-doc-insert-doc
+             (if old-ds
+                 (sphinx-doc-merge-docs old-ds new-ds)
+               new-ds))
+            (sphinx-doc-indent-doc indent)
+            (search-forward "\"\"\""))))))
+
+
+(defvar sphinx-doc-mode-map
+  (let ((m (make-sparse-keymap)))
+    (define-key m (kbd "C-c M-d") 'sphinx-doc)
+    m))
+
+
+;;;###autoload
+(define-minor-mode sphinx-doc-mode
+  "Sphinx friendly docstring generation for Python code."
+  :init-value nil
+  :lighter " Spnxd"
+  :keymap sphinx-doc-mode-map
+  (when sphinx-doc-mode ; ON
+    (set (make-local-variable 'sphinx-doc-python-indent)
+         (cond ((boundp 'python-indent-offset)
+                python-indent-offset)
+               ((boundp 'python-indent)
+                python-indent)
+               (t 4)))))
+
+
+(provide 'sphinx-doc)
+
+;;; sphinx-doc.el ends here
diff --git a/lisp/stickyfunc-enhance.el b/lisp/stickyfunc-enhance.el
new file mode 100644
index 00000000..2b65bd2c
--- /dev/null
+++ b/lisp/stickyfunc-enhance.el
@@ -0,0 +1,211 @@
+;;; stickyfunc-enhance.el --- An enhancement to stock `semantic-stickyfunc-mode'
+;;
+;; Filename: stickyfunc-enhance.el
+;; Description: An enhancement to `semantic-stickyfunc-mode'
+;; Author: Tu, Do Hoang 
+;; URL      : https://github.com/tuhdo/semantic-stickyfunc-enhance
+;; Package-Version: 20150429.1814
+;; Maintainer: Tu, Do Hoang
+;; Created: Friday March 13
+;; Version: 0.1
+;; Package-Requires: ((emacs "24.3"))
+;; Keywords: c, languages, tools
+;; Compatibility: GNU Emacs: 24.3+
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+;;
+;; When enable, `semantic-stickyfunc-mode' shows the function point is
+;; currently in at the first line of the current buffer. This is
+;; useful when you have a very long function that spreads more than a
+;; screen, and you don't have to scroll up to read the function name
+;; and then scroll down to original position.
+;;
+;; However, one of the problem with current semantic-stickyfunc-mode
+;; is that it does not display all parameters that are scattered on
+;; multiple lines. To solve this problem, we need to redefine
+;; `semantic-stickyfunc-fetch-stickyline' function.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; 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 GNU Emacs.  If not, see .
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Code:
+(require 'cl-lib)
+(require 'cc-mode)
+(require 'semantic)
+(if (not (version< emacs-version "24.4"))
+    (require 'subr-x)
+  (defsubst string-trim (string)
+    "Remove leading and trailing whitespace from STRING."
+    (string-trim-left (string-trim-right string)))
+
+  (defsubst string-empty-p (string)
+    "Check whether STRING is empty."
+    (string= string ""))
+
+  (defsubst string-trim-left (string)
+    "Remove leading whitespace from STRING."
+    (if (string-match "\\`[ \t\n\r]+" string)
+        (replace-match "" t t string)
+      string))
+
+  (defsubst string-trim-right (string)
+    "Remove trailing whitespace from STRING."
+    (if (string-match "[ \t\n\r]+\\'" string)
+        (replace-match "" t t string)
+      string)))
+
+;;;###autoload
+(defun semantic-stickyfunc-fetch-stickyline ()
+  "Make the function at the top of the current window sticky.
+Capture its function declaration, and place it in the header line.
+If there is no function, disable the header line."
+  (save-excursion
+    (goto-char (window-start (selected-window)))
+    (let* ((noshow (bobp))
+           (str
+            (progn
+              (forward-line -1)
+              (end-of-line)
+              ;; Capture this function
+              (let* ((tag (semantic-stickyfunc-tag-to-stick))
+                     param-tags filtered-tags tmp-str)
+                ;; TAG is nil if there was nothing of the appropriate type there.
+                (if (not tag)
+                    ;; Set it to be the text under the header line
+                    (if noshow
+                        ""
+                      (if semantic-stickyfunc-show-only-functions-p ""
+                        (buffer-substring (point-at-bol) (point-at-eol))))
+                  (setq param-tags (semantic-tag-function-arguments tag))
+                  (setq filtered-tags (stickyfunc-enhance--tags-out-of-screen param-tags tag)) ;
+                  (setq tmp-str (semantic-format-tag-prototype tag nil t))
+                  (if (and (= (length param-tags) (length filtered-tags))
+                           (not (eq major-mode 'python-mode)))
+                      tmp-str
+                    (if (not (eq (semantic-tag-class tag) 'function))
+                        tmp-str
+                      (string-match (stickyfunc-enhance--parameters-regexp tag) tmp-str)
+                      (setq tmp-str (replace-match (stickyfunc-enhance--text-to-replace tag) t t tmp-str 0))
+                      (if filtered-tags
+                          (dolist (v filtered-tags)
+                            (setq tmp-str (concat tmp-str
+                                                  (stickyfunc-enhance--function-parameter-string v)
+                                                  (stickyfunc-enhance--function-argument-separator))))
+                        (setq tmp-str (concat tmp-str ")"))))
+                    tmp-str)))))
+           (start 0))
+      (while (string-match "%" str start)
+        (setq str (replace-match "%%" t t str 0)
+              start (1+ (match-end 0))))
+      ;; In 21.4 (or 22.1) the header doesn't expand tabs.  Hmmmm.
+      ;; We should replace them here.
+      ;;
+      ;; This hack assumes that tabs are kept smartly at tab boundaries
+      ;; instead of in a tab boundary where it might only represent 4 spaces.
+      (while (string-match "\t" str start)
+        (setq str (replace-match "        " t t str 0)))
+      str)))
+
+(defun stickyfunc-enhance--function-parameter-string (tag)
+  "Return a string of a parameter TAG to be displayed.
+
+It handles Python specifically along with other modes, because
+the stock Semantic formate functions do not display assigned
+values to parameters if there is any.
+
+Also handles a case if tag is stored a string, not a list, as
+returned by `semantic-tag-function-arguments' in Emacs Lisp mode."
+  (cond
+   ((eq major-mode 'python-mode)
+    (save-excursion
+      (let* ((tag-start (semantic-tag-start tag))
+             (next-tag (save-excursion
+                         (goto-char tag-start)
+                         (semantic-find-tag-by-overlay-next)))
+             (next-tag-start (if (not next-tag)
+                                 (search-forward ":")
+                               (semantic-tag-start next-tag))))
+        (string-trim
+         (replace-regexp-in-string "\\Ca.*"
+                                   ""
+                                   (buffer-substring tag-start
+                                                     next-tag-start))))))
+   (t
+    (if (listp tag)
+        (semantic-format-tag-prototype tag nil t)
+      (propertize tag 'face 'font-lock-variable-name-face)))))
+
+(defun stickyfunc-enhance--function-argument-separator ()
+  "Return a proper separator between parameter tags."
+  (cond
+   ((or (eq major-mode 'c-mode)
+        (eq major-mode 'c++-mode))
+    ",")
+   ((or (eq major-mode 'emacs-lisp-mode)
+        (eq major-mode 'python-mode))
+    " ")
+   (t ",")))
+
+(defun stickyfunc-enhance--text-to-replace (tag)
+  "Text to replace a matched text of a TAG.
+
+To be used with `stickyfunc-enhance--parameters-regexp'"
+  (cond
+   ((or (eq major-mode 'c-mode)
+        (eq major-mode 'c++-mode))
+    "(")
+   ((eq major-mode 'emacs-lisp-mode)
+    (concat "(" (propertize (semantic-tag-name tag) 'face 'font-lock-function-name-face) " "))
+   (t "(")))
+
+(defun stickyfunc-enhance--parameters-regexp (tag)
+  "Return parameter regexp of a function TAG.
+
+To be used with `stickyfunc-enhance--text-to-replace'"
+  (cond
+   ((or (eq major-mode 'c-mode)
+        (eq major-mode 'c++-mode))
+    "(.*)")
+   ((eq major-mode 'emacs-lisp-mode)
+    "(.*)")
+   (t "(.*)")))
+
+(defun stickyfunc-enhance--tags-out-of-screen (tags parent-tag)
+  "Return a list of tags that are out of current visible screen.
+
+TAGS are a list of tags that are function parameters of PARENT-TAG.
+
+PARENT-TAG is a function."
+  (let ((start-line (line-number-at-pos (window-start))))
+    (cl-remove-if (lambda (tag)
+                    (>= (line-number-at-pos (if (listp tag)
+                                                (semantic-tag-start tag)
+                                              (save-excursion
+                                                (goto-char (semantic-tag-start parent-tag))
+                                                (search-forward tag)
+                                                (point))))
+                        start-line))
+                  tags)))
+
+(provide 'stickyfunc-enhance)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; stickyfunc-enhance.el ends here
+;; Local Variables:
+;; byte-compile-warnings: t
+;; End:
diff --git a/lisp/swiper.el b/lisp/swiper.el
new file mode 100644
index 00000000..ada41fd8
--- /dev/null
+++ b/lisp/swiper.el
@@ -0,0 +1,1719 @@
+;;; swiper.el --- Isearch with an overview. Oh, man! -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015-2019  Free Software Foundation, Inc.
+
+;; Author: Oleh Krehel 
+;; URL: https://github.com/abo-abo/swiper
+;; Package-Version: 20200503.1102
+;; Package-Commit: d951004c7f3ebf98d55fc5a80a3471ec95b6db05
+;; Version: 0.13.0
+;; Package-Requires: ((emacs "24.5") (ivy "0.13.0"))
+;; Keywords: matching
+
+;; This file is 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 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.
+
+;; For a full copy of the GNU General Public License
+;; see .
+
+;;; Commentary:
+
+;; This package gives an overview of the current regex search
+;; candidates.  The search regex can be split into groups with a
+;; space.  Each group is highlighted with a different face.
+;;
+;; It can double as a quick `regex-builder', although only single
+;; lines will be matched.
+
+;;; Code:
+
+(require 'ivy)
+
+(defgroup swiper nil
+  "`isearch' with an overview."
+  :group 'matching
+  :prefix "swiper-")
+
+(defface swiper-match-face-1
+  '((t (:inherit lazy-highlight)))
+  "The background face for `swiper' matches."
+  :group 'ivy-faces)
+
+(defface swiper-match-face-2
+  '((t (:inherit isearch)))
+  "Face for `swiper' matches modulo 1."
+  :group 'ivy-faces)
+
+(defface swiper-match-face-3
+  '((t (:inherit match)))
+  "Face for `swiper' matches modulo 2."
+  :group 'ivy-faces)
+
+(defface swiper-match-face-4
+  '((t (:inherit isearch-fail)))
+  "Face for `swiper' matches modulo 3."
+  :group 'ivy-faces)
+
+(defface swiper-background-match-face-1
+  '((t (:inherit swiper-match-face-1)))
+  "The background face for non-current `swiper' matches."
+  :group 'ivy-faces)
+
+(defface swiper-background-match-face-2
+  '((t (:inherit swiper-match-face-2)))
+  "Face for non-current `swiper' matches modulo 1."
+  :group 'ivy-faces)
+
+(defface swiper-background-match-face-3
+  '((t (:inherit swiper-match-face-3)))
+  "Face for non-current `swiper' matches modulo 2."
+  :group 'ivy-faces)
+
+(defface swiper-background-match-face-4
+  '((t (:inherit swiper-match-face-4)))
+  "Face for non-current `swiper' matches modulo 3."
+  :group 'ivy-faces)
+
+(defface swiper-line-face
+  '((t (:inherit highlight)))
+  "Face for current `swiper' line."
+  :group 'ivy-faces)
+
+(defcustom swiper-faces '(swiper-match-face-1
+                          swiper-match-face-2
+                          swiper-match-face-3
+                          swiper-match-face-4)
+  "List of `swiper' faces for group matches."
+  :group 'ivy-faces
+  :type '(repeat face))
+
+(defvar swiper-background-faces
+  '(swiper-background-match-face-1
+    swiper-background-match-face-2
+    swiper-background-match-face-3
+    swiper-background-match-face-4)
+  "Like `swiper-faces', but used for all matches except the current one.")
+
+(defun swiper--recompute-background-faces ()
+  (let ((faces '(swiper-background-match-face-1
+                 swiper-background-match-face-2
+                 swiper-background-match-face-3
+                 swiper-background-match-face-4))
+        (colir-compose-method #'colir-compose-soft-light))
+    (cl-mapc (lambda (f1 f2)
+               (let ((bg (face-background f1)))
+                 (when bg
+                   (set-face-background
+                    f2
+                    (colir-blend
+                     (colir-color-parse bg)
+                     (colir-color-parse "#ffffff"))))))
+             swiper-faces
+             faces)))
+(swiper--recompute-background-faces)
+
+(defcustom swiper-min-highlight 2
+  "Only highlight matches for regexps at least this long."
+  :type 'integer)
+
+(defcustom swiper-include-line-number-in-search nil
+  "Include line number in text of search candidates."
+  :type 'boolean
+  :group 'swiper)
+
+(defcustom swiper-goto-start-of-match nil
+  "When non-nil, go to the start of the match, not its end.
+Treated as non-nil when searching backwards."
+  :type 'boolean
+  :group 'swiper)
+
+(defun swiper-C-s (&optional arg)
+  "Move cursor vertically down ARG candidates.
+If the input is empty, select the previous history element instead."
+  (interactive "p")
+  (if (string= ivy-text "")
+      (ivy-previous-history-element 1)
+    (ivy-next-line arg)))
+
+(defvar swiper-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map (kbd "C-s") 'swiper-C-s)
+    (define-key map (kbd "M-q") 'swiper-query-replace)
+    (define-key map (kbd "C-l") 'swiper-recenter-top-bottom)
+    (define-key map (kbd "C-'") 'swiper-avy)
+    (define-key map (kbd "C-7") 'swiper-mc)
+    (define-key map (kbd "C-c C-f") 'swiper-toggle-face-matching)
+    map)
+  "Keymap for swiper.")
+
+(defvar swiper--query-replace-overlays nil)
+
+(defun swiper--query-replace-updatefn ()
+  (let ((lisp (ignore-errors (nth 2 (query-replace-compile-replacement ivy-text t)))))
+    (dolist (ov swiper--query-replace-overlays)
+      (overlay-put
+       ov 'after-string
+       (propertize
+        (condition-case nil
+            (with-current-buffer (overlay-buffer ov)
+              (set-match-data (overlay-get ov 'md))
+              (if (consp lisp)
+                  (eval lisp)
+                (match-substitute-replacement ivy-text)))
+          (error ivy-text))
+        'face 'error)))))
+
+(defun swiper--query-replace-cleanup ()
+  (while swiper--query-replace-overlays
+    (delete-overlay (pop swiper--query-replace-overlays))))
+
+(defun swiper--query-replace-setup ()
+  (with-ivy-window
+    (let ((end (window-end (selected-window) t))
+          (re (ivy-re-to-str ivy-regex)))
+      (save-excursion
+        (beginning-of-line)
+        (while (re-search-forward re end t)
+          (let ((ov (make-overlay (1- (match-end 0)) (match-end 0)))
+                (md (match-data t)))
+            (overlay-put
+             ov 'matches
+             (mapcar
+              (lambda (x)
+                (list `(match-string ,x) (match-string x)))
+              (number-sequence 0 (1- (/ (length md) 2)))))
+            (overlay-put ov 'md md)
+            (push ov swiper--query-replace-overlays))
+          (unless (> (match-end 0) (match-beginning 0))
+            (forward-char)))))))
+
+(defun swiper-query-replace ()
+  "Start `query-replace' with string to replace from last search string."
+  (interactive)
+  (cond ((null (window-minibuffer-p))
+         (user-error "Should only be called in the minibuffer through `swiper-map'"))
+        ((string= "" ivy-text)
+         (user-error "Empty input"))
+        (t
+         (swiper--query-replace-setup)
+         (unwind-protect
+              (let* ((enable-recursive-minibuffers t)
+                     (from (ivy-re-to-str ivy-regex))
+                     (groups (number-sequence 1 ivy--subexps))
+                     (default
+                      (list
+                       (mapconcat (lambda (i) (format "\\%d" i)) groups " ")
+                       (format "\\,(concat %s)"
+                               (if (<= ivy--subexps 1)
+                                   "\\&"
+                                 (mapconcat
+                                  (lambda (i) (format "\\%d" i))
+                                  groups
+                                  " \" \" ")))))
+                     (to
+                      (query-replace-compile-replacement
+                       (ivy-read
+                        (format "Query replace %s with: " from) nil
+                        :def default
+                        :caller 'swiper-query-replace)
+                       t)))
+                (swiper--cleanup)
+                (ivy-exit-with-action
+                 (lambda (_)
+                   (with-ivy-window
+                     (move-beginning-of-line 1)
+                     (let ((inhibit-read-only t))
+                       (perform-replace from to
+                                        t t nil))))))
+           (swiper--query-replace-cleanup)))))
+
+(ivy-configure 'swiper-query-replace
+  :update-fn #'swiper--query-replace-updatefn)
+(put 'swiper-query-replace 'no-counsel-M-x t)
+
+(defvar inhibit-message)
+
+(defun swiper-all-query-replace ()
+  "Start `query-replace' with string to replace from last search string."
+  (interactive)
+  (if (null (window-minibuffer-p))
+      (user-error
+       "Should only be called in the minibuffer through `swiper-all-map'")
+    (let* ((enable-recursive-minibuffers t)
+           (from (ivy--regex ivy-text))
+           (to (query-replace-read-to from "Query replace" t)))
+      (swiper--cleanup)
+      (ivy-exit-with-action
+       (lambda (_)
+         (let ((wnd-conf (current-window-configuration))
+               (inhibit-message t))
+           (unwind-protect
+                (dolist (cand ivy--old-cands)
+                  (let ((buffer (get-text-property 0 'buffer cand)))
+                    (switch-to-buffer buffer)
+                    (goto-char (point-min))
+                    (perform-replace from to t t nil)))
+             (set-window-configuration wnd-conf))))))))
+(put 'swiper-all-query-replace 'no-counsel-M-x t)
+
+(defvar avy-all-windows)
+(defvar avy-style)
+(defvar avy-keys)
+(declare-function avy--overlay-post "ext:avy")
+(declare-function avy-action-goto "ext:avy")
+(declare-function avy-candidate-beg "ext:avy")
+(declare-function avy--done "ext:avy")
+(declare-function avy--make-backgrounds "ext:avy")
+(declare-function avy-window-list "ext:avy")
+(declare-function avy-read "ext:avy")
+(declare-function avy-read-de-bruijn "ext:avy")
+(declare-function avy-tree "ext:avy")
+(declare-function avy-push-mark "ext:avy")
+(declare-function avy--remove-leading-chars "ext:avy")
+
+(defun swiper--avy-candidates ()
+  (let* (
+         ;; We'll have overlapping overlays, so we sort all the
+         ;; overlays in the visible region by their start, and then
+         ;; throw out non-Swiper overlays or overlapping Swiper
+         ;; overlays.
+         (visible-overlays (cl-sort (with-ivy-window
+                                      (overlays-in (window-start)
+                                                   (window-end)))
+                                    #'< :key #'overlay-start))
+         (min-overlay-start 0)
+         (overlays-for-avy
+          (cl-remove-if-not
+           (lambda (ov)
+             (when (and (>= (overlay-start ov)
+                            min-overlay-start)
+                        (memq (overlay-get ov 'face)
+                              (append swiper-faces swiper-background-faces)))
+               (setq min-overlay-start (overlay-start ov))))
+           visible-overlays))
+         (offset (if (eq (ivy-state-caller ivy-last) 'swiper) 1 0)))
+    (nconc
+     (mapcar (lambda (ov)
+               (cons (overlay-start ov)
+                     (overlay-get ov 'window)))
+             overlays-for-avy)
+     (save-excursion
+       (save-restriction
+         (narrow-to-region (window-start) (window-end))
+         (goto-char (point-min))
+         (forward-line)
+         (let ((win (selected-window))
+               cands)
+           (while (not (eobp))
+             (push (cons (+ (point) offset) win)
+                   cands)
+             (forward-line))
+           cands))))))
+
+(defun swiper--avy-candidate ()
+  (let ((candidates (swiper--avy-candidates))
+        (avy-all-windows nil))
+    (unwind-protect
+         (prog2
+             (avy--make-backgrounds
+              (append (avy-window-list)
+                      (list (ivy-state-window ivy-last))))
+             (if (eq avy-style 'de-bruijn)
+                 (avy-read-de-bruijn candidates avy-keys)
+               (avy-read (avy-tree candidates avy-keys)
+                         #'avy--overlay-post
+                         #'avy--remove-leading-chars))
+           (avy-push-mark))
+      (avy--done))))
+
+(defun swiper--avy-goto (candidate)
+  (cond ((let ((win (cdr-safe candidate)))
+           (and win (window-minibuffer-p win)))
+         (let ((nlines (count-lines (point-min) (point-max))))
+           (ivy-set-index
+            (+ (car (ivy--minibuffer-index-bounds
+                     ivy--index ivy--length ivy-height))
+               (line-number-at-pos (car candidate))
+               (if (or (= nlines (1+ ivy-height))
+                       (< ivy--length ivy-height))
+                   0
+                 (- ivy-height nlines))
+               -2)))
+         (ivy--exhibit)
+         (ivy-done)
+         (ivy-call))
+        ((or (consp candidate)
+             (number-or-marker-p candidate))
+         (ivy-quit-and-run
+           (avy-action-goto (avy-candidate-beg candidate))))))
+
+;;;###autoload
+(defun swiper-avy ()
+  "Jump to one of the current swiper candidates."
+  (interactive)
+  (unless (require 'avy nil 'noerror)
+    (error "Package avy isn't installed"))
+  (cl-case (length ivy-text)
+    (0
+     (user-error "Need at least one char of input"))
+    (1
+     (let ((swiper-min-highlight 1))
+       (swiper--update-input-ivy))))
+  (swiper--avy-goto (swiper--avy-candidate)))
+
+(declare-function mc/create-fake-cursor-at-point "ext:multiple-cursors-core")
+(declare-function multiple-cursors-mode "ext:multiple-cursors-core")
+
+(defun swiper-mc ()
+  "Create a fake cursor for each `swiper' candidate.
+Make sure `swiper-mc' is on `mc/cmds-to-run-once' list."
+  (interactive)
+  (unless (require 'multiple-cursors nil t)
+    (error "Multiple-cursors isn't installed"))
+  (unless (window-minibuffer-p)
+    (error "Call me only from `swiper'"))
+  (let ((cands (nreverse ivy--old-cands))
+        (action (ivy--get-action ivy-last)))
+    (unless (string= ivy-text "")
+      (ivy-exit-with-action
+       (lambda (_)
+         (let (cand)
+           (while (setq cand (pop cands))
+             (funcall action cand)
+             (when cands
+               (mc/create-fake-cursor-at-point))))
+         (multiple-cursors-mode 1))))))
+
+(defvar swiper--current-window-start nil
+  "Store `window-start' to restore it later.
+This prevents a \"jumping\" behavior which occurs when variables
+such as `scroll-conservatively' are set to a high value.")
+
+(defun swiper-recenter-top-bottom (&optional arg)
+  "Call (`recenter-top-bottom' ARG)."
+  (interactive "P")
+  (with-ivy-window
+    (recenter-top-bottom arg)
+    (setq swiper--current-window-start (window-start))))
+
+(defvar swiper-font-lock-exclude
+  '(Man-mode
+    adoc-mode
+    bbdb-mode
+    bongo-library-mode
+    bongo-mode
+    bongo-playlist-mode
+    bookmark-bmenu-mode
+    circe-channel-mode
+    circe-query-mode
+    circe-server-mode
+    deadgrep-mode
+    debbugs-gnu-mode
+    dired-mode
+    elfeed-search-mode
+    elfeed-show-mode
+    emms-playlist-mode
+    emms-stream-mode
+    erc-mode
+    eshell-mode
+    eww-mode
+    forth-block-mode
+    forth-mode
+    fundamental-mode
+    gnus-article-mode
+    gnus-group-mode
+    gnus-summary-mode
+    help-mode
+    helpful-mode
+    jabber-chat-mode
+    magit-popup-mode
+    matrix-client-mode
+    matrix-client-room-list-mode
+    mu4e-headers-mode
+    mu4e-view-mode
+    nix-mode
+    notmuch-search-mode
+    notmuch-tree-mode
+    occur-edit-mode
+    occur-mode
+    org-agenda-mode
+    package-menu-mode
+    rcirc-mode
+    sauron-mode
+    sieve-mode
+    treemacs-mode
+    twittering-mode
+    vc-dir-mode
+    w3m-mode
+    woman-mode
+    xref--xref-buffer-mode)
+  "List of major-modes that are incompatible with `font-lock-ensure'.")
+
+(defun swiper-font-lock-ensure-p ()
+  "Return non-nil if we should `font-lock-ensure'."
+  (or (derived-mode-p 'magit-mode)
+      (bound-and-true-p magit-blame-mode)
+      (memq major-mode swiper-font-lock-exclude)
+      (not (derived-mode-p 'prog-mode))))
+
+(defun swiper-font-lock-ensure ()
+  "Ensure the entire buffer is highlighted."
+  (unless (swiper-font-lock-ensure-p)
+    (unless (or (> (buffer-size) 100000) (null font-lock-mode))
+      (if (fboundp 'font-lock-ensure)
+          ;; Added in Emacs 25.1.
+          (font-lock-ensure)
+        (with-no-warnings (font-lock-fontify-buffer))))))
+
+(defvar swiper--format-spec ""
+  "Store the current candidates format spec.")
+
+(defvar swiper--width nil
+  "Store the number of digits needed for the longest line number.")
+
+(defvar swiper-use-visual-line nil
+  "When non-nil, use `line-move' instead of `forward-line'.")
+
+(defvar dired-isearch-filenames)
+(declare-function dired-move-to-filename "dired")
+
+(defun swiper--line ()
+  (let* ((beg (cond ((and (eq major-mode 'dired-mode)
+                          (bound-and-true-p dired-isearch-filenames))
+                     (dired-move-to-filename)
+                     (point))
+                    (swiper-use-visual-line
+                     (save-excursion
+                       (beginning-of-visual-line)
+                       (point)))
+                    (t
+                     (point))))
+         (end (if swiper-use-visual-line
+                  (save-excursion
+                    (end-of-visual-line)
+                    (point))
+                (line-end-position))))
+
+    (concat
+     " "
+     (buffer-substring beg end))))
+
+(defvar swiper-use-visual-line-p
+  (lambda (n-lines)
+    (and visual-line-mode
+         ;; super-slow otherwise
+         (< (buffer-size) 20000)
+         (< n-lines 400)))
+  "A predicate that decides whether `line-move' or `forward-line' is used.
+Note that `line-move' can be very slow.")
+
+(defun swiper--candidates (&optional numbers-width)
+  "Return a list of this buffer lines.
+
+NUMBERS-WIDTH, when specified, is used for width spec of line
+numbers; replaces calculating the width from buffer line count."
+  (let* ((inhibit-field-text-motion t)
+         (n-lines (count-lines (point-min) (point-max))))
+    (if (funcall swiper-use-visual-line-p n-lines)
+        (progn
+          (when (eq major-mode 'org-mode)
+            (require 'outline)
+            (if (fboundp 'outline-show-all)
+                ;; Added in Emacs 25.1.
+                (outline-show-all)
+              (with-no-warnings
+                (show-all))))
+          (setq swiper-use-visual-line t))
+      (setq swiper-use-visual-line nil))
+    (unless (zerop n-lines)
+      (setq swiper--width (or numbers-width
+                              (1+ (floor (log n-lines 10)))))
+      (setq swiper--format-spec
+            (format "%%-%dd " swiper--width))
+      (let ((line-number 1)
+            (advancer (if swiper-use-visual-line
+                          (lambda (arg) (line-move arg t))
+                        #'forward-line))
+            candidates)
+        (save-excursion
+          (goto-char (point-min))
+          (swiper-font-lock-ensure)
+          (while (< (point) (point-max))
+            (when (swiper-match-usable-p)
+              (let ((str (swiper--line)))
+                (setq str (ivy-cleanup-string str))
+                (let ((line-number-str
+                       (format swiper--format-spec line-number)))
+                  (if swiper-include-line-number-in-search
+                      (setq str (concat line-number-str str))
+                    (put-text-property
+                     0 1 'display line-number-str str))
+                  (put-text-property
+                   0 1 'swiper-line-number line-number str))
+                (push str candidates)))
+            (funcall advancer 1)
+            (cl-incf line-number))
+          (nreverse candidates))))))
+
+(defvar swiper--opoint 1
+  "The point when `swiper' starts.")
+
+;;;###autoload
+(defun swiper-backward (&optional initial-input)
+  "`isearch-backward' with an overview.
+When non-nil, INITIAL-INPUT is the initial search pattern."
+  (interactive)
+  (let ((ivy-index-functions-alist
+         '((swiper . ivy-recompute-index-swiper-backward))))
+    (swiper initial-input)))
+
+;;;###autoload
+(defun swiper-thing-at-point ()
+  "`swiper' with `ivy-thing-at-point'."
+  (interactive)
+  (let ((thing (ivy-thing-at-point)))
+    (when (use-region-p)
+      (deactivate-mark))
+    (swiper (regexp-quote thing))))
+
+;;;###autoload
+(defun swiper-all-thing-at-point ()
+  "`swiper-all' with `ivy-thing-at-point'."
+  (interactive)
+  (let ((thing (ivy-thing-at-point)))
+    (when (use-region-p)
+      (deactivate-mark))
+    (swiper-all (regexp-quote thing))))
+
+(defun swiper--extract-matches (regex cands)
+  "Extract captured REGEX groups from CANDS."
+  (let (res)
+    (dolist (cand cands)
+      (setq cand (substring cand 1))
+      (when (string-match regex cand)
+        (push (mapconcat (lambda (n) (match-string-no-properties n cand))
+                         (number-sequence
+                          1
+                          (/ (- (length (match-data)) 2) 2))
+                         " ")
+              res)))
+    (nreverse res)))
+
+(defun swiper--occur-cands (fname cands)
+  (when cands
+    (with-current-buffer (ivy-state-buffer ivy-last)
+      (when (eq (ivy-state-caller ivy-last) 'swiper-isearch)
+        (setq cands (mapcar #'swiper--line-at-point cands)))
+      (let* ((pt-min (point-min))
+             (line-delta
+              (save-restriction
+                (widen)
+                (1- (line-number-at-pos pt-min))))
+             (lines
+              (if (eq (ivy-state-caller ivy-last) 'swiper-isearch)
+                  (swiper--isearch-occur-cands cands)
+                (mapcar (lambda (s)
+                          (let ((n (swiper--line-number s)))
+                            (setq s (substring s 1))
+                            (add-text-properties 0 1 (list 'swiper-line-number n) s)
+                            (cons n s)))
+                        cands)))
+             (offset (+ (length fname) 2)))
+        (mapcar (lambda (x)
+                  (let ((nn (number-to-string
+                             (+ (car x) line-delta))))
+                    (remove-text-properties 0 1 '(display) (cdr x))
+                    (put-text-property 0 (length nn) 'face 'ivy-grep-line-number nn)
+                    (put-text-property 0 1 'offset (+ offset (length nn)) fname)
+                    (format "%s:%s:%s" fname nn (cdr x))))
+                lines)))))
+
+(defun swiper--isearch-occur-cands (cands)
+  (let* ((last-pt (get-text-property 0 'point (car cands)))
+         (line (1+ (line-number-at-pos last-pt)))
+         res pt)
+    (dolist (cand cands)
+      (setq pt (get-text-property 0 'point cand))
+      (cl-incf line (1- (count-lines last-pt pt)))
+      (push (cons line cand) res)
+      (setq last-pt pt))
+    (nreverse res)))
+
+(defun swiper--occur-insert-lines (cands)
+  (let ((inhibit-read-only t))
+    ;; Need precise number of header lines for `wgrep' to work.
+    (insert (format "-*- mode:grep; default-directory: %S -*-\n\n\n"
+                    default-directory))
+    (insert (format "%d candidates:\n" (length cands)))
+    (ivy--occur-insert-lines cands)
+    (goto-char (point-min))
+    (forward-line 4)))
+
+(defun swiper--occur-buffer ()
+  (let ((buffer (ivy-state-buffer ivy-last)))
+    (unless (buffer-live-p buffer)
+      (setq buffer
+            (setf (ivy-state-buffer ivy-last)
+                  (find-file-noselect
+                   (plist-get (ivy-state-extra-props ivy-last) :fname))))
+      (save-selected-window
+        (pop-to-buffer buffer))
+      (setf (ivy-state-window ivy-last) (selected-window)))
+    buffer))
+
+(defun swiper-occur (&optional cands)
+  "Generate a custom occur buffer for `swiper'.
+When capture groups are present in the input, print them instead of lines."
+  (setq cands (or ivy-marked-candidates cands))
+  (let* ((buffer (swiper--occur-buffer))
+         (fname (propertize
+                 (with-ivy-window
+                   (if (buffer-file-name buffer)
+                       (file-name-nondirectory
+                        (buffer-file-name buffer))
+                     (buffer-name buffer)))
+                 'face
+                 'ivy-grep-info))
+         (re
+          (progn
+            (string-match "\"\\(.*\\)\"" (buffer-name))
+            (ivy-set-text (match-string 1 (buffer-name)))
+            (mapconcat #'identity (ivy--split ivy-text) ".*?")))
+         (cands
+          (swiper--occur-cands
+           fname
+           (or cands
+               (save-window-excursion
+                 (switch-to-buffer buffer)
+                 (if (eq (ivy-state-caller ivy-last) 'swiper)
+                     (let ((ivy--regex-function 'swiper--re-builder))
+                       (setq ivy--old-re nil)
+                       (ivy--filter re (swiper--candidates)))
+                   (swiper-isearch-function ivy-text)))))))
+    (if (string-match-p "\\\\(" re)
+        (insert
+         (mapconcat #'identity
+                    (swiper--extract-matches
+                     re (with-current-buffer buffer
+                          (swiper--candidates)))
+                    "\n"))
+      (unless (eq major-mode 'ivy-occur-grep-mode)
+        (ivy-occur-grep-mode)
+        (font-lock-mode -1))
+      (swiper--occur-insert-lines
+       (mapcar (lambda (cand) (concat "./" cand)) cands)))))
+
+(declare-function evil-set-jump "ext:evil-jumps")
+
+(defvar swiper--current-line nil)
+(defvar swiper--current-match-start nil)
+(defvar swiper--point-min nil)
+(defvar swiper--point-max nil)
+(defvar swiper--reveal-mode nil)
+
+(defun swiper--init ()
+  "Perform initialization common to both completion methods."
+  (setq swiper--current-line nil)
+  (setq swiper--current-match-start nil)
+  (setq swiper--current-window-start nil)
+  (setq swiper--opoint (point))
+  (setq swiper--point-min (point-min))
+  (setq swiper--point-max (point-max))
+  (when (setq swiper--reveal-mode
+              (bound-and-true-p reveal-mode))
+    (reveal-mode -1))
+  (lazy-highlight-cleanup t)
+  (setq isearch-opened-overlays nil)
+  (when (bound-and-true-p evil-mode)
+    (evil-set-jump)))
+
+(defun swiper--normalize-regex (re)
+  "Normalize the swiper regex RE.
+Add a space after a leading `^' if needed and apply
+`search-default-mode' if bound."
+  (replace-regexp-in-string
+   "^\\(?:\\\\(\\)?\\^"
+   (concat "\\&" (if (eq 'swiper (ivy-state-caller ivy-last)) " " ""))
+   (if (functionp (bound-and-true-p search-default-mode))
+       (mapconcat
+        (lambda (x)
+          (if (string-match-p "\\`[^$\\^]+\\'" x)
+              (funcall search-default-mode x)
+            x))
+        (split-string re "\\b") "")
+     re)
+   t))
+
+(defun swiper--re-builder (str)
+  "Transform STR into a swiper regex.
+This is the regex used in the minibuffer where candidates have
+line numbers.  For the buffer, use `ivy--regex' instead."
+  (let* ((re-builder (ivy-alist-setting ivy-re-builders-alist))
+         (str (replace-regexp-in-string "\\\\n" "\n" str))
+         (re (funcall re-builder str)))
+    (if (consp re)
+        (mapcar
+         (lambda (x)
+           (cons (swiper--normalize-regex (car x))
+                 (cdr x)))
+         re)
+      (swiper--normalize-regex re))))
+
+(defvar swiper-history nil
+  "History for `swiper'.")
+
+(defvar swiper-invocation-face nil
+  "The face at the point of invocation of `swiper'.")
+
+(defcustom swiper-stay-on-quit nil
+  "When non-nil don't go back to search start on abort."
+  :type 'boolean)
+
+;;;###autoload
+(defun swiper (&optional initial-input)
+  "`isearch-forward' with an overview.
+When non-nil, INITIAL-INPUT is the initial search pattern."
+  (interactive)
+  (let ((candidates (swiper--candidates)))
+    (swiper--init)
+    (setq swiper-invocation-face
+          (plist-get (text-properties-at (point)) 'face))
+    (let ((preselect
+           (if (or swiper-use-visual-line (null search-invisible))
+               (count-screen-lines
+                (point-min)
+                (save-excursion (beginning-of-visual-line) (point)))
+             (1- (line-number-at-pos))))
+          (minibuffer-allow-text-properties t)
+          res)
+      (unwind-protect
+           (and
+            (setq res
+                  (ivy-read
+                   "Swiper: "
+                   candidates
+                   :initial-input initial-input
+                   :keymap swiper-map
+                   :preselect
+                   (if initial-input
+                       (cl-position-if
+                        (lambda (x)
+                          (= (1+ preselect) (swiper--line-number x)))
+                        (progn
+                          (setq ivy--old-re nil)
+                          (ivy--filter initial-input candidates)))
+                     preselect)
+                   :require-match t
+                   :action #'swiper--action
+                   :re-builder #'swiper--re-builder
+                   :history 'swiper-history
+                   :extra-props (list :fname (buffer-file-name))
+                   :caller 'swiper))
+            (point))
+        (unless (or res swiper-stay-on-quit)
+          (goto-char swiper--opoint))
+        (isearch-clean-overlays)
+        (unless (or res (string= ivy-text ""))
+          (cl-pushnew ivy-text swiper-history))
+        (setq swiper--current-window-start nil)
+        (when swiper--reveal-mode
+          (reveal-mode 1))))))
+
+(ivy-configure 'swiper
+  :occur #'swiper-occur
+  :update-fn #'swiper--update-input-ivy
+  :unwind-fn #'swiper--cleanup
+  :index-fn #'ivy-recompute-index-swiper)
+
+(defun swiper-toggle-face-matching ()
+  "Toggle matching only the candidates with `swiper-invocation-face'."
+  (interactive)
+  (setf (ivy-state-matcher ivy-last)
+        (if (ivy-state-matcher ivy-last)
+            nil
+          #'swiper--face-matcher))
+  (setq ivy--old-re nil))
+
+(defun swiper--face-matcher (regexp candidates)
+  "Return REGEXP matching CANDIDATES.
+Matched candidates should have `swiper-invocation-face'."
+  (cl-remove-if-not
+   (lambda (x)
+     (and (string-match regexp x)
+          (let* ((s (match-string 0 x))
+                 (n (length s))
+                 (i 0))
+            (while (and (< i n)
+                        (text-property-any
+                         i (1+ i)
+                         'face swiper-invocation-face
+                         s))
+              (cl-incf i))
+            (= i n))))
+   candidates))
+
+(defun swiper--ensure-visible ()
+  "Remove overlays hiding point."
+  (let ((overlays (overlays-at (1- (point))))
+        ov expose)
+    (while (setq ov (pop overlays))
+      (if (and (invisible-p (overlay-get ov 'invisible))
+               (setq expose (overlay-get ov 'isearch-open-invisible)))
+          (funcall expose ov)))))
+
+(defvar swiper--overlays nil
+  "Store overlays.")
+
+(defvar swiper--isearch-highlight-timer nil
+  "This timer used by `swiper--delayed-add-overlays'.")
+
+(defun swiper--cleanup ()
+  "Clean up the overlays."
+  (while swiper--overlays
+    (delete-overlay (pop swiper--overlays)))
+  ;; force cleanup unless it's :unwind
+  (lazy-highlight-cleanup
+   (if (eq ivy-exit 'done) lazy-highlight-cleanup t))
+  (when (timerp swiper--isearch-highlight-timer)
+    (cancel-timer swiper--isearch-highlight-timer)
+    (setq swiper--isearch-highlight-timer nil)))
+
+(defun swiper--add-cursor-overlay (wnd)
+  (let* ((special (or (eolp) (looking-at "\t")))
+         (ov (make-overlay (point) (if special (point) (1+ (point))))))
+    (if special
+        (overlay-put ov 'after-string (propertize " " 'face 'ivy-cursor))
+      (overlay-put ov 'face 'ivy-cursor))
+    (overlay-put ov 'window wnd)
+    (overlay-put ov 'priority 2)
+    (push ov swiper--overlays)))
+
+(defun swiper--add-line-overlay (wnd)
+  (let ((beg (if visual-line-mode
+                 (save-excursion
+                   (beginning-of-visual-line)
+                   (point))
+               (line-beginning-position)))
+        (end (if visual-line-mode
+                 (save-excursion
+                   (end-of-visual-line)
+                   (point))
+               (1+ (line-end-position)))))
+    (push (swiper--make-overlay beg end 'swiper-line-face wnd 0)
+          swiper--overlays)))
+
+(defun swiper--make-overlay (beg end face wnd priority)
+  "Create an overlay bound by BEG and END.
+FACE, WND and PRIORITY are properties corresponding to
+the face, window and priority of the overlay."
+  (let ((overlay (make-overlay beg end)))
+    (overlay-put overlay 'face face)
+    (overlay-put overlay 'window wnd)
+    (overlay-put overlay 'priority priority)
+    overlay))
+
+(defun swiper--recenter-p ()
+  (or (display-graphic-p)
+      (not recenter-redisplay)))
+
+(defun swiper--positive-regexps ()
+  (if (listp ivy-regex)
+      (mapcar #'car (cl-remove-if-not #'cdr ivy-regex))
+    (list ivy-regex)))
+
+(defun swiper--update-input-ivy ()
+  "Called when `ivy' input is updated."
+  (with-ivy-window
+    (swiper--cleanup)
+    (when (> (length (ivy-state-current ivy-last)) 0)
+      (let ((regexps (swiper--positive-regexps))
+            (re-idx -1)
+            (case-fold-search (ivy--case-fold-p ivy-text)))
+        (dolist (re regexps)
+          (setq re-idx (1+ re-idx))
+          (let* ((re (replace-regexp-in-string
+                      "    " "\t"
+                      re))
+                 (num (swiper--line-number (ivy-state-current ivy-last))))
+            (unless (memq this-command '(ivy-yank-word
+                                         ivy-yank-symbol
+                                         ivy-yank-char
+                                         scroll-other-window))
+              (when (cl-plusp num)
+                (unless (if swiper--current-line
+                            (eq swiper--current-line num)
+                          (eq (line-number-at-pos) num))
+                  (goto-char swiper--point-min)
+                  (if swiper-use-visual-line
+                      (line-move (1- num))
+                    (forward-line (1- num))))
+                (if (and (equal ivy-text "")
+                         (>= swiper--opoint (line-beginning-position))
+                         (<= swiper--opoint (line-end-position)))
+                    (goto-char swiper--opoint)
+                  (if (eq swiper--current-line num)
+                      (when swiper--current-match-start
+                        (goto-char swiper--current-match-start))
+                    (setq swiper--current-line num))
+                  (when (re-search-forward re (line-end-position) t)
+                    (setq swiper--current-match-start (match-beginning 0))))
+                (isearch-range-invisible (line-beginning-position)
+                                         (line-end-position))
+                (swiper--maybe-recenter)))
+            (swiper--add-overlays
+             re
+             (max
+              (if (swiper--recenter-p)
+                  (window-start)
+                (line-beginning-position (- (window-height))))
+              swiper--point-min)
+             (min
+              (if (swiper--recenter-p)
+                  (window-end (selected-window) t)
+                (line-end-position (window-height)))
+              swiper--point-max)
+             nil
+             re-idx)))))))
+
+(defun swiper--add-overlays (re &optional beg end wnd re-idx)
+  "Add overlays for RE regexp in visible part of the current buffer.
+BEG and END, when specified, are the point bounds.
+WND, when specified is the window."
+  (setq wnd (or wnd (ivy-state-window ivy-last)))
+  (swiper--add-line-overlay wnd)
+  (let* ((pt (point))
+         (wh (window-height))
+         (beg (or beg (save-excursion
+                        (forward-line (- wh))
+                        (point))))
+         (end (or end (save-excursion
+                        (forward-line wh)
+                        (point))))
+         (case-fold-search (ivy--case-fold-p re)))
+    (when (>= (length re) swiper-min-highlight)
+      (save-excursion
+        (goto-char beg)
+        ;; RE can become an invalid regexp
+        (while (progn
+                 (when (eolp)
+                   (unless (eobp)
+                     (forward-char)))
+                 (and (ignore-errors (re-search-forward re end t))
+                      (> (- (match-end 0) (match-beginning 0)) 0)))
+          ;; Don't highlight a match if it spans multiple
+          ;; lines. `count-lines' returns 1 if the match is within a
+          ;; single line, even if it includes the newline, and 2 or
+          ;; greater otherwise. We hope that the inclusion of the
+          ;; newline will not ever be a problem in practice.
+          (when (< (count-lines (match-beginning 0) (match-end 0)) 2)
+            (let* ((faces (if (= (match-end 0) pt)
+                              swiper-faces
+                            swiper-background-faces))
+                   (adder-fn (lambda (beg end face priority)
+                               (push (swiper--make-overlay beg end face wnd priority)
+                                     isearch-lazy-highlight-overlays))))
+              (unless (and (consp ivy--old-re)
+                           (null
+                            (save-match-data
+                              (ivy--re-filter ivy--old-re
+                                              (list
+                                               (buffer-substring-no-properties
+                                                (line-beginning-position)
+                                                (line-end-position)))))))
+                (swiper--add-properties faces adder-fn re-idx)))))))))
+
+(defun swiper--add-properties (faces adder-fn &optional re-idx)
+  (let ((mb (match-beginning 0))
+        (me (match-end 0)))
+    (unless (> (- me mb) 2017)
+      (funcall adder-fn
+               mb me
+               (if (and ivy-use-group-face-if-no-groups (zerop ivy--subexps))
+                   (nth (1+ (mod (or re-idx 0) (1- (length faces)))) faces)
+                 (car faces))
+               0)))
+  (let ((i 1)
+        (j 0))
+    (while (<= (cl-incf j) ivy--subexps)
+      (let ((bm (match-beginning j))
+            (em (match-end j)))
+        (when (and (integerp em)
+                   (integerp bm))
+          (when (eq (ivy-alist-setting ivy-re-builders-alist t) #'ivy--regex-fuzzy)
+            (while (and (< j ivy--subexps)
+                        (integerp (match-beginning (+ j 1)))
+                        (= em (match-beginning (+ j 1))))
+              (setq em (match-end (cl-incf j)))))
+          (funcall adder-fn
+                   bm em
+                   (nth (1+ (mod (+ i 2) (1- (length faces))))
+                        faces)
+                   i)
+          (cl-incf i))))))
+
+(defcustom swiper-action-recenter nil
+  "When non-nil, recenter after exiting `swiper'."
+  :type 'boolean)
+(defvar evil-search-module)
+(defvar evil-ex-search-pattern)
+(defvar evil-ex-search-persistent-highlight)
+(defvar evil-ex-search-direction)
+(declare-function evil-ex-search-activate-highlight "evil-ex")
+
+(defun swiper--maybe-recenter ()
+  (cond (swiper-action-recenter
+         (recenter))
+        ((swiper--recenter-p)
+         (when swiper--current-window-start
+           (set-window-start (selected-window) swiper--current-window-start))
+         (when (or
+                (< (point) (window-start))
+                (> (point) (window-end (ivy-state-window ivy-last) t)))
+           (recenter))))
+  (setq swiper--current-window-start (window-start)))
+
+(defun swiper--line-number (x)
+  (or (get-text-property 0 'swiper-line-number x)
+      (get-text-property 1 'swiper-line-number x)))
+
+(defcustom swiper-verbose t
+  "When non-nil, print more informational messages."
+  :type 'boolean)
+
+(defun swiper--push-mark ()
+  (when (/= (point) swiper--opoint)
+    (unless (and transient-mark-mode mark-active)
+      (when (eq ivy-exit 'done)
+        (push-mark swiper--opoint t)
+        (when swiper-verbose
+          (message "Mark saved where search started"))))))
+
+(defun swiper--action (x)
+  "Goto line X."
+  (let ((ln (1- (swiper--line-number x)))
+        (re (ivy--regex ivy-text))
+        (case-fold-search (ivy--case-fold-p ivy-text)))
+    (if (null x)
+        (user-error "No candidates")
+      (with-ivy-window
+        (unless (equal (current-buffer)
+                       (ivy-state-buffer ivy-last))
+          (switch-to-buffer (ivy-state-buffer ivy-last)))
+        (goto-char
+         (if (buffer-narrowed-p)
+             swiper--point-min
+           (point-min)))
+        (funcall (if swiper-use-visual-line
+                     #'line-move
+                   #'forward-line)
+                 ln)
+        (when (and (re-search-forward re (line-end-position) t) swiper-goto-start-of-match)
+          (goto-char (match-beginning 0)))
+        (swiper--ensure-visible)
+        (swiper--maybe-recenter)
+        (swiper--push-mark)
+        (swiper--remember-search-history re)))))
+
+(defun swiper--remember-search-history (re)
+  "Add the search pattern RE to the search history ring."
+  (add-to-history
+   'regexp-search-ring
+   re
+   regexp-search-ring-max)
+  ;; integration with evil-mode's search
+  (when (bound-and-true-p evil-mode)
+    (when (eq evil-search-module 'isearch)
+      (setq isearch-string ivy-text))
+    (when (eq evil-search-module 'evil-search)
+      (add-to-history 'evil-ex-search-history re)
+      (setq evil-ex-search-pattern (list re t t))
+      (setq evil-ex-search-direction 'forward)
+      (when evil-ex-search-persistent-highlight
+        (evil-ex-search-activate-highlight evil-ex-search-pattern)))))
+
+(defun swiper-from-isearch ()
+  "Invoke `swiper' from isearch."
+  (interactive)
+  (let ((query (if isearch-regexp
+                   isearch-string
+                 (regexp-quote isearch-string))))
+    (isearch-exit)
+    (swiper query)))
+
+(defvar swiper-multi-buffers nil
+  "Store the current list of buffers.")
+
+(defvar swiper-multi-candidates nil
+  "Store the list of candidates for `swiper-multi'.")
+
+(defun swiper-multi-prompt ()
+  "Return prompt for `swiper-multi'."
+  (format "Buffers (%s): "
+          (mapconcat #'identity swiper-multi-buffers ", ")))
+
+(defvar swiper-window-width 80)
+
+(defun swiper-multi ()
+  "Select one or more buffers.
+Run `swiper' for those buffers."
+  (interactive)
+  (setq swiper-multi-buffers nil)
+  (let ((ivy-use-virtual-buffers nil))
+    (ivy-read (swiper-multi-prompt)
+              #'internal-complete-buffer
+              :action #'swiper-multi-action-1))
+  (let ((swiper-window-width (- (- (frame-width) (if (display-graphic-p) 0 1)) 4)))
+    (ivy-read "Swiper: " swiper-multi-candidates
+              :action #'swiper-multi-action-2
+              :caller 'swiper-multi)))
+
+(ivy-configure 'swiper-multi
+  :unwind-fn #'swiper--cleanup
+  :index-fn #'ivy-recompute-index-swiper
+  :format-fn #'swiper--all-format-function)
+
+(defun swiper-multi-action-1 (x)
+  "Add X to list of selected buffers `swiper-multi-buffers'.
+If X is already part of the list, remove it instead.  Quit the selection if
+X is selected by either `ivy-done', `ivy-alt-done' or `ivy-immediate-done',
+otherwise continue prompting for buffers."
+  (if (member x swiper-multi-buffers)
+      (progn
+        (setq swiper-multi-buffers (delete x swiper-multi-buffers)))
+    (unless (equal x "")
+      (setq swiper-multi-buffers (append swiper-multi-buffers (list x)))))
+  (let ((prompt (swiper-multi-prompt)))
+    (setf (ivy-state-prompt ivy-last) prompt)
+    (setq ivy--prompt (concat "%-4d " prompt)))
+  (cond ((memq this-command '(ivy-done
+                              ivy-alt-done
+                              ivy-immediate-done))
+         (setq swiper-multi-candidates
+               (swiper--multi-candidates
+                (mapcar #'get-buffer swiper-multi-buffers))))
+        ((eq this-command 'ivy-call)
+         (with-selected-window (active-minibuffer-window)
+           (delete-minibuffer-contents)))))
+
+(defun swiper-multi-action-2 (x)
+  "Move to candidate X from `swiper-multi'."
+  (when (> (length x) 0)
+    (let ((buffer-name (get-text-property 0 'buffer x)))
+      (when buffer-name
+        (with-ivy-window
+          (switch-to-buffer buffer-name)
+          (goto-char (point-min))
+          (forward-line (1- (swiper--line-number x)))
+          (re-search-forward
+           (ivy--regex ivy-text)
+           (line-end-position) t)
+          (isearch-range-invisible (line-beginning-position)
+                                   (line-end-position))
+          (unless (eq ivy-exit 'done)
+            (swiper--cleanup)
+            (swiper--add-overlays (ivy--regex ivy-text))))))))
+
+(defun swiper-all-buffer-p (buffer)
+  "Return non-nil if BUFFER should be considered by `swiper-all'."
+  (let ((mode (buffer-local-value 'major-mode (get-buffer buffer))))
+    (cond
+      ;; Ignore TAGS buffers, they tend to add duplicate results.
+      ((eq mode #'tags-table-mode) nil)
+      ;; Always consider dired buffers, even though they're not backed
+      ;; by a file.
+      ((eq mode #'dired-mode) t)
+      ;; Always consider stash buffers too, as they may have
+      ;; interesting content not present in any buffers. We don't #'
+      ;; quote to satisfy the byte-compiler.
+      ((eq mode 'magit-stash-mode) t)
+      ;; Email buffers have no file, but are useful to search
+      ((eq mode 'gnus-article-mode) t)
+      ;; Otherwise, only consider the file if it's backed by a file.
+      (t (buffer-file-name buffer)))))
+
+;;* `swiper-all'
+(defun swiper-all-function (str)
+  "Search in all open buffers for STR."
+  (or
+   (ivy-more-chars)
+   (let* ((buffers (cl-remove-if-not #'swiper-all-buffer-p (buffer-list)))
+          (re-full ivy-regex)
+          re re-tail
+          cands match
+          (case-fold-search (ivy--case-fold-p str)))
+     (setq re (ivy-re-to-str re-full))
+     (when (consp re-full)
+       (setq re-tail (cdr re-full)))
+     (dolist (buffer buffers)
+       (with-current-buffer buffer
+         (save-excursion
+           (goto-char (point-min))
+           (while (re-search-forward re nil t)
+             (setq match (if (memq major-mode '(org-mode dired-mode))
+                             (buffer-substring-no-properties
+                              (line-beginning-position)
+                              (line-end-position))
+                           (buffer-substring
+                            (line-beginning-position)
+                            (line-end-position))))
+             (put-text-property
+              0 1 'buffer
+              (buffer-name)
+              match)
+             (put-text-property 0 1 'point (point) match)
+             (when (or (null re-tail) (ivy-re-match re-tail match))
+               (push match cands))))))
+     (setq ivy--old-re re-full)
+     (if (null cands)
+         (list "")
+       (setq ivy--old-cands (nreverse cands))))))
+
+(defun swiper--all-format-function (cands)
+  "Format CANDS for `swiper-all'.
+See `ivy-format-functions-alist' for further information."
+  (let* ((ww swiper-window-width)
+         (col2 1)
+         (cands-with-buffer
+          (mapcar (lambda (s)
+                    (let ((buffer (get-text-property 0 'buffer s)))
+                      (setq col2 (max col2 (length buffer)))
+                      (cons s buffer))) cands))
+         (col1 (- ww 4 col2)))
+    (setq cands
+          (mapcar (lambda (x)
+                    (if (cdr x)
+                        (let ((s (ivy--truncate-string (car x) col1)))
+                          (concat
+                           s
+                           (make-string
+                            (max 0
+                                 (- ww (string-width s) (length (cdr x))))
+                            ?\ )
+                           (cdr x)))
+                      (car x)))
+                  cands-with-buffer))
+    (ivy--format-function-generic
+     (lambda (str)
+       (ivy--add-face str 'ivy-current-match))
+     (lambda (str)
+       str)
+     cands
+     "\n")))
+
+(defvar swiper-all-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map (kbd "M-q") 'swiper-all-query-replace)
+    map)
+  "Keymap for `swiper-all'.")
+
+;;;###autoload
+(defun swiper-all (&optional initial-input)
+  "Run `swiper' for all open buffers."
+  (interactive)
+  (let ((swiper-window-width (- (frame-width) (if (display-graphic-p) 0 1))))
+    (ivy-read "swiper-all: " 'swiper-all-function
+              :action #'swiper-all-action
+              :dynamic-collection t
+              :keymap swiper-all-map
+              :initial-input initial-input
+              :caller 'swiper-all)))
+
+(ivy-configure 'swiper-all
+  :update-fn 'auto
+  :unwind-fn #'swiper--cleanup
+  :format-fn #'swiper--all-format-function)
+
+(defun swiper-all-action (x)
+  "Move to candidate X from `swiper-all'."
+  (when (> (length x) 0)
+    (let ((buffer-name (get-text-property 0 'buffer x)))
+      (when buffer-name
+        (with-ivy-window
+          (switch-to-buffer buffer-name)
+          (goto-char (get-text-property 0 'point x))
+          (isearch-range-invisible (line-beginning-position)
+                                   (line-end-position))
+          (unless (eq ivy-exit 'done)
+            (swiper--cleanup)
+            (swiper--add-overlays (ivy--regex ivy-text))))))))
+
+(defun swiper--multi-candidates (buffers)
+  "Extract candidates from BUFFERS."
+  (let ((res nil))
+    (dolist (buf buffers)
+      (with-current-buffer buf
+        (setq res
+              (nconc
+               (mapcar
+                (lambda (s) (put-text-property 0 1 'buffer (buffer-name) s) s)
+                (swiper--candidates 4))
+               res))))
+    res))
+
+;;* `swiper-isearch'
+(defun swiper-isearch-function (str)
+  "Collect STR matches in the current buffer for `swiper-isearch'."
+  (with-ivy-window
+    (swiper--isearch-function str)))
+
+(defun swiper-match-usable-p ()
+  (or search-invisible
+      (not (cl-find-if
+            (lambda (ov)
+              (invisible-p (overlay-get ov 'invisible)))
+            (overlays-at (point))))))
+
+(defvar swiper--isearch-backward nil)
+(defvar swiper--isearch-start-point nil)
+
+(defun swiper--isearch-function-1 (re backward)
+  (unless (string= re ".")
+    (let (cands)
+      (save-excursion
+        (goto-char (if backward (point-max) (point-min)))
+        (while (and (funcall (if backward #'re-search-backward #'re-search-forward) re nil t)
+                    (not (and
+                          (= (match-beginning 0) (match-end 0))
+                          (if backward (bobp) (eobp)))))
+          (when (swiper-match-usable-p)
+            (let ((pos (if (or backward swiper-goto-start-of-match)
+                           (match-beginning 0)
+                         (point))))
+              (push pos cands)))
+          (when (= (match-beginning 0) (match-end 0))
+            (if backward
+                (backward-char)
+              (forward-char)))))
+      (if backward
+          cands
+        (nreverse cands)))))
+
+(defun swiper--isearch-next-item (re cands)
+  (if swiper--isearch-backward
+      (or
+       (cl-position-if
+        (lambda (x)
+          (and
+           (< x swiper--isearch-start-point)
+           (eq 0 (string-match-p
+                  re
+                  (buffer-substring-no-properties
+                   x swiper--isearch-start-point)))))
+        cands
+        :from-end t)
+       0)
+    (or
+     (cl-position-if
+      (lambda (x) (> x swiper--isearch-start-point))
+      cands)
+     0)))
+
+(defun swiper--isearch-filter-ignore-order (re-full cands)
+  (let (filtered-cands)
+    (dolist (re-cons re-full cands)
+      (save-excursion
+        (dolist (cand cands)
+          (goto-char cand)
+          (beginning-of-line)
+          (unless (if (re-search-forward (car re-cons) (line-end-position) t)
+                      (not (cdr re-cons))
+                    (cdr re-cons))
+            (push cand filtered-cands))))
+      (setq cands (nreverse filtered-cands))
+      (setq filtered-cands nil))))
+
+(defun swiper--isearch-function (str)
+  (let ((re-full ivy-regex))
+    (unless (equal re-full "")
+      (let* ((case-fold-search (ivy--case-fold-p str))
+             (re
+              (if (stringp re-full)
+                  re-full
+                (mapconcat
+                 #'ivy--regex-or-literal
+                 (delq nil (mapcar (lambda (x) (and (cdr x) (car x))) re-full))
+                 "\\|")))
+             (cands (swiper--isearch-function-1 re swiper--isearch-backward)))
+        (when (consp re-full)
+          (setq cands (swiper--isearch-filter-ignore-order re-full cands)))
+        (setq ivy--old-re re)
+        (ivy-set-index (swiper--isearch-next-item re cands))
+        (setq ivy--old-cands cands)))))
+
+(defcustom swiper-isearch-highlight-delay '(2 0.2)
+  "When `ivy-text' is too short, delay showing the overlay.
+
+The default value will delay showing the overlay by 0.2 seconds
+if `ivy-text' is shorter than 2 characters.
+
+The aim is to reduce the visual clutter, since it's very rare
+that we search only for one character."
+  :type '(list
+          (integer :tag "Text length")
+          (float :tag "Delay in seconds")))
+
+(defun swiper--delayed-add-overlays ()
+  (if (and swiper-isearch-highlight-delay
+           (< (length ivy-text) (car swiper-isearch-highlight-delay)))
+      (setq swiper--isearch-highlight-timer
+            (run-with-idle-timer
+             (cadr swiper-isearch-highlight-delay) nil
+             (lambda ()
+               (with-ivy-window
+                 (swiper--add-overlays (ivy--regex ivy-text))))))
+    (dolist (re (swiper--positive-regexps))
+      (swiper--add-overlays re))))
+
+(defun swiper-isearch-action (x)
+  "Move to X for `swiper-isearch'."
+  (if (or (numberp x)
+          (and (> (length x) 0)
+               (setq x (get-text-property 0 'point x))))
+      (with-ivy-window
+        (goto-char x)
+        (when (and (or (eq this-command 'ivy-previous-line-or-history)
+                       (and (eq this-command 'ivy-done)
+                            (eq last-command 'ivy-previous-line-or-history)))
+                   (looking-back ivy-regex (line-beginning-position)))
+          (goto-char (match-beginning 0)))
+        (isearch-range-invisible (point) (1+ (point)))
+        (swiper--maybe-recenter)
+        (if (eq ivy-exit 'done)
+            (progn
+              (swiper--push-mark)
+              (swiper--remember-search-history (ivy--regex ivy-text)))
+          (swiper--cleanup)
+          (swiper--delayed-add-overlays)
+          (swiper--add-cursor-overlay
+           (ivy-state-window ivy-last))))
+    (swiper--cleanup)))
+
+(defun swiper-action-copy (_x)
+  "Copy line at point and go back."
+  (kill-new
+   (buffer-substring-no-properties
+    (line-beginning-position) (line-end-position)))
+  (goto-char swiper--opoint))
+
+(ivy-add-actions 'swiper-isearch '(("w" swiper-action-copy "copy")))
+(ivy-add-actions 'swiper '(("w" swiper-action-copy "copy")))
+
+(defun swiper-isearch-thing-at-point ()
+  "Insert `symbol-at-point' into the minibuffer of `swiper-isearch'.
+When not running `swiper-isearch' already, start it."
+  (interactive)
+  (if (window-minibuffer-p)
+      (let (bnd str regionp)
+        (with-ivy-window
+          (setq bnd
+                (if (setq regionp (region-active-p))
+                    (prog1 (cons (region-beginning) (region-end))
+                      (deactivate-mark))
+                  (bounds-of-thing-at-point 'symbol)))
+          (setq str (buffer-substring-no-properties (car bnd) (cdr bnd))))
+        (insert str)
+        (unless regionp
+          (ivy--insert-symbol-boundaries)))
+    (let (thing)
+      (if (use-region-p)
+          (progn
+            (setq thing (buffer-substring-no-properties
+                         (region-beginning) (region-end)))
+            (goto-char (region-beginning))
+            (deactivate-mark))
+        (let ((bnd (bounds-of-thing-at-point 'symbol)))
+          (when bnd
+            (goto-char (car bnd)))
+          (setq thing (ivy-thing-at-point))))
+      (swiper-isearch thing))))
+
+(defvar swiper-isearch-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map swiper-map)
+    (define-key map (kbd "M-n") 'swiper-isearch-thing-at-point)
+    map)
+  "Keymap for `swiper-isearch'.")
+
+(defun swiper--isearch-same-line-p (s1 s2)
+  "Check if S1 and S2 are equal and on the same line."
+  (and (equal s1 s2)
+       (<= (count-lines
+            (get-text-property 0 'point s2)
+            (get-text-property 0 'point s1))
+           1)))
+
+(defun swiper-isearch-format-function (cands)
+  (if (numberp (car-safe cands))
+      (let ((re (ivy-re-to-str ivy-regex)))
+        (if (string= re "^$")
+            ""
+          (mapconcat
+           #'identity
+           (swiper--isearch-format
+            ivy--index ivy--length (or ivy--old-cands ivy--all-candidates)
+            re
+            (ivy-state-current ivy-last)
+            (ivy-state-buffer ivy-last))
+           "\n")))
+    (funcall
+     (ivy-alist-setting ivy-format-functions-alist t)
+     cands)))
+
+(defun swiper--line-at-point (pt)
+  (save-excursion
+    (goto-char pt)
+    (let ((s (buffer-substring
+              (line-beginning-position)
+              (line-end-position))))
+      (if (string= s "")
+          s
+        (put-text-property 0 1 'point pt s)
+        (ivy-cleanup-string s)))))
+
+(defun swiper--isearch-highlight (str &optional current)
+  (let ((start 0)
+        (i 0)
+        (re (ivy-re-to-str ivy-regex)))
+    (catch 'done
+      (while (string-match re str start)
+        (if (= (match-beginning 0) (match-end 0))
+            (throw 'done t)
+          (setq start (match-end 0)))
+        (swiper--add-properties
+         (if (eq current i)
+             swiper-faces
+           swiper-background-faces)
+         (lambda (beg end face _priority)
+           (add-face-text-property beg end face nil str)))
+        (cl-incf i)))
+    str))
+
+(defun swiper--isearch-format (index length cands regex current buffer)
+  (let* ((half-height (/ ivy-height 2))
+         (i (1- index))
+         (j 0)
+         (len 0)
+         res s)
+    (with-current-buffer buffer
+      (while (and (>= i 0)
+                  (swiper--isearch-same-line-p
+                   (swiper--line-at-point (nth i cands))
+                   (swiper--line-at-point current)))
+        (cl-decf i)
+        (cl-incf j))
+      (while (and (>= i 0)
+                  (< len half-height))
+        (setq s (swiper--line-at-point (nth i cands)))
+        (unless (swiper--isearch-same-line-p s (car res))
+          (push (swiper--isearch-highlight s) res)
+          (cl-incf len))
+        (cl-decf i))
+      (setq res (nreverse res))
+      (let ((current-str
+             (swiper--line-at-point current))
+            (start 0))
+        (dotimes (_ (1+ j))
+          (string-match regex current-str start)
+          (setq start (match-end 0)))
+        (font-lock-prepend-text-property
+         0 (length current-str)
+         'face 'swiper-line-face current-str)
+        (swiper--isearch-highlight current-str j)
+        (push current-str res))
+      (cl-incf len)
+      (setq i (1+ index))
+      (while (and (< i length)
+                  (swiper--isearch-same-line-p
+                   (swiper--line-at-point (nth i cands))
+                   (swiper--line-at-point current)))
+        (cl-incf i))
+      (while (and (< i length)
+                  (< len ivy-height))
+        (setq s (swiper--line-at-point (nth i cands)))
+        (unless (swiper--isearch-same-line-p s (car res))
+          (push (swiper--isearch-highlight s) res)
+          (cl-incf len))
+        (cl-incf i))
+      (nreverse res))))
+
+(defun swiper--isearch-init ()
+  "Initialize `swiper-isearch'."
+  (swiper--init)
+  (setq swiper--isearch-start-point (point))
+  (swiper-font-lock-ensure))
+
+(defun swiper--isearch-unwind ()
+  (swiper--cleanup)
+  (unless (or (eq ivy-exit 'done) swiper-stay-on-quit)
+    (goto-char swiper--opoint))
+  (isearch-clean-overlays)
+  (swiper--ensure-visible)
+  (unless (or (eq ivy-exit 'done) (string= ivy-text ""))
+    (cl-pushnew ivy-text swiper-history)))
+
+;;;###autoload
+(defun swiper-isearch (&optional initial-input)
+  "A `swiper' that's not line-based."
+  (interactive)
+  (let ((ivy-fixed-height-minibuffer t)
+        (cursor-in-non-selected-windows nil)
+        (swiper-min-highlight 1))
+    (ivy-read
+     "Swiper: "
+     #'swiper-isearch-function
+     :initial-input initial-input
+     :keymap swiper-isearch-map
+     :dynamic-collection t
+     :require-match t
+     :action #'swiper-isearch-action
+     :re-builder #'swiper--re-builder
+     :history 'swiper-history
+     :extra-props (list :fname (buffer-file-name))
+     :caller 'swiper-isearch)))
+
+(ivy-configure 'swiper-isearch
+  :occur #'swiper-occur
+  :init-fn #'swiper--isearch-init
+  :update-fn 'auto
+  :unwind-fn #'swiper--isearch-unwind
+  :format-fn #'swiper-isearch-format-function)
+
+;;;###autoload
+(defun swiper-isearch-backward (&optional initial-input)
+  "Like `swiper-isearch' but the first result is before the point."
+  (interactive)
+  (let ((swiper--isearch-backward t))
+    (swiper-isearch initial-input)))
+
+(defun swiper-isearch-toggle ()
+  "Two-way toggle between `swiper-isearch' and isearch.
+Intended to be bound in `isearch-mode-map' and `swiper-map'."
+  (interactive)
+  (if isearch-mode
+      (let ((query (if isearch-regexp
+                       isearch-string
+                     (regexp-quote isearch-string))))
+        (isearch-exit)
+        (goto-char (or (and isearch-forward isearch-other-end)
+                       (point)))
+        (swiper-isearch query))
+    (ivy-exit-with-action
+     (lambda (_)
+       (when (looking-back (ivy-re-to-str ivy-regex) (line-beginning-position))
+         (goto-char (match-beginning 0)))
+       (isearch-mode t)
+       (unless (string= ivy-text "")
+         (isearch-yank-string ivy-text))))))
+
+(provide 'swiper)
+
+;;; swiper.el ends here
diff --git a/lisp/treemacs-magit.el b/lisp/treemacs-magit.el
new file mode 100644
index 00000000..19d9fb63
--- /dev/null
+++ b/lisp/treemacs-magit.el
@@ -0,0 +1,156 @@
+;;; treemacs-magit.el --- Magit integration for treemacs -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020 Alexander Miller
+
+;; Author: Alexander Miller 
+;; Package-Requires: ((emacs "25.2") (treemacs "0.0") (pfuture "1.3" ) (magit "2.90.0"))
+;; Package-Version: 20200421.1426
+;; Package-Commit: 1ce0bd487f0b9178744e19bbc48b6692c55c590c
+;; Version: 0
+;; Homepage: https://github.com/Alexander-Miller/treemacs
+
+;; 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 .
+
+;;; Commentary:
+;;; Closing the gaps for filewatch- and git-modes in conjunction with magit.
+;;; Specifically this package will hook into magit so as to artificially
+;;; produce filewatch events for changes that treemacs would otherwise
+;;; not catch, nameley the committing and (un)staging of files.
+
+;;; Code:
+
+(require 'treemacs)
+(require 'magit)
+(require 'pfuture)
+(require 'seq)
+
+;; no need for dash for a single when-let
+(eval-when-compile
+  (when (version< emacs-version "26")
+    (defalias 'if-let* #'if-let)
+    (defalias 'when-let* #'when-let)))
+
+(defvar treemacs-magit--timers nil
+  "Cached list of roots an update is scheduled for.")
+
+(defun treemacs-magit--schedule-update ()
+  "Schedule an update to potentially run after 3 seconds of idle time.
+In order for the update to fully run several conditions must be met:
+ * A timer for an update for the given dir must not already exist
+   (see `treemacs-magit--timers')
+ * The dir must be part of a treemacs workspace, and
+ * The project must not be set for refresh already."
+  (when treemacs-git-mode
+    (let ((magit-root (treemacs--canonical-path (magit-toplevel))))
+      (unless (member magit-root treemacs-magit--timers)
+        (push magit-root treemacs-magit--timers)
+        (run-with-idle-timer
+         3 nil
+         (lambda ()
+           (unwind-protect
+               (pcase treemacs-git-mode
+                 ('simple
+                  (treemacs-magit--simple-git-mode-update magit-root))
+                 ((or 'extended 'deferred)
+                  (treemacs-magit--extended-git-mode-update magit-root)))
+             (setf treemacs-magit--timers (delete magit-root treemacs-magit--timers)))))))))
+
+(defun treemacs-magit--simple-git-mode-update (magit-root)
+  "Update the project at the given MAGIT-ROOT.
+Without the parsing ability of extended git-mode this update uses
+filewatch-mode's mechanics to update the entire project."
+  (treemacs-run-in-every-buffer
+   (when-let* ((project (treemacs--find-project-for-path magit-root)))
+     (let* ((project-root (treemacs-project->path project))
+            (dom-node (treemacs-find-in-dom project-root)))
+       (when (and dom-node
+                  (null (treemacs-dom-node->refresh-flag dom-node)))
+         (treemacs--set-refresh-flags project-root 'magit-refresh project-root))))))
+
+(defun treemacs-magit--extended-git-mode-update (magit-root)
+  "Update the project at the given MAGIT-ROOT.
+This runs due to a commit or stash action, so we know that no files have
+actually been added or deleted.  This allows us to forego rebuilding the entire
+project structure just to be sure we caught everything.  Instead we grab the
+current git status and just go through the lines as they are right now."
+  ;; we run a single git process to update every buffer, so we need to gather
+  ;; the visible dirs in every buffer
+  ;; this collection may contain duplicates, but they are removed in python
+  (-let [visible-dirs nil]
+    (treemacs-run-in-every-buffer
+     (dolist (dir (-some->> magit-root
+                            (treemacs-find-in-dom)
+                            (treemacs-dom-node->children)
+                            (-map #'treemacs-dom-node->key)))
+       (push dir visible-dirs)))
+    (pfuture-callback `(,treemacs-python-executable
+                        "-O" "-S"
+                        ,treemacs--git-status.py
+                        ,magit-root
+                        ,(number-to-string treemacs-max-git-entries)
+                        ,treemacs-git-command-pipe
+                        ,@visible-dirs)
+      :directory magit-root
+      :on-success
+      (progn
+        (ignore status)
+        (treemacs-magit--update-callback magit-root pfuture-buffer)))))
+
+(defun treemacs-magit--update-callback (magit-root pfuture-buffer)
+  "Run the update as a pfuture callback.
+Will update nodes under MAGIT-ROOT with output in PFUTURE-BUFFER."
+  (let ((ht (read (pfuture-output-from-buffer pfuture-buffer))))
+    (treemacs-run-in-every-buffer
+     (let ((dom-node (or (treemacs-find-in-dom magit-root)
+                         (when-let* ((project
+                                      (seq-find
+                                       (lambda (pr) (treemacs-is-path (treemacs-project->path pr) :in magit-root))
+                                       (treemacs-workspace->projects (treemacs-current-workspace)))))
+                           (treemacs-find-in-dom (treemacs-project->path project))))))
+       (when (and dom-node
+                  (null (treemacs-dom-node->refresh-flag dom-node)))
+         (save-excursion
+           (goto-char (treemacs-dom-node->position dom-node))
+           (forward-line 1)
+           (let* ((node (treemacs-node-at-point))
+                  (start-depth (-some-> node (treemacs-button-get :depth)))
+                  (curr-depth start-depth)
+                  (path (-some-> node (treemacs-button-get :key))))
+             (treemacs-with-writable-buffer
+              (while (and node
+                          (file-exists-p path)
+                          (>= curr-depth start-depth))
+                (put-text-property (treemacs-button-start node) (treemacs-button-end node) 'face
+                                   (treemacs--get-node-face
+                                    path ht
+                                    (if (memq (treemacs-button-get node :state)
+                                              '(file-node-open file-node-closed))
+                                        'treemacs-git-unmodified-face
+                                      'treemacs-directory-face)))
+                (forward-line 1)
+                (if (eobp)
+                    (setf node nil)
+                  (setf node (treemacs-node-at-point)
+                        path (-some-> node (treemacs-button-get :path))
+                        curr-depth (-some-> node (treemacs-button-get :depth)))))))))))))
+
+(unless (featurep 'treemacs-magit)
+  (add-hook 'magit-post-commit-hook      #'treemacs-magit--schedule-update)
+  (add-hook 'git-commit-post-finish-hook #'treemacs-magit--schedule-update)
+  (add-hook 'magit-post-stage-hook       #'treemacs-magit--schedule-update)
+  (add-hook 'magit-post-unstage-hook     #'treemacs-magit--schedule-update))
+
+(provide 'treemacs-magit)
+
+;;; treemacs-magit.el ends here
diff --git a/lisp/versions b/lisp/versions
new file mode 100644
index 00000000..5fafc1f5
--- /dev/null
+++ b/lisp/versions
@@ -0,0 +1,168 @@
+# -*- mode: org -*-
+| package                    |         | current Version | Package-Version | previous Version | Package-Version |                                                                                                     |
+|----------------------------+---------+-----------------+-----------------+------------------+-----------------+-----------------------------------------------------------------------------------------------------|
+| ace-window.el              | melpa   |          0.10.0 |   20200606.1259 |            0.9.0 |               - |                                                                                                     |
+| adaptive-wrap              | elpa    |             0.7 |               - |                  |                 | required by virtual-auto-fill                                                                       |
+| all-the-icons              | melpa   |           4.0.0 |   20200730.1545 |                  |                 | required by dashboard, requires memoize, run M-x all-the-icons-install-fonts                        |
+| amx.el                     | melpa   |             3.3 |   20200701.2108 |                  |                 | requires ivy or ido, imporves M-x saving history, etc.                                              |
+| anaconda-mode.el           | melpa   |          0.1.13 |   20200129.1718 |           0.1.13 |   20191001.2056 |                                                                                                     |
+| async                      | melpa   |           1.9.4 |   20200113.1745 |                  |                 | required by ob-async                                                                                |
+| avy.el                     | melpa   |           0.5.0 |   20200624.1148 |            0.5.0 |               - |                                                                                                     |
+| biblio                     | melpa   |             0.2 |   20200416.1407 |              0.2 |   20190624.1408 |                                                                                                     |
+| biblio-core.el             | melpa   |           0.2.1 |    20200416.307 |              0.2 |   20190624.1408 |                                                                                                     |
+| bibtex-completion.el       | melpa   |           1.0.0 |    20200513.852 |                  |                 | required by ivy-bibtex                                                                              |
+| bind-key.el                | melpa   |             2.4 |    20191110.416 |                  |                 | required by use-package                                                                             |
+| cl-libify.el               | melpa   |               0 |    20181130.230 |                  |                 | prevent: Package cl is deprecated                                                                   |
+| company                    | melpa   |          0.9.12 |   20200616.2354 |           0.9.10 |               - |                                                                                                     |
+| company-anaconda.el        | melpa   |           0.2.0 |   20200404.1859 |            0.2.0 |   20181025.1305 |                                                                                                     |
+| company-ledger.el          | melpa   |           0.1.0 |   20200726.1825 |                  |                 |                                                                                                     |
+| company-quickhelp.el       | melpa   |           2.2.0 |   20200626.1245 |            2.2.0 |   20180525.1003 |                                                                                                     |
+| company-web                | melpa   |             2.1 |   20180402.1155 |                  |                 | requires cl-lib company dash web-completion-data                                                    |
+| counsel.el                 | melpa   |          0.13.0 |   20200619.1030 |           0.12.0 |   20191007.1406 |                                                                                                     |
+| crdt.el                    | [[https://code.librehq.com/qhong/crdt.el/][librehq]] |           0.0.0 |               - |                  |                 | Collaborative editing using Conflict-free Replicated Data Types                                     |
+| ctable.el                  | melpa   |           0.1.2 |     20171006.11 |                  |                 |                                                                                                     |
+| dash.el                    | melpa   |          2.17.0 |   20200524.1947 |           2.16.0 |   20191109.1327 |                                                                                                     |
+| dashboard                  | melpa   |  1.8.0-SNAPSHOT |   20200306.1344 |                  |                 | requires page-break-lines, (all-the-icons)                                                          |
+| deft.el                    | melpa   |             0.8 |   20200515.1513 |              0.8 |   20181226.1534 |                                                                                                     |
+| delight.el                 | elpa    |             1.7 |               - |                  |                 | mode-line                                                                                           |
+| dialog.el                  |         |                 |                 |                  |                 |                                                                                                     |
+| diff-hl                    | melpa   |           1.8.7 |   20200604.1223 |            1.8.7 |               - |                                                                                                     |
+| dim.el                     | melpa   |             0.1 |    20160818.949 |                  |                 | mode-line                                                                                           |
+| emojify                    | melpa   |           1.2.1 |   20200513.1627 |              1.2 |    20190809.959 |                                                                                                     |
+| ess                        | melpa   | 18.10.3snapshot |   20200623.1908 |  18.10.3snapshot |   20190921.1258 |                                                                                                     |
+| ess-R-data-view.el         | melpa   |             0.1 |   20130509.1158 |                  |                 |                                                                                                     |
+| f.el                       | melpa   |          0.20.0 |   20191110.1357 |                  |                 |                                                                                                     |
+| flycheck                   | melpa   |          32-cvs |   20200610.1809 |           32-cvs |   20190913.1456 |                                                                                                     |
+| flycheck-ledger.el         | melpa   |             DEV |   20200304.2204 |              DEV |    20180819.321 |                                                                                                     |
+| flycheck-pos-tip.el        | melpa   |         0.4-cvs |   20200516.1600 |          0.4-cvs |   20180610.1615 |                                                                                                     |
+| focus                      | melpa   |           1.0.0 |   20191209.2210 |                  |                 |                                                                                                     |
+| git-commit.el              | melpa   |               - |    20200608.928 |                - |     20190717.29 |                                                                                                     |
+| git-messenger.el           | melpa   |            0.18 |   20200321.2337 |             0.18 |    20170102.440 |                                                                                                     |
+| gnuplot                    | melpa   |           0.7.0 |     20200322.53 |            0.7.0 |   20141231.2137 |                                                                                                     |
+| gnuplot-mode.el            | melpa   |           1.2.0 |   20171013.1616 |                  |                 |                                                                                                     |
+| ht.el                      | melpa   |             2.3 |   20200217.2331 |              2.3 |    20190830.910 | hash table library                                                                                  |
+| htmlize.el                 | melpa   |            1.56 |   20191111.2130 |             1.55 |   20180923.1829 |                                                                                                     |
+| hydra                      | melpa   |          0.15.0 |   20200608.1528 |           0.14.0 |               - | required by org-ref                                                                                 |
+| indent-guide.el            | melpa   |           2.3.1 |    20191106.240 |                  |                 |                                                                                                     |
+| ivy                        | melpa   |          0.13.0 |   20200624.1140 |           0.12.0 |               - |                                                                                                     |
+| ivy-bibtex                 | melpa   |           1.0.1 |   20200429.1606 |            1.0.0 |   20190918.1116 |                                                                                                     |
+| js2-mode                   | melpa   |        20190219 |   20200610.1339 |         20190219 |   20190815.1327 |                                                                                                     |
+| langtool                   | melpa   |           2.2.1 |    20200529.230 |                  |                 |                                                                                                     |
+| ledger-mode                | melpa   |           4.0.0 |   20200530.1710 |            3.0.0 |   20190901.1439 |                                                                                                     |
+| lv                         | melpa   |               - |   20200507.1518 |                  |                 | required by hydra                                                                                   |
+| magit                      | melpa   |          2.90.1 |    20200627.806 |           2.90.1 |               - | IMPORTANT do not delete and change in magit-version.el the version, see also git repo lisp/Makefile |
+| markdown-mode.el           | melpa   |         2.5-dev |     20200622.20 |          2.4-dev |   20190802.2215 |                                                                                                     |
+| memoize.el                 | melpa   |             1.1 |   20200103.2036 |                  |                 | required by all-the-icons                                                                           |
+| mu4e-maildirs-extension.el | melpa   |             0.1 |    20200508.712 |                  |                 |                                                                                                     |
+| multiple-cursors           | melpa   |           1.4.0 |   20191210.1759 |                  |                 |                                                                                                     |
+| ob-async.el                | melpa   |             0.1 |   20190916.1537 |                  |                 |                                                                                                     |
+| org                        |         |           9.3.6 |               - |            9.2.6 |               - |                                                                                                     |
+| org-brain.el               | melpa   |            0.94 |   20201106.2123 |                  |                 |                                                                                                     |
+| org-cliplink               | melpa   |                 |   20190608.2134 |                  |                 |                                                                                                     |
+| org-drill                  | melpa   |           2.7.0 |   20200412.1812 |                  |                 | (alternatives anki-mode, anki-editor)                                                               |
+| org-priorities             | melpa   |             1.1 |   20180328.2331 |                  |                 |                                                                                                     |
+| org-ref                    | mepla   |           1.1.1 |   20200624.1342 |            1.1.1 |   20190921.2346 | uses ivy                                                                                            |
+| org-sticky-header.el       | melpa   |         1.1-pre |    20191117.549 |                  |                 | instead of org-bullets.el (last version used 20200317.1740)                                         |
+| org-superstar.el           | melpa   |           1.2.1 |   20200616.1633 |                  |                 |                                                                                                     |
+| org-table-sticky-header.el | melpa   |           0.1.0 |    20190924.506 |                  |                 | (alternative orgtbl-show-header)                                                                    |
+| orgit.el                   | mepla   |           1.6.0 |                 |            1.6.0 |   20190717.1526 |                                                                                                     |
+| ov.el                      | melpa   |           1.0.6 |   20200326.1042 |                  |                 |                                                                                                     |
+| ox-tufte.el                | melpa   |           1.0.0 |   20160926.1607 |                  |                 |                                                                                                     |
+| page-break-lines.el        | melpa   |               0 |    20200305.244 |                  |                 | required by dashboard                                                                               |
+| parsebib.el                | melpa   |             2.3 |   20200513.2352 |              2.3 |    20181219.928 |                                                                                                     |
+| pdf-tools                  | melpa   |             1.0 |   20200512.1524 |              1.0 |   20190918.1715 |                                                                                                     |
+| persist                    | elpa    |             0.4 |               - |                  |                 | required by org-drill                                                                               |
+| pfuture.el                 | melpa   |             1.9 |   20200425.1357 |              1.6 |   20190505.1006 |                                                                                                     |
+| php-mode                   | mepla   |          1.23.0 |   20200507.1755 |           1.22.1 |   20191111.1650 |                                                                                                     |
+| plantuml-mode.el           | melpa   |           1.2.9 |   20191102.2056 |            1.2.9 |    20190905.838 |                                                                                                     |
+| polymode                   | melpa   |           0.2.2 |   20200606.1106 |                  |                 |                                                                                                     |
+| popup.el                   | melpa   |           0.5.8 |    20200610.317 |            0.5.3 |   20160709.1429 |                                                                                                     |
+| popwin.el                  | melpa   |           1.0.0 |   20200122.1440 |            1.0.0 |   20150315.1300 |                                                                                                     |
+| pos-tip.el                 | melpa   |           0.4.6 |   20191227.1356 |            0.4.6 |   20150318.1513 |                                                                                                     |
+| powershell.el              | melpa   |             0.3 |   20190421.2038 |                  |                 |                                                                                                     |
+| pythonic.el                | melpa   |           0.1.1 |   20200304.1901 |            0.1.1 |    20191021.811 |                                                                                                     |
+| rainbow-mode.el            | elpa    |           1.0.4 |               - |            1.0.1 |               - |                                                                                                     |
+| restart-emacs.el           | melpa   |           0.1.1 |   20180601.1031 |                  |                 |                                                                                                     |
+| s.el                       | melpa   |          1.12.0 |    20180406.808 |                  |                 |                                                                                                     |
+| spacemancs-theme           | melpa   |             0.1 |   20200615.1304 |              0.1 |               - |                                                                                                     |
+| sphinx-doc.el              | melpa   |           0.3.0 |   20160116.1117 |                  |                 |                                                                                                     |
+| sql-indent                 | elpa    |             1.5 |               - |              1.4 |               - |                                                                                                     |
+| srefactor                  | melpa   |             0.3 |   20180703.1810 |                  |                 |                                                                                                     |
+| stickyfunc-enhance.el      | melpa   |             0.1 |   20150429.1814 |                  |                 |                                                                                                     |
+| swiper.el                  | melpa   |          0.13.0 |   20200503.1102 |           0.12.0 |   20191007.1521 |                                                                                                     |
+| systemd                    | melpa   |                 |   20191219.2304 |                  |                 |                                                                                                     |
+| transient                  | melpa   |           0.2.0 |   20200622.2050 |            0.1.0 |   20190905.1138 |                                                                                                     |
+| treemacs                   | melpa   |             2.8 |   20200625.2056 |              2.6 |    20190916.913 |                                                                                                     |
+| treemacs-magit.el          | melpa   |               0 |   20200421.1426 |                0 |    20190731.540 |                                                                                                     |
+| use-package                | melpa   |             2.4 |   20200721.2156 |                  |                 |                                                                                                     |
+| virtual-auto-fill          | melpa   |             0.1 |   20200217.2333 |                  |                 | requires visual-line-mode (builtin) adaptive-wrap visual-fill-column                                |
+| visual-fill-column         | melpa   |            1.11 |    20200428.816 |                  |                 | best with visual-line-mode, required by virtual-auto-fill                                           |
+| web-completion-data        | melpa   |             0.2 |    20160318.848 |                  |                 | required by company-web                                                                             |
+| web-mode.el                | melpa   |          17.0.0 |   20200612.1038 |                  |                 |                                                                                                     |
+| which-key.el               | melpa   |           3.3.2 |    20200702.219 |            3.3.2 |   20200216.1350 |                                                                                                     |
+| with-editor                | melpa   |           2.9.3 |   20200617.1234 |            2.8.3 |   20190715.2007 |                                                                                                     |
+| yasnippet.el               | melpa   |          0.14.0 |   20200524.2215 |           0.13.0 |               - |                                                                                                     |
+| yasnippet-snippets         | melpa   |             0.2 |   20200606.1149 |              0.2 |   20190926.1252 |                                                                                                     |
+
+
+
+to add?
+posframe: company-posframe, flycheck-posframe, ivy-posframe
+https://github.com/Malabarba/beacon
+biblio.el
+button-lock
+company-box
+company-jedi
+counsel-notmuch
+emojify-logos
+expand-region
+flycheck-indicator
+flycheck-plantuml
+flycheck-popup-tip
+focus
+ivy-avy
+ivy-emoji  (not needed bc emojify?)
+ivy-pass
+ivy-prescient  (instead of amx?)
+ivy-rich
+ivy-yasnippet
+lsp-mode company-lsp lsp-ivy lsp-treemacs lsp-ui
+magic-latex-buffer
+magit-todos
+move-text
+notify.el
+origami.el
+ob-http
+org-autolist
+org-edit-latex
+org-fragtog
+org-pdftools
+org-sidebar
+org-special-block-extras
+org-super-agenda
+org-tanglesync
+org-treescope
+orgtbl-aggregate
+ox-latex-subfigure
+https://github.com/misohena/phscroll
+
+todo
+https://github.com/syl20bnr/spacemacs/blob/c7a103a772d808101d7635ec10f292ab9202d9ee/layers/%2Bdistributions/spacemacs-base/packages.el
+subword M-m t c subword-mode "Toggle CamelCase motions.", M-m t C-c global-subword-mode "Globally toggle CamelCase motions."
+whitespace M-m t w whitespace-mode "Display whitespace.", M-m t C-w global-whitespace-mode "Display whitespace globally."
+
+
+yasnippet-snippets excluded modes:
+antlr apples applescript bazel chef cider-repl coq cpp-omnet crystal d dart dix
+elixir enh-ruby ensime erc erlang faust fish go groovy haskell hy java julia
+kotlin lua m4 makefile-automake makefile-bsdmake makefile-gmake makefile malabar
+nasm ned nesc nix nsis protobuf racket reason rjsx ruby rust rustic scala swift
+terraform tuareg typerex typescript udev vhdl
+
+
+* removed
+| package                    |       | current Version | Package-Version | previous Version | Package-Version |                                    |
+|----------------------------+-------+-----------------+-----------------+------------------+-----------------+------------------------------------|
+| ido-completing-read+.el    | melpa |            4.13 |   20200520.1535 |             4.13 |      20190719.4 | also used for magit, now using ivy |
+| smex.el                    | melpa |             3.0 |   20151212.2209 |                  |                 | uses Ido for M-x                   |
+| highlight-indent-guides.el | melpa |                 |   20200528.2128 |                  |                 | indent-guide.el works better       |
diff --git a/lisp/virtual-auto-fill.el b/lisp/virtual-auto-fill.el
new file mode 100644
index 00000000..a35317c7
--- /dev/null
+++ b/lisp/virtual-auto-fill.el
@@ -0,0 +1,326 @@
+;;; virtual-auto-fill.el --- Readably display text without adding line breaks -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Author: Luis Gerhorst 
+;; Maintainer: Luis Gerhorst 
+;; URL: https://github.com/luisgerhorst/virtual-auto-fill
+;; Package-Version: 20200217.2333
+;; Package-Commit: 291f6178a5423f01f2f69d6bc48603d4f605b61a
+;; Keywords: convenience, mail, outlines, files, wp
+;; Created: Sun 26. Jan 2020
+;; Version: 0.1
+;; Package-Requires: ((emacs "25.2") (adaptive-wrap "0.7") (visual-fill-column "1.9"))
+
+;; This file is NOT 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 .
+
+;;; Commentary:
+;;
+;; Virtual Auto Fill mode displays unfilled text in a readable way.  It wraps
+;; the text as if you had inserted line breaks (e.g. using `fill-paragraph' or
+;; `auto-fill-mode') without actually modifying the underlying buffer.  It also
+;; indents paragraphs in bullet lists properly.
+;;
+;; Specifically, `adaptive-wrap-prefix-mode', Visual Fill Column mode and
+;; `visual-line-mode' are used to wrap paragraphs and bullet lists between the
+;; wrap prefix and the fill column.
+
+;;; Code:
+
+(require 'adaptive-wrap)
+(require 'visual-fill-column)
+
+;; To support Emacs versions < 26.1, which added `read-multiple-choice', we
+;; include a copy of the function from rmc.el here.
+(defun virtual-auto-fill--read-multiple-choice (prompt choices)
+  "Ask user a multiple choice question.
+PROMPT should be a string that will be displayed as the prompt.
+
+CHOICES is an alist where the first element in each entry is a
+character to be entered, the second element is a short name for
+the entry to be displayed while prompting (if there's room, it
+might be shortened), and the third, optional entry is a longer
+explanation that will be displayed in a help buffer if the user
+requests more help.
+
+This function translates user input into responses by consulting
+the bindings in `query-replace-map'; see the documentation of
+that variable for more information.  In this case, the useful
+bindings are `recenter', `scroll-up', and `scroll-down'.  If the
+user enters `recenter', `scroll-up', or `scroll-down' responses,
+perform the requested window recentering or scrolling and ask
+again.
+
+When `use-dialog-box' is t (the default), this function can pop
+up a dialog window to collect the user input.  That functionality
+requires `display-popup-menus-p' to return t. Otherwise, a text
+dialog will be used.
+
+The return value is the matching entry from the CHOICES list.
+
+Usage example:
+
+\(virtual-auto-fill--read-multiple-choice \"Continue connecting?\"
+                      \\='((?a \"always\")
+                        (?s \"session only\")
+                        (?n \"no\")))"
+  (let* ((altered-names nil)
+         (full-prompt
+          (format
+           "%s (%s): "
+           prompt
+           (mapconcat
+            (lambda (elem)
+              (let* ((name (cadr elem))
+                     (pos (seq-position name (car elem)))
+                     (altered-name
+                      (cond
+                       ;; Not in the name string.
+                       ((not pos)
+                        (format "[%c] %s" (car elem) name))
+                       ;; The prompt character is in the name, so highlight
+                       ;; it on graphical terminals...
+                       ((display-supports-face-attributes-p
+                         '(:underline t) (window-frame))
+                        (setq name (copy-sequence name))
+                        (put-text-property pos (1+ pos)
+                                           'face 'read-multiple-choice-face
+                                           name)
+                        name)
+                       ;; And put it in [bracket] on non-graphical terminals.
+                       (t
+                        (concat
+                         (substring name 0 pos)
+                         "["
+                         (upcase (substring name pos (1+ pos)))
+                         "]"
+                         (substring name (1+ pos)))))))
+                (push (cons (car elem) altered-name)
+                      altered-names)
+                altered-name))
+            (append choices '((?? "?")))
+            ", ")))
+         tchar buf wrong-char answer)
+    (save-window-excursion
+      (save-excursion
+        (while (not tchar)
+          (message "%s%s"
+                   (if wrong-char
+                       "Invalid choice.  "
+                     "")
+                   full-prompt)
+          (setq tchar
+                (if (and (display-popup-menus-p)
+                         last-input-event ; not during startup
+                         (listp last-nonmenu-event)
+                         use-dialog-box)
+                    (x-popup-dialog
+                     t
+                     (cons prompt
+                           (mapcar
+                            (lambda (elem)
+                              (cons (capitalize (cadr elem))
+                                    (car elem)))
+                            choices)))
+                  (condition-case nil
+                      (let ((cursor-in-echo-area t))
+                        (read-char))
+                    (error nil))))
+          (setq answer (lookup-key query-replace-map (vector tchar) t))
+          (setq tchar
+                (cond
+                 ((eq answer 'recenter)
+                  (recenter) t)
+                 ((eq answer 'scroll-up)
+                  (ignore-errors (scroll-up-command)) t)
+                 ((eq answer 'scroll-down)
+                  (ignore-errors (scroll-down-command)) t)
+                 ((eq answer 'scroll-other-window)
+                  (ignore-errors (scroll-other-window)) t)
+                 ((eq answer 'scroll-other-window-down)
+                  (ignore-errors (scroll-other-window-down)) t)
+                 (t tchar)))
+          (when (eq tchar t)
+            (setq wrong-char nil
+                  tchar nil))
+          ;; The user has entered an invalid choice, so display the
+          ;; help messages.
+          (when (and (not (eq tchar nil))
+                     (not (assq tchar choices)))
+            (setq wrong-char (not (memq tchar '(?? ?\C-h)))
+                  tchar nil)
+            (when wrong-char
+              (ding))
+            (with-help-window (setq buf (get-buffer-create
+                                         "*Multiple Choice Help*"))
+              (with-current-buffer buf
+                (erase-buffer)
+                (pop-to-buffer buf)
+                (insert prompt "\n\n")
+                (let* ((columns (/ (window-width) 25))
+                       (fill-column 21)
+                       (times 0)
+                       (start (point)))
+                  (dolist (elem choices)
+                    (goto-char start)
+                    (unless (zerop times)
+                      (if (zerop (mod times columns))
+                          ;; Go to the next "line".
+                          (goto-char (setq start (point-max)))
+                        ;; Add padding.
+                        (while (not (eobp))
+                          (end-of-line)
+                          (insert (make-string (max (- (* (mod times columns)
+                                                          (+ fill-column 4))
+                                                       (current-column))
+                                                    0)
+                                               ?\s))
+                          (forward-line 1))))
+                    (setq times (1+ times))
+                    (let ((text
+                           (with-temp-buffer
+                             (insert (format
+                                      "%c: %s\n"
+                                      (car elem)
+                                      (cdr (assq (car elem) altered-names))))
+                             (fill-region (point-min) (point-max))
+                             (when (nth 2 elem)
+                               (let ((start (point)))
+                                 (insert (nth 2 elem))
+                                 (unless (bolp)
+                                   (insert "\n"))
+                                 (fill-region start (point-max))))
+                             (buffer-string))))
+                      (goto-char start)
+                      (dolist (line (split-string text "\n"))
+                        (end-of-line)
+                        (if (bolp)
+                            (insert line "\n")
+                          (insert line))
+                        (forward-line 1)))))))))))
+    (when (buffer-live-p buf)
+      (kill-buffer buf))
+    (assq tchar choices)))
+
+;; When available however, use the default `read-multiple-choice'.
+(require 'rmc nil t)
+(when (fboundp 'read-multiple-choice)
+  (defalias 'virtual-auto-fill--read-multiple-choice #'read-multiple-choice))
+
+(defvar virtual-auto-fill--saved-mode-enabled-states nil
+  "Saves enabled states of local minor modes.
+The mode function and variable must behave according to
+define-minor-mode's default.")
+
+(defun virtual-auto-fill--save-state ()
+  "Save enabled modes."
+  (set (make-local-variable 'virtual-auto-fill--saved-mode-enabled-states) nil)
+  (dolist (var '(visual-line-mode
+                 adaptive-wrap-prefix-mode
+                 visual-fill-column-mode))
+    (push (cons var (symbol-value var))
+          virtual-auto-fill--saved-mode-enabled-states)))
+
+(defun virtual-auto-fill--restore-state ()
+  "Restore enabled modes."
+  (dolist (saved virtual-auto-fill--saved-mode-enabled-states)
+    (if (cdr saved)
+        (funcall (car saved) 1)
+      (funcall (car saved) -1)))
+  ;; Clean up.
+  (kill-local-variable 'virtual-auto-fill--saved-mode-enabled-states))
+
+(defvar virtual-auto-fill-fill-paragraph-require-confirmation t
+  "Ask for confirmation before `fill-paragraph'.")
+
+(defun virtual-auto-fill-fill-paragraph-after-confirmation ()
+  "Ask the first time a paragraph is filled in a buffer.
+Confirmation is always skipped if
+`virtual-auto-fill-fill-paragraph-require-confirmation' is nil."
+  (interactive)
+  (unless (when virtual-auto-fill-fill-paragraph-require-confirmation
+            (pcase (car (virtual-auto-fill--read-multiple-choice
+                         "Really fill paragraphs in visually wrapped buffer?"
+                         '((?y "yes" "Fill the paragraph, do not ask again")
+                           (?n "no" "Don't fill the paragraph and ask again next time")
+                           (?d "disable visual wrapping" "Disable virtual-auto-fill-mode"))))
+              (?y (progn (setq-local virtual-auto-fill-fill-paragraph-require-confirmation nil)
+                         nil))
+              (?n t)
+              (?d (progn (virtual-auto-fill-mode -1) nil))))
+    ;; Either no confirmation was required or the user decided to fill the
+    ;; paragraph.
+    (call-interactively #'fill-paragraph)))
+
+(defvar virtual-auto-fill-visual-fill-column-in-emacs-pre-26-1 nil
+  "Enable Visual Fill Column mode even if Emacs is too old.
+Emacs versions before 26.1 have a bug that can crash Emacs when
+Visual Fill Column mode is enabled (a mode employed by
+Virtual Auto Fill mode).  For further information, see:
+
+  https://github.com/joostkremers/visual-fill-column/issues/1
+
+By setting this to non-nil, you risk a crash when your Emacs
+version is too old.  To only disable the warning about the bug,
+unset
+`virtual-auto-fill-visual-fill-column-warning-in-emacs-pre-26-1'.")
+
+(put 'virtual-auto-fill-visual-fill-column-in-emacs-pre-26-1
+     'risky-local-variable t)
+
+(defvar virtual-auto-fill-visual-fill-column-warning-in-emacs-pre-26-1 nil
+  "Don't warn about the Emacs bug triggered by Visual Fill Column mode.
+Emacs versions before 26.1 have a bug that can crash Emacs when
+Visual Fill Column mode is enabled (a mode employed by Virtual
+Auto Fill mode).  For further information and workarounds, see:
+
+  https://github.com/joostkremers/visual-fill-column/issues/1
+
+Setting this to non-nil silences the warning issued when you are
+running an Emacs version smaller than 26.1, but still leaves
+Visual Fill Column mode disabled.  To enable Visual Fill Column
+mode even when your Emacs is deemed buggy, set
+`virtual-auto-fill-visual-fill-column-in-emacs-pre-26-1'.")
+
+(put 'virtual-auto-fill-visual-fill-column-warning-in-emacs-pre-26-1
+     'risky-local-variable t)
+
+;;;###autoload
+(define-minor-mode virtual-auto-fill-mode
+  "Visually wrap lines between wrap prefix and `fill-column'."
+  :lighter " VirtualFill"
+  (if virtual-auto-fill-mode
+      (progn
+        (virtual-auto-fill--save-state)
+        (visual-line-mode 1)
+        (adaptive-wrap-prefix-mode 1)
+        (if (and (version< emacs-version "26.1")
+                 (not virtual-auto-fill-visual-fill-column-in-emacs-pre-26-1))
+            (when virtual-auto-fill-visual-fill-column-warning-in-emacs-pre-26-1
+              (message "You are running an Emacs version < 26.1 which has a bug that can crash Emacs when Visual Fill Column mode is enabled (that's a mode employed by Virtual Auto Fill mode). This bug has been fixed starting with Emacs version 26.1. Visual Fill Column mode is left disabled for now. To enable it anyway, set `virtual-auto-fill-visual-fill-column-in-emacs-pre-26-1' to non-nil and retry. To disable this warning (but leave Virtual Auto Fill mode disabled), unset `virtual-auto-fill-visual-fill-column-warning-in-emacs-pre-26-1'. For further information, see https://github.com/joostkremers/visual-fill-column/issues/1"))
+          (visual-fill-column-mode 1))
+        (local-set-key [remap fill-paragraph]
+                       #'virtual-auto-fill-fill-paragraph-after-confirmation)
+        (local-set-key [remap mu4e-fill-paragraph]
+                       #'virtual-auto-fill-fill-paragraph-after-confirmation))
+    (virtual-auto-fill--restore-state)
+    (local-set-key [remap fill-paragraph] nil)
+    (local-set-key [remap mu4e-fill-paragraph] nil)
+    (kill-local-variable 'virtual-auto-fill-fill-paragraph-require-confirmation)))
+
+(provide 'virtual-auto-fill)
+
+;;; virtual-auto-fill.el ends here
diff --git a/lisp/visual-fill-column.el b/lisp/visual-fill-column.el
new file mode 100644
index 00000000..25106f23
--- /dev/null
+++ b/lisp/visual-fill-column.el
@@ -0,0 +1,229 @@
+;;; visual-fill-column.el --- fill-column for visual-line-mode  -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015-2019 Joost Kremers
+;; Copyright (C) 2016 Martin Rudalics
+;; All rights reserved.
+
+;; Author: Joost Kremers 
+;; Maintainer: Joost Kremers 
+;; URL: https://github.com/joostkremers/visual-fill-column
+;; Package-Version: 20200428.816
+;; Package-Commit: 64d38bc1c00953be05c193c01332a633be67aac2
+;; Created: 2015
+;; Version: 1.11
+;; Package-Requires: ((emacs "24.3"))
+
+;; This file is NOT part of GNU Emacs.
+
+;; visual-fill-column 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.
+
+;; visual-fill-column 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 GNU Emacs.  If not, see .
+
+;;; Commentary:
+
+;; `visual-fill-column-mode' is a small Emacs minor mode that mimics the effect of `fill-column'
+;; in `visual-line-mode'.  Instead of wrapping lines at the window edge, which
+;; is the standard behaviour of `visual-line-mode', it wraps lines at
+;; `fill-column'.  If `fill-column' is too large for the window, the text is
+;; wrapped at the window edge.
+
+;;; Code:
+
+(defgroup visual-fill-column nil "Wrap lines according to `fill-column' in `visual-line-mode'."
+  :group 'text
+  :prefix "visual-fill-column-")
+
+(defcustom visual-fill-column-width nil
+  "Width of the text area.
+By default, the global value of `fill-column' is used, but if
+this option is set to a value, it is used instead."
+  :group 'visual-fill-column
+  :type '(choice (const :tag "Use `fill-column'" :value nil)
+                 (integer :tag "Specify width" :value 70)))
+(make-variable-buffer-local 'visual-fill-column-width)
+(put 'visual-fill-column-width 'safe-local-variable 'numberp)
+
+(defcustom visual-fill-column-fringes-outside-margins t
+  "Put the fringes outside the margins."
+  :group 'visual-fill-column
+  :type '(choice (const :tag "Put fringes outside the margins" t)
+                 (const :tag "Keep the fringes inside the margins" nil)))
+(make-variable-buffer-local 'visual-fill-column-fringes-outside-margins)
+(put 'visual-fill-column-fringes-outside-margins 'safe-local-variable 'symbolp)
+
+(defcustom visual-fill-column-center-text nil
+  "If set, center the text area in the window."
+  :group 'visual-fill-column
+  :type '(choice (const :tag "Display text area at window margin" nil)
+                 (const :tag "Center text area" t)))
+(make-variable-buffer-local 'visual-fill-column-center-text)
+(put 'visual-fill-column-center-text 'safe-local-variable 'symbolp)
+
+;;;###autoload
+(define-minor-mode visual-fill-column-mode
+  "Wrap lines according to `fill-column' in `visual-line-mode'."
+  :init-value nil :lighter nil :global nil
+  :keymap
+  (let ((map (make-sparse-keymap)))
+    (when (bound-and-true-p mouse-wheel-mode)
+      (progn
+        (define-key map (vector 'left-margin mouse-wheel-down-event) 'mwheel-scroll)
+        (define-key map (vector 'left-margin mouse-wheel-up-event) 'mwheel-scroll)
+        (define-key map (vector 'right-margin mouse-wheel-down-event) 'mwheel-scroll)
+        (define-key map (vector 'right-margin mouse-wheel-up-event) 'mwheel-scroll))
+      map))
+  (if visual-fill-column-mode
+      (visual-fill-column-mode--enable)
+    (visual-fill-column-mode--disable)))
+
+;;;###autoload
+(define-globalized-minor-mode global-visual-fill-column-mode visual-fill-column-mode turn-on-visual-fill-column-mode
+  :require 'visual-fill-column-mode
+  :group 'visual-fill-column)
+
+(defun turn-on-visual-fill-column-mode ()
+  "Turn on `visual-fill-column-mode'.
+Note that `visual-fill-column-mode' is only turned on in buffers
+in which Visual Line mode is active as well, and only in buffers
+that actually visit a file."
+  (when (and visual-line-mode
+             buffer-file-name)
+    (visual-fill-column-mode 1)))
+
+(defun visual-fill-column-mode--enable ()
+  "Set up `visual-fill-column-mode' for the current buffer."
+  (add-hook 'window-configuration-change-hook #'visual-fill-column--adjust-window 'append 'local)
+  (if (>= emacs-major-version 26)
+      (add-hook 'window-size-change-functions #'visual-fill-column--adjust-frame 'append))
+  (visual-fill-column--adjust-window))
+
+(defun visual-fill-column-mode--disable ()
+  "Disable `visual-fill-column-mode' for the current buffer."
+  (remove-hook 'window-configuration-change-hook #'visual-fill-column--adjust-window 'local)
+  (set-window-fringes (get-buffer-window (current-buffer)) nil)
+  (set-window-margins (get-buffer-window (current-buffer)) nil))
+
+(defun visual-fill-column-split-window (&optional window size side pixelwise)
+  "Split WINDOW, unsetting its margins first.
+SIZE, SIDE, and PIXELWISE are passed on to `split-window'.  This
+function is for use in the window parameter `split-window'."
+  (let ((horizontal (memq side '(t left right)))
+	margins new)
+    (when horizontal
+      ;; Reset margins.
+      (setq margins (window-margins window))
+      (set-window-margins window nil))
+    ;; Now try to split the window.
+    (set-window-parameter window 'split-window nil)
+    (unwind-protect
+	(setq new (split-window window size side pixelwise))
+      (set-window-parameter window 'split-window #'visual-fill-column-split-window)
+      ;; Restore old margins if we failed.
+      (when (and horizontal (not new))
+	(set-window-margins window (car margins) (cdr margins))))))
+
+;;;###autoload
+(defun visual-fill-column-split-window-sensibly (&optional window)
+  "Split WINDOW sensibly, unsetting its margins first.
+This function unsets the window margins and calls
+`split-window-sensibly'.
+
+By default, `split-window-sensibly' does not split a window
+vertically if it has wide margins, even if there is enough space
+for a vertical split.  This function can be used as the value of
+`split-window-preferred-function' to enable vertically splitting
+windows with wide margins."
+  (let ((margins (window-margins window))
+        new)
+    ;; unset the margins and try to split the window
+    (when (buffer-local-value 'visual-fill-column-mode (window-buffer window))
+      (set-window-margins window nil))
+    (unwind-protect
+        (setq new (split-window-sensibly window))
+      (when (not new)
+        (set-window-margins window (car margins) (cdr margins))))))
+
+(defun visual-fill-column--adjust-window ()
+  "Adjust the window margins and fringes."
+  ;; Only run when we're really looking at a buffer that has v-f-c-mode enabled. See #22.
+  (when (buffer-local-value 'visual-fill-column-mode (window-buffer (selected-window)))
+    (set-window-fringes (get-buffer-window (current-buffer)) nil nil visual-fill-column-fringes-outside-margins)
+    (if (>= emacs-major-version 25)
+        (set-window-parameter (get-buffer-window (current-buffer)) 'split-window #'visual-fill-column-split-window))
+    (visual-fill-column--set-margins)))
+
+(defun visual-fill-column--adjust-frame (frame)
+  "Adjust the windows of FRAME."
+  (mapc (lambda (w)
+          (with-selected-window w
+            (visual-fill-column--adjust-window)))
+        (window-list frame :never)))
+
+(defun visual-fill-column-adjust (&optional _inc)
+  "Adjust the window margins and fringes.
+This function is for use as advice to `text-scale-adjust'.  It
+calls `visual-fill-column--adjust-window', but only if
+`visual-fill-column' is active."
+  (if visual-fill-column-mode
+      (visual-fill-column--adjust-window)))
+
+(defun visual-fill-column--window-max-text-width (&optional window)
+  "Return the maximum possible text width of WINDOW.
+The maximum possible text width is the width of the current text
+area plus the margins, but excluding the fringes, scroll bar and
+right divider.  WINDOW defaults to the selected window.  The
+return value is scaled to account for `text-scale-mode-amount'
+and `text-scale-mode-step'."
+  (or window (setq window (get-buffer-window (current-buffer))))
+  (let* ((margins (window-margins window))
+         (buffer (window-buffer window))
+         (scale (if (and (boundp 'text-scale-mode-step)
+                         (boundp 'text-scale-mode-amount))
+                    (with-current-buffer buffer
+                      (expt text-scale-mode-step
+                            text-scale-mode-amount))
+                  1.0)))
+    (truncate (/ (+ (window-width window)
+                    (or (car margins) 0)
+                    (or (cdr margins) 0)
+                    (or (and (boundp 'display-line-numbers-width)
+                             (numberp display-line-numbers-width)
+                             (- display-line-numbers-width))
+                        0))
+                 (float scale)))))
+
+(defun visual-fill-column--set-margins ()
+  "Set window margins for the current window."
+  ;; calculate left & right margins
+  (let* ((window (get-buffer-window (current-buffer)))
+         (total-width (visual-fill-column--window-max-text-width window))
+         (width (or visual-fill-column-width
+                    fill-column))
+         (margins (if (< (- total-width width) 0) ; margins must be >= 0
+                      0
+                    (- total-width width)))
+         (left (if visual-fill-column-center-text
+                   (/ margins 2)
+                 0))
+         (right (- margins left)))
+
+    ;; put an explicitly R2L buffer on the right side of the window
+    (when (and (eq bidi-paragraph-direction 'right-to-left)
+               (= left 0))
+      (setq left right)
+      (setq right 0))
+
+    (set-window-margins window left right)))
+
+(provide 'visual-fill-column)
+
+;;; visual-fill-column.el ends here
diff --git a/lisp/web-mode.el b/lisp/web-mode.el
new file mode 100644
index 00000000..6626eb39
--- /dev/null
+++ b/lisp/web-mode.el
@@ -0,0 +1,14312 @@
+;;; web-mode.el --- major mode for editing web templates
+;;; -*- coding: utf-8; lexical-binding: t; -*-
+
+;; Copyright 2011-2020 François-Xavier Bois
+
+;; Version: 17.0.0
+;; Package-Version: 20200612.1038
+;; Package-Commit: 60ffd878c4371644bd964f00fea38054645e3e47
+;; Author: François-Xavier Bois 
+;; Maintainer: François-Xavier Bois
+;; Package-Requires: ((emacs "23.1"))
+;; URL: http://web-mode.org
+;; Repository: http://github.com/fxbois/web-mode
+;; Created: July 2011
+;; Keywords: languages
+;; License: GNU General Public License >= 2
+;; Distribution: This file is not part of Emacs
+
+;;; Commentary:
+
+;;==============================================================================
+;; WEB-MODE is sponsored by ** Kernix ** Best Digital Factory & Data Lab (Paris)
+;;==============================================================================
+
+;;; Code:
+
+;;---- CONSTS ------------------------------------------------------------------
+
+(defconst web-mode-version "17.0.0"
+  "Web Mode version.")
+
+;;---- GROUPS ------------------------------------------------------------------
+
+(defgroup web-mode nil
+  "Major mode for editing web templates"
+  :group 'languages
+  :prefix "web-"
+  :link '(url-link :tag "Site" "http://web-mode.org")
+  :link '(url-link :tag "Repository" "https://github.com/fxbois/web-mode"))
+
+(defgroup web-mode-faces nil
+  "Faces for syntax highlighting."
+  :group 'web-mode
+  :group 'faces)
+
+;;---- CUSTOMS -----------------------------------------------------------------
+
+(defcustom web-mode-block-padding 0
+  "Multi-line block (php, ruby, java, python, asp, etc.) left padding.
+   -1 to have to code aligned on the column 0."
+  :type '(choice (integer :tags "Number of spaces")
+                 (const :tags "No indent" nil))
+  :group 'web-mode)
+
+(defcustom web-mode-part-padding 1
+  "Part elements (script, style) left padding."
+  :type '(choice (integer :tags "Number of spaces")
+                 (const :tags "No indent" nil))
+  :group 'web-mode)
+
+(defcustom web-mode-script-padding web-mode-part-padding
+  "Script element left padding."
+  :type '(choice (integer :tags "Number of spaces")
+                 (const :tags "No indent" nil))
+  :group 'web-mode)
+
+(defcustom web-mode-style-padding web-mode-part-padding
+  "Style element left padding."
+  :type '(choice (integer :tags "Number of spaces")
+                 (const :tags "No indent" nil))
+  :group 'web-mode)
+
+(defcustom web-mode-attr-indent-offset nil
+  "Html attribute indentation level."
+  :type '(choice (integer :tags "Number of spaces")
+                 (const :tags "Default" nil))
+  :safe #'(lambda (v) (or (integerp v) (booleanp v)))
+  :group 'web-mode)
+
+(defcustom web-mode-attr-value-indent-offset nil
+  "Html attribute value indentation level."
+  :type '(choice (integer :tags "Number of spaces")
+                 (const :tags "Default" nil))
+  :safe #'(lambda (v) (or (integerp v) (booleanp v)))
+  :group 'web-mode)
+
+(defcustom web-mode-markup-indent-offset
+  (if (and (boundp 'standard-indent) standard-indent) standard-indent 2)
+  "Html indentation level."
+  :type 'integer
+  :safe #'integerp
+  :group 'web-mode)
+
+(defcustom web-mode-css-indent-offset
+  (if (and (boundp 'standard-indent) standard-indent) standard-indent 2)
+  "CSS indentation level."
+  :type 'integer
+  :safe #'integerp
+  :group 'web-mode)
+
+(defcustom web-mode-code-indent-offset
+  (if (and (boundp 'standard-indent) standard-indent) standard-indent 2)
+  "Code (javascript, php, etc.) indentation level."
+  :type 'integer
+  :safe #'integerp
+  :group 'web-mode)
+
+(defcustom web-mode-sql-indent-offset 4
+  "Sql (inside strings) indentation level."
+  :type 'integer
+  :safe #'integerp
+  :group 'web-mode)
+
+(defcustom web-mode-enable-css-colorization (display-graphic-p)
+  "In a CSS part, set background according to the color: #xxx, rgb(x,x,x)."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-comment-interpolation nil
+  "Enable highlight of keywords like FIXME, TODO, etc. in comments."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-comment-annotation nil
+  "Enable annotation in comments (jsdoc, phpdoc, etc.)."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-auto-indentation (display-graphic-p)
+  "Auto-indentation."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-auto-closing (display-graphic-p)
+  "Auto-closing."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-auto-pairing (display-graphic-p)
+  "Auto-pairing."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-auto-opening (display-graphic-p)
+  "Html element auto-opening."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-auto-quoting (display-graphic-p)
+  "Add double quotes after the character = in a tag."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-auto-expanding nil
+  "e.g. s/ expands to |."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-control-block-indentation t
+  "Control blocks increase indentation."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-current-element-highlight nil
+  "Enable current element highlight."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-current-column-highlight nil
+  "Show column for current element."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-whitespace-fontification nil
+  "Enable whitespaces."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-html-entities-fontification nil
+  "Enable html entities fontification."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-block-face nil
+  "Enable block face (useful for setting a background for example).
+See web-mode-block-face."
+  :type 'boolean
+  :group 'web-mode)
+
+(defcustom web-mode-enable-part-face nil
+  "Enable part face (useful for setting background of ")
+            (cond
+             ((string-match-p " lang[ ]*=[ ]*[\"']stylus" style)
+              (setq element-content-type "stylus"))
+             ((string-match-p " lang[ ]*=[ ]*[\"']sass" style)
+              (setq element-content-type "sass"))
+             (t
+              (setq element-content-type "css"))
+             ) ;cond
+            ) ;let
+          ) ;style
+         ((string= tname "script")
+          (let (script)
+            (setq script (buffer-substring-no-properties tbeg tend)
+                  part-close-tag "")
+            (cond
+             ((string-match-p " type[ ]*=[ ]*[\"']text/\\(jsx\\|babel\\)" script)
+              (setq element-content-type "jsx"))
+             ((string-match-p " type[ ]*=[ ]*[\"']text/\\(markdown\\|template\\)" script)
+              (setq element-content-type "markdown"))
+             ((string-match-p " type[ ]*=[ ]*[\"']text/ruby" script)
+              (setq element-content-type "ruby"))
+             ((seq-some (lambda (x)
+                          (string-match-p (concat "type[ ]*=[ ]*[\"']" x) script))
+                        web-mode-script-template-types)
+              (setq element-content-type "html"
+                    part-close-tag nil))
+             ((string-match-p " type[ ]*=[ ]*[\"']application/\\(ld\\+json\\|json\\)" script)
+              (setq element-content-type "json"))
+             ((string-match-p " lang[ ]*=[ ]*[\"']\\(typescript\\|ts\\)" script)
+              (setq element-content-type "typescript"))
+             (t
+              (setq element-content-type "javascript"))
+             ) ;cond
+            ) ;let
+          ) ;script
+         ((and (string= tname "template") (string-match-p " lang" (buffer-substring-no-properties tbeg tend)))
+          (let (template)
+            (setq template (buffer-substring-no-properties tbeg tend)
+                  part-close-tag "")
+            (cond
+             ((string-match-p " lang[ ]*=[ ]*[\"']pug" template)
+              (setq element-content-type "pug"))
+             (t
+              (setq element-content-type "html"))
+             ) ;cond
+            ) ;let
+          ) ;style
+         ((and (string= web-mode-engine "archibus")
+               (string= tname "sql"))
+          (setq element-content-type "sql"
+                part-close-tag ""))
+         )
+
+        (add-text-properties tbeg tend props)
+        (put-text-property tbeg (1+ tbeg) 'tag-beg flags)
+        (put-text-property (1- tend) tend 'tag-end t)
+
+        (when (and part-close-tag
+                   (web-mode-dom-sf part-close-tag reg-end t)
+                   (setq part-beg tend)
+                   (setq part-end (match-beginning 0))
+                   (> part-end part-beg))
+          (put-text-property part-beg part-end 'part-side
+                             (intern element-content-type web-mode-obarray))
+          (setq tend part-end)
+          ) ;when
+
+        (goto-char tend)
+
+        ) ;while
+
+      )))
+
+;; FLAGS: attr
+;; (1)custom-attr (2)engine-attr (4)spread-attr[jsx] (8)code-value
+
+;; STATES: attr
+;; (0)nil (1)space (2)name (3)space-before (4)equal (5)space-after
+;; (6)value-uq (7)value-sq (8)value-dq (9)value-bq : jsx attr={}
+
+(defun web-mode-attr-skip (limit)
+
+  (let ((tag-flags 0) (attr-flags 0) (continue t) (attrs 0) (counter 0) (brace-depth 0)
+        (pos-ori (point)) (state 0) (equal-offset 0) (go-back nil)
+        (is-jsx (or (string= web-mode-content-type "jsx") (eq (get-text-property (point) 'part-type) 'jsx)))
+        attr name-beg name-end val-beg char pos escaped spaced quoted)
+
+    (while continue
+
+      (setq pos (point)
+            char (char-after)
+            ;;spaced (eq char ?\s)
+            spaced (member char '(?\s ?\n))
+            )
+
+      (when quoted (setq quoted (1+ quoted)))
+
+      (cond
+
+       ((>= pos limit)
+        (setq continue nil)
+        (setq go-back t)
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        )
+
+       ((or (and (= state 8) (not (member char '(?\" ?\\))))
+            (and (= state 7) (not (member char '(?\' ?\\))))
+            (and (= state 9) (not (member char '(?} ?\\))))
+            )
+        (when (and (= state 9) (eq char ?\{))
+          (setq brace-depth (1+ brace-depth)))
+        )
+
+       ((and (= state 9) (eq char ?\}) (> brace-depth 1))
+        (setq brace-depth (1- brace-depth)))
+
+       ((get-text-property pos 'block-side)
+        (when (= state 2)
+          (setq name-end pos))
+        )
+
+       ((and (= state 2) is-jsx (eq char ?\}) (eq attr-flags 4))
+        (setq name-end pos)
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        (setq state 0
+              attr-flags 0
+              equal-offset 0
+              name-beg nil
+              name-end nil
+              val-beg nil)
+        )
+
+       ((or (and (= state 8) (eq ?\" char) (not escaped))
+            (and (= state 7) (eq ?\' char) (not escaped))
+            (and (= state 9) (eq ?\} char) (= brace-depth 1))
+            )
+
+        ;;(message "%S %S" (point) attr-flags)
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        (setq state 0
+              attr-flags 0
+              equal-offset 0
+              name-beg nil
+              name-end nil
+              val-beg nil)
+        )
+
+       ((and (member state '(4 5)) (member char '(?\' ?\" ?\{)))
+        (setq val-beg pos)
+        (setq quoted 1)
+        (setq state (cond ((eq ?\' char) 7)
+                          ((eq ?\" char) 8)
+                          (t             9)))
+        (when (= state 9)
+          (setq brace-depth 1))
+        )
+
+       ((and (eq ?\= char) (member state '(2 3)))
+        (setq equal-offset (- pos name-beg)
+              name-end (1- pos))
+        (setq state 4)
+        (setq attr (buffer-substring-no-properties name-beg (1+ name-end)))
+        (when (and web-mode-indentless-attributes (member (downcase attr) web-mode-indentless-attributes))
+          ;;(message "onclick")
+          (setq attr-flags (logior attr-flags 8)))
+        )
+
+       ((and spaced (= state 0))
+        (setq state 1)
+        )
+
+       ((and (eq char ?\<) (not (member state '(7 8 9))))
+        (setq continue nil)
+        (setq go-back t)
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        )
+
+       ((and (eq char ?\>) (not (member state '(7 8 9))))
+        (setq tag-flags (logior tag-flags 16))
+        (when (eq (char-before) ?\/)
+          (setq tag-flags (logior tag-flags 8))
+          )
+        (setq continue nil)
+        (when name-beg
+          (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset))))
+        )
+
+       ((and spaced (member state '(1 3 5)))
+        )
+
+       ((and spaced (= state 2))
+        (setq state 3)
+        )
+
+       ((and (eq char ?\/) (member state '(4 5)))
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        (setq state 1
+              attr-flags 0
+              equal-offset 0
+              name-beg nil
+              name-end nil
+              val-beg nil)
+        )
+
+       ((and (eq char ?\/) (member state '(0 1)))
+        )
+
+       ((and spaced (= state 4))
+        (setq state 5)
+        )
+
+       ((and (= state 3)
+             (or (and (>= char 97) (<= char 122)) ;a - z
+                 (and (>= char 65) (<= char 90)) ;A - Z
+                 (eq char ?\-)))
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        (setq state 2
+              attr-flags 0
+              equal-offset 0
+              name-beg pos
+              name-end pos
+              val-beg nil)
+        )
+
+       ((and (eq char ?\n) (not (member state '(7 8 9))))
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        (setq state 1
+              attr-flags 0
+              equal-offset 0
+              name-beg nil
+              name-end nil
+              val-beg nil)
+        )
+
+       ((and (= state 6) (member char '(?\s ?\n ?\/)))
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        (setq state 1
+              attr-flags 0
+              equal-offset 0
+              name-beg nil
+              name-end nil
+              val-beg nil)
+        )
+
+       ((and quoted (= quoted 2) (member char '(?\s ?\n ?\>)))
+        (when (eq char ?\>)
+          (setq tag-flags (logior tag-flags 16))
+          (setq continue nil))
+        (setq state 6)
+        (setq attrs (+ attrs (web-mode-attr-scan state char name-beg name-end val-beg attr-flags equal-offset)))
+        (setq state 1
+              attr-flags 0
+              equal-offset 0
+              name-beg nil
+              name-end nil
+              val-beg nil)
+        )
+
+       ((and (not spaced) (= state 1))
+        (when (and is-jsx (eq char ?\{))
+          (setq attr-flags 4))
+        (setq state 2)
+        (setq name-beg pos
+              name-end pos)
+        )
+
+       ((member state '(4 5))
+        (setq val-beg pos)
+        (setq state 6)
+        )
+
+       ((= state 1)
+        (setq state 2)
+        )
+
+       ((= state 2)
+        (setq name-end pos)
+        (when (and nil (= attr-flags 0) (member char '(?\- ?\:)))
+          (let (attr)
+            (setq attr (buffer-substring-no-properties name-beg (1+ name-end)))
+            (cond
+             ((member attr '("http-equiv"))
+              (setq attr-flags (1- attr-flags))
+              )
+             ;;((and web-mode-engine-attr-regexp
+             ;;      (string-match-p web-mode-engine-attr-regexp attr))
+             ;; (setq attr-flags (logior attr-flags 2))
+             ;; )
+             ((and (eq char ?\-) (not (string= attr "http-")))
+              (setq attr-flags (logior attr-flags 1)))
+             ) ;cond
+            ) ;let
+          ) ;when attr-flags = 1
+        ) ;state=2
+
+       ) ;cond
+
+      ;;(message "point(%S) end(%S) state(%S) c(%S) name-beg(%S) name-end(%S) val-beg(%S) attr-flags(%S) equal-offset(%S)" pos end state char name-beg name-end val-beg attr-flags equal-offset)
+
+      (when (and quoted (>= quoted 2))
+        (setq quoted nil))
+
+      (setq escaped (eq ?\\ char))
+      (when (null go-back)
+        (forward-char))
+
+      ) ;while
+
+    (when (> attrs 0) (setq tag-flags (logior tag-flags 1)))
+
+    tag-flags))
+
+(defun web-mode-attr-scan (state char name-beg name-end val-beg flags equal-offset)
+  ;;(message "point(%S) state(%S) c(%c) name-beg(%S) name-end(%S) val-beg(%S) flags(%S) equal-offset(%S)"
+  ;;         (point) state char name-beg name-end val-beg flags equal-offset)
+  (when (null flags) (setq flags 0))
+  (when (and name-beg name-end web-mode-engine-attr-regexp)
+    (let (name)
+      (setq name (buffer-substring-no-properties name-beg (1+ name-end)))
+      ;;(message "%S" name)
+      (cond
+       ((string-match-p "^data[-]" name)
+        (setq flags (logior flags 1))
+        )
+       ((string-match-p web-mode-engine-attr-regexp name)
+        (setq flags (logior flags 2))
+        )
+       )
+      ) ;name
+    )
+  ;;(message "%S" name)
+  (cond
+   ((null name-beg)
+    ;;    (message "name-beg is null (%S)" (point))
+    0)
+   ((or (and (= state 8) (not (eq ?\" char)))
+        (and (= state 7) (not (eq ?\' char))))
+    (put-text-property name-beg (1+ name-beg) 'tag-attr-beg flags)
+    (put-text-property name-beg val-beg 'tag-attr t)
+    (put-text-property (1- val-beg) val-beg 'tag-attr-end equal-offset)
+    1)
+   ((and (member state '(4 5)) (null val-beg))
+    (put-text-property name-beg (1+ name-beg) 'tag-attr-beg flags)
+    (put-text-property name-beg (+ name-beg equal-offset 1) 'tag-attr t)
+    (put-text-property (+ name-beg equal-offset) (+ name-beg equal-offset 1) 'tag-attr-end equal-offset)
+    1)
+   (t
+    (let (val-end)
+      (if (null val-beg)
+          (setq val-end name-end)
+        (setq val-end (point))
+        (when (or (null char) (member char '(?\s ?\n ?\> ?\/)))
+          (setq val-end (1- val-end))
+          )
+        ) ;if
+      (put-text-property name-beg (1+ name-beg) 'tag-attr-beg flags)
+      (put-text-property name-beg (1+ val-end) 'tag-attr t)
+      (put-text-property val-end (1+ val-end) 'tag-attr-end equal-offset)
+      ) ;let
+    1) ;t
+   ) ;cond
+  )
+
+(defun web-mode-part-foreach (reg-beg reg-end func)
+  (let ((i 0) (continue t) (part-beg reg-beg) (part-end nil))
+    (while continue
+      (setq part-end nil)
+      (unless (get-text-property part-beg 'part-side)
+        (setq part-beg (web-mode-part-next-position part-beg)))
+      (when (and part-beg (< part-beg reg-end))
+        (setq part-end (web-mode-part-end-position part-beg)))
+      (cond
+       ((> (setq i (1+ i)) 100)
+        (message "process-parts ** warning (%S) **" (point))
+        (setq continue nil))
+       ((or (null part-end) (> part-end reg-end))
+        (setq continue nil))
+       (t
+        (setq part-end (1+ part-end))
+        (funcall func part-beg part-end)
+        (setq part-beg part-end))
+       ) ;cond
+      ) ;while
+    ))
+
+(defun web-mode-part-scan (reg-beg reg-end &optional content-type depth)
+  (save-excursion
+    (let (token-re ch-before ch-at ch-next token-type beg continue)
+      ;;(message "%S %S" reg-beg reg-end)
+      (cond
+       (content-type
+        )
+       ((member web-mode-content-type web-mode-part-content-types)
+        (setq content-type web-mode-content-type))
+       (t
+        (setq content-type (symbol-name (get-text-property reg-beg 'part-side))))
+       ) ;cond
+
+      (goto-char reg-beg)
+
+      (cond
+       ((member content-type '("javascript" "json"))
+        (setq token-re "/\\|\"\\|'\\|`"))
+       ((member content-type '("typescript"))
+        (setq token-re "\"\\|'\\|`\\|//\\|/\\*"))
+       ((member content-type '("jsx"))
+        (setq token-re "/\\|\"\\|'\\|`\\|]"))
+       ((string= web-mode-content-type "css")
+        (setq token-re "\"\\|'\\|/\\*\\|//"))
+       ((string= content-type "css")
+        (setq token-re "\"\\|'\\|/\\*"))
+       (t
+        (setq token-re "/\\*\\|\"\\|'"))
+       )
+
+      (while (and token-re (< (point) reg-end) (web-mode-dom-rsf token-re reg-end t))
+
+        (setq beg (match-beginning 0)
+              token-type nil
+              continue t
+              ch-at (char-after beg)
+              ch-next (or (char-after (1+ beg)) ?\d)
+              ch-before (or (char-before beg) ?\d))
+
+        ;;(message "[%S>%S|%S] %S %c %c %c" reg-beg reg-end depth beg ch-before ch-at ch-next)
+
+        (cond
+
+         ((eq ?\' ch-at)
+          (while (and continue (search-forward "'" reg-end t))
+            (cond
+             ((get-text-property (1- (point)) 'block-side)
+              (setq continue t))
+             (t
+              (setq continue (web-mode-string-continue-p reg-beg)))
+             )
+            ) ;while
+          (setq token-type 'string))
+
+         ((eq ?\` ch-at)
+          (while (and continue (search-forward "`" reg-end t))
+            (cond
+             ((get-text-property (1- (point)) 'block-side)
+              (setq continue t))
+             (t
+              (setq continue (web-mode-string-continue-p reg-beg)))
+             )
+            ) ;while
+          (setq token-type 'string))
+
+         ((eq ?\" ch-at)
+          (while (and continue (search-forward "\"" reg-end t))
+            (cond
+             ((get-text-property (1- (point)) 'block-side)
+              (setq continue t))
+             (t
+              (setq continue (web-mode-string-continue-p reg-beg)))
+             ) ;cond
+            ) ;while
+          (cond
+           ((string= content-type "json")
+            (if (looking-at-p "[ ]*:")
+                (cond
+                 ((eq ?\@ (char-after (1+ beg)))
+                  (setq token-type 'context))
+                 (t
+                  (setq token-type 'key))
+                 )
+              (setq token-type 'string))
+            ) ;json
+           (t
+            (setq token-type 'string))
+           ) ;cond
+          )
+
+         ((and (eq ?\< ch-at)
+               (not (or (and (>= ch-before 97) (<= ch-before 122))
+                        (and (>= ch-before 65) (<= ch-before 90)))))
+          ;;(message "before [%S>%S|%S] pt=%S" reg-beg reg-end depth (point))
+          (search-backward "<")
+          (if (web-mode-jsx-skip reg-end)
+              (web-mode-jsx-scan-element beg (point) depth)
+            (forward-char))
+          ;;(message "after [%S>%S|%S] pt=%S" reg-beg reg-end depth (point))
+          )
+
+         ((and (eq ?\/ ch-at) (member content-type '("javascript" "jsx")))
+          (cond
+           ((eq ?\\ ch-before)
+            )
+           ((eq ?\* ch-next)
+            ;;(message "--> %S %S" (point) reg-end)
+            (when (search-forward "*/" reg-end t)
+              (setq token-type 'comment))
+            )
+           ((eq ?\/ ch-next)
+            (setq token-type 'comment)
+            (goto-char (if (< reg-end (line-end-position)) reg-end (line-end-position)))
+            )
+           ((and (looking-at-p ".*/")
+                 (looking-back "\\(^\\|case\\|[[(,=:!&|?{};]\\)[ ]*/" (point-min)))
+                 ;;(re-search-forward "/[gimyu]*" reg-end t))
+            (let ((eol (line-end-position)))
+              (while (and continue (search-forward "/" eol t))
+                (cond
+                 ((get-text-property (1- (point)) 'block-side)
+                  (setq continue t))
+                 ((looking-back "\\\\+/" reg-beg t)
+                  (setq continue (= (mod (- (point) (match-beginning 0)) 2) 0)))
+                 (t
+                  (re-search-forward "[gimyu]*" eol t)
+                  (setq token-type 'string)
+                  (setq continue nil))
+                 )
+                ) ;while
+              ) ;let
+            )
+           ) ;cond
+          )
+
+         ((eq ?\/ ch-next)
+          ;;(message "%S" (point))
+          (cond
+           ((and (string= content-type "css")
+                 (eq ?/ ch-at)
+                 (eq ?: ch-before))
+            )
+           (t
+            (unless (eq ?\\ ch-before)
+             (setq token-type 'comment)
+             (goto-char (if (< reg-end (line-end-position)) reg-end (line-end-position)))
+             )
+            )
+           )
+
+          )
+
+         ((eq ?\* ch-next)
+          (cond
+           ((search-forward "*/" reg-end t)
+            (setq token-type 'comment))
+           ((not (eobp))
+            (forward-char))
+           ) ;cond
+          )
+
+         ) ;cond
+
+        (when (and beg (>= reg-end (point)) token-type)
+          (put-text-property beg (point) 'part-token token-type)
+          (cond
+           ((eq token-type 'comment)
+            (put-text-property beg (1+ beg) 'syntax-table (string-to-syntax "<"))
+            (when (< (point) (point-max))
+              (if (< (point) (line-end-position))
+                  (put-text-property (1- (point)) (point) 'syntax-table (string-to-syntax ">")) ;#445
+                (put-text-property (point) (1+ (point)) 'syntax-table (string-to-syntax ">")) ;#377
+                )
+              ) ;when
+            ) ;comment
+           ((eq token-type 'string)
+            (put-text-property beg (1+ beg) 'syntax-table (string-to-syntax "|"))
+            (when (< (point) (point-max))
+              (if (< (point) (line-end-position))
+                  (put-text-property (1- (point)) (point) 'syntax-table (string-to-syntax "|"))
+                (put-text-property (point) (1+ (point)) 'syntax-table (string-to-syntax "|"))
+                )
+              ) ;when
+            ) ;string
+           ) ;cond
+          ) ;when
+
+        (when (> (point) reg-end)
+          (message "reg-beg(%S) reg-end(%S) token-type(%S) point(%S)" reg-beg reg-end token-type (point)))
+
+        ;;(message "#[%S>%S|%S] %S %c %c %c | (%S)" reg-beg reg-end depth beg ch-before ch-at ch-next (point))
+
+        ) ;while
+
+      )))
+
+(defun web-mode-string-continue-p (reg-beg)
+  "Is `point' preceeded by an odd number of backslashes?"
+  (let ((p (1- (point))))
+    (while (and (< reg-beg p) (eq ?\\ (char-before p)))
+      (setq p (1- p)))
+    (= (mod (- (point) p) 2) 0)))
+
+;; css rule = selector(s) + declaration (properties)
+(defun web-mode-css-rule-next (limit)
+  (let (at-rule var-rule sel-beg sel-end dec-beg dec-end chunk)
+    (skip-chars-forward "\n\t ")
+    (setq sel-beg (point))
+    (when (and (< (point) limit)
+               (web-mode-part-rsf "[{;]" limit))
+      (setq sel-end (1- (point)))
+      (cond
+       ((eq (char-before) ?\{)
+        (setq dec-beg (point))
+        (setq dec-end (web-mode-closing-paren-position (1- dec-beg) limit))
+        (if dec-end
+            (progn
+              (goto-char dec-end)
+              (forward-char))
+          (setq dec-end limit)
+          (goto-char limit))
+        )
+       (t
+        )
+       ) ;cond
+      (setq chunk (buffer-substring-no-properties sel-beg sel-end))
+      (cond
+       ((string-match "@\\([[:alpha:]-]+\\)" chunk)
+        (setq at-rule (match-string-no-properties 1 chunk)))
+       ((string-match "\\$\\([[:alpha:]-]+\\)" chunk)
+        (setq var-rule (match-string-no-properties 1 chunk)))
+       ) ;cond
+      ) ;when
+    (if (not sel-end)
+        (progn (goto-char limit) nil)
+      (list :at-rule at-rule
+            :var-rule var-rule
+            :sel-beg sel-beg
+            :sel-end sel-end
+            :dec-beg dec-beg
+            :dec-end dec-end)
+      ) ;if
+    ))
+
+(defun web-mode-css-rule-current (&optional pos part-beg part-end)
+  "Current CSS rule boundaries."
+  (unless pos (setq pos (point)))
+  (unless part-beg (setq part-beg (web-mode-part-beginning-position pos)))
+  (unless part-end (setq part-end (web-mode-part-end-position pos)))
+  (save-excursion
+    (let (beg end)
+      (goto-char pos)
+      (if (not (web-mode-part-sb "{" part-beg))
+          (progn
+            (setq beg part-beg)
+            (if (web-mode-part-sf ";" part-end)
+                (setq end (1+ (point)))
+              (setq end part-end))
+            ) ;progn
+        (setq beg (point))
+        (setq end (web-mode-closing-paren-position beg part-end))
+        (if end
+            (setq end (1+ end))
+          (setq end (line-end-position)))
+;;        (message "%S >>beg%S >>end%S" pos beg end)
+        (if (> pos end)
+
+            ;;selectors
+            (progn
+              (goto-char pos)
+              (if (web-mode-part-rsb "[};]" part-beg)
+                  (setq beg (1+ (point)))
+                (setq beg part-beg)
+                ) ;if
+              (goto-char pos)
+              (if (web-mode-part-rsf "[{;]" part-end)
+                  (cond
+                   ((eq (char-before) ?\;)
+                    (setq end (point))
+                    )
+                   (t
+                    (setq end (web-mode-closing-paren-position (1- (point)) part-end))
+                    (if end
+                        (setq end (1+ end))
+                      (setq end part-end))
+                    )
+                   ) ;cond
+                (setq end part-end)
+                )
+              ) ;progn selectors
+
+          ;; declaration
+          (goto-char beg)
+          (if (web-mode-part-rsb "[}{;]" part-beg)
+              (setq beg (1+ (point)))
+            (setq beg part-beg)
+            ) ;if
+          ) ;if > pos end
+        )
+;;      (message "beg(%S) end(%S)" beg end)
+      (when (eq (char-after beg) ?\n)
+        (setq beg (1+ beg)))
+      (cons beg end)
+      )))
+
+(defun web-mode-jsx-skip (reg-end)
+  (let ((continue t) (pos nil) (i 0) tag)
+    (looking-at "<\\([[:alpha:]][[:alnum:]:-]*\\)")
+    (setq tag (match-string-no-properties 1))
+    ;;(message "point=%S tag=%S" (point) tag)
+    (save-excursion
+      (while continue
+        (cond
+         ((> (setq i (1+ i)) 1000)
+          (message "jsx-skip ** warning **")
+          (setq continue nil))
+         ((looking-at "<[[:alpha:]][[:alnum:]:-]*[ ]*/>")
+          (goto-char (match-end 0))
+          (setq pos (point))
+          (setq continue nil))
+         ((not (web-mode-dom-rsf ">\\([ \t\n]*[\];,)':}|&]\\)\\|{" reg-end))
+          (setq continue nil)
+          )
+         ((eq (char-before) ?\{)
+          (backward-char)
+          (web-mode-closing-paren reg-end)
+          (forward-char)
+          )
+         (t
+          (setq continue nil)
+          (setq pos (match-beginning 1))
+          ) ;t
+         ) ;cond
+        ) ;while
+      ) ;save-excursion
+    (when pos (goto-char pos))
+    ;;(message "jsx-skip: %S" pos)
+    pos))
+
+;; (defun web-mode-jsx-skip2 (reg-end)
+;;   (let ((continue t) (pos nil) (i 0) (tag nil) (regexp nil) (counter 1))
+;;     (looking-at "<\\([[:alpha:]][[:alnum:]:-]*\\)")
+;;     (setq tag (match-string-no-properties 1))
+;;     (setq regexp (concat " (setq i (1+ i)) 100)
+;;           (message "jsx-skip ** warning **")
+;;           (setq continue nil))
+;;          ((looking-at "<[[:alpha:]][[:alnum:]:-]*[ ]*/>")
+;;           (goto-char (match-end 0))
+;;           (setq pos (point))
+;;           (setq continue nil))
+;;          ((not (web-mode-dom-rsf ">\\([ \t\n]*[\];,)':}]\\)\\|{" reg-end))
+;;           (setq continue nil)
+;;           )
+;;          ((eq (char-before) ?\{)
+;;           (backward-char)
+;;           (web-mode-closing-paren reg-end)
+;;           (forward-char)
+;;           )
+;;          (t
+;;           (setq continue nil)
+;;           (setq pos (match-beginning 1))
+;;           ) ;t
+;;          ) ;cond
+;;         ) ;while
+;;       ) ;save-excursion
+;;     (when pos (goto-char pos))
+;;     ;;(message "jsx-skip: %S" pos)
+;;     pos))
+
+;; http://facebook.github.io/jsx/
+;; https://github.com/facebook/jsx/blob/master/AST.md
+(defun web-mode-jsx-scan-element (reg-beg reg-end depth)
+  (unless depth (setq depth 1))
+  (save-excursion
+    (let (token-beg token-end regexp)
+      (goto-char reg-beg)
+      (put-text-property reg-beg (1+ reg-beg) 'jsx-beg depth)
+      (put-text-property (1- reg-end) reg-end 'jsx-end depth)
+      (put-text-property reg-beg reg-end 'jsx-depth depth)
+      (goto-char reg-beg)
+      (web-mode-scan-elements reg-beg reg-end)
+      (web-mode-jsx-scan-expression reg-beg reg-end (1+ depth))
+      )))
+
+(defun web-mode-jsx-scan-expression (reg-beg reg-end depth)
+  (let ((continue t) beg end)
+    (save-excursion
+      (goto-char reg-beg)
+      ;;(message "reg-beg=%S reg-end=%S" reg-beg reg-end)
+      (while (and continue (search-forward "{" reg-end t))
+        (backward-char)
+        (setq beg (point)
+              end (web-mode-closing-paren reg-end))
+        (cond
+         ((eq (get-text-property beg 'part-token) 'comment)
+          (forward-char))
+         ((not end)
+          (setq continue nil))
+         (t
+          (setq end (1+ end))
+          (put-text-property beg end 'jsx-depth depth)
+          (put-text-property beg (1+ beg) 'jsx-beg depth)
+          (put-text-property (1- end) end 'jsx-end depth)
+          (web-mode-part-scan beg end "jsx" (1+ depth))
+          ) ;t
+         ) ;cond
+        ) ;while
+      ) ;save-excursion
+    ))
+
+(defun web-mode-jsx-is-html (&optional pos)
+  (interactive)
+  (unless pos (setq pos (point)))
+  (let (ret (depth (get-text-property pos 'jsx-depth)))
+    (cond
+     ((or (null depth) (<= pos 2))
+      (setq pos nil))
+     ((and (= depth 1) (get-text-property pos 'jsx-beg))
+      (setq pos nil))
+     ((get-text-property pos 'tag-end)
+      (setq pos nil))
+     ((get-text-property pos 'tag-attr-beg)
+      (setq pos nil))
+     ((get-text-property pos 'jsx-beg)
+      (setq pos (null (get-text-property pos 'tag-beg))))
+     ((setq pos (web-mode-jsx-depth-beginning-position pos))
+      (setq pos (not (null (get-text-property pos 'tag-beg)))))
+     (t
+      (setq pos nil))
+     ) ;cond
+    ;;(message "is-html: %S (depth=%S)" pos depth)
+    pos))
+
+(defun web-mode-jsx-is-expr (&optional pos)
+  (cond
+   ((and (get-text-property pos 'jsx-beg)
+         (not (get-text-property pos 'tag-beg)))
+    nil)
+   (t
+    (setq pos (web-mode-jsx-depth-beginning-position pos))
+    (null (get-text-property pos 'tag-beg)))
+   ) ;cond
+  )
+
+(defun web-mode-jsx-depth-beginning-position (&optional pos target-depth)
+  (interactive)
+  (unless pos (setq pos (point)))
+  (unless target-depth (setq target-depth (get-text-property pos 'jsx-depth)))
+  (cond
+   ((or (null target-depth) (bobp))
+    (setq pos nil))
+   ((and (get-text-property pos 'jsx-beg) (= target-depth (get-text-property pos 'jsx-depth)))
+    )
+   (t
+    (let ((continue t) depth)
+      (while continue
+        (setq pos (previous-single-property-change pos 'jsx-depth))
+        (cond
+         ((or (null pos)
+              (null (setq depth (get-text-property pos 'jsx-depth))))
+          (setq continue nil
+                pos nil))
+         ((and (get-text-property pos 'jsx-beg) (= target-depth depth))
+          (setq continue nil))
+         ) ;cond
+        ) ;while
+      ) ;let
+    ) ;t
+   ) ;cond
+  ;;(message "beg: %S" pos)
+  pos)
+
+(defun web-mode-jsx-element-next (reg-end)
+  (let (continue beg end)
+    (setq beg (point))
+    (unless (get-text-property beg 'jsx-depth)
+      (setq beg (next-single-property-change beg 'jsx-beg)))
+    (setq continue (and beg (< beg reg-end))
+          end beg)
+    (while continue
+      (setq end (next-single-property-change end 'jsx-end))
+      (cond
+       ((or (null end) (> end reg-end))
+        (setq continue nil
+              end nil))
+       ((eq (get-text-property end 'jsx-depth) 1)
+        (setq continue nil))
+       (t
+        (setq end (1+ end)))
+       ) ;cond
+      ) ;while
+    ;;(message "beg=%S end=%S" beg end)
+    (if (and beg end (< beg end)) (cons beg end) nil)))
+
+(defun web-mode-jsx-expression-next (reg-end)
+  (let (beg end depth continue pos)
+    (setq beg (point))
+    ;;(message "pt=%S" beg)
+    (unless (and (get-text-property beg 'jsx-beg) (null (get-text-property beg 'tag-beg)))
+      ;;(setq beg (next-single-property-change beg 'jsx-beg))
+      (setq continue t
+            pos (1+ beg))
+      (while continue
+        (setq pos (next-single-property-change pos 'jsx-beg))
+        (cond
+         ((null pos)
+          (setq continue nil
+                beg nil))
+         ((> pos reg-end)
+          (setq continue nil
+                beg nil))
+         ((null (get-text-property pos 'jsx-beg))
+          )
+         ((null (get-text-property pos 'tag-beg))
+          (setq continue nil
+                beg pos))
+         ;;(t
+         ;; (setq pos (1+ pos)))
+         ) ;cond
+        ) ;while
+      ) ;unless
+    ;;(message "beg=%S" beg)
+    (when (and beg (< beg reg-end))
+      (setq depth (get-text-property beg 'jsx-beg)
+            continue (not (null depth))
+            pos beg)
+      ;;(message "beg=%S" beg)
+      (while continue
+        (setq pos (next-single-property-change pos 'jsx-end))
+        ;;(message "pos=%S" pos)
+        (cond
+         ((null pos)
+          (setq continue nil))
+         ((> pos reg-end)
+          (setq continue nil))
+         ((eq depth (get-text-property pos 'jsx-end))
+          (setq continue nil
+                end pos))
+         (t
+          ;;(setq pos (1+ pos))
+          )
+         ) ;cond
+        ) ;while
+      ) ;when
+    ;;(message "%S > %S" beg end)
+    (if (and beg end) (cons beg end) nil)))
+
+(defun web-mode-jsx-depth-next (reg-end)
+  (let (beg end depth continue pos)
+    (setq beg (point))
+    ;;(message "pt=%S" beg)
+    (unless (get-text-property beg 'jsx-beg)
+      ;;(setq beg (next-single-property-change beg 'jsx-beg))
+      ;;(setq pos (1+ beg))
+      (setq pos (next-single-property-change (1+ beg) 'jsx-beg))
+      (cond
+       ((null pos)
+        (setq beg nil))
+       ((>= pos reg-end)
+        (setq beg nil))
+       (t
+        (setq beg pos))
+       ) ;cond
+      ) ;unless
+    ;;(message "beg=%S" beg)
+    (when beg
+      (setq depth (get-text-property beg 'jsx-beg)
+            continue (not (null depth))
+            pos beg)
+      ;;(message "beg=%S" beg)
+      (while continue
+        (setq pos (next-single-property-change pos 'jsx-end))
+        ;;(message "pos=%S" pos)
+        (cond
+         ((null pos)
+          (setq continue nil))
+         ((> pos reg-end)
+          (setq continue nil))
+         ((eq depth (get-text-property pos 'jsx-end))
+          (setq continue nil
+                end pos))
+         (t
+          ;;(setq pos (1+ pos))
+          )
+         ) ;cond
+        ) ;while
+      ) ;when
+    ;;(message "%S > %S" beg end)
+    (if (and beg end) (cons beg end) nil)))
+
+(defun web-mode-jsx-beginning ()
+  (interactive)
+  (let (depth (continue t) (reg-beg (point-min)) (pos (point)))
+    (setq depth (get-text-property pos 'jsx-depth))
+    (cond
+     ((not depth)
+      )
+     ((get-text-property (1- pos) 'jsx-beg)
+      (goto-char (1- pos)))
+     (t
+      (while continue
+        (setq pos (previous-single-property-change pos 'jsx-beg))
+        ;;(message "pos=%S" pos)
+        (cond
+         ((null pos)
+          (setq continue nil))
+         ((<= pos reg-beg)
+          (setq continue nil))
+         ((eq depth (get-text-property pos 'jsx-beg))
+          (setq continue nil))
+         ) ;cond
+        ) ;while
+      (web-mode-go pos)
+      ) ;t
+     ) ;cond
+    ))
+
+(defun web-mode-jsx-end ()
+  (interactive)
+  (let (depth (continue t) (reg-end (point-max)) (pos (point)))
+    (setq depth (get-text-property pos 'jsx-depth))
+    (cond
+     ((not depth)
+      )
+     ((get-text-property pos 'jsx-end)
+      (goto-char (+ pos 1)))
+     (t
+      (while continue
+        (setq pos (next-single-property-change pos 'jsx-end))
+        ;;(message "pos=%S" pos)
+        (cond
+         ((null pos)
+          (setq continue nil))
+         ((> pos reg-end)
+          (setq continue nil))
+         ((eq depth (get-text-property pos 'jsx-end))
+          (setq continue nil))
+         ) ;cond
+        ) ;while
+      (web-mode-go pos 1)
+      ) ;t
+     ) ;cond
+    ))
+
+;;---- FONTIFICATION -----------------------------------------------------------
+
+;; 1/ after-change
+;; 2/ extend-region
+;; 3/ scan
+;; 4/ fontify
+;; 5/ post-command
+
+(defun web-mode-extend-region ()
+  ;;(message "extend-region: flb(%S) fle(%S) wmcb(%S) wmce(%S)" font-lock-beg font-lock-end web-mode-change-beg web-mode-change-end)
+  (cond
+   (web-mode-fontification-off
+    nil)
+   (t
+    (when (or (null web-mode-change-beg) (< font-lock-beg web-mode-change-beg))
+      ;;(message "font-lock-beg(%S) < web-mode-change-beg(%S)" font-lock-beg web-mode-change-beg)
+      (setq web-mode-change-beg font-lock-beg))
+    (when (or (null web-mode-change-end) (> font-lock-end web-mode-change-end))
+      ;;(message "font-lock-end(%S) > web-mode-change-end(%S)" font-lock-end web-mode-change-end)
+      (setq web-mode-change-end font-lock-end))
+    (let ((region (web-mode-scan web-mode-change-beg web-mode-change-end)))
+      (when region
+        ;;(message "region: %S" region)
+        (setq font-lock-beg (car region)
+              font-lock-end (cdr region))
+        ) ;when
+      ) ;let
+    nil) ;t
+   ))
+
+(defun web-mode-fontify (limit)
+  ;;(message "fontify: point(%S) limit(%S) change-beg(%S) change-end(%S)" (point) limit web-mode-change-beg web-mode-change-end)
+  (cond
+   (web-mode-fontification-off
+    nil)
+   (t
+    (web-mode-with-silent-modifications
+      (save-excursion
+        (save-restriction
+          (save-match-data
+            (let ((beg (point))
+                  (buffer-undo-list t)
+                  (end limit)
+                  (inhibit-point-motion-hooks t)
+                  (inhibit-quit t))
+              (remove-list-of-text-properties beg end '(font-lock-face face))
+              (cond
+               ((and (get-text-property beg 'block-side)
+                     (not (get-text-property beg 'block-beg)))
+                (web-mode-fontify-block beg end))
+               ((or (member web-mode-content-type web-mode-part-content-types)
+                    (get-text-property beg 'part-side))
+                (web-mode-fontify-part beg end)
+                (web-mode-block-foreach beg end 'web-mode-fontify-block))
+               ((string= web-mode-engine "none")
+                (web-mode-fontify-tags beg end)
+                (web-mode-part-foreach beg end 'web-mode-fontify-part))
+               (t
+                (web-mode-fontify-tags beg end)
+                (web-mode-part-foreach beg end 'web-mode-fontify-part)
+                (web-mode-block-foreach beg end 'web-mode-fontify-block))
+               ) ;cond
+              (when web-mode-enable-element-content-fontification
+                (web-mode-fontify-elements beg end))
+              (when web-mode-enable-whitespace-fontification
+                (web-mode-fontify-whitespaces beg end))
+              ) ;let
+            ))))
+    nil) ;t
+   ))
+
+(defun web-mode-buffer-fontify ()
+  (interactive)
+  (cond
+   ((and (fboundp 'font-lock-flush) global-font-lock-mode)
+    (font-lock-flush)
+    (font-lock-ensure))
+   (t  ;emacs 24
+    ;;(font-lock-fontify-buffer)
+    (and global-font-lock-mode
+         (font-lock-fontify-region (point-min) (point-max))))
+   ))
+
+(defun web-mode-unfontify-region (beg end)
+  ;;(message "unfontify: %S %S" beg end)
+  )
+
+(defun web-mode-fontify-region (beg end keywords)
+;;  (message "beg=%S end=%S keywords=%S" beg end (symbol-name keywords))
+  (save-excursion
+    (let ((font-lock-keywords keywords)
+          (font-lock-multiline nil)
+          (font-lock-keywords-case-fold-search
+           (member web-mode-engine '("archibus" "asp" "template-toolkit")))
+          (font-lock-keywords-only t)
+          (font-lock-extend-region-functions nil))
+      (when (and (listp font-lock-keywords) global-font-lock-mode)
+        (font-lock-fontify-region beg end)
+        )
+      )))
+
+(defun web-mode-fontify-tags (reg-beg reg-end &optional depth)
+  (let ((continue t))
+    (goto-char reg-beg)
+    (when (and (not (get-text-property (point) 'tag-beg))
+               (not (web-mode-tag-next)))
+      (setq continue nil))
+    (when (and continue (>= (point) reg-end))
+      (setq continue nil))
+    (while continue
+      (cond
+       (depth
+        (when (eq depth (get-text-property (point) 'jsx-depth))
+          (web-mode-fontify-tag))
+        )
+       (t
+        (web-mode-fontify-tag))
+       ) ;cond
+      (when (or (not (web-mode-tag-next))
+                (>= (point) reg-end))
+        (setq continue nil))
+      ) ;while
+    (when web-mode-enable-inlays
+      (when (null web-mode-inlay-regexp)
+        (setq web-mode-inlay-regexp (regexp-opt '("\\[" "\\(" "\\begin{align}"))))
+      (let (beg end expr)
+        (goto-char reg-beg)
+        (while (web-mode-dom-rsf web-mode-inlay-regexp reg-end)
+          (setq beg (match-beginning 0)
+                end nil
+                expr (substring (match-string-no-properties 0) 0 2))
+          (setq expr (cond
+                      ((string= expr "\\[") "\\]")
+                      ((string= expr "\\(") "\\)")
+                      (t "\\end{align}")))
+          (when (and (web-mode-dom-sf expr reg-end)
+                     (setq end (match-end 0))
+                     (not (text-property-any beg end 'tag-end t)))
+            (font-lock-append-text-property beg end 'font-lock-face 'web-mode-inlay-face)
+            ) ;when
+          ) ;while
+        ) ;let
+      ) ;when
+    (when web-mode-enable-html-entities-fontification
+      (let (beg end)
+        (goto-char reg-beg)
+        (while (web-mode-dom-rsf "&\\([#]?[[:alnum:]]\\{2,8\\}\\);" reg-end)
+          (setq beg (match-beginning 0)
+                end (match-end 0))
+          (when (not (text-property-any beg end 'tag-end t))
+            (font-lock-append-text-property beg end 'font-lock-face 'web-mode-html-entity-face)
+            ) ;when
+          ) ;while
+        ) ;let
+      ) ;when
+    ))
+
+(defun web-mode-fontify-tag (&optional beg end)
+  (unless beg (setq beg (point)))
+  (unless end (setq end (1+ (web-mode-tag-end-position beg))))
+  (let (name type face flags slash-beg slash-end bracket-end)
+    (setq flags (get-text-property beg 'tag-beg)
+          type (get-text-property beg 'tag-type)
+          name (get-text-property beg 'tag-name))
+    (setq bracket-end (> (logand flags 16) 0))
+    (cond
+     ((eq type 'comment)
+      (put-text-property beg end 'font-lock-face 'web-mode-comment-face)
+      (when (and web-mode-enable-comment-interpolation (> (- end beg) 5))
+        (web-mode-interpolate-comment beg end nil)))
+     ((eq type 'cdata)
+      (put-text-property beg end 'font-lock-face 'web-mode-doctype-face))
+     ((eq type 'doctype)
+      (put-text-property beg end 'font-lock-face 'web-mode-doctype-face))
+     ((eq type 'declaration)
+      (put-text-property beg end 'font-lock-face 'web-mode-doctype-face))
+     (name
+      (setq slash-beg (> (logand flags 4) 0)
+            slash-end (> (logand flags 8) 0)
+            bracket-end (> (logand flags 16) 0))
+      (setq face (cond
+                  ((not bracket-end)       'web-mode-html-tag-unclosed-face)
+                  ((and web-mode-enable-element-tag-fontification
+                        (setq face (cdr (assoc name web-mode-element-tag-faces))))
+                   face)
+                  ((> (logand flags 32) 0) 'web-mode-html-tag-namespaced-face)
+                  ((> (logand flags 2) 0)  'web-mode-html-tag-custom-face)
+                  (t                       'web-mode-html-tag-face)))
+      (put-text-property beg (+ beg (if slash-beg 2 1))
+                         'font-lock-face 'web-mode-html-tag-bracket-face)
+      (unless (string= name "_fragment_")
+        (put-text-property (+ beg (if slash-beg 2 1))
+                           (+ beg (if slash-beg 2 1) (length name))
+                           'font-lock-face face))
+      (when (or slash-end bracket-end)
+        (put-text-property (- end (if slash-end 2 1)) end 'font-lock-face 'web-mode-html-tag-bracket-face)
+        ) ;when
+      (when (> (logand flags 1) 0)
+        ;;(message "%S>%S" beg end)
+        (web-mode-fontify-attrs beg end))
+      ) ;case name
+     ) ;cond
+    ))
+
+(defun web-mode-fontify-attrs (reg-beg reg-end)
+  (let ((continue t) (pos reg-beg) beg end flags offset face)
+    ;;(message "fontify-attrs %S>%S" reg-beg reg-end)
+    (while continue
+      (setq beg (web-mode-attribute-next-position pos reg-end))
+      (cond
+       ((or (null beg) (>= beg reg-end))
+        (setq continue nil))
+       (t
+        (setq flags (or (get-text-property beg 'tag-attr-beg) 0))
+        (setq face (cond
+                    ((= (logand flags 1) 1) 'web-mode-html-attr-custom-face)
+                    ((= (logand flags 2) 2) 'web-mode-html-attr-engine-face)
+                    ((= (logand flags 4) 4) nil)
+                    (t                      'web-mode-html-attr-name-face)))
+        ;;(setq end (if (get-text-property beg 'tag-attr-end) beg (web-mode-attribute-end-position beg)))
+        (setq end (web-mode-attribute-end-position beg))
+        ;;(message "beg=%S end=%S" beg end)
+        (cond
+         ((or (null end) (>= end reg-end))
+          (setq continue nil))
+         (t
+          (setq offset (get-text-property end 'tag-attr-end))
+          (if (= offset 0)
+              (put-text-property beg (1+ end) 'font-lock-face face)
+            (put-text-property beg (+ beg offset) 'font-lock-face face)
+            (put-text-property (+ beg offset) (+ beg offset 1)
+                               'font-lock-face
+                               'web-mode-html-attr-equal-face)
+            (when (not (get-text-property (+ beg offset 1) 'jsx-beg))
+              (put-text-property (+ beg offset 1) (1+ end)
+                                 'font-lock-face
+                                 'web-mode-html-attr-value-face)
+              )
+            ) ;if offset
+          (setq pos (1+ end))
+          ) ;t
+         ) ;cond
+        ) ;t
+       );cond
+      ) ;while
+    ))
+
+(defun web-mode-fontify-block (reg-beg reg-end)
+  (let (sub1 sub2 sub3 continue char keywords token-type face beg end (buffer (current-buffer)))
+    ;;(message "reg-beg=%S reg-end=%S" reg-beg reg-end)
+
+    ;; NOTE: required for blocks inside tag attrs
+    (remove-list-of-text-properties reg-beg reg-end '(font-lock-face))
+
+    (goto-char reg-beg)
+
+    (when (null web-mode-engine-font-lock-keywords)
+      (setq sub1 (buffer-substring-no-properties
+                  reg-beg (+ reg-beg 1))
+            sub2 (buffer-substring-no-properties
+                  reg-beg (+ reg-beg 2))
+            sub3 (buffer-substring-no-properties
+                  reg-beg (+ reg-beg (if (>= (point-max) (+ reg-beg 3)) 3 2))))
+      )
+
+    (cond
+
+     ((and (get-text-property reg-beg 'block-beg)
+           (eq (get-text-property reg-beg 'block-token) 'comment))
+      (put-text-property reg-beg reg-end 'font-lock-face 'web-mode-comment-face)
+      ) ;comment block
+
+     (web-mode-engine-font-lock-keywords
+      (setq keywords web-mode-engine-font-lock-keywords)
+      )
+
+     ((string= web-mode-engine "django")
+      (cond
+       ((string= sub2 "{{")
+        (setq keywords web-mode-django-expr-font-lock-keywords))
+       ((string= sub2 "{%")
+        (setq keywords web-mode-django-code-font-lock-keywords))
+       )) ;django
+
+     ((string= web-mode-engine "mako")
+      (cond
+       ((member sub3 '("<% " "<%\n" "<%!"))
+        (setq keywords web-mode-mako-block-font-lock-keywords))
+       ((eq (aref sub2 0) ?\%)
+        (setq keywords web-mode-mako-block-font-lock-keywords))
+       ((member sub2 '("<%" " %S face(%S)" beg end face)
+                    (remove-list-of-text-properties beg end '(face))
+                    (put-text-property beg end 'font-lock-face face)
+                    )
+                (setq continue nil
+                      end nil)
+                ) ;if end
+              ) ;progn beg
+          (setq continue nil
+                end nil)
+          ) ;if beg
+        (when (and beg end)
+          (save-match-data
+            (when (and web-mode-enable-heredoc-fontification
+                       (eq char ?\<)
+                       (> (- end beg) 8)
+                       ;;(progn (message "%S" (buffer-substring-no-properties beg end)) t)
+                       (string-match-p "JS\\|JAVASCRIPT\\|HTM\\|CSS" (buffer-substring-no-properties beg end)))
+              (setq keywords
+                    (cond
+                     ((string-match-p "H" (buffer-substring-no-properties beg (+ beg 8)))
+                      web-mode-html-font-lock-keywords)
+                     (t
+                      web-mode-javascript-font-lock-keywords)
+                     ))
+              (web-mode-fontify-region beg end keywords)
+            ))
+;;          (message "%S %c %S beg=%S end=%S" web-mode-enable-string-interpolation char web-mode-engine beg end)
+          (when (and web-mode-enable-string-interpolation
+                     (member char '(?\" ?\<))
+                     (member web-mode-engine '("php" "erb"))
+                     (> (- end beg) 4))
+            (web-mode-interpolate-block-string beg end)
+            ) ;when
+          (when (and web-mode-enable-comment-interpolation
+                     (eq token-type 'comment)
+                     (> (- end beg) 3))
+            (web-mode-interpolate-comment beg end t)
+            ) ;when
+          (when (and web-mode-enable-comment-annotation
+                     (eq token-type 'comment)
+                     (> (- end beg) 3))
+            (web-mode-annotate-comment beg end)
+            ) ;when
+          (when (and web-mode-enable-sql-detection
+                     (eq token-type 'string)
+                     (> (- end beg) 6)
+                     ;;(eq char ?\<)
+                     ;;(web-mode-looking-at-p (concat "[ \n]*" web-mode-sql-queries) (1+ beg))
+                     (web-mode-looking-at-p (concat "\\(.\\|<<<[[:alnum:]]+\\)[ \n]*" web-mode-sql-queries) beg)
+                     )
+            (web-mode-interpolate-sql-string beg end)
+            ) ;when
+          ) ;when beg end
+        ) ;while continue
+      ) ;when keywords
+
+    ;;(when (and (member web-mode-engine '("jsp" "mako"))
+    (when (and (member web-mode-engine '("mako"))
+               (> (- reg-end reg-beg) 12)
+               (eq ?\< (char-after reg-beg)))
+      (web-mode-interpolate-block-tag reg-beg reg-end))
+
+    (when web-mode-enable-block-face
+;;      (message "block-face %S %S" reg-beg reg-end)
+      (font-lock-append-text-property reg-beg reg-end 'face 'web-mode-block-face))
+
+    ))
+
+(defun web-mode-fontify-part (reg-beg reg-end &optional depth)
+  (save-excursion
+    (let (start continue token-type face pos beg end string-face comment-face content-type)
+      ;;(message "fontify-part: reg-beg(%S) reg-end(%S)" reg-beg reg-end)
+      (if (member web-mode-content-type web-mode-part-content-types)
+          (setq content-type web-mode-content-type)
+        (setq content-type (symbol-name (get-text-property reg-beg 'part-side))))
+      ;;(message "content-type=%S" content-type)
+      (unless depth
+        (when (string= content-type "jsx") (setq depth 0))
+        )
+      (setq string-face 'web-mode-part-string-face
+            comment-face 'web-mode-part-comment-face)
+      (cond
+       ((member content-type '("javascript" "jsx"))
+        (setq string-face 'web-mode-javascript-string-face
+              comment-face 'web-mode-javascript-comment-face)
+        (web-mode-fontify-region reg-beg reg-end web-mode-javascript-font-lock-keywords))
+       ((string= content-type "json")
+        (setq string-face 'web-mode-json-string-face
+              comment-face 'web-mode-json-comment-face)
+        (web-mode-fontify-region reg-beg reg-end web-mode-javascript-font-lock-keywords))
+       ((string= content-type "css")
+        (setq string-face 'web-mode-css-string-face
+              comment-face 'web-mode-css-comment-face)
+        (web-mode-fontify-css-rules reg-beg reg-end))
+       ((string= content-type "sql")
+        (web-mode-fontify-region reg-beg reg-end web-mode-sql-font-lock-keywords))
+       ((string= content-type "stylus")
+        (web-mode-fontify-region reg-beg reg-end web-mode-stylus-font-lock-keywords))
+       ((string= content-type "sass")
+        (web-mode-fontify-region reg-beg reg-end web-mode-sass-font-lock-keywords))
+       ((string= content-type "pug")
+        (web-mode-fontify-region reg-beg reg-end web-mode-pug-font-lock-keywords))
+       ((string= content-type "markdown")
+        (web-mode-fontify-region reg-beg reg-end web-mode-markdown-font-lock-keywords))
+       ((string= content-type "ruby")
+        (web-mode-fontify-region reg-beg reg-end web-mode-erb-font-lock-keywords))
+       ((string= content-type "typescript")
+        (web-mode-fontify-region reg-beg reg-end web-mode-javascript-font-lock-keywords))
+       ) ;cond
+
+      (goto-char reg-beg)
+
+      ;;(when (string= content-type "jsx") (web-mode-fontify-tags reg-beg reg-end))
+      ;;(setq continue (and pos (< pos reg-end)))
+      (setq continue t
+            pos reg-beg)
+      (while continue
+        (if (get-text-property pos 'part-token)
+            (setq beg pos)
+          (setq beg (next-single-property-change pos 'part-token)))
+        (cond
+         ((or (null beg) (>= beg reg-end))
+          (setq continue nil
+                end nil))
+         ((and (eq depth 0) (get-text-property beg 'jsx-depth))
+          (setq pos (or (next-single-property-change beg 'jsx-depth) (point-max))))
+         (t
+          ;;(message "%c" (char-after beg))
+          (setq token-type (get-text-property beg 'part-token))
+          (setq face (cond
+                      ((eq token-type 'string)  string-face)
+                      ((eq token-type 'comment) comment-face)
+                      ((eq token-type 'context) 'web-mode-json-context-face)
+                      ((eq token-type 'key)     'web-mode-json-key-face)
+                      (t                        nil)))
+          (setq end (or (next-single-property-change beg 'part-token) (point-max))
+                pos end)
+          (cond
+           ((or (null end) (> end reg-end))
+            (setq continue nil
+                  end nil))
+           (t
+            (when face
+              (remove-list-of-text-properties beg end '(face))
+              (put-text-property beg end 'font-lock-face face))
+            (cond
+             ((< (- end beg) 6)
+              )
+             ((eq token-type 'string)
+              (cond
+               ((and (eq (char-after beg) ?\`)
+                     web-mode-enable-literal-interpolation
+                     (member content-type '("javascript" "jsx")))
+                (web-mode-interpolate-javascript-literal beg end)
+                )
+               ((and (eq (char-after beg) ?\")
+                     web-mode-enable-string-interpolation
+                     (member content-type '("javascript" "jsx")))
+                (web-mode-interpolate-javascript-string beg end))
+               ) ;cond
+              ) ;case string
+             ((eq token-type 'comment)
+              (when web-mode-enable-comment-interpolation
+                (web-mode-interpolate-comment beg end t))
+              (when web-mode-enable-comment-annotation
+                (web-mode-annotate-comment beg end))
+              )
+             ) ;cond
+            ) ;t
+           ) ;cond
+          ) ;t
+         ) ;cond
+        ) ;while
+
+      (when (and (string= web-mode-content-type "html") web-mode-enable-part-face)
+        (font-lock-append-text-property reg-beg reg-end 'face
+                                        (cond
+                                         ((string= content-type "javascript")
+                                          'web-mode-script-face)
+                                         ((string= content-type "css")
+                                          'web-mode-style-face)
+                                         (t
+                                          'web-mode-part-face)))
+        )
+
+      (when (and web-mode-enable-css-colorization (string= content-type "stylus"))
+        (goto-char reg-beg)
+        (while (and (re-search-forward "#[0-9a-fA-F]\\{6\\}\\|#[0-9a-fA-F]\\{3\\}\\|rgba?([ ]*\\([[:digit:]]\\{1,3\\}\\)[ ]*,[ ]*\\([[:digit:]]\\{1,3\\}\\)[ ]*,[ ]*\\([[:digit:]]\\{1,3\\}\\)\\(.*?\\))" end t)
+                    (<= (point) reg-end))
+          (web-mode-colorize (match-beginning 0) (match-end 0))
+          )
+        )
+
+      (when (and (eq depth 0) (string= content-type "jsx"))
+        (let (pair elt-beg elt-end exp-beg exp-end exp-depth)
+          (goto-char reg-beg)
+          (while (setq pair (web-mode-jsx-element-next reg-end))
+            ;;(message "elt-pair=%S" pair)
+            (setq elt-beg (car pair)
+                  elt-end (cdr pair))
+            (remove-list-of-text-properties elt-beg (1+ elt-end) '(face))
+            (web-mode-fontify-tags elt-beg elt-end 1)
+            (goto-char elt-beg)
+            (while (setq pair (web-mode-jsx-expression-next elt-end))
+              ;;(message "exp-pair=%S elt-end=%S" pair elt-end)
+              (setq exp-beg (car pair)
+                    exp-end (cdr pair))
+              (when (eq (char-after exp-beg) ?\{)
+                ;;(message "%S : %c %c" exp-beg (char-after (+ exp-beg 1)) (char-after (+ exp-beg 2)))
+                (cond
+                 ;;((and (eq (char-after (+ exp-beg 1)) ?\/) (eq (char-after (+ exp-beg 2)) ?\*))
+                 ;; (put-text-property exp-beg (1+ exp-end) 'font-lock-face 'web-mode-part-comment-face)
+                 ;; )
+                 (t
+                  (setq exp-depth (get-text-property exp-beg 'jsx-depth))
+                  (remove-list-of-text-properties exp-beg exp-end '(font-lock-face))
+                  (put-text-property exp-beg (1+ exp-beg) 'font-lock-face 'web-mode-block-delimiter-face)
+                  (when (and (eq (get-text-property exp-beg 'tag-attr-beg) 4) (web-mode-looking-at-p "\.\.\." (1+ exp-beg)))
+                  (put-text-property exp-beg (+ exp-beg 4) 'font-lock-face 'web-mode-block-delimiter-face))
+                  (put-text-property exp-end (1+ exp-end) 'font-lock-face 'web-mode-block-delimiter-face)
+                  (web-mode-fontify-tags (1+ exp-beg) exp-end (1+ exp-depth))
+                  (web-mode-fontify-part (1+ exp-beg) exp-end exp-depth)
+                  (web-mode-fontify-region (1+ exp-beg) exp-end web-mode-javascript-font-lock-keywords)
+                  ) ;t
+                 ) ;cond
+                ) ;when
+              (goto-char (1+ exp-beg))
+              ) ;while exp
+
+            (when (and elt-beg web-mode-jsx-depth-faces)
+              (let (depth-beg depth-end jsx-face)
+                (goto-char elt-beg)
+                (while (setq pair (web-mode-jsx-depth-next reg-end))
+                  ;;(message "depth-pair=%S" pair)
+                  (setq depth-beg (car pair)
+                        depth-end (cdr pair)
+                        depth (get-text-property depth-beg 'jsx-depth)
+                        jsx-face (elt web-mode-jsx-depth-faces (1- depth)))
+                  ;;(message "%S" jsx-face)
+                  (font-lock-prepend-text-property depth-beg (1+ depth-end) 'face jsx-face)
+                  (goto-char (+ depth-beg 2))
+                  )
+                ) ;let
+              )
+
+            (goto-char (1+ elt-end))
+            ) ;while elt
+          ) ;let
+        ) ;when
+
+      ) ;let
+    ) ;save-excursion
+  )
+
+(defun web-mode-fontify-css-rules (part-beg part-end)
+  (save-excursion
+    (goto-char part-beg)
+    (let (rule (continue t) (i 0) (at-rule nil) (var-rule nil))
+      (while continue
+        (setq rule (web-mode-css-rule-next part-end))
+        ;;(message "rule=%S" rule)
+        (cond
+         ((> (setq i (1+ i)) 1000)
+          (message "fontify-css-rules ** too much rules **")
+          (setq continue nil))
+         ((null rule)
+          (setq continue nil))
+         ((and (setq at-rule (plist-get rule :at-rule))
+               (not (member at-rule '("charset" "font-face" "import" "viewport")))
+               (plist-get rule :dec-end))
+          (web-mode-fontify-css-rule (plist-get rule :sel-beg)
+                                     (plist-get rule :sel-end)
+                                     nil nil)
+          (web-mode-fontify-css-rules (plist-get rule :dec-beg)
+                                      (plist-get rule :dec-end)))
+         (t
+          (web-mode-fontify-css-rule (plist-get rule :sel-beg)
+                                     (plist-get rule :sel-end)
+                                     (plist-get rule :dec-beg)
+                                     (plist-get rule :dec-end)))
+         ) ;cond
+        ) ;while
+      ) ;let
+    ))
+
+(defun web-mode-fontify-css-rule (sel-beg sel-end dec-beg dec-end)
+  (save-excursion
+    ;;(let ((end sel-end))
+    ;;(message "sel-beg=%S sel-end=%S dec-beg=%S dec-end=%S" sel-beg sel-end dec-beg dec-end)
+    (web-mode-fontify-region sel-beg sel-end web-mode-selector-font-lock-keywords)
+    (when (and dec-beg dec-end)
+      ;;(setq end dec-end)
+      (web-mode-fontify-region dec-beg dec-end web-mode-declaration-font-lock-keywords)
+      ) ;when
+    (when (and dec-beg dec-end)
+      (goto-char dec-beg)
+      (while (and web-mode-enable-css-colorization
+                  (re-search-forward "#[0-9a-fA-F]\\{6\\}\\|#[0-9a-fA-F]\\{3\\}\\|rgba?([ ]*\\([[:digit:]]\\{1,3\\}\\)[ ]*,[ ]*\\([[:digit:]]\\{1,3\\}\\)[ ]*,[ ]*\\([[:digit:]]\\{1,3\\}\\)\\(.*?\\))" dec-end t)
+                  ;;(progn (message "%S %S" end (point)) t)
+                  (<= (point) dec-end))
+        (web-mode-colorize (match-beginning 0) (match-end 0))
+        ) ;while
+      ) ;when
+    ;;) ;let
+    ))
+
+(defun web-mode-colorize-foreground (color)
+  (let* ((values (x-color-values color))
+         (r (car values))
+         (g (cadr values))
+         (b (car (cdr (cdr values)))))
+    (if (> 128.0 (floor (+ (* .3 r) (* .59 g) (* .11 b)) 256))
+        "white" "black")))
+
+(defun web-mode-colorize (beg end)
+  (let (str plist len)
+    (setq str (buffer-substring-no-properties beg end))
+    (setq len (length str))
+    (cond
+     ((string= (substring str 0 1) "#")
+      (setq plist (list :background str
+                        :foreground (web-mode-colorize-foreground str)))
+      (put-text-property beg end 'face plist))
+     ((or (string= (substring str 0 4) "rgb(") (string= (substring str 0 5) "rgba("))
+      (setq str (format "#%02X%02X%02X"
+                        (string-to-number (match-string-no-properties 1))
+                        (string-to-number (match-string-no-properties 2))
+                        (string-to-number (match-string-no-properties 3))))
+      (setq plist (list :background str
+                        :foreground (web-mode-colorize-foreground str)))
+      (put-text-property beg end 'face plist))
+     ) ;cond
+    ))
+
+(defun web-mode-interpolate-block-tag (beg end)
+  (save-excursion
+    (goto-char (+ 4 beg))
+    (setq end (1- end))
+    (while (re-search-forward "${.*?}" end t)
+      (remove-list-of-text-properties (match-beginning 0) (match-end 0) '(face))
+      (web-mode-fontify-region (match-beginning 0) (match-end 0)
+                               web-mode-uel-font-lock-keywords))
+    ))
+
+(defun web-mode-interpolate-javascript-string (beg end)
+  (save-excursion
+    (goto-char (1+ beg))
+    (setq end (1- end))
+    (while (re-search-forward "${.*?}" end t)
+      (put-text-property (match-beginning 0) (match-end 0)
+                         'font-lock-face
+                         'web-mode-variable-name-face)
+      )
+    ))
+
+(defun web-mode-interpolate-javascript-literal (beg end)
+  (save-excursion
+    (goto-char (1+ beg))
+    (setq end (1- end))
+    (while (re-search-forward "${.*?}" end t)
+      (put-text-property (match-beginning 0) (match-end 0)
+                           'font-lock-face
+                           'web-mode-variable-name-face)
+      )
+    (cond
+     ((web-mode-looking-back "\\(css\\|styled[[:alnum:].]+\\)" beg)
+      (goto-char (1+ beg))
+      (while (re-search-forward ".*?:" end t)
+        (put-text-property (match-beginning 0) (match-end 0)
+                           'font-lock-face
+                           'web-mode-interpolate-color1-face)
+        )
+      ) ;case css
+     ((web-mode-looking-back "\\(template\\|html\\)" beg)
+      (goto-char (1+ beg))
+      (while (re-search-forward web-mode-tag-regexp end t)
+        (put-text-property (match-beginning 1) (match-end 1)
+                           'font-lock-face
+                           'web-mode-interpolate-color1-face)
+        )
+      (goto-char (1+ beg))
+      (while (re-search-forward "\\| [[:alnum:]]+=" end t)
+        (cond
+         ((member (char-after (match-beginning 0)) '(?\< ?\/ ?\>))
+          (put-text-property (match-beginning 0) (match-end 0)
+                             'font-lock-face
+                             'web-mode-interpolate-color2-face)
+          )
+         (t
+          (put-text-property (1+ (match-beginning 0)) (1- (match-end 0))
+                             'font-lock-face
+                             'web-mode-interpolate-color3-face)
+          ) ;t
+         ) ;cond
+        ) ;while
+      ) ;case html
+     ) ;cond type of literal
+    ))
+
+;; todo : parsing plus compliqué: {$obj->values[3]->name}
+(defun web-mode-interpolate-block-string (beg end)
+  (save-excursion
+    (goto-char (1+ beg))
+    (setq end (1- end))
+    (cond
+     ((string= web-mode-engine "php")
+      (while (re-search-forward "$[[:alnum:]_]+\\(->[[:alnum:]_]+\\)*\\|{[ ]*$.+?}" end t)
+;;        (message "%S > %S" (match-beginning 0) (match-end 0))
+        (remove-list-of-text-properties (match-beginning 0) (match-end 0) '(font-lock-face))
+        (web-mode-fontify-region (match-beginning 0) (match-end 0)
+                                 web-mode-php-var-interpolation-font-lock-keywords)
+        ))
+     ((string= web-mode-engine "erb")
+      (while (re-search-forward "#{.*?}" end t)
+        (remove-list-of-text-properties (match-beginning 0) (match-end 0) '(font-lock-face))
+        (put-text-property (match-beginning 0) (match-end 0)
+                           'font-lock-face 'web-mode-variable-name-face)
+        ))
+     ) ;cond
+    ))
+
+(defun web-mode-interpolate-comment (beg end block-side)
+  (save-excursion
+    (let ((regexp (concat "\\_<\\(" web-mode-comment-keywords "\\)\\_>")))
+      (goto-char beg)
+      (while (re-search-forward regexp end t)
+        (font-lock-prepend-text-property (match-beginning 1) (match-end 1)
+                                         'font-lock-face
+                                         'web-mode-comment-keyword-face)
+        ) ;while
+      )))
+
+(defun web-mode-annotate-comment (beg end)
+  (save-excursion
+    ;;(message "beg=%S end=%S" beg end)
+    (goto-char beg)
+    (when (looking-at-p "/\\*\\*")
+      (while (re-search-forward "\\(.+\\)" end t)
+        (font-lock-prepend-text-property (match-beginning 1) (match-end 1)
+                                         'font-lock-face
+                                         'web-mode-annotation-face))
+      (goto-char beg)
+      (while (re-search-forward "[ ]+\\({[^}]+}\\)" end t)
+        (font-lock-prepend-text-property (match-beginning 1) (match-end 1)
+                                         'font-lock-face
+                                         'web-mode-annotation-type-face))
+      (goto-char beg)
+      (while (re-search-forward "\\(@[[:alnum:]]+\\)" end t)
+        (font-lock-prepend-text-property (match-beginning 1) (match-end 1)
+                                         'font-lock-face
+                                         'web-mode-annotation-tag-face))
+      (goto-char beg)
+      (while (re-search-forward "}[[:blank:]]+\\([[:graph:]]+\\)" end t)
+        (font-lock-prepend-text-property (match-beginning 1) (match-end 1)
+                                         'font-lock-face
+                                         'web-mode-annotation-value-face))
+      (goto-char beg)
+      (while (re-search-forward "@see[[:blank:]]+\\([[:graph:]]+\\)" end t)
+        (font-lock-prepend-text-property (match-beginning 1) (match-end 1)
+                                         'font-lock-face
+                                         'web-mode-annotation-value-face))
+      (goto-char beg)
+      (while (re-search-forward "{\\(@\\(?:link\\|code\\)\\)\\s-+\\([^}\n]+\\)\\(#.+\\)?}" end t)
+        (font-lock-prepend-text-property (match-beginning 2) (match-end 2)
+                                         'font-lock-face
+                                         'web-mode-annotation-value-face))
+      (goto-char beg)
+      (while (re-search-forward "\\(\\)" end t)
+        (font-lock-prepend-text-property (match-beginning 1) (match-end 1)
+                                         'font-lock-face
+                                         'web-mode-annotation-html-face)
+        (font-lock-prepend-text-property (match-beginning 2) (match-end 2)
+                                         'font-lock-face
+                                         'web-mode-annotation-html-face)
+        (font-lock-prepend-text-property (match-beginning 3) (match-end 3)
+                                         'font-lock-face
+                                         'web-mode-annotation-html-face))
+      ) ;when
+    ))
+
+(defun web-mode-interpolate-sql-string (beg end)
+  (save-excursion
+    (let ((case-fold-search t)
+          (regexp (concat "\\_<\\(" web-mode-sql-keywords "\\)\\_>")))
+      (goto-char beg)
+      (while (re-search-forward regexp end t)
+        (font-lock-prepend-text-property (match-beginning 1) (match-end 1)
+                                         'font-lock-face
+                                         'web-mode-sql-keyword-face)
+        ) ;while
+      )))
+
+;;---- EFFECTS -----------------------------------------------------------------
+
+(defun web-mode-fill-paragraph (&optional justify)
+  (save-excursion
+    (let ((pos (point)) fill-coll
+          prop pair beg end delim-beg delim-end chunk fill-col)
+      (cond
+       ((or (eq (get-text-property pos 'part-token) 'comment)
+            (eq (get-text-property pos 'block-token) 'comment))
+        (setq prop
+              (if (get-text-property pos 'part-token) 'part-token 'block-token))
+        (setq pair (web-mode-property-boundaries prop pos))
+        (when (and pair (> (- (cdr pair) (car pair)) 6))
+          (setq fill-coll (if (< fill-column 10) 70 fill-column))
+          (setq beg (car pair)
+                end (cdr pair))
+          (goto-char beg)
+          (setq chunk (buffer-substring-no-properties beg (+ beg 2)))
+          (cond
+           ((string= chunk "//")
+            (setq delim-beg "//"
+                  delim-end "EOL"))
+           ((string= chunk "/*")
+            (setq delim-beg "/*"
+                  delim-end "*/"))
+           ((string= chunk "{#")
+            (setq delim-beg "{#"
+                  delim-end "#}"))
+           ((string= chunk ""))
+           )
+          )
+        ) ;comment - case
+       ((web-mode-is-content)
+        (setq pair (web-mode-content-boundaries pos))
+        (setq beg (car pair)
+              end (cdr pair))
+        )
+       ) ;cond
+      ;;(message "beg(%S) end(%S)" beg end)
+      (when (and beg end)
+        (fill-region beg end))
+      t)))
+
+(defun web-mode-engine-syntax-check ()
+  (interactive)
+  (let ((proc nil) (errors nil)
+        (file (concat temporary-file-directory "emacs-web-mode-tmp")))
+    (write-region (point-min) (point-max) file)
+    (cond
+     ;; ((null (buffer-file-name))
+     ;; )
+     ((string= web-mode-engine "php")
+      (setq proc (start-process "php-proc" nil "php" "-l" file))
+      (set-process-filter
+       proc
+       (lambda (proc output)
+         (cond
+          ((string-match-p "No syntax errors" output)
+           (message "No syntax errors")
+           )
+          (t
+           ;; (setq output (replace-regexp-in-string temporary-file-directory "" output))
+           ;; (message output)
+           (message "Syntax error")
+           (setq errors t))
+          ) ;cond
+         ;; (delete-file file)
+         ) ;lambda
+       )
+      ) ;php
+     (t
+      (message "no syntax checker found")
+      ) ;t
+     ) ;cond
+    errors))
+
+(defun web-mode-jshint ()
+  "Run JSHint on all the JavaScript parts."
+  (interactive)
+  (let (proc lines)
+    (when (buffer-file-name)
+      (setq proc (start-process
+                  "jshint-proc"
+                  nil
+                  (or (executable-find "jshint") "/usr/local/bin/jshint")
+                  "--extract=auto"
+                  (buffer-file-name)))
+      (setq web-mode-jshint-errors 0)
+      (set-process-filter proc
+                          (lambda (proc output)
+                            (let ((offset 0) overlay pos (old 0) msg)
+                              (remove-overlays (point-min) (point-max) 'font-lock-face 'web-mode-error-face)
+                              (while (string-match
+                                      "line \\([[:digit:]]+\\), col \\([[:digit:]]+\\), \\(.+\\)\\.$"
+                                      output offset)
+                                (setq web-mode-jshint-errors (1+ web-mode-jshint-errors))
+                                (setq offset (match-end 0))
+                                (setq pos (web-mode-coord-position
+                                           (match-string-no-properties 1 output)
+                                           (match-string-no-properties 2 output)))
+                                (when (get-text-property pos 'tag-beg)
+                                  (setq pos (1- pos)))
+                                (when (not (= pos old))
+                                  (setq old pos)
+                                  (setq overlay (make-overlay pos (1+ pos)))
+                                  (overlay-put overlay 'font-lock-face 'web-mode-error-face)
+                                  )
+                                (setq msg (or (overlay-get overlay 'help-echo)
+                                               (concat "line="
+                                                       (match-string-no-properties 1 output)
+                                                       " column="
+                                                       (match-string-no-properties 2 output)
+                                                       )))
+                                (overlay-put overlay 'help-echo
+                                             (concat msg " ## " (match-string-no-properties 3 output)))
+                                ) ;while
+                              ))
+                          )
+      ) ;when
+    ))
+
+(defun web-mode-dom-errors-show ()
+  "Show unclosed tags."
+  (interactive)
+  (let (beg end tag pos l n tags i cont cell overlay overlays first
+            (ori (point))
+            (errors 0)
+            (continue t)
+        )
+    (setq overlays (overlays-in (point-min) (point-max)))
+    (when overlays
+      (dolist (overlay overlays)
+        (when (eq (overlay-get overlay 'face) 'web-mode-warning-face)
+          (delete-overlay overlay)
+          )
+        )
+      )
+    (goto-char (point-min))
+    (when (not (or (get-text-property (point) 'tag-beg)
+                   (web-mode-tag-next)))
+      (setq continue nil))
+    (while continue
+      (setq pos (point))
+      (setq tag (get-text-property pos 'tag-name))
+      (cond
+       ((eq (get-text-property (point) 'tag-type) 'start)
+        (setq tags (add-to-list 'tags (list tag pos)))
+;;        (message "(%S) opening %S" pos tag)
+        )
+       ((eq (get-text-property (point) 'tag-type) 'end)
+        (setq i 0
+              l (length tags)
+              cont t)
+        (while (and (< i l) cont)
+          (setq cell (nth i tags))
+;;          (message "cell=%S" cell)
+          (setq i (1+ i))
+          (cond
+           ((string= tag (nth 0 cell))
+            (setq cont nil)
+            )
+           (t
+            (setq errors (1+ errors))
+            (setq beg (nth 1 cell))
+            (setq end (web-mode-tag-end-position beg))
+            (unless first
+              (setq first beg))
+            (setq overlay (make-overlay beg (1+ end)))
+            (overlay-put overlay 'font-lock-face 'web-mode-warning-face)
+;;            (message "invalid <%S> at %S" (nth 0 cell) (nth 1 cell))
+            )
+           ) ;cond
+          ) ;while
+
+        (dotimes (i i)
+          (setq tags (cdr tags)))
+
+        )
+       ) ;cond
+      (when (not (web-mode-tag-next))
+        (setq continue nil))
+      ) ;while
+    (message "%S error(s) detected" errors)
+    (if (< errors 1)
+        (goto-char ori)
+      (goto-char first)
+      (recenter))
+    ;;    (message "%S" tags)
+    ))
+
+(defun web-mode-fontify-elements (beg end)
+  (save-excursion
+    (goto-char beg)
+    (let ((continue (or (get-text-property (point) 'tag-beg) (web-mode-tag-next)))
+          (i 0) (ctx nil) (face nil))
+      (while continue
+        (cond
+         ((> (setq i (1+ i)) 1000)
+          (message "fontify-elements ** too much tags **")
+          (setq continue nil))
+         ((> (point) end)
+          (setq continue nil))
+         ((not (get-text-property (point) 'tag-beg))
+          (setq continue nil))
+         ((eq (get-text-property (point) 'tag-type) 'start)
+          (when (and (setq ctx (web-mode-element-boundaries (point)))
+                     (<= (car (cdr ctx)) end)
+                     (setq face (cdr (assoc (get-text-property (point) 'tag-name) web-mode-element-content-faces))))
+            (font-lock-prepend-text-property (1+ (cdr (car ctx))) (car (cdr ctx))
+                                             'font-lock-face face))
+          )
+         ) ;cond
+        (when (not (web-mode-tag-next))
+          (setq continue nil))
+        ) ;while
+      )))
+
+(defun web-mode-enable (feature)
+  "Enable one feature."
+  (interactive
+   (list (completing-read
+          "Feature: "
+          (let (features)
+            (dolist (elt web-mode-features)
+              (setq features (append features (list (car elt)))))
+            features))))
+  (when (and (or (not feature) (< (length feature) 1)) web-mode-last-enabled-feature)
+    (setq feature web-mode-last-enabled-feature))
+  (when feature
+    (setq web-mode-last-enabled-feature feature)
+    (setq feature (cdr (assoc feature web-mode-features)))
+    (cond
+     ((eq feature 'web-mode-enable-current-column-highlight)
+      (web-mode-column-show))
+     ((eq feature 'web-mode-enable-current-element-highlight)
+      (when (not web-mode-enable-current-element-highlight)
+        (web-mode-toggle-current-element-highlight))
+      )
+     ((eq feature 'web-mode-enable-whitespace-fontification)
+      (web-mode-whitespaces-on))
+     (t
+      (set feature t)
+      (web-mode-buffer-fontify))
+     )
+    ) ;when
+  )
+
+(defun web-mode-disable (feature)
+  "Disable one feature."
+  (interactive
+   (list (completing-read
+          "Feature: "
+          (let (features)
+            (dolist (elt web-mode-features)
+              (setq features (append features (list (car elt)))))
+            features))))
+  (when (and (or (not feature) (< (length feature) 1)) web-mode-last-enabled-feature)
+    (setq feature web-mode-last-enabled-feature))
+  (when feature
+    (setq feature (cdr (assoc feature web-mode-features)))
+    (cond
+     ((eq feature 'web-mode-enable-current-column-highlight)
+      (web-mode-column-hide))
+     ((eq feature 'web-mode-enable-current-element-highlight)
+      (when web-mode-enable-current-element-highlight
+        (web-mode-toggle-current-element-highlight))
+      )
+     ((eq feature 'web-mode-enable-whitespace-fontification)
+      (web-mode-whitespaces-off))
+     (t
+      (set feature nil)
+      (web-mode-buffer-fontify))
+     )
+    ) ;when
+  )
+
+(defun web-mode-toggle-current-element-highlight ()
+  "Toggle highlighting of the current html element."
+  (interactive)
+  (if web-mode-enable-current-element-highlight
+      (progn
+        (web-mode-delete-tag-overlays)
+        (setq web-mode-enable-current-element-highlight nil))
+    (setq web-mode-enable-current-element-highlight t)
+    ))
+
+(defun web-mode-make-tag-overlays ()
+  (unless web-mode-overlay-tag-start
+    (setq web-mode-overlay-tag-start (make-overlay 1 1)
+          web-mode-overlay-tag-end (make-overlay 1 1))
+    (overlay-put web-mode-overlay-tag-start
+                 'font-lock-face
+                 'web-mode-current-element-highlight-face)
+    (overlay-put web-mode-overlay-tag-end
+                 'font-lock-face
+                 'web-mode-current-element-highlight-face)))
+
+(defun web-mode-delete-tag-overlays ()
+  (when web-mode-overlay-tag-start
+    (delete-overlay web-mode-overlay-tag-start)
+    (delete-overlay web-mode-overlay-tag-end)))
+
+(defun web-mode-column-overlay-factory (index)
+  (let (overlay)
+    (when (null web-mode-column-overlays)
+      (dotimes (i 100)
+        (setq overlay (make-overlay 1 1))
+        (overlay-put overlay 'font-lock-face 'web-mode-current-column-highlight-face)
+        (setq web-mode-column-overlays (append web-mode-column-overlays (list overlay)))
+        )
+      ) ;when
+    (setq overlay (nth index web-mode-column-overlays))
+    (when (null overlay)
+      (setq overlay (make-overlay 1 1))
+      (overlay-put overlay 'font-lock-face 'web-mode-current-column-highlight-face)
+      (setq web-mode-column-overlays (append web-mode-column-overlays (list overlay)))
+      ) ;when
+    overlay))
+
+(defun web-mode-column-hide ()
+  (setq web-mode-enable-current-column-highlight nil)
+  (remove-overlays (point-min) (point-max)
+                   'font-lock-face
+                   'web-mode-current-column-highlight-face))
+
+(defun web-mode-column-show ()
+  (let ((index 0) overlay diff column line-to line-from)
+    (web-mode-column-hide)
+    (setq web-mode-enable-current-column-highlight t)
+    (save-excursion
+      (back-to-indentation)
+      (setq column (current-column)
+            line-to (web-mode-line-number))
+      (when (and (get-text-property (point) 'tag-beg)
+                 (member (get-text-property (point) 'tag-type) '(start end))
+                 (web-mode-tag-match)
+                 (setq line-from (web-mode-line-number))
+                 (not (= line-from line-to)))
+        (when (> line-from line-to)
+          (let (tmp)
+            (setq tmp line-from)
+            (setq line-from line-to)
+            (setq line-to tmp))
+          ) ;when
+        ;;(message "column(%S) line-from(%S) line-to(%S)" column line-from line-to)
+        (goto-char (point-min))
+        (when (> line-from 1)
+          (forward-line (1- line-from)))
+        (while (<= line-from line-to)
+          (setq overlay (web-mode-column-overlay-factory index))
+          (setq diff (- (line-end-position) (point)))
+          (cond
+           ((or (and (= column 0) (= diff 0))
+                (> column diff))
+            (end-of-line)
+            (move-overlay overlay (point) (point))
+            (overlay-put overlay
+                         'after-string
+                         (concat
+                          (if (> column diff) (make-string (- column diff) ?\s) "")
+                          (propertize " "
+                                      'font-lock-face
+                                      'web-mode-current-column-highlight-face)
+                          ) ;concat
+                         )
+            )
+           (t
+            (move-to-column column)
+            (overlay-put overlay 'after-string nil)
+            (move-overlay overlay (point) (1+ (point)))
+            )
+           ) ;cond
+          (setq line-from (1+ line-from))
+          (forward-line)
+          (setq index (1+ index))
+          ) ;while
+        ) ;when
+      ) ;save-excursion
+    ) ;let
+  )
+
+(defun web-mode-highlight-current-element ()
+  (let ((ctx (web-mode-element-boundaries)) len)
+    (cond
+     ((null ctx)
+      (web-mode-delete-tag-overlays))
+     ((eq (get-text-property (caar ctx) 'tag-type) 'void) ;; #1046
+      (web-mode-make-tag-overlays)
+      (setq len (length (get-text-property (caar ctx) 'tag-name)))
+      (move-overlay web-mode-overlay-tag-start (+ (caar ctx) 1) (+ (caar ctx) 1 len))
+      )
+     (t
+      (web-mode-make-tag-overlays)
+      (setq len (length (get-text-property (caar ctx) 'tag-name)))
+      (move-overlay web-mode-overlay-tag-start (+ (caar ctx) 1) (+ (caar ctx) 1 len))
+      (move-overlay web-mode-overlay-tag-end (+ (cadr ctx) 2) (+ (cadr ctx) 2 len))
+      ) ;t
+     ) ;cond
+    ))
+
+(defun web-mode-fontify-whitespaces (beg end)
+  (save-excursion
+    (goto-char beg)
+    (while (re-search-forward web-mode-whitespaces-regexp end t)
+      (add-text-properties (match-beginning 0) (match-end 0)
+                           '(face web-mode-whitespace-face))
+      ) ;while
+    ))
+
+(defun web-mode-whitespaces-show ()
+  "Toggle whitespaces."
+  (interactive)
+  (if web-mode-enable-whitespace-fontification
+      (web-mode-whitespaces-off)
+    (web-mode-whitespaces-on)))
+
+(defun web-mode-whitespaces-on ()
+  "Show whitespaces."
+  (interactive)
+  (when web-mode-display-table
+    (setq buffer-display-table web-mode-display-table))
+  (setq web-mode-enable-whitespace-fontification t))
+
+(defun web-mode-whitespaces-off ()
+  (setq buffer-display-table nil)
+  (setq web-mode-enable-whitespace-fontification nil))
+
+(defun web-mode-use-tabs ()
+  "Tweaks vars to be compatible with TAB indentation."
+  (let (offset)
+    (setq web-mode-block-padding 0)
+    (setq web-mode-script-padding 0)
+    (setq web-mode-style-padding 0)
+    (setq offset
+          (cond
+           ((and (boundp 'tab-width) tab-width) tab-width)
+           ((and (boundp 'standard-indent) standard-indent) standard-indent)
+           (t 4)))
+    ;;    (message "offset(%S)" offset)
+    (setq web-mode-attr-indent-offset offset)
+    (setq web-mode-code-indent-offset offset)
+    (setq web-mode-css-indent-offset offset)
+    (setq web-mode-markup-indent-offset offset)
+    (setq web-mode-sql-indent-offset offset)
+    (add-to-list 'web-mode-indentation-params '("lineup-args" . nil))
+    (add-to-list 'web-mode-indentation-params '("lineup-calls" . nil))
+    (add-to-list 'web-mode-indentation-params '("lineup-concats" . nil))
+    (add-to-list 'web-mode-indentation-params '("lineup-ternary" . nil))
+    ))
+
+(defun web-mode-element-children-fold-or-unfold (&optional pos)
+  "Fold/Unfold all the children of the current html element."
+  (interactive)
+  (unless pos (setq pos (point)))
+  (save-excursion
+    (dolist (child (reverse (web-mode-element-children pos)))
+      (goto-char child)
+      (web-mode-fold-or-unfold))
+    ))
+
+(defun web-mode-fold-or-unfold (&optional pos)
+  "Toggle folding on an html element or a control block."
+  (interactive)
+  (web-mode-scan)
+  (web-mode-with-silent-modifications
+   (save-excursion
+     (if pos (goto-char pos))
+     (let (beg-inside beg-outside end-inside end-outside overlay overlays regexp)
+       (when (looking-back "^[\t ]*" (point-min))
+         (back-to-indentation))
+       (setq overlays (overlays-at (point)))
+       (dolist (elt overlays)
+         (when (and (not overlay)
+                    (eq (overlay-get elt 'font-lock-face) 'web-mode-folded-face))
+           (setq overlay elt)))
+       (cond
+        ;; *** unfolding
+        (overlay
+         (setq beg-inside (overlay-start overlay)
+               end-inside (overlay-end overlay))
+         (remove-overlays beg-inside end-inside)
+         (put-text-property beg-inside end-inside 'invisible nil)
+         )
+        ;; *** block folding
+        ((and (get-text-property (point) 'block-side)
+              (cdr (web-mode-block-is-control (point))))
+         (setq beg-outside (web-mode-block-beginning-position (point)))
+         (setq beg-inside (1+ (web-mode-block-end-position (point))))
+         (when (web-mode-block-match)
+           (setq end-inside (point))
+           (setq end-outside (1+ (web-mode-block-end-position (point)))))
+         )
+        ;; *** html comment folding
+        ((eq (get-text-property (point) 'tag-type) 'comment)
+         (setq beg-outside (web-mode-tag-beginning-position))
+         (setq beg-inside (+ beg-outside 4))
+         (setq end-outside (web-mode-tag-end-position))
+         (setq end-inside (- end-outside 3))
+         )
+        ;; *** tag folding
+        ((or (member (get-text-property (point) 'tag-type) '(start end))
+             (web-mode-element-parent))
+         (when (not (web-mode-element-is-collapsed (point)))
+           (web-mode-tag-beginning)
+           (when (eq (get-text-property (point) 'tag-type) 'end)
+             (web-mode-tag-match))
+           (setq beg-outside (point))
+           (web-mode-tag-end)
+           (setq beg-inside (point))
+           (goto-char beg-outside)
+           (when (web-mode-tag-match)
+             (setq end-inside (point))
+             (web-mode-tag-end)
+             (setq end-outside (point)))
+           )
+         )
+        ) ;cond
+       (when (and beg-inside beg-outside end-inside end-outside)
+         (setq overlay (make-overlay beg-outside end-outside))
+         (overlay-put overlay 'font-lock-face 'web-mode-folded-face)
+         (put-text-property beg-inside end-inside 'invisible t))
+       ))))
+
+;;---- TRANSFORMATION ----------------------------------------------------------
+
+(defun web-mode-buffer-change-tag-case (&optional type)
+  "Change html tag case."
+  (interactive)
+  (save-excursion
+    (goto-char (point-min))
+    (let ((continue t) f)
+      (setq f (if (member type '("upper" "uppercase" "upper-case")) 'uppercase 'downcase))
+      (when (and (not (get-text-property (point) 'tag-beg))
+                 (not (web-mode-tag-next)))
+        (setq continue nil))
+      (while continue
+        (skip-chars-forward " and < in html content."
+  (interactive)
+  (save-excursion
+    (let (expr (min (point-min)) (max (point-max)))
+      (when mark-active
+        (setq min (region-beginning)
+              max (region-end))
+        (deactivate-mark))
+      (goto-char min)
+      (while (web-mode-content-rsf "[&<>]" max)
+        (replace-match (cdr (assq (char-before) web-mode-xml-chars)) t t))
+      )))
+
+(defun web-mode-dom-quotes-replace ()
+  "Replace dumb quotes."
+  (interactive)
+  (save-excursion
+    (let (expr (min (point-min)) (max (point-max)))
+      (when mark-active
+        (setq min (region-beginning)
+              max (region-end))
+        (deactivate-mark))
+      (goto-char min)
+      (setq expr (concat (car web-mode-smart-quotes) "\\2" (cdr web-mode-smart-quotes)))
+      (while (web-mode-content-rsf "\\(\"\\)\\(.\\{1,200\\}\\)\\(\"\\)" max)
+        (replace-match expr)
+        ) ;while
+      )))
+
+;;---- INDENTATION -------------------------------------------------------------
+
+;; todo : passer de règle en règle et mettre un \n à la fin
+(defun web-mode-css-indent ()
+  (save-excursion
+    (goto-char (point-min))
+    (let ((continue t) rule part-end)
+      (while continue
+        (cond
+         ((not (web-mode-part-next))
+          (setq continue nil))
+         ((eq (get-text-property (point) 'part-side) 'css)
+          (setq part-end (web-mode-part-end-position))
+          (while (setq rule (web-mode-css-rule-next part-end))
+            (when (not (looking-at-p "[[:space:]]*\\($\\|<\\)"))
+              (newline)
+              (indent-according-to-mode)
+              (setq part-end (web-mode-part-end-position)))
+            )
+          )
+         ) ;cond
+        )
+      )))
+
+(defun web-mode-buffer-indent ()
+  "Indent all buffer."
+  (interactive)
+  (let ((debug t) (ts (current-time)) (sub nil))
+    (indent-region (point-min) (point-max))
+    (when debug
+      (setq sub (time-subtract (current-time) ts))
+      (message "buffer-indent: time elapsed = %Ss %9Sµs" (nth 1 sub) (nth 2 sub)))
+    (delete-trailing-whitespace)))
+
+(defun web-mode-point-context (pos)
+  "POS should be at the beginning of the indentation."
+  (save-excursion
+    (let (curr-char curr-indentation curr-line
+          language
+          options
+          reg-beg reg-col
+          prev-char prev-indentation prev-line prev-pos
+          token
+          part-language
+          depth)
+
+      (setq reg-beg (point-min)
+            reg-col 0
+            token "live"
+            options ""
+            language ""
+            prev-line ""
+            prev-char 0
+            prev-pos nil)
+
+      (when (get-text-property pos 'part-side)
+        (setq part-language (symbol-name (get-text-property pos 'part-side))))
+
+      ;;(message "part-language=%S" part-language)
+
+      (cond
+
+       ((and (bobp) (member web-mode-content-type '("html" "xml")))
+        (setq language web-mode-content-type)
+        )
+
+       ((string= web-mode-content-type "css")
+        (setq language "css"
+              curr-indentation web-mode-css-indent-offset))
+
+       ((member web-mode-content-type '("javascript" "json" "typescript"))
+        (setq language web-mode-content-type
+              curr-indentation web-mode-code-indent-offset))
+
+       ((or (string= web-mode-content-type "jsx")
+            (and part-language (string= part-language "jsx")))
+        (setq language "jsx"
+              curr-indentation web-mode-code-indent-offset)
+        (cond
+         ((web-mode-jsx-is-html pos)
+          (setq curr-indentation web-mode-markup-indent-offset
+                options "is-html"))
+         ((and (setq depth (get-text-property pos 'jsx-depth)) (> depth 1))
+          (when (get-text-property pos 'jsx-beg)
+            (setq depth (1- depth)))
+          (setq reg-beg (web-mode-jsx-depth-beginning-position pos depth))
+          (setq reg-beg (1+ reg-beg))
+          ;;(message "%S" (point))
+          (save-excursion
+            (goto-char reg-beg)
+            ;;(message "pt=%S" reg-beg)
+            (cond
+             ((and (not (looking-at-p "[ ]*$"))
+                   (looking-back "^[[:space:]]*{" (point-min)))
+              (setq reg-col (+ (current-indentation) ;; #1027
+                               (cond
+                                ((looking-at "[ ]+") (1+ (length (match-string-no-properties 0))))
+                                (t 0))
+                               ))
+              )
+             ((looking-at-p "[ ]*\\[[ ]*$") ;; #0659
+              (setq reg-col (current-indentation))
+              )
+             ((and (looking-back "=[ ]*{" (point-min)) ;; #0739 #1022
+                   (not (looking-at-p "[[:space:]]*<")))
+              (setq reg-col (current-indentation))
+              )
+             ;;((and (looking-back "=[ ]*{" (point-min)) ;; #0739
+             ;;      (looking-at-p "{[ ]*"))
+             ;; (setq reg-col (current-indentation))
+             ;; )
+             ((get-text-property (1- (point)) 'tag-beg)
+              ;;(message "point=%S" (point))
+              (setq reg-col (current-indentation))
+              )
+             (t
+              (message "%S : %S %S" (point) (current-indentation) web-mode-code-indent-offset)
+              ;;(setq reg-col (+ (current-indentation) web-mode-code-indent-offset web-mode-jsx-expression-padding)))
+              (setq reg-col (+ (current-indentation) web-mode-code-indent-offset)))
+             )
+
+            ;;(message "%S %S %S" (point) (current-indentation) reg-col)
+            ) ;save-excursion
+          )
+         ((string= web-mode-content-type "jsx")
+          (setq reg-beg (point-min)))
+         (t
+          (setq reg-beg (or (web-mode-part-beginning-position pos) (point-min)))
+          (save-excursion
+            (goto-char reg-beg)
+            (search-backward "<" nil t)
+            (setq reg-col (current-column))
+            ) ;save-excursion
+          )
+         ) ;cond
+        ;;(message "jsx reg-beg=%S" reg-beg)
+        ) ;jsx
+
+       ((string= web-mode-content-type "php")
+        (setq language "php"
+              curr-indentation web-mode-code-indent-offset))
+
+       ((or (string= web-mode-content-type "xml"))
+        (setq language "xml"
+              curr-indentation web-mode-markup-indent-offset))
+
+       ;; TODO: est ce util ?
+       ((and (get-text-property pos 'tag-beg)
+             (get-text-property pos 'tag-name)
+             ;;(not (get-text-property pos 'part-side))
+             )
+        (setq language "html"
+              curr-indentation web-mode-markup-indent-offset))
+
+       ((and (get-text-property pos 'block-side)
+             (not (get-text-property pos 'block-beg)))
+
+        (setq reg-beg (or (web-mode-block-beginning-position pos) (point-min)))
+        (goto-char reg-beg)
+        (setq reg-col (current-column))
+        ;;(message "%S %S" reg-beg reg-col)
+        (setq language web-mode-engine)
+        (setq curr-indentation web-mode-code-indent-offset)
+
+        (cond
+         ((string= web-mode-engine "blade")
+          (save-excursion
+            (when (web-mode-rsf "{[{!]+[ ]*")
+              (setq reg-col (current-column))))
+          (setq reg-beg (+ reg-beg 2))
+          )
+         ((string= web-mode-engine "razor")
+          ;;(setq reg-beg (+ reg-beg 2))
+          ;;(setq reg-col (current-column))
+          )
+         ;; tests/demo.chtml
+         ((string= web-mode-engine "ctemplate")
+          (save-excursion
+            (when (web-mode-rsf "{{#?")
+              (setq reg-col (current-column))))
+          )
+         ((string= web-mode-engine "dust")
+          (save-excursion
+            (when (web-mode-rsf "{@")
+              (setq reg-col (current-column))))
+          )
+         ((string= web-mode-engine "svelte")
+          (save-excursion
+            (when (web-mode-rsf "{@")
+              (setq reg-col (current-column))))
+          )
+         ((string= web-mode-engine "template-toolkit")
+          (setq reg-beg (+ reg-beg 3)
+                reg-col (+ reg-col 3))
+          )
+         ((and (string= web-mode-engine "jsp")
+               (web-mode-looking-at "<%@" reg-beg))
+          (save-excursion
+            (goto-char reg-beg)
+            (looking-at "<%@[ ]*[[:alpha:]]+[ ]+\\| pos (point-min))
+                 (eq (get-text-property pos 'part-token) 'comment)
+                 (eq (get-text-property (1- pos) 'part-token) 'comment)
+                 (progn
+                   (setq reg-beg (previous-single-property-change pos 'part-token))
+                   t))
+            (and (> pos (point-min))
+                 (eq (get-text-property pos 'block-token) 'comment)
+                 (eq (get-text-property (1- pos) 'block-token) 'comment)
+                 (progn
+                   (setq reg-beg (previous-single-property-change pos 'block-token))
+                   t))
+            (and (> pos (point-min))
+                 (eq (get-text-property pos 'tag-type) 'comment)
+                 (not (get-text-property pos 'tag-beg))
+                 (progn
+                   (setq reg-beg (web-mode-tag-beginning-position pos))
+                   t))
+            )
+        (setq token "comment"))
+       ((or (and (> pos (point-min))
+                 (member (get-text-property pos 'part-token)
+                         '(string context key))
+                 (member (get-text-property (1- pos) 'part-token)
+                         '(string context key)))
+            (and (eq (get-text-property pos 'block-token) 'string)
+                 (eq (get-text-property (1- pos) 'block-token) 'string)))
+        (setq token "string"))
+       )
+
+      (goto-char pos)
+      (setq curr-line (web-mode-trim
+                       (buffer-substring-no-properties
+                        (line-beginning-position)
+                        (line-end-position))))
+      (setq curr-char (if (string= curr-line "") 0 (aref curr-line 0)))
+
+      (when (or (member language '("php" "blade" "javascript" "typescript" "jsx" "razor" "css"))
+                (and (member language '("html" "xml"))
+                     (not (eq ?\< curr-char))))
+        (let (prev)
+          (cond
+           ((member language '("html" "xml" "javascript" "jsx" "css"))
+            (when (setq prev (web-mode-part-previous-live-line reg-beg))
+              (setq prev-line (nth 0 prev)
+                    prev-indentation (nth 1 prev)
+                    prev-pos (nth 2 prev))
+              )
+            )
+           ((setq prev (web-mode-block-previous-live-line))
+            (setq prev-line (car prev)
+                  prev-indentation (cdr prev))
+            (setq prev-line (web-mode-clean-block-line prev-line)))
+           ) ;cond
+          ) ;let
+        (when (>= (length prev-line) 1)
+          (setq prev-char (aref prev-line (1- (length prev-line))))
+          (setq prev-line (substring-no-properties prev-line))
+          )
+        )
+
+      (cond
+       ((not (member web-mode-content-type '("html" "xml")))
+        )
+       ((member language '("javascript" "typescript" "jsx" "ruby"))
+        (setq reg-col (if web-mode-script-padding (+ reg-col web-mode-script-padding) 0)))
+       ((member language '("css" "sql" "markdown" "pug" "sass" "stylus"))
+        (setq reg-col (if web-mode-style-padding (+ reg-col web-mode-style-padding) 0)))
+       ((not (member language '("html" "xml")))
+        (setq reg-col
+              (cond
+               ((not web-mode-block-padding) reg-col)
+               ((eq web-mode-block-padding -1) 0)
+               (t (+ reg-col web-mode-block-padding))
+               ) ;cond
+              ) ;setq
+        )
+       )
+
+      (list :curr-char curr-char
+            :curr-indentation curr-indentation
+            :curr-line curr-line
+            :language language
+            :options options
+            :prev-char prev-char
+            :prev-indentation prev-indentation
+            :prev-line prev-line
+            :prev-pos prev-pos
+            :reg-beg reg-beg
+            :reg-col reg-col
+            :token token)
+      )))
+
+(defun web-mode-indent-line ()
+
+  (web-mode-scan)
+
+  (let ((offset nil)
+        (char nil)
+        (debug nil)
+        (inhibit-modification-hooks nil)
+        (adjust t))
+
+    (save-excursion
+      (back-to-indentation)
+      (setq char (char-after))
+      (let* ((pos (point))
+             (ctx (web-mode-point-context pos))
+             (curr-char (plist-get ctx :curr-char))
+             (curr-indentation (plist-get ctx :curr-indentation))
+             (curr-line (plist-get ctx :curr-line))
+             (language (plist-get ctx :language))
+             (prev-char (plist-get ctx :prev-char))
+             (prev-indentation (plist-get ctx :prev-indentation))
+             (prev-line (plist-get ctx :prev-line))
+             (prev-pos (plist-get ctx :prev-pos))
+             (reg-beg (plist-get ctx :reg-beg))
+             (reg-col (plist-get ctx :reg-col))
+             (token (plist-get ctx :token))
+             (options (plist-get ctx :options))
+             (chars (list curr-char prev-char))
+             (tmp nil)
+             (is-js (member language '("javascript" "jsx" "ejs"))))
+
+        (when (member language '("json" "typescript"))
+          (setq language "javascript"))
+
+        ;;(message "%S" language)
+        ;;(message "curr-char=[%c] prev-char=[%c]\n%S" curr-char prev-char ctx)
+        ;;(message "options=%S" ctx)
+
+        (cond
+
+         ((or (bobp) (= (line-number-at-pos pos) 1))
+          (when debug (message "I100(%S) first line" pos))
+          (setq offset 0))
+
+         ;; #1073
+         ((get-text-property pos 'invisible)
+          (when debug (message "I110(%S) invible" pos))
+          (setq offset nil))
+
+         ((string= token "string")
+          (when debug (message "I120(%S) string" pos))
+          (cond
+           ((web-mode-is-token-end pos)
+            (if (get-text-property pos 'block-side)
+                (web-mode-block-token-beginning)
+              (web-mode-part-token-beginning))
+            (setq offset (current-indentation))
+            )
+           ((and web-mode-enable-sql-detection
+                 (web-mode-block-token-starts-with (concat "[ \n]*" web-mode-sql-queries)))
+            (save-excursion
+              (let (col)
+                (web-mode-block-string-beginning)
+                (skip-chars-forward "[ \"'\n]")
+                (setq col (current-column))
+                (goto-char pos)
+                (if (looking-at-p "\\(SELECT\\|INSERT\\|DELETE\\|UPDATE\\|FROM\\|LEFT\\|JOIN\\|WHERE\\|GROUP BY\\|LIMIT\\|HAVING\\|\)\\)")
+                    (setq offset col)
+                  (setq offset (+ col web-mode-sql-indent-offset)))
+                )
+              ) ;save-excursion
+            )
+           ((and is-js
+                 (web-mode-is-ql-string pos "Relay\.QL"))
+            (setq offset (web-mode-relayql-indentation pos))
+            )
+           ((and is-js
+                 (web-mode-is-ql-string pos "gql"))
+            (setq offset (web-mode-relayql-indentation pos "gql"))
+            )
+           ((and is-js
+                 (web-mode-is-ql-string pos "graphql"))
+            (setq offset (web-mode-relayql-indentation pos "graphql"))
+            )
+           ((and is-js
+                 (web-mode-is-css-string pos))
+            (when debug (message "I127(%S) css string" pos))
+            (setq offset (web-mode-token-css-indentation pos))
+            )
+           ((and is-js
+                 (web-mode-is-html-string pos))
+            (when debug (message "I128(%S) html string" pos))
+            (setq offset (web-mode-token-html-indentation pos))
+            )
+           (t
+            (setq offset nil))
+           ) ;cond
+          ) ;case string
+
+         ((string= token "comment")
+          (when debug (message "I130(%S) comment" pos))
+          (if (eq (get-text-property pos 'tag-type) 'comment)
+              (web-mode-tag-beginning)
+            (goto-char (car
+                        (web-mode-property-boundaries
+                         (if (eq (get-text-property pos 'part-token) 'comment)
+                             'part-token
+                           'block-token)
+                         pos))))
+          (setq offset (current-column))
+          (cond
+           ((string= web-mode-engine "freemarker")
+            (setq offset (+ (current-indentation) 2)))
+           ((member (buffer-substring-no-properties (point) (+ (point) 2)) '("/*" "{*" "@*"))
+            (cond
+             ((eq ?\* curr-char)
+              (setq offset (+ offset 1)))
+             (t
+              (setq offset (+ offset 3)))
+             ) ;cond
+            )
+           ((string= (buffer-substring-no-properties (point) (+ (point) 4)) "" curr-line)
+              (setq offset offset))
+             ((string-match-p "^-" curr-line)
+              (setq offset (+ offset 3)))
+             (t
+              (setq offset (+ offset 5)))
+             ) ;cond
+            )
+           ((and (string= web-mode-engine "django") (looking-back "{% comment %}" (point-min)))
+            (setq offset (- offset 12)))
+           ((and (string= web-mode-engine "mako") (looking-back "<%doc%>" (point-min)))
+            (setq offset (- offset 6)))
+           ((and (string= web-mode-engine "mason") (looking-back "<%doc%>" (point-min)))
+            (setq offset (- offset 6)))
+           ) ;cond
+          ) ;case comment
+
+         ((and (string= web-mode-engine "mason")
+               (string-match-p "^%" curr-line))
+          (when debug (message "I140(%S) mason" pos))
+          (setq offset 0))
+
+         ((and (get-text-property pos 'block-beg)
+               (or (web-mode-block-is-close pos)
+                   (web-mode-block-is-inside pos)))
+          (when debug (message "I150(%S) block-match" pos))
+          (cond
+           ((not (web-mode-block-match))
+            )
+           ((and (string= web-mode-engine "closure")
+                 (string-match-p "{\\(case\\|default\\)" curr-line))
+            (setq offset (+ (current-indentation) web-mode-markup-indent-offset)))
+           (t
+            (setq offset (current-indentation))
+            (if (and (string= web-mode-engine "blade")
+                     (string-match-p "@break" curr-line))
+                (setq offset (+ (current-indentation) offset)))
+            )
+           ) ;cond
+          )
+
+         ((eq (get-text-property pos 'block-token) 'delimiter-end)
+          (when debug (message "I160(%S) block-beginning" pos))
+          (when (web-mode-block-beginning)
+            (setq reg-col (current-indentation))
+            (setq offset (current-column))))
+
+         ((or (and (get-text-property pos 'tag-beg)
+                   (eq (get-text-property pos 'tag-type) 'end))
+              (and (eq (get-text-property pos 'tag-type) 'comment)
+                   (string-match-p "" (point))
+              (web-mode-insert-text-at-pos "" (point))
+          (web-mode-insert-text-at-pos "")
+      (search-backward " -->")
+      ) ;case html
+     ) ;cond
+    ))
+
+(defun web-mode-comment (pos)
+  (let (ctx language col sel beg end tmp block-side single-line-block pos-after content)
+
+    (setq pos-after pos)
+
+    (setq block-side (get-text-property pos 'block-side))
+    (setq single-line-block (web-mode-is-single-line-block pos))
+
+    (cond
+
+     ((and block-side (string= web-mode-engine "erb"))
+      (web-mode-comment-erb-block pos)
+      )
+
+     ((and block-side (string= web-mode-engine "artanis"))
+      (web-mode-comment-artanis-block pos)
+      )
+
+     ((and single-line-block block-side
+           (intern-soft (concat "web-mode-comment-" web-mode-engine "-block")))
+        (funcall (intern (concat "web-mode-comment-" web-mode-engine "-block")) pos)
+        )
+
+     (t
+      (setq ctx (web-mode-point-context
+                 (if mark-active (region-beginning) (line-beginning-position))))
+      ;;(message "%S" ctx)
+      (setq language (plist-get ctx :language))
+      (setq col (current-column))
+      (cond
+       (mark-active
+        ;;(message "%S %S" (point) col)
+        )
+       ((and (member language '("html" "xml"))
+             (get-text-property (progn (back-to-indentation) (point)) 'tag-beg))
+        (web-mode-element-select))
+       (t
+        (end-of-line)
+        (set-mark (line-beginning-position)))
+       ) ;cond
+
+      (setq beg (region-beginning)
+            end (region-end))
+
+      (when (> (point) (mark))
+        (exchange-point-and-mark))
+
+      (if (and (eq (char-before end) ?\n)
+               (not (eq (char-after end) ?\n)))
+          (setq end (1- end)))
+
+      (setq sel (buffer-substring-no-properties beg end))
+
+      (cond
+
+       ((member language '("html" "xml"))
+        (cond
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "django"))
+          (setq content (concat "{# " sel " #}")))
+         ((and (= web-mode-comment-style 2) (member web-mode-engine '("ejs" "erb")))
+          (setq content (concat "<%# " sel " %>")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "artanis"))
+          (setq content (concat "<%; " sel " %>")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "aspx"))
+          (setq content (concat "<%-- " sel " --%>")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "smarty"))
+          (setq content (concat "{* " sel " *}")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "expressionengine"))
+          (setq content (concat "{!-- " sel " --}")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "xoops"))
+          (setq content (concat "<{* " sel " *}>")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "hero"))
+          (setq content (concat "<%# " sel " %>")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "blade"))
+          (setq content (concat "{{-- " sel " --}}")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "ctemplate"))
+          (setq content (concat "{{!-- " sel " --}}")))
+         ((and (= web-mode-comment-style 2) (string= web-mode-engine "razor"))
+          (setq content (concat "@* " sel " *@")))
+         (t
+          (setq content (concat ""))
+          (when (< (length sel) 1)
+            (search-backward " -->")
+            (setq pos-after nil))
+          ))
+        ) ;case html
+
+       ((member language '("php" "javascript" "typescript" "java" "jsx"))
+        (let (alt)
+          (setq alt (cdr (assoc language web-mode-comment-formats)))
+          ;;(message "language=%S alt=%S sel=%S col=%S" language alt sel col)
+          (cond
+           ((and alt (string= alt "//"))
+            (setq content (replace-regexp-in-string (concat "\n[ ]\\{" (number-to-string col) "\\}") "\n" sel))
+            (setq content (replace-regexp-in-string (concat "\n") "\n// " content))
+            (setq content (concat "// " content)))
+           ((get-text-property pos 'jsx-depth)
+            (setq content (concat "{/* " sel " */}")))
+           (web-mode-comment-prefixing
+            (setq content (replace-regexp-in-string (concat "\n[ ]\\{" (number-to-string col) "\\}") "\n* " sel))
+            (setq content (concat "/* " content " */")))
+           (t
+            (setq content (concat "/* " sel " */")))
+           ) ;cond
+          ) ;let
+        )
+
+       ((member language '("erb"))
+        (setq content (replace-regexp-in-string "^[ ]*" "#" sel)))
+
+       ((member language '("asp"))
+        (setq content (replace-regexp-in-string "^[ ]*" "''" sel)))
+
+       (t
+        (setq content (concat "/* " sel " */")))
+
+       ) ;cond
+
+      (when content
+        (delete-region beg end)
+        (deactivate-mark)
+        (let (beg end)
+          (setq beg (point-at-bol))
+          (insert content)
+          (setq end (point-at-eol))
+          (indent-region beg end)
+          )
+        ) ;when
+
+      ) ;t
+     ) ;cond
+
+    (when pos-after (goto-char pos-after))
+
+    ))
+
+(defun web-mode-comment-ejs-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "//" (+ beg 2))))
+
+(defun web-mode-comment-erb-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "#" (+ beg 2))))
+
+(defun web-mode-comment-artanis-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos ";" (+ beg 2))))
+
+(defun web-mode-comment-django-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "#" end)
+    (web-mode-insert-text-at-pos "#" (1+ beg))))
+
+(defun web-mode-comment-dust-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "!" end)
+    (web-mode-insert-text-at-pos "!" (1+ beg))))
+
+(defun web-mode-comment-aspx-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "#" end)
+    (web-mode-insert-text-at-pos "#" (1+ beg))))
+
+(defun web-mode-comment-jsp-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "--" (+ beg 2))))
+
+(defun web-mode-comment-go-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "*/" (1- end))
+    (web-mode-insert-text-at-pos "/*" (+ beg (if (web-mode-looking-at "{{" beg) 2 0)))))
+
+(defun web-mode-comment-php-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "*/" (- end 2))
+    (web-mode-insert-text-at-pos "/*" (+ beg 1 (if (web-mode-looking-at "<\\?php" beg) 5 3)))))
+
+(defun web-mode-comment-svelte-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-insert-text-at-pos "!" end)
+    (web-mode-insert-text-at-pos "!" (1+ beg))))
+
+(defun web-mode-comment-boundaries (&optional pos)
+  (interactive)
+  (unless pos (setq pos (point)))
+  (let ((beg pos) (end pos) prop)
+    (save-excursion
+      (goto-char pos)
+      (setq prop
+            (cond
+             ((eq (get-text-property pos 'block-token) 'comment) 'block-token)
+             ((eq (get-text-property pos 'tag-type) 'comment) 'tag-type)
+             ((eq (get-text-property pos 'part-token) 'comment) 'part-token)
+             (t nil)
+             ))
+      (if (null prop)
+          (setq beg nil
+                end nil)
+        (when (and (not (bobp))
+                   (eq (get-text-property pos prop) (get-text-property (1- pos) prop)))
+          (setq beg (or (previous-single-property-change pos prop) (point-min))))
+        (when (and (not (eobp))
+                   (eq (get-text-property pos prop) (get-text-property (1+ pos) prop)))
+          (setq end (or (next-single-property-change pos prop) (point-max)))))
+      (message "beg(%S) end(%S) point-max(%S)" beg end (point-max))
+      (when (and beg (string= (buffer-substring-no-properties beg (+ beg 2)) "//"))
+        (goto-char end)
+        (while (and (looking-at-p "\n[ ]*//")
+                    (not (eobp)))
+          (search-forward "//")
+          (backward-char 2)
+          ;;(message "%S" (point))
+          (setq end (next-single-property-change (point) prop))
+          (goto-char end)
+          ;;(message "%S" (point))
+          ) ;while
+        ) ;when
+      ;;(when end (setq end (1- end))) ;; #1021
+      ) ;save-excursion
+    ;;(message "beg=%S end=%S" beg end)
+    (if (and beg end) (cons beg end) nil)
+    ))
+
+(defun web-mode-uncomment (pos)
+  (let ((beg pos) (end pos) (sub2 "") comment boundaries)
+    (save-excursion
+      (cond
+       ((and (get-text-property pos 'block-side)
+             (intern-soft (concat "web-mode-uncomment-" web-mode-engine "-block")))
+        (funcall (intern (concat "web-mode-uncomment-" web-mode-engine "-block")) pos))
+       ((and (setq boundaries (web-mode-comment-boundaries pos))
+             (setq beg (car boundaries))
+             (setq end (1+ (cdr boundaries)))
+             (> (- end beg) 4))
+        (message "%S" boundaries)
+        ;;(message "beg(%S) end(%S)" beg end)
+        (setq comment (buffer-substring-no-properties beg end))
+        (setq sub2 (substring comment 0 2))
+        (cond
+         ((member sub2 '("$\\)" "" comment)))
+         ((string= sub2 "{#")
+          (setq comment (replace-regexp-in-string "\\(^{#[ ]?\\|[ ]?#}$\\)" "" comment)))
+         ((string= sub2 "{/") ;jsx comments
+          (setq comment (replace-regexp-in-string "\\(^{/\\*[ ]?\\|[ ]?\\*/}$\\)" "" comment)))
+         ((string= sub2 "/*")
+          ;;(message "%S" comment)
+          ;;(setq comment (replace-regexp-in-string "\\(\\*/\\|^/\\*[ ]?\\|^[ \t]*\\*\\)" "" comment))
+          (setq comment (replace-regexp-in-string "\\([ ]?\\*/$\\|^/\\*[ ]?\\)" "" comment))
+          (setq comment (replace-regexp-in-string "\\(^[ \t]*\\*\\)" "" comment))
+          ;;(message "%S" comment)
+          )
+         ((string= sub2 "//")
+          (setq comment (replace-regexp-in-string "^ *//" "" comment)))
+         ) ;cond
+        (delete-region beg end)
+        (web-mode-insert-and-indent comment)
+        (goto-char beg)
+        )
+       ) ;cond
+      (indent-according-to-mode)
+      )))
+
+(defun web-mode-uncomment-erb-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (cond
+     ((string= (buffer-substring-no-properties beg (+ beg 4)) "<%#=")
+      (web-mode-remove-text-at-pos 1 (+ beg 2)))
+     ((string-match-p "<[%[:alpha:]]" (buffer-substring-no-properties (+ beg 2) (- end 2)))
+      (web-mode-remove-text-at-pos 2 (1- end))
+      (web-mode-remove-text-at-pos 3 beg))
+     (t
+      (web-mode-remove-text-at-pos 1 (+ beg 2)))
+      ) ;cond
+    )
+  )
+
+(defun web-mode-uncomment-artanis-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (cond
+     ((string= (buffer-substring-no-properties beg (+ beg 4)) "<%;=")
+      (web-mode-remove-text-at-pos 1 (+ beg 2)))
+     ((string-match-p "<[%[:alpha:]]" (buffer-substring-no-properties (+ beg 2) (- end 2)))
+      (web-mode-remove-text-at-pos 2 (1- end))
+      (web-mode-remove-text-at-pos 3 beg))
+     (t
+      (web-mode-remove-text-at-pos 1 (+ beg 2)))
+      ) ;cond
+    )
+  )
+
+(defun web-mode-uncomment-ejs-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-remove-text-at-pos 1 (+ beg 2))))
+
+(defun web-mode-uncomment-django-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (cond
+     ((web-mode-looking-at-p "{#[{%]" beg)
+      (web-mode-remove-text-at-pos 1 (1- end))
+      (web-mode-remove-text-at-pos 1 (1+ beg))
+      )
+     (t
+      (web-mode-remove-text-at-pos 2 (1- end))
+      (web-mode-remove-text-at-pos 2 beg))
+     ) ;cond
+    ))
+
+(defun web-mode-uncomment-ctemplate-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-remove-text-at-pos 5 (- end 4))
+    (web-mode-remove-text-at-pos 5 beg)))
+
+(defun web-mode-uncomment-dust-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-remove-text-at-pos 1 (1- end))
+    (web-mode-remove-text-at-pos 1 (1+ beg))))
+
+(defun web-mode-uncomment-aspx-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-remove-text-at-pos 1 (1- end))
+    (web-mode-remove-text-at-pos 1 (1+ beg))))
+
+(defun web-mode-uncomment-jsp-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-remove-text-at-pos 2 (+ beg 2))))
+
+(defun web-mode-uncomment-go-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-remove-text-at-pos 2 (+ beg 2))
+    (web-mode-remove-text-at-pos 2 (- end 5))))
+
+(defun web-mode-uncomment-svelte-block (pos)
+  (let (beg end)
+    (setq beg (web-mode-block-beginning-position pos)
+          end (web-mode-block-end-position pos))
+    (web-mode-remove-text-at-pos 1 (1- end))
+    (web-mode-remove-text-at-pos 1 (1+ beg))))
+
+(defun web-mode-snippet-names ()
+  (let (codes)
+    (dolist (snippet web-mode-snippets)
+      (add-to-list 'codes (car snippet) t))
+    codes))
+
+(defun web-mode-snippet-insert (code)
+  "Insert a snippet."
+  (interactive
+   (list (completing-read "Snippet: " (web-mode-snippet-names))))
+  (let (beg
+        (continue t)
+        (counter 0)
+        end
+        sel
+        snippet
+        (l (length web-mode-snippets))
+        pos)
+    (when mark-active
+      (setq sel (web-mode-trim (buffer-substring-no-properties
+                                (region-beginning) (region-end))))
+      (delete-region (region-beginning) (region-end)))
+    (while (and continue (< counter l))
+      (setq snippet (nth counter web-mode-snippets))
+      (when (string= (car snippet) code)
+        (setq continue nil))
+      (setq counter (1+ counter)))
+    (when snippet
+      (setq snippet (cdr snippet))
+      (setq beg (point-at-bol))
+      (insert snippet)
+      (setq pos (point)
+            end (point))
+      (cond
+       ((string-match-p "¦" snippet)
+        (search-backward "¦")
+        (delete-char 1)
+        (setq pos (point)
+              end (1- end)))
+       ((string-match-p "|" snippet)
+        (search-backward "|")
+        (delete-char 1)
+        (setq pos (point)
+              end (1- end)))
+       ) ;cond
+      (when sel
+        (insert sel)
+        (setq pos (point)
+              end (+ end (length sel))))
+      (goto-char end)
+      (setq end (point-at-eol))
+      (unless sel (goto-char pos))
+      (indent-region beg end))
+    ))
+
+(defun web-mode-looking-at (regexp pos)
+  (save-excursion
+    (goto-char pos)
+    (looking-at regexp)))
+
+(defun web-mode-looking-at-p (regexp pos)
+  (save-excursion
+    (goto-char pos)
+    (looking-at-p regexp)))
+
+(defun web-mode-looking-back (regexp pos &optional limit greedy)
+  (save-excursion
+    (goto-char pos)
+    (if limit
+        (looking-back regexp limit greedy)
+      (looking-back regexp (point-min)))))
+
+(defun web-mode-insert-text-at-pos (text pos)
+  (let ((mem web-mode-enable-auto-pairing))
+    (setq web-mode-enable-auto-pairing nil)
+    (save-excursion
+      (goto-char pos)
+      (insert text)
+      (setq web-mode-enable-auto-pairing mem)
+      )))
+
+(defun web-mode-remove-text-at-pos (n &optional pos)
+  (unless pos (setq pos (point)))
+  (delete-region pos (+ pos n)))
+
+(defun web-mode-insert-and-indent (text)
+  (let (beg end)
+    (setq beg (point-at-bol))
+    (insert text)
+    (setq end (point-at-eol))
+    (indent-region beg end)
+    ))
+
+(defun web-mode-column-at-pos (pos)
+  (save-excursion
+    (goto-char pos)
+    (current-column)))
+
+(defun web-mode-indentation-at-pos (pos)
+  (save-excursion
+    (goto-char pos)
+    (current-indentation)))
+
+(defun web-mode-navigate (&optional pos)
+  "Move point to the matching opening/closing tag/block."
+  (interactive)
+  (unless pos (setq pos (point)))
+  (let (init)
+    (goto-char pos)
+    (setq init (point))
+    (when (> (current-indentation) (current-column))
+      (back-to-indentation))
+    (setq pos (point))
+    (cond
+     ((and (get-text-property pos 'block-side)
+           (web-mode-block-beginning)
+           (web-mode-block-controls-get (point)))
+      (web-mode-block-match))
+     ((member (get-text-property pos 'tag-type) '(start end))
+      (web-mode-tag-beginning)
+      (web-mode-tag-match))
+     (t
+      (goto-char init))
+     )
+    ))
+
+(defun web-mode-block-match (&optional pos)
+  (unless pos (setq pos (point)))
+  (let (pos-ori controls control (counter 1) type (continue t) pair)
+    (setq pos-ori pos)
+    (goto-char pos)
+    (setq controls (web-mode-block-controls-get pos))
+    ;;(message "controls=%S" controls)
+    (cond
+     (controls
+      (setq pair (car controls))
+      (setq control (cdr pair))
+      (setq type (car pair))
+      (when (eq type 'inside) (setq type 'close))
+      (while continue
+        (cond
+         ((and (> pos-ori 1) (bobp))
+          (setq continue nil))
+         ((or (and (eq type 'open) (not (web-mode-block-next)))
+              (and (eq type 'close) (not (web-mode-block-previous))))
+          (setq continue nil)
+          )
+         ((null (setq controls (web-mode-block-controls-get (point))))
+          )
+         (t
+          ;;TODO : est il nécessaire de faire un reverse sur controls si on doit matcher backward
+          (dolist (pair controls)
+            (cond
+             ((not (string= (cdr pair) control))
+              )
+             ((eq (car pair) 'inside)
+              )
+             ((eq (car pair) type)
+              (setq counter (1+ counter)))
+             (t
+              (setq counter (1- counter)))
+             )
+            ) ;dolist
+          (when (= counter 0)
+            (setq continue nil))
+          ) ;t
+         ) ;cond
+        ) ;while
+      (if (= counter 0) (point) nil)
+      ) ;controls
+     (t
+      (goto-char pos-ori)
+      nil
+      ) ;controls = nul
+     ) ;conf
+    ))
+
+(defun web-mode-tag-match (&optional pos)
+  "Move point to the matching opening/closing tag."
+  (interactive)
+  (unless pos (setq pos (point)))
+  (let (regexp name)
+    (cond
+     ((eq (get-text-property pos 'tag-type) 'void)
+      (web-mode-tag-beginning))
+     ((and (eq (get-text-property pos 'tag-type) 'comment)
+           (web-mode-looking-at-p " %S %S" pos (get-text-property pos 'jsx-depth))
+        )
+       ((and blockside
+             (member (get-text-property pos 'block-token) '(string comment))
+             (eq (get-text-property pos 'block-token) (get-text-property (1- pos) 'block-token)))
+        (setq pos (web-mode-block-token-beginning-position pos)))
+       ((and (not blockside)
+             (member (get-text-property pos 'part-token) '(string comment))
+             (eq (get-text-property pos 'part-token) (get-text-property (1- pos) 'part-token)))
+        (setq pos (web-mode-part-token-beginning-position pos)))
+       ((and (not blockside)
+             (get-text-property pos 'block-side))
+        (when (setq pos (web-mode-block-beginning-position pos))
+          (setq pos (1- pos))))
+       ((member char '(?\) ?\] ?\}))
+        (setq pos (web-mode-part-opening-paren-position pos reg-beg))
+        (setq pos (1- pos)))
+       ((and (eq char ?\=)
+             (web-mode-looking-back "[<>!=]+" pos reg-beg t))
+        (setq pos (- pos 1 (length (match-string-no-properties 0)))))
+       ((member char '(?\( ?\{ ?\[ ?\= ?\< ?\>))
+        (web-mode-looking-at ".[ \t\n]*" pos)
+        (setq continue nil
+              pos (+ pos (length (match-string-no-properties 0)))))
+
+       ((web-mode-looking-at "\\(return\\)[ \n]" pos)
+        (setq continue nil
+              pos (+ pos (length (match-string-no-properties 0)))))
+       ((and (eq char ?\:)
+             (web-mode-looking-back "[{,][ \t\n]*[[:alnum:]_]+[ ]*" pos))
+        (web-mode-looking-at ".[ \t\n]*" pos)
+        (setq continue nil
+              pos (+ pos (length (match-string-no-properties 0)))))
+       (t
+        (setq pos (web-mode-rsb-position pos regexp reg-beg))
+        (when (not pos)
+          (cond
+           (is-jsx
+            (when (web-mode-looking-at "[ \n]*" reg-beg)
+              (setq pos (+ reg-beg (length (match-string-no-properties 0)))))
+            (setq continue nil))
+           (t
+            (message "javascript-statement-beginning-position ** search failure **")
+            (setq continue nil
+                  pos reg-beg))
+           ) ;cond
+          )
+        ) ;t
+       ) ;cond
+      ) ;while
+    ;;(message "%S -------" pos)
+    pos))
+
+(defun web-mode-javascript-args-beginning-position (pos &optional reg-beg)
+  (unless pos (setq pos (point)))
+  (setq pos (1- pos))
+  (let ((char nil)
+        (blockside (get-text-property pos 'block-side))
+        (i 0)
+        (continue (not (null pos))))
+    (unless reg-beg
+      (if blockside
+          (setq reg-beg (web-mode-block-beginning-position pos))
+        (setq reg-beg (web-mode-part-beginning-position pos)))
+      )
+    (while continue
+      (setq char (char-after pos))
+      ;;(message "pos(%S) char(%c)" pos char)
+      (cond
+       ((> (setq i (1+ i)) 20000)
+        (message "javascript-args-beginning-position ** warning (%S) **" pos)
+        (setq continue nil
+              pos nil))
+       ((null pos)
+        (message "javascript-args-beginning-position ** invalid pos **")
+        (setq continue nil))
+       ((< pos reg-beg)
+        (message "javascript-args-beginning-position ** failure(position) **")
+        (setq continue nil
+              pos reg-beg))
+       ((and blockside
+             (member (get-text-property pos 'block-token) '(string comment))
+             (eq (get-text-property pos 'block-token) (get-text-property (1- pos) 'block-token)))
+        (setq pos (web-mode-block-token-beginning-position pos)))
+       ((and (not blockside)
+             (member (get-text-property pos 'part-token) '(string comment))
+             (eq (get-text-property pos 'part-token) (get-text-property (1- pos) 'part-token)))
+        (setq pos (web-mode-part-token-beginning-position pos)))
+       ((and (not blockside)
+             (get-text-property pos 'block-side))
+        (when (setq pos (web-mode-block-beginning-position pos))
+          (setq pos (1- pos)))
+        )
+       ((member char '(?\) ?\] ?\}))
+        (when (setq pos (web-mode-part-opening-paren-position pos reg-beg))
+          (setq pos (1- pos))))
+       ((member char '(?\( ?\[ ?\{))
+        (web-mode-looking-at ".[ ]*" pos)
+        (setq pos (+ pos (length (match-string-no-properties 0)))
+              continue nil)
+        )
+       ((web-mode-looking-at "\\(var\\|let\\|return\\|const\\)[ \n]" pos)
+        (setq pos (+ pos (length (match-string-no-properties 0)))
+              continue nil))
+       (t
+        (setq pos (web-mode-rsb-position pos "[\]\[}{)(]\\|\\(var\\|let\\|return\\|const\\)" reg-beg))
+        (when (not pos)
+          (message "javascript-args-beginning-position ** search failure **")
+          (setq continue nil
+                pos reg-beg)))
+       ) ;cond
+      ) ;while
+    ;;(message "=%S" pos)
+    pos))
+
+(defun web-mode-javascript-calls-beginning-position (pos &optional reg-beg)
+  (unless pos (setq pos (point)))
+  ;;(message "pos=%S" pos)
+  (let ((char nil)
+        (dot-pos nil)
+        (blockside (get-text-property pos 'block-side))
+        (i 0)
+        (continue (not (null pos))))
+    (unless reg-beg
+      (setq reg-beg (if blockside
+                        (web-mode-block-beginning-position pos)
+                      (web-mode-part-beginning-position pos))))
+    (while continue
+      (setq char (char-after pos))
+      ;;(message "%S| %S=%c" reg-beg pos char)
+      (cond
+       ((> (setq i (1+ i)) 20000)
+        (message "javascript-calls-beginning-position ** warning (%S) **" pos)
+        (setq continue nil
+              pos nil))
+       ((null pos)
+        (message "javascript-calls-beginning-position ** invalid pos **")
+        (setq continue nil))
+       ((< pos reg-beg)
+        (setq continue nil
+              pos reg-beg))
+       ((and blockside
+             (member (get-text-property pos 'block-token) '(string comment))
+             (eq (get-text-property pos 'block-token) (get-text-property (1- pos) 'block-token)))
+        (setq pos (web-mode-block-token-beginning-position pos)))
+       ((and (not blockside)
+             (member (get-text-property pos 'part-token) '(string comment))
+             (eq (get-text-property pos 'part-token) (get-text-property (1- pos) 'part-token)))
+        (setq pos (web-mode-part-token-beginning-position pos)))
+       ((and (not blockside)
+             (get-text-property pos 'block-side))
+        (when (setq pos (web-mode-block-beginning-position pos))
+          (setq pos (1- pos))))
+       ((and (member char '(?\.)) (> i 1))
+        (setq dot-pos pos
+              pos (1- pos)))
+       ((member char '(?\) ?\]))
+        (when (setq pos (web-mode-part-opening-paren-position pos reg-beg))
+          (setq pos (1- pos)))
+        )
+       ((member char '(?\( ?\{ ?\} ?\[ ?\= ?\? ?\: ?\; ?\, ?\& ?\| ?\>))
+        (web-mode-looking-at ".[ \t\n]*" pos)
+        (setq pos (+ pos (length (match-string-no-properties 0)))
+              continue nil))
+       ((web-mode-looking-at "\\(return\\|else\\|const\\)[ \n]" pos)
+        (setq pos (+ pos (length (match-string-no-properties 0)))
+              continue nil))
+       (t
+        (setq pos (web-mode-rsb-position pos "[\]\[}{)(=?:;,&|>.]\\|\\(return\\|else\\|const\\)" reg-beg))
+        (when (not pos)
+          (message "javascript-calls-beginning-position ** search failure **")
+          (setq pos reg-beg
+                continue nil))
+        ) ;t
+       ) ;cond
+      ) ;while
+    ;;(message "pos=%S dot-pos=%S" pos dot-pos)
+    (if (null pos) pos (cons pos dot-pos))
+    ))
+
+(defun web-mode-part-token-beginning-position (&optional pos)
+  (unless pos (setq pos (point)))
+  (cond
+   ((not (get-text-property pos 'part-token))
+    nil)
+   ((or (= pos (point-min))
+        (and (> pos (point-min))
+             (not (get-text-property (1- pos) 'part-token))))
+    pos)
+   (t
+    (setq pos (previous-single-property-change pos 'part-token))
+    (if (and pos (> pos (point-min))) pos (point-min)))
+   ))
+
+(defun web-mode-part-token-end-position (&optional pos)
+  (unless pos (setq pos (point)))
+  (cond
+   ((not (get-text-property pos 'part-token))
+    nil)
+   ((or (= pos (point-max))
+        (not (get-text-property (1+ pos) 'part-token)))
+    pos)
+   (t
+    (1- (next-single-property-change pos 'part-token)))
+   ))
+
+(defun web-mode-block-token-beginning-position (&optional pos)
+  (unless pos (setq pos (point)))
+  (cond
+   ((not (get-text-property pos 'block-token))
+    nil)
+   ((or (= pos (point-min))
+        (and (> pos (point-min))
+             (not (get-text-property (1- pos) 'block-token))))
+    pos)
+   (t
+    (setq pos (previous-single-property-change pos 'block-token))
+    (if (and pos (> pos (point-min))) pos (point-min)))
+   ))
+
+(defun web-mode-block-token-end-position (&optional pos)
+  (unless pos (setq pos (point)))
+  (cond
+   ((not (get-text-property pos 'block-token))
+    nil)
+   ((or (= pos (point-max))
+        (not (get-text-property (1+ pos) 'block-token)))
+    pos)
+   (t
+    (1- (next-single-property-change pos 'block-token)))
+   ))
+
+(defun web-mode-block-code-end-position (&optional pos)
+  (unless pos (setq pos (point)))
+  (setq pos (web-mode-block-end-position pos))
+  (cond
+   ((not pos)
+    nil)
+   ((and (eq (get-text-property pos 'block-token) 'delimiter-end)
+         (eq (get-text-property (1- pos) 'block-token) 'delimiter-end))
+    (previous-single-property-change pos 'block-token))
+   ((= pos (1- (point-max))) ;; TODO: comparer plutot avec line-end-position
+    (point-max))
+   (t
+    pos)
+   ))
+
+(defun web-mode-block-end-position (&optional pos)
+  (unless pos (setq pos (point)))
+  (cond
+   ((get-text-property pos 'block-end)
+    pos)
+   ((get-text-property pos 'block-side)
+    (or (next-single-property-change pos 'block-end)
+        (point-max)))
+   (t
+    nil)
+   ))
+
+(defun web-mode-block-previous-position (&optional pos)
+  (unless pos (setq pos (point)))
+  (cond
+   ((= pos (point-min))
+    (setq pos nil))
+   ((get-text-property pos 'block-side)
+    (setq pos (web-mode-block-beginning-position pos))
+    (cond
+     ((or (null pos) (= pos (point-min)))
+      (setq pos nil)
+      )
+     ((and (setq pos (previous-single-property-change pos 'block-beg))
+           (> pos (point-min)))
+      (setq pos (1- pos))
+      )
+     )
+    ) ;block-side
+   ((get-text-property (1- pos) 'block-side)
+    (setq pos (web-mode-block-beginning-position (1- pos)))
+    )
+   (t
+    (setq pos (previous-single-property-change pos 'block-side))
+    (cond
+     ((and (null pos) (get-text-property (point-min) 'block-beg))
+      (setq pos (point-min)))
+     ((and pos (> pos (point-min)))
+      (setq pos (web-mode-block-beginning-position (1- pos))))
+     )
+    )
+   ) ;conf
+  pos)
+
+(defun web-mode-block-next-position (&optional pos limit)
+  (unless pos (setq pos (point)))
+  (unless limit (setq limit (point-max)))
+  (cond
+   ((and (get-text-property pos 'block-side)
+         (setq pos (web-mode-block-end-position pos))
+         (< pos (point-max))
+         (setq pos (1+ pos)))
+    (unless (get-text-property pos 'block-beg)
+      (setq pos (next-single-property-change pos 'block-side)))
+    )
+   (t
+    (setq pos (next-single-property-change pos 'block-side)))
+   ) ;cond
+  (if (and pos (<= pos limit)) pos nil))
+
+(defun web-mode-is-css-string (pos)
+  (let (beg)
+    (cond
+     ((and (setq beg (web-mode-part-token-beginning-position pos))
+           (web-mode-looking-at-p "`" beg)
+           (web-mode-looking-back "\\(styled[[:alnum:].]+\\|css\\)" beg))
+      beg)
+     (t
+      nil)
+     ) ;cond
+    ))
+
+;; Relay.QL , gql, graphql
+(defun web-mode-is-ql-string (pos prefix-regexp)
+  (let (beg)
+    (cond
+     ((and (setq beg (web-mode-part-token-beginning-position pos))
+           (web-mode-looking-back prefix-regexp beg))
+      beg)
+     (t
+      nil)
+     ) ;cond
+    ))
+
+(defun web-mode-is-html-string (pos)
+  (let (beg)
+    (cond
+     ((and (setq beg (web-mode-part-token-beginning-position pos))
+           (web-mode-looking-at-p "`[ \t\n]*<[a-zA-Z]" beg)
+           (web-mode-looking-back "\\(template\\|html\\)\\([ ]*[=:][ ]*\\)?" beg))
+      beg)
+     (t
+      nil)
+     ) ;cond
+    ))
+
+;;---- EXCURSION ---------------------------------------------------------------
+
+(defun web-mode-backward-sexp (n)
+  (interactive "p")
+  (if (< n 0) (web-mode-forward-sexp (- n))
+    (let (pos)
+      (dotimes (_ n)
+        (skip-chars-backward "[:space:]")
+        (setq pos (point))
+        (cond
+         ((bobp) nil)
+         ((get-text-property (1- pos) 'block-end)
+          (backward-char 1)
+          (web-mode-block-beginning))
+         ((get-text-property (1- pos) 'block-token)
+          (backward-char 1)
+          (web-mode-block-token-beginning))
+         ((get-text-property (1- pos) 'part-token)
+          (backward-char 1)
+          (web-mode-part-token-beginning))
+         ((get-text-property (1- pos) 'tag-end)
+          (backward-char 1)
+          (web-mode-element-beginning))
+         ((get-text-property (1- pos) 'tag-attr)
+          (backward-char 1)
+          (web-mode-attribute-beginning))
+         ((get-text-property (1- pos) 'tag-type)
+          (backward-char 1)
+          (web-mode-tag-beginning))
+         ((get-text-property (1- pos) 'jsx-end)
+          (backward-char 1)
+          (web-mode-jsx-beginning))
+         (t
+          (let ((forward-sexp-function nil))
+            (backward-sexp))
+          ) ;case t
+         ) ;cond
+        ) ;dotimes
+      ))) ;let if defun
+
+(defun web-mode-forward-sexp (n)
+  (interactive "p")
+  (if (< n 0) (web-mode-backward-sexp (- n))
+    (let (pos)
+      (dotimes (_ n)
+        (skip-chars-forward "[:space:]")
+        (setq pos (point))
+        (cond
+         ((eobp) nil)
+         ((get-text-property pos 'block-beg)
+          (web-mode-block-end))
+         ((get-text-property pos 'block-token)
+          (web-mode-block-token-end))
+         ((get-text-property pos 'part-token)
+          (web-mode-part-token-end))
+         ((get-text-property pos 'tag-beg)
+          (web-mode-element-end))
+         ((get-text-property pos 'tag-attr)
+          (web-mode-attribute-end))
+         ((get-text-property pos 'tag-type)
+          (web-mode-tag-end))
+         ((get-text-property pos 'jsx-beg)
+          (web-mode-jsx-end))
+         (t
+          (let ((forward-sexp-function nil))
+            (forward-sexp))
+          ) ;case t
+         ) ;cond
+        ) ;dotimes
+      ))) ;let if defun
+
+(defun web-mode-comment-beginning ()
+  "Fetch current comment beg."
+  (interactive)
+  (web-mode-go (web-mode-comment-beginning-position (point))))
+
+(defun web-mode-comment-end ()
+  "Fetch current comment end."
+  (interactive)
+  (web-mode-go (web-mode-comment-end-position (point)) 1))
+
+(defun web-mode-tag-beginning ()
+  "Fetch current html tag beg."
+  (interactive)
+  (web-mode-go (web-mode-tag-beginning-position (point))))
+
+(defun web-mode-tag-end ()
+  "Fetch current html tag end."
+  (interactive)
+  (web-mode-go (web-mode-tag-end-position (point)) 1))
+
+(defun web-mode-tag-previous ()
+  "Fetch previous tag."
+  (interactive)
+  (web-mode-go (web-mode-tag-previous-position (point))))
+
+(defun web-mode-tag-next ()
+  "Fetch next tag. Might be html comment or server tag (e.g. jsp)."
+  (interactive)
+  (web-mode-go (web-mode-tag-next-position (point))))
+
+(defun web-mode-attribute-beginning ()
+  "Fetch html attribute beginning."
+  (interactive)
+  (web-mode-go (web-mode-attribute-beginning-position (point))))
+
+(defun web-mode-attribute-end ()
+  "Fetch html attribute end."
+  (interactive)
+  (web-mode-go (web-mode-attribute-end-position (point)) 1))
+
+(defun web-mode-attribute-next (&optional arg)
+  "Fetch next attribute."
+  (interactive "p")
+  (unless arg (setq arg 1))
+  (cond
+   ((= arg 1) (web-mode-go (web-mode-attribute-next-position (point))))
+   ((< arg 1) (web-mode-element-previous (* arg -1)))
+   (t
+    (while (>= arg 1)
+      (setq arg (1- arg))
+      (web-mode-go (web-mode-attribute-next-position (point)))
+      )
+    )
+   )
+  )
+
+(defun web-mode-attribute-previous (&optional arg)
+  "Fetch previous attribute."
+  (interactive "p")
+  (unless arg (setq arg 1))
+  (unless arg (setq arg 1))
+  (cond
+   ((= arg 1) (web-mode-go (web-mode-attribute-previous-position (point))))
+   ((< arg 1) (web-mode-element-next (* arg -1)))
+   (t
+    (while (>= arg 1)
+      (setq arg (1- arg))
+      (web-mode-go (web-mode-attribute-previous-position (point)))
+      )
+    )
+   )
+  )
+
+(defun web-mode-element-previous (&optional arg)
+  "Fetch previous element."
+  (interactive "p")
+  (unless arg (setq arg 1))
+  (cond
+   ((= arg 1) (web-mode-go (web-mode-element-previous-position (point))))
+   ((< arg 1) (web-mode-element-next (* arg -1)))
+   (t
+    (while (>= arg 1)
+      (setq arg (1- arg))
+      (web-mode-go (web-mode-element-previous-position (point)))
+      ) ;while
+    ) ;t
+   ) ;cond
+  )
+
+(defun web-mode-element-next (&optional arg)
+  "Fetch next element."
+  (interactive "p")
+  (unless arg (setq arg 1))
+  (cond
+   ((= arg 1) (web-mode-go (web-mode-element-next-position (point))))
+   ((< arg 1) (web-mode-element-previous (* arg -1)))
+   (t
+    (while (>= arg 1)
+      (setq arg (1- arg))
+      (web-mode-go (web-mode-element-next-position (point)))
+      ) ;while
+    ) ;t
+   ) ;cond
+  )
+
+(defun web-mode-element-sibling-next ()
+  "Fetch next sibling element."
+  (interactive)
+  (let ((pos (point)))
+    (save-excursion
+      (cond
+       ((not (get-text-property pos 'tag-type))
+        (if (and (web-mode-element-parent)
+                 (web-mode-tag-match)
+                 (web-mode-tag-next)
+                 (member (get-text-property (point) 'tag-type) '(start void comment)))
+            (setq pos (point))
+          (setq pos nil))
+        )
+       ((member (get-text-property pos 'tag-type) '(start void))
+        (if (and (web-mode-tag-match)
+                 (web-mode-tag-next)
+                 (member (get-text-property (point) 'tag-type) '(start void comment)))
+            (setq pos (point))
+          (setq pos nil))
+        )
+       ((and (web-mode-tag-next)
+             (member (get-text-property (point) 'tag-type) '(start void comment)))
+        (setq pos (point)))
+       (t
+        (setq pos nil))
+       ) ;cond
+      ) ;save-excursion
+    (web-mode-go pos)))
+
+(defun web-mode-element-sibling-previous ()
+  "Fetch previous sibling element."
+  (interactive)
+  (let ((pos (point)))
+    (save-excursion
+      (cond
+       ((not (get-text-property pos 'tag-type))
+        (if (and (web-mode-element-parent)
+                 (web-mode-tag-previous)
+                 (web-mode-element-beginning))
+            (setq pos (point))
+          (setq pos nil))
+        )
+       ((eq (get-text-property pos 'tag-type) 'start)
+        (if (and (web-mode-tag-beginning)
+                 (web-mode-tag-previous)
+                 (web-mode-element-beginning))
+            (setq pos (point))
+          (setq pos nil))
+        )
+       ((and (web-mode-element-beginning)
+             (web-mode-tag-previous)
+             (web-mode-element-beginning))
+        (setq pos (point)))
+       (t
+        (setq pos nil))
+       ) ;cond
+      ) ;save-excursion
+    (web-mode-go pos)))
+
+(defun web-mode-element-beginning ()
+  "Move to beginning of element."
+  (interactive)
+  (web-mode-go (web-mode-element-beginning-position (point))))
+
+(defun web-mode-element-end ()
+  "Move to end of element."
+  (interactive)
+  (web-mode-go (web-mode-element-end-position (point)) 1))
+
+(defun web-mode-element-parent ()
+  "Fetch parent element."
+  (interactive)
+  (web-mode-go (web-mode-element-parent-position (point))))
+
+(defun web-mode-element-child ()
+  "Fetch child element."
+  (interactive)
+  (web-mode-go (web-mode-element-child-position (point))))
+
+(defun web-mode-dom-traverse ()
+  "Traverse html dom tree."
+  (interactive)
+  (cond
+   ((web-mode-element-child)
+    )
+   ((web-mode-element-sibling-next)
+    )
+   ((and (web-mode-element-parent)
+         (not (web-mode-element-sibling-next)))
+    (goto-char (point-min)))
+   (t
+    (goto-char (point-min)))
+   ) ;cond
+  )
+
+(defun web-mode-closing-paren (limit)
+  (let ((pos (web-mode-closing-paren-position (point) limit)))
+    (if (or (null pos) (> pos limit))
+        nil
+      (goto-char pos)
+      pos)
+    ))
+
+(defun web-mode-part-next ()
+  "Move point to the beginning of the next part."
+  (interactive)
+  (web-mode-go (web-mode-part-next-position (point))))
+
+(defun web-mode-part-beginning ()
+  "Move point to the beginning of the current part."
+  (interactive)
+  (web-mode-go (web-mode-part-beginning-position (point))))
+
+(defun web-mode-part-end ()
+  "Move point to the end of the current part."
+  (interactive)
+  (web-mode-go (web-mode-part-end-position (point)) 1))
+
+(defun web-mode-block-previous ()
+  "Move point to the beginning of the previous block."
+  (interactive)
+  (web-mode-go (web-mode-block-previous-position (point))))
+
+(defun web-mode-block-next ()
+  "Move point to the beginning of the next block."
+  (interactive)
+  (web-mode-go (web-mode-block-next-position (point))))
+
+(defun web-mode-block-beginning ()
+  "Move point to the beginning of the current block."
+  (interactive)
+  (web-mode-go (web-mode-block-beginning-position (point))))
+
+(defun web-mode-block-end ()
+  "Move point to the end of the current block."
+  (interactive)
+  (web-mode-go (web-mode-block-end-position (point)) 1))
+
+(defun web-mode-block-token-beginning ()
+  (web-mode-go (web-mode-block-token-beginning-position (point))))
+
+(defun web-mode-block-token-end ()
+  (web-mode-go (web-mode-block-token-end-position (point)) 1))
+
+(defun web-mode-part-token-beginning ()
+  (web-mode-go (web-mode-part-token-beginning-position (point))))
+
+(defun web-mode-part-token-end ()
+  (web-mode-go (web-mode-part-token-end-position (point)) 1))
+
+(defun web-mode-block-opening-paren (limit)
+  (web-mode-go (web-mode-block-opening-paren-position (point) limit)))
+
+(defun web-mode-block-string-beginning (&optional pos block-beg)
+  (unless pos (setq pos (point)))
+  (unless block-beg (setq block-beg (web-mode-block-beginning-position pos)))
+  (web-mode-go (web-mode-block-string-beginning-position pos block-beg)))
+
+(defun web-mode-block-statement-beginning (pos block-beg is-ternary)
+  (unless pos (setq pos (point)))
+  (unless block-beg (setq block-beg (web-mode-block-beginning-position pos)))
+  (web-mode-go (web-mode-block-statement-beginning-position pos block-beg is-ternary)))
+
+(defun web-mode-block-args-beginning (&optional pos block-beg)
+  (unless pos (setq pos (point)))
+  (unless block-beg (setq block-beg (web-mode-block-beginning-position pos)))
+  (web-mode-go (web-mode-block-args-beginning-position pos block-beg)))
+
+(defun web-mode-block-calls-beginning (&optional pos block-beg)
+  (unless pos (setq pos (point)))
+  (unless block-beg (setq block-beg (web-mode-block-beginning-position pos)))
+  (web-mode-go (web-mode-block-calls-beginning-position pos block-beg)))
+
+(defun web-mode-javascript-string-beginning (&optional pos reg-beg)
+  (unless pos (setq pos (point)))
+  (unless reg-beg
+    (if (get-text-property pos 'block-side)
+        (setq reg-beg (web-mode-block-beginning-position pos))
+      (setq reg-beg (web-mode-part-beginning-position pos))))
+  (web-mode-go (web-mode-javascript-string-beginning-position pos reg-beg)))
+
+(defun web-mode-javascript-statement-beginning (pos reg-beg is-ternary)
+  (unless pos (setq pos (point)))
+  (unless reg-beg
+    (if (get-text-property pos 'block-side)
+        (setq reg-beg (web-mode-block-beginning-position pos))
+      (setq reg-beg (web-mode-part-beginning-position pos))))
+  (web-mode-go (web-mode-javascript-statement-beginning-position pos reg-beg is-ternary)))
+
+(defun web-mode-javascript-args-beginning (&optional pos reg-beg)
+  (unless pos (setq pos (point)))
+  (unless reg-beg
+    (setq reg-beg (if (get-text-property pos 'block-side)
+                      (web-mode-block-beginning-position pos)
+                    (web-mode-part-beginning-position pos))))
+  ;;(message "reg-beg%S" reg-beg)
+  (web-mode-go (web-mode-javascript-args-beginning-position pos reg-beg)))
+
+(defun web-mode-javascript-calls-beginning (&optional pos reg-beg)
+  (unless pos (setq pos (point)))
+  (unless reg-beg
+    (if (get-text-property pos 'block-side)
+        (setq reg-beg (web-mode-block-beginning-position pos))
+      (setq reg-beg (web-mode-part-beginning-position pos))))
+  (let (pair)
+    (setq pair (web-mode-javascript-calls-beginning-position pos reg-beg))
+    (when pair (web-mode-go (car pair)))
+    ))
+
+(defun web-mode-go (pos &optional offset)
+  (unless offset (setq offset 0))
+  (when pos
+    (cond
+     ((and (> offset 0) (<= (+ pos offset) (point-max)))
+      (setq pos (+ pos offset)))
+     ((and (< offset 0) (>= (+ pos offset) (point-min)))
+      (setq pos (+ pos offset)))
+     ) ;cond
+    (goto-char pos))
+  pos)
+
+;;---- SEARCH ------------------------------------------------------------------
+
+(defun web-mode-rsf-balanced (regexp-open regexp-close &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (let ((continue t)
+        (level 1)
+        (pos (point))
+        ret
+        (regexp (concat regexp-open "\\|" regexp-close)))
+    (while continue
+      (setq ret (re-search-forward regexp limit noerror))
+      (cond
+       ((null ret)
+        (setq continue nil)
+        )
+       (t
+        (if (string-match-p regexp-open (match-string-no-properties 0))
+            (setq level (1+ level))
+          (setq level (1- level)))
+        (when (< level 1)
+          (setq continue nil)
+          )
+        ) ;t
+       ) ;cond
+      ) ;while
+    (when (not (= level 0)) (goto-char pos))
+    ret))
+
+(defun web-mode-block-sb (expr &optional limit noerror)
+  (unless limit (setq limit (web-mode-block-beginning-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (search-backward expr limit noerror))
+      (when (or (null ret)
+                (not (get-text-property (point) 'block-token)))
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-block-sf (expr &optional limit noerror)
+  (unless limit (setq limit (web-mode-block-end-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (search-forward expr limit noerror))
+      (when (or (null ret)
+                (not (get-text-property (point) 'block-token)))
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-block-rsb (regexp &optional limit noerror)
+  (unless limit (setq limit (web-mode-block-beginning-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (re-search-backward regexp limit noerror))
+      (when (or (null ret)
+                (not (get-text-property (point) 'block-token)))
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-block-rsf (regexp &optional limit noerror)
+  (unless limit (setq limit (web-mode-block-end-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (re-search-forward regexp limit noerror))
+      (when (or (null ret)
+                (not (get-text-property (point) 'block-token)))
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-part-sb (expr &optional limit noerror)
+  (unless limit (setq limit (web-mode-part-beginning-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (search-backward expr limit noerror))
+      (when (or (null ret)
+                (and (not (get-text-property (point) 'part-token))
+                     (not (get-text-property (point) 'block-side)))
+                )
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-part-sf (expr &optional limit noerror)
+  (unless limit (setq limit (web-mode-part-end-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (search-forward expr limit noerror))
+      (when (or (null ret)
+                (and (not (get-text-property (point) 'part-token))
+                     (not (get-text-property (point) 'block-side)))
+                )
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-part-rsb (regexp &optional limit noerror)
+  (unless limit (setq limit (web-mode-part-beginning-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (re-search-backward regexp limit noerror))
+      (when (or (null ret)
+                (and (not (get-text-property (point) 'part-token))
+                     (not (get-text-property (point) 'block-side)))
+                )
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-part-rsf (regexp &optional limit noerror)
+  (unless limit (setq limit (web-mode-part-end-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (re-search-forward regexp limit t))
+      (when (or (null ret)
+                (and (not (get-text-property (point) 'part-token))
+                     (not (get-text-property (point) 'block-side)))
+                )
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-javascript-rsb (regexp &optional limit noerror)
+  (unless limit (setq limit (web-mode-part-beginning-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (re-search-backward regexp limit noerror))
+      (when (or (null ret)
+                (and (not (get-text-property (point) 'part-token))
+                     (not (get-text-property (point) 'block-side))
+                     (not (get-text-property (point) 'jsx-depth)))
+                )
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-javascript-rsf (regexp &optional limit noerror)
+  (unless limit (setq limit (web-mode-part-end-position (point))))
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (re-search-forward regexp limit t))
+      (when (or (null ret)
+                (and (not (get-text-property (point) 'part-token))
+                     (not (get-text-property (point) 'block-side))
+                     (not (get-text-property (point) 'jsx-depth)))
+                )
+        (setq continue nil)
+        ) ;when
+      ) ;while
+    ret))
+
+(defun web-mode-dom-sf (expr &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (search-forward expr limit noerror))
+      (if (or (null ret)
+              (not (get-text-property (- (point) (length expr)) 'block-side)))
+          (setq continue nil))
+      )
+    ret))
+
+(defun web-mode-dom-rsf (regexp &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (let ((continue t) (ret nil))
+    (while continue
+      (setq ret (re-search-forward regexp limit noerror))
+      ;;      (message "ret=%S point=%S limit=%S i=%S" ret (point) limit 0)
+      (cond
+       ((null ret)
+        (setq continue nil))
+       ((or (get-text-property (match-beginning 0) 'block-side)
+            (get-text-property (match-beginning 0) 'part-token))
+        )
+       (t
+        (setq continue nil))
+       ) ;cond
+      ) ;while
+    ret))
+
+(defun web-mode-rsb-position (pos regexp &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (save-excursion
+    (goto-char pos)
+    (if (re-search-backward regexp limit noerror) (point) nil)
+    ))
+
+(defun web-mode-rsb (regexp &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (re-search-backward regexp limit noerror))
+      (if (or (null ret)
+              (not (web-mode-is-comment-or-string)))
+          (setq continue nil)))
+    ret))
+
+(defun web-mode-rsf (regexp &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (re-search-forward regexp limit noerror))
+      (if (or (null ret)
+              (not (web-mode-is-comment-or-string)))
+          (setq continue nil))
+      )
+    ret))
+
+(defun web-mode-sb (expr &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (search-backward expr limit noerror))
+      (if (or (null ret)
+              (not (web-mode-is-comment-or-string)))
+          (setq continue nil)))
+    ret))
+
+(defun web-mode-sf (expr &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret)
+    (while continue
+      (setq ret (search-forward expr limit noerror))
+      (if (or (null ret)
+              (not (web-mode-is-comment-or-string)))
+          (setq continue nil)))
+    ret))
+
+(defun web-mode-content-rsf (regexp &optional limit noerror)
+  (unless noerror (setq noerror t))
+  (let ((continue t) ret beg end)
+    (while continue
+      (setq ret (re-search-forward regexp limit noerror)
+            beg (if (null ret) (point) (match-beginning 0))
+            end (if (null ret) (point) (1- (match-end 0))))
+      (if (or (null ret)
+              (and (web-mode-is-content beg)
+                   (web-mode-is-content end)))
+          (setq continue nil)))
+    ret))
+
+;;---- ADVICES -----------------------------------------------------------------
+
+(defadvice ac-start (before web-mode-set-up-ac-sources activate)
+  "Set `ac-sources' based on current language before running auto-complete."
+  (when (equal major-mode 'web-mode)
+    ;; set ignore each time to nil. User has to implement a hook to change it
+    ;; for each completion
+    (setq web-mode-ignore-ac-start-advice nil)
+    (run-hooks 'web-mode-before-auto-complete-hooks)
+    (unless web-mode-ignore-ac-start-advice
+      (when web-mode-ac-sources-alist
+        (let ((new-web-mode-ac-sources
+               (assoc (web-mode-language-at-pos)
+                      web-mode-ac-sources-alist)))
+          (setq ac-sources (cdr new-web-mode-ac-sources)))))))
+
+;;---- MINOR MODE ADDONS -------------------------------------------------------
+
+(defun web-mode-yasnippet-exit-hook ()
+  "Yasnippet exit hook"
+  (when (and (boundp 'yas-snippet-beg) (boundp 'yas-snippet-end))
+    (indent-region yas-snippet-beg yas-snippet-end)))
+
+(defun web-mode-imenu-index ()
+  (interactive)
+  "Returns imenu items."
+  (let (toc-index
+        line)
+    (save-excursion
+      (goto-char (point-min))
+      (while (not (eobp))
+        (setq line (buffer-substring-no-properties
+                    (line-beginning-position)
+                    (line-end-position)))
+        (let (found
+              (i 0)
+              item
+              regexp
+              type
+              type-idx
+              content
+              content-idx
+              content-regexp
+              close-tag-regexp
+              concat-str
+              jumpto
+              str)
+          (while (and (not found ) (< i (length web-mode-imenu-regexp-list)))
+            (setq item (nth i web-mode-imenu-regexp-list))
+            (setq regexp (nth 0 item))
+            (setq type-idx (nth 1 item))
+            (setq content-idx (nth 2 item))
+            (setq concat-str (nth 3 item))
+            (when (not (numberp content-idx))
+              (setq content-regexp (nth 2 item)
+                    close-tag-regexp (nth 4 item)
+                    content-idx nil))
+
+            (when (string-match regexp line)
+
+              (cond
+               (content-idx
+                (setq type (match-string type-idx line))
+                (setq content (match-string content-idx line))
+                (setq str (concat type concat-str content))
+                (setq jumpto (line-beginning-position)))
+               (t
+                (let (limit)
+                  (setq type (match-string type-idx line))
+                  (goto-char (line-beginning-position))
+                  (save-excursion
+                    (setq limit (re-search-forward close-tag-regexp (point-max) t)))
+
+                  (when limit
+                    (when (re-search-forward content-regexp limit t)
+                      (setq content (match-string 1))
+                      (setq str (concat type concat-str content))
+                      (setq jumpto (line-beginning-position))
+                      )
+                    )))
+               )
+              (when str (setq toc-index
+                              (cons (cons str jumpto)
+                                    toc-index)
+                              )
+                    (setq found t))
+              )
+            (setq i (1+ i))))
+        (forward-line)
+        (goto-char (line-end-position)) ;; make sure we are at eobp
+        ))
+    (nreverse toc-index)))
+
+;;---- UNIT TESTING ------------------------------------------------------------
+
+(defun web-mode-test ()
+  "Executes web-mode unit tests. See `web-mode-tests-directory'."
+  (interactive)
+  (let (files ret regexp)
+    (setq regexp "^[[:alnum:]][[:alnum:]._]+\\'")
+    (setq files (directory-files web-mode-tests-directory t regexp))
+    (dolist (file files)
+      (cond
+       ((eq (string-to-char (file-name-nondirectory file)) ?\_)
+        (delete-file file))
+       (t
+        (setq ret (web-mode-test-process file)))
+       ) ;cond
+      ) ;dolist
+    ))
+
+(defun web-mode-test-process (file)
+  (with-temp-buffer
+    (let (out sig1 sig2 success err)
+      (setq-default indent-tabs-mode nil)
+      (if (string-match-p "sql" file)
+          (setq web-mode-enable-sql-detection t)
+        (setq web-mode-enable-sql-detection nil))
+      (insert-file-contents file)
+      (set-visited-file-name file)
+      (web-mode)
+      (setq sig1 (md5 (current-buffer)))
+      (delete-horizontal-space)
+      (while (not (eobp))
+        (forward-line)
+        (delete-horizontal-space)
+        (end-of-line))
+      (web-mode-buffer-indent)
+      (setq sig2 (md5 (current-buffer)))
+      (setq success (string= sig1 sig2))
+      (setq out (concat (if success "ok" "ko") " : " (file-name-nondirectory file) "\n"))
+      (princ out)
+      (setq err (concat (file-name-directory file) "_err." (file-name-nondirectory file)))
+      (if success
+          (when (file-readable-p err)
+            (delete-file err))
+        (write-file err)
+        (message "[%s]" (buffer-string))
+        ) ;if
+      out)))
+
+;;---- MISC --------------------------------------------------------------------
+
+(defun web-mode-set-engine (engine)
+  "Set the engine for the current buffer."
+  (interactive
+   (list (completing-read
+          "Engine: "
+          (let (engines)
+            (dolist (elt web-mode-engines)
+              (setq engines (append engines (list (car elt)))))
+            engines))))
+  (setq web-mode-content-type "html"
+        web-mode-engine (web-mode-engine-canonical-name engine)
+        web-mode-minor-engine engine)
+  (web-mode-on-engine-setted)
+  (web-mode-buffer-fontify))
+
+(defun web-mode-set-content-type (content-type)
+  "Set the content-type for the current buffer"
+  (interactive (list (completing-read "Content-type: " web-mode-part-content-types)))
+  (setq web-mode-content-type content-type)
+  (when (called-interactively-p 'any)
+    )
+  (web-mode-buffer-fontify))
+
+(defun web-mode-on-engine-setted ()
+  (let (elt elts engines)
+
+    (when (string= web-mode-engine "razor") (setq web-mode-enable-block-face t))
+    ;;(setq web-mode-engine-attr-regexp (cdr (assoc web-mode-engine web-mode-engine-attr-regexps)))
+    (setq web-mode-engine-token-regexp (cdr (assoc web-mode-engine web-mode-engine-token-regexps)))
+
+    ;;(message "%S %S %S" web-mode-engine web-mode-engine-attr-regexp web-mode-engine-token-regexp)
+
+    (when (null web-mode-minor-engine)
+      (setq web-mode-minor-engine "none"))
+
+    (setq elt (assoc web-mode-engine web-mode-engine-open-delimiter-regexps))
+    (cond
+     (elt
+      (setq web-mode-block-regexp (cdr elt)))
+     ((string= web-mode-engine "archibus")
+      (setq web-mode-block-regexp nil))
+     (t
+      (setq web-mode-engine "none"))
+     )
+
+    (unless (boundp 'web-mode-extra-auto-pairs)
+      (setq web-mode-extra-auto-pairs nil))
+
+    (setq web-mode-auto-pairs
+          (append
+           (cdr (assoc web-mode-engine web-mode-engines-auto-pairs))
+           (cdr (assoc nil web-mode-engines-auto-pairs))
+           (cdr (assoc web-mode-engine web-mode-extra-auto-pairs))
+           (cdr (assoc nil web-mode-extra-auto-pairs))))
+
+    (unless (boundp 'web-mode-extra-snippets)
+      (setq web-mode-extra-snippets nil))
+
+    (setq elts
+          (append
+           (cdr (assoc web-mode-engine web-mode-extra-snippets))
+           (cdr (assoc nil             web-mode-extra-snippets))
+           (cdr (assoc web-mode-engine web-mode-engines-snippets))
+           (cdr (assoc nil             web-mode-engines-snippets))))
+
+    ;;(message "%S" elts)
+
+    (dolist (elt elts)
+      (unless (assoc (car elt) web-mode-snippets)
+        (setq web-mode-snippets (append (list elt) web-mode-snippets)))
+      )
+
+    (setq web-mode-engine-font-lock-keywords
+          (symbol-value (cdr (assoc web-mode-engine web-mode-engines-font-lock-keywords))))
+
+    (when (and (string= web-mode-minor-engine "jinja")
+               (not (member "endtrans" web-mode-django-control-blocks)))
+      (add-to-list 'web-mode-django-control-blocks "endtrans")
+      (setq web-mode-django-control-blocks-regexp
+            (regexp-opt web-mode-django-control-blocks t))
+      )
+
+    (when (string= web-mode-engine "spip")
+      (modify-syntax-entry ?# "w" (syntax-table)))
+
+;;    (message "%S" (symbol-value (cdr (assoc web-mode-engine web-mode-engines-font-lock-keywords))))
+
+    ))
+
+(defun web-mode-detect-engine ()
+  (save-excursion
+    (goto-char (point-min))
+    (when (re-search-forward "-\\*- engine:[ ]*\\([[:alnum:]-]+\\)[ ]*-\\*-" web-mode-chunk-length t)
+      (setq web-mode-minor-engine (match-string-no-properties 1))
+      (setq web-mode-engine (web-mode-engine-canonical-name web-mode-minor-engine)))
+    web-mode-minor-engine))
+
+(defun web-mode-guess-engine-and-content-type ()
+  (let (buff-name elt found)
+
+    (setq buff-name (buffer-file-name))
+    (unless buff-name (setq buff-name (buffer-name)))
+    (setq web-mode-is-scratch (string= buff-name "*scratch*"))
+    (setq web-mode-content-type nil)
+
+    (when (boundp 'web-mode-content-types-alist)
+      (setq found nil)
+      (dolist (elt web-mode-content-types-alist)
+        (when (and (not found) (string-match-p (cdr elt) buff-name))
+          (setq web-mode-content-type (car elt)
+                found t))
+        ) ;dolist
+      ) ;when
+
+    (unless web-mode-content-type
+      (setq found nil)
+      (dolist (elt web-mode-content-types)
+        (when (and (not found) (string-match-p (cdr elt) buff-name))
+          (setq web-mode-content-type (car elt)
+                found t)
+          ;;(message "%S" web-mode-content-type)
+          ) ;when
+        ) ;dolist
+      ) ;unless
+
+    (when (boundp 'web-mode-engines-alist)
+      (setq found nil)
+      (dolist (elt web-mode-engines-alist)
+        (cond
+         ((stringp (cdr elt))
+          (when (string-match-p (cdr elt) buff-name)
+            (setq web-mode-engine (car elt))))
+         ((functionp (cdr elt))
+          (when (funcall (cdr elt))
+            (setq web-mode-engine (car elt))))
+         ) ;cond
+        ) ;dolist
+      ) ;when
+
+    (unless web-mode-engine
+      (setq found nil)
+      (dolist (elt web-mode-engine-file-regexps)
+        ;;(message "%S %S" (cdr elt) buff-name)
+        (when (and (not found) (string-match-p (cdr elt) buff-name))
+          (setq web-mode-engine (car elt)
+                found t))
+        )
+      )
+
+    (when (and (or (null web-mode-engine) (string= web-mode-engine "none"))
+               (string-match-p "php" (buffer-substring-no-properties
+                                      (line-beginning-position)
+                                      (line-end-position))))
+      (setq web-mode-engine "php"))
+
+    (when (and (string= web-mode-content-type "javascript")
+               (string-match-p "@jsx"
+                               (buffer-substring-no-properties
+                                (point-min)
+                                (if (< (point-max) web-mode-chunk-length)
+                                    (point-max)
+                                  web-mode-chunk-length)
+                                )))
+      (setq web-mode-content-type "jsx"))
+
+    (when web-mode-engine
+      (setq web-mode-minor-engine web-mode-engine
+            web-mode-engine (web-mode-engine-canonical-name web-mode-engine))
+      )
+
+    (when (and (or (null web-mode-engine)
+                   (string= web-mode-engine "none"))
+               web-mode-enable-engine-detection)
+      (web-mode-detect-engine))
+
+    (web-mode-on-engine-setted)
+
+    ))
+
+(defun web-mode-engine-canonical-name (name)
+  (let (engine)
+    (cond
+     ((null name)
+      nil)
+     ((assoc name web-mode-engines)
+      name)
+     (t
+      (dolist (elt web-mode-engines)
+        (when (and (null engine) (member name (cdr elt)))
+          (setq engine (car elt)))
+        ) ;dolist
+      engine)
+     )))
+
+(defun web-mode-on-after-save ()
+  (when web-mode-is-scratch
+    (web-mode-guess-engine-and-content-type)
+    (web-mode-buffer-fontify))
+  nil)
+
+(defun web-mode-on-exit ()
+  (web-mode-with-silent-modifications
+   (put-text-property (point-min) (point-max) 'invisible nil)
+   (remove-overlays)
+   (remove-hook 'change-major-mode-hook 'web-mode-on-exit t)
+   ))
+
+(defun web-mode-file-link (file)
+  "Insert a link to a file in html document. This function can be
+extended to support more filetypes by customizing
+`web-mode-links'."
+  (interactive
+   (list (file-relative-name (read-file-name "Link file: "))))
+  (let ((matched nil)
+        (point-line (line-number-at-pos))
+        (point-column (current-column)))
+    (dolist (type web-mode-links)
+      (when (string-match (car type) file)
+        (setq matched t)
+        (when (nth 2 type)
+          (goto-char (point-min))
+          (search-forward "")
+          (backward-char 7)
+          (open-line 1))
+        (insert (format (cadr type) file))
+        (indent-for-tab-command)
+        (when (nth 2 type)
+          ;; return point where it was and fix indentation
+          (forward-line)
+          (indent-for-tab-command)
+          (if (> point-line (- (line-number-at-pos) 2))
+              (forward-line (+ (- point-line (line-number-at-pos)) 1))
+            (forward-line (- point-line (line-number-at-pos))))
+          (move-to-column point-column))
+        ;; move point back if needed
+        (backward-char (nth 3 type))))
+    (when (not matched)
+      (user-error "Unknown file type"))))
+
+(defun web-mode-reload ()
+  "Reload web-mode."
+  (interactive)
+  (web-mode-with-silent-modifications
+    (put-text-property (point-min) (point-max) 'invisible nil)
+    (remove-overlays)
+    (setq font-lock-unfontify-region-function 'font-lock-default-unfontify-region)
+    (load "web-mode.el")
+    (setq web-mode-change-beg nil
+          web-mode-change-end nil)
+    (web-mode)
+    ))
+
+(defun web-mode-trace (msg)
+  (let (sub)
+    (when (null web-mode-time) (setq web-mode-time (current-time)))
+    (setq sub (time-subtract (current-time) web-mode-time))
+    (when nil
+      (save-excursion
+        (let ((n 0))
+          (goto-char (point-min))
+          (while (web-mode-tag-next)
+            (setq n (1+ n))
+            )
+          (message "%S tags found" n)
+          )))
+    (message "%18s: time elapsed = %Ss %9Sµs" msg (nth 1 sub) (nth 2 sub))
+    ))
+
+(defun web-mode-reveal ()
+  "Display text properties at point."
+  (interactive)
+  (let (symbols out)
+    (setq out (format
+               "[point=%S engine=%S minor=%S content-type=%S language-at-pos=%S]\n"
+               (point)
+               web-mode-engine
+               web-mode-minor-engine
+               web-mode-content-type
+               (web-mode-language-at-pos (point))))
+    (setq symbols (append web-mode-scan-properties '(font-lock-face face)))
+    (dolist (symbol symbols)
+      (when symbol
+        (setq out (concat out (format "%s(%S) " (symbol-name symbol) (get-text-property (point) symbol)))))
+      )
+    (message "%s\n" out)
+    ;;(message "syntax-class=%S" (syntax-class (syntax-after (point))))
+    (message nil)))
+
+(defun web-mode-debug ()
+  "Display informations useful for debugging."
+  (interactive)
+  (let ((modes nil)
+        (customs '(web-mode-enable-current-column-highlight web-mode-enable-current-element-highlight indent-tabs-mode))
+        (ignore '(abbrev-mode auto-composition-mode auto-compression-mode auto-encryption-mode auto-insert-mode blink-cursor-mode column-number-mode delete-selection-mode display-time-mode electric-indent-mode file-name-shadow-mode font-lock-mode global-font-lock-mode global-hl-line-mode line-number-mode menu-bar-mode mouse-wheel-mode recentf-mode show-point-mode tool-bar-mode tooltip-mode transient-mark-mode)))
+    (message "\n")
+    (message "--- WEB-MODE DEBUG BEG ---")
+    (message "versions: emacs(%S.%S) web-mode(%S)"
+             emacs-major-version emacs-minor-version web-mode-version)
+    (message "vars: engine(%S) minor(%S) content-type(%S) file(%S)"
+             web-mode-engine
+             web-mode-minor-engine
+             web-mode-content-type
+             (or (buffer-file-name) (buffer-name)))
+    (message "system: window(%S) config(%S)" window-system system-configuration)
+    (message "colors: fg(%S) bg(%S) "
+             (cdr (assoc 'foreground-color default-frame-alist))
+             (cdr (assoc 'background-color default-frame-alist)))
+    (mapc (lambda (mode)
+            (condition-case nil
+                (if (and (symbolp mode) (symbol-value mode) (not (member mode ignore)))
+                    (add-to-list 'modes mode))
+              (error nil))
+            ) ;lambda
+          minor-mode-list)
+    (message "minor modes: %S" modes)
+    (message "vars:")
+    (dolist (custom customs)
+      (message (format "%s=%S " (symbol-name custom) (symbol-value custom))))
+    (message "--- WEB-MODE DEBUG END ---")
+    (switch-to-buffer "*Messages*")
+    (goto-char (point-max))
+    (recenter)
+  ))
+
+(provide 'web-mode)
+
+;;; web-mode.el ends here
+
+;; Local Variables:
+;; coding: utf-8
+;; indent-tabs-mode: nil
+;; End:
diff --git a/lisp/which-key.el b/lisp/which-key.el
new file mode 100644
index 00000000..353d3b99
--- /dev/null
+++ b/lisp/which-key.el
@@ -0,0 +1,2758 @@
+;;; which-key.el --- Display available keybindings in popup  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017  Free Software Foundation, Inc.
+
+;; Author: Justin Burkett 
+;; Maintainer: Justin Burkett 
+;; URL: https://github.com/justbur/emacs-which-key
+;; Package-Version: 20200702.219
+;; Package-Commit: 8f2427a69bc0388ddfb14a10eaf71e589f3b0913
+;; Version: 3.3.2
+;; Keywords:
+;; Package-Requires: ((emacs "24.4"))
+
+;; 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 .
+
+;;; Commentary:
+
+;; which-key provides the minor mode which-key-mode for Emacs. The mode displays
+;; the key bindings following your currently entered incomplete command (a
+;; prefix) in a popup. For example, after enabling the minor mode if you enter
+;; C-x and wait for the default of 1 second the minibuffer will expand with all
+;; of the available key bindings that follow C-x (or as many as space allows
+;; given your settings). This includes prefixes like C-x 8 which are shown in a
+;; different face. Screenshots of what the popup will look like along with
+;; information about additional features can be found at
+;; https://github.com/justbur/emacs-which-key.
+;;
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'button)
+(require 'regexp-opt)
+
+;; For compiler
+(defvar evil-operator-shortcut-map)
+(defvar evil-operator-state-map)
+(defvar evil-motion-state-map)
+(defvar golden-ratio-mode)
+(declare-function evil-get-command-property "ext:evil-common.el")
+
+;;; Options
+
+(defgroup which-key nil
+  "Customization options for which-key-mode"
+  :group 'help
+  :prefix "which-key-")
+
+(defcustom which-key-idle-delay 1.0
+  "Delay (in seconds) for which-key buffer to popup. This
+ variable should be set before activating `which-key-mode'.
+
+A value of zero might lead to issues, so a non-zero value is
+recommended
+(see https://github.com/justbur/emacs-which-key/issues/134)."
+  :group 'which-key
+  :type 'float)
+
+(defcustom which-key-idle-secondary-delay nil
+  "Once the which-key buffer shows once for a key sequence reduce
+the idle time to this amount (in seconds). This makes it possible
+to shorten the delay for subsequent popups in the same key
+sequence. The default is for this value to be nil, which disables
+this behavior."
+  :group 'which-key
+  :type '(choice float (const :tag "Disabled" nil)))
+
+(defcustom which-key-echo-keystrokes (if (and echo-keystrokes
+                                              (> (+ echo-keystrokes 0.01)
+                                                 which-key-idle-delay))
+                                         (/ (float which-key-idle-delay) 4)
+                                       echo-keystrokes)
+  "Value to use for `echo-keystrokes'.
+This only applies if `which-key-popup-type' is minibuffer or
+`which-key-show-prefix' is echo. It needs to be less than
+`which-key-idle-delay' or else the keystroke echo will erase the
+which-key popup."
+  :group 'which-key
+  :type 'float)
+
+(defcustom which-key-max-description-length 27
+  "Truncate the description of keys to this length.
+Also adds \"..\". If nil, disable any truncation."
+  :group 'which-key
+  :type '(choice integer (const :tag "Disable truncation" nil)))
+
+(defcustom which-key-add-column-padding 0
+  "Additional padding (number of spaces) to add to the left of
+each key column."
+  :group 'which-key
+  :type 'integer)
+
+(defcustom which-key-unicode-correction 3
+  "Correction for wide unicode characters.
+Since we measure width in terms of the number of characters,
+Unicode characters that are wider than ASCII characters throw off
+the calculation for available width in the which-key buffer.  This
+variable allows you to adjust for the wide unicode characters by
+artificially reducing the available width in the buffer.
+
+The default of 3 means allow for the total extra width
+contributed by any wide unicode characters to be up to one
+additional ASCII character in the which-key buffer.  Increase this
+number if you are seeing characters get cutoff on the right side
+of the which-key popup."
+  :group 'which-key
+  :type 'integer)
+
+(defcustom which-key-dont-use-unicode nil
+  "If non-nil, don't use any unicode characters in default setup."
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-separator
+  (if which-key-dont-use-unicode " : " " → ")
+  "Separator to use between key and description. Default is \" →
+\", unless `which-key-dont-use-unicode' is non nil, in which case
+the default is \" : \"."
+  :group 'which-key
+  :type 'string)
+
+(defcustom which-key-prefix-prefix "+"
+  "String to insert in front of prefix commands (i.e., commands
+that represent a sub-map). Default is \"+\"."
+  :group 'which-key
+  :type 'string)
+
+(defcustom which-key-compute-remaps nil
+  "If non-nil, show remapped command if a command has been
+remapped given the currently active keymaps."
+  :group 'which-key
+  :type 'boolean)
+
+(defvar which-key-key-replacement-alist nil)
+(make-obsolete-variable 'which-key-key-replacement-alist
+                        'which-key-replacement-alist "2016-11-21")
+(defvar which-key-description-replacement-alist nil)
+(make-obsolete-variable 'which-key-description-replacement-alist
+                        'which-key-replacement-alist "2016-11-21")
+(defvar which-key-key-based-description-replacement-alist nil)
+(make-obsolete-variable 'which-key-key-based-description-replacement-alist
+                        'which-key-replacement-alist "2016-11-21")
+
+(defcustom which-key-replacement-alist
+  (delq nil
+        `(((nil . "Prefix Command") . (nil . "prefix"))
+          ((nil . "\\`\\?\\?\\'") . (nil . "lambda"))
+          ((nil . "which-key-show-next-page-no-cycle") . (nil . "wk next pg"))
+          ,@(unless which-key-dont-use-unicode
+              '((("") . ("←"))
+                (("") . ("→"))))
+          (("<\\([[:alnum:]-]+\\)>") . ("\\1"))))
+  "Association list to determine how to manipulate descriptions
+of key bindings in the which-key popup. Each element of the list
+is a nested cons cell with the format
+
+\(MATCH CONS . REPLACEMENT\).
+
+The MATCH CONS determines when a replacement should occur and
+REPLACEMENT determines how the replacement should occur. Each may
+have the format \(KEY REGEXP . BINDING REGEXP\). For the
+replacement to apply the key binding must match both the KEY
+REGEXP and the BINDING REGEXP. A value of nil in either position
+can be used to match every possibility. The replacement is
+performed by using `replace-regexp-in-string' on the KEY REGEXP
+from the MATCH CONS and REPLACEMENT when it is a cons cell, and
+then similarly for the BINDING REGEXP. A nil value in the BINDING
+REGEXP position cancels the replacement. For example, the entry
+
+\(\(nil . \"Prefix Command\"\) . \(nil . \"prefix\"\)\)
+
+matches any binding with the descriptions \"Prefix Command\" and
+replaces the description with \"prefix\", ignoring the
+corresponding key.
+
+REPLACEMENT may also be a function taking a cons cell
+\(KEY . BINDING\) and producing a new corresponding cons cell.
+
+If REPLACEMENT is anything other than a cons cell \(and non nil\)
+the key binding is ignored by which-key.
+
+Finally, you can multiple replacements to occur for a given key
+binding by setting `which-key-allow-multiple-replacements' to a
+non-nil value."
+  :group 'which-key
+  :type '(alist :key-type (cons (choice regexp (const nil))
+                                (choice regexp (const nil)))
+                :value-type (cons (choice string (const nil))
+                                  (choice string (const nil)))))
+
+(when (bound-and-true-p which-key-key-replacement-alist)
+  (mapc
+   (lambda (repl)
+     (push (cons (cons (car repl) nil) (cons (cdr repl) nil))
+           which-key-replacement-alist))
+   which-key-key-replacement-alist))
+(when (bound-and-true-p which-key-description-replacement-alist)
+  (mapc
+   (lambda (repl)
+     (push (cons (cons nil (car repl)) (cons nil (cdr repl)))
+           which-key-replacement-alist))
+   which-key-description-replacement-alist))
+
+(defcustom which-key-allow-multiple-replacements nil
+  "Allow a key binding to match and be modified by multiple
+elements in `which-key-replacement-alist' if non-nil. When nil,
+only the first match is used to perform replacements from
+`which-key-replacement-alist'."
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-show-docstrings nil
+  "If non-nil, show each command's docstring next to the command
+in the which-key buffer. This will only display the docstring up
+to the first line break. If you set this variable to the symbol
+docstring-only, then the command's name with be omitted. You
+probably also want to adjust `which-key-max-description-length'
+at the same time if you use this feature."
+  :group 'which-key
+  :type '(radio
+          (const :tag "Do not show docstrings" nil)
+          (const :tag "Add docstring to command names" t)
+          (const :tag "Replace command name with docstring" docstring-only)))
+
+(defcustom which-key-highlighted-command-list '()
+  "A list of strings and/or cons cells used to highlight certain
+commands. If the element is a string, assume it is a regexp
+pattern for matching command names and use
+`which-key-highlighted-command-face' for any matching names. If
+the element is a cons cell, it should take the form (regexp .
+face to apply)."
+  :group 'which-key
+  :type  '(repeat (choice string (cons regexp face))))
+
+(defcustom which-key-special-keys '()
+  "These keys will automatically be truncated to one character
+and have `which-key-special-key-face' applied to them. This is
+disabled by default. Try this to see the effect.
+
+\(setq which-key-special-keys '(\"SPC\" \"TAB\" \"RET\" \"ESC\" \"DEL\")\)"
+  :group 'which-key
+  :type '(repeat string))
+
+(defcustom which-key-buffer-name " *which-key*"
+  "Name of which-key buffer."
+  :group 'which-key
+  :type 'string)
+
+(defcustom which-key-show-prefix 'echo
+  "Whether to and where to display the current prefix sequence.
+Possible choices are echo for echo area (the default), left, top
+and nil. Nil turns the feature off."
+  :group 'which-key
+  :type '(radio (const :tag "Left of the keys" left)
+                (const :tag "In the first line" top)
+                (const :tag "In the last line" bottom)
+                (const :tag "In the echo area" echo)
+                (const :tag "In the mode-line" mode-line)
+                (const :tag "Hide" nil)))
+
+(defcustom which-key-popup-type 'side-window
+  "Supported types are minibuffer, side-window, frame, and custom."
+  :group 'which-key
+  :type '(radio (const :tag "Show in minibuffer" minibuffer)
+                (const :tag "Show in side window" side-window)
+                (const :tag "Show in popup frame" frame)
+                (const :tag "Use your custom display functions" custom)))
+
+(defcustom which-key-min-display-lines 1
+  "The minimum number of horizontal lines to display in the
+  which-key buffer."
+  :group 'which-key
+  :type 'integer)
+
+(defcustom which-key-max-display-columns nil
+  "The maximum number of columns to display in the which-key
+buffer. nil means don't impose a maximum."
+  :group 'which-key
+  :type '(choice integer (const :tag "Unbounded" nil)))
+
+(defcustom which-key-side-window-location 'bottom
+  "Location of which-key popup when `which-key-popup-type' is side-window.
+Should be one of top, bottom, left or right. You can also specify
+a list of two locations, like (right bottom). In this case, the
+first location is tried. If there is not enough room, the second
+location is tried."
+  :group 'which-key
+  :type '(radio (const right)
+                (const bottom)
+                (const left)
+                (const top)
+                (const (right bottom))
+                (const (bottom right))))
+
+(defcustom which-key-side-window-slot 0
+  "The `slot' to use for `display-buffer-in-side-window' when
+`which-key-popup-type' is 'side-window. Quoting from the
+docstring of `display-buffer-in-side-window',
+
+‘slot’ if non-nil, specifies the window slot where to display
+  BUFFER.  A value of zero or nil means use the middle slot on
+  the specified side.  A negative value means use a slot
+  preceding (that is, above or on the left of) the middle slot.
+  A positive value means use a slot following (that is, below or
+  on the right of) the middle slot.  The default is zero."
+  :group 'which-key
+  :type 'integer)
+
+(defcustom which-key-side-window-max-width 0.333
+  "Maximum width of which-key popup when type is side-window and
+location is left or right.
+This variable can also be a number between 0 and 1. In that case, it denotes
+a percentage out of the frame's width."
+  :group 'which-key
+  :type 'float)
+
+(defcustom which-key-side-window-max-height 0.25
+  "Maximum height of which-key popup when type is side-window and
+location is top or bottom.
+This variable can also be a number between 0 and 1. In that case, it denotes
+a percentage out of the frame's height."
+  :group 'which-key
+  :type 'float)
+
+(defcustom which-key-frame-max-width 60
+  "Maximum width of which-key popup when type is frame."
+  :group 'which-key
+  :type 'integer)
+
+(defcustom which-key-frame-max-height 20
+  "Maximum height of which-key popup when type is frame."
+  :group 'which-key
+  :type 'integer)
+
+(defcustom which-key-allow-imprecise-window-fit (not (display-graphic-p))
+  "If non-nil allow which-key to use a less intensive method of
+fitting the popup window to the buffer. If you are noticing lag
+when the which-key popup displays turning this on may help.
+
+See https://github.com/justbur/emacs-which-key/issues/130
+and https://github.com/justbur/emacs-which-key/issues/225."
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-show-remaining-keys nil
+  "Show remaining keys in last slot, when keys are hidden."
+  :group 'which-key
+  :type '(radio (const :tag "Yes" t)
+                (const :tag "No" nil)))
+
+(defcustom which-key-sort-order 'which-key-key-order
+  "If nil, do not resort the output from
+`describe-buffer-bindings' which groups by mode. Ordering options
+are
+
+1. `which-key-key-order': by key (default)
+2. `which-key-key-order-alpha': by key using alphabetical order
+3. `which-key-description-order': by description
+4. `which-key-prefix-then-key-order': prefix (no prefix first) then key
+5. `which-key-local-then-key-order': local binding then key
+
+See the README and the docstrings for those functions for more
+information."
+  :group 'which-key
+  :type '(choice (function-item which-key-key-order)
+                 (function-item which-key-key-order-alpha)
+                 (function-item which-key-description-order)
+                 (function-item which-key-prefix-then-key-order)
+                 (function-item which-key-local-then-key-order)))
+
+(defcustom which-key-sort-uppercase-first t
+  "If non-nil, uppercase comes before lowercase in sorting
+function chosen in `which-key-sort-order'. Otherwise, the order
+is reversed."
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-paging-prefixes '()
+  "Enable paging for these prefixes."
+  :group 'which-key
+  :type '(repeat string))
+
+(defcustom which-key-paging-key ""
+  "Key to use for changing pages. Bound after each of the
+prefixes in `which-key-paging-prefixes'"
+  :group 'which-key
+  :type 'string)
+
+;; (defcustom which-key-undo-key nil
+;;   "Key (string) to use for undoing keypresses. Bound recursively
+;; in each of the maps in `which-key-undo-keymaps'."
+;;   :group 'which-key
+;;   :type 'string)
+
+;; (defcustom which-key-undo-keymaps '()
+;;   "Keymaps in which to bind `which-key-undo-key'"
+;;   :group 'which-key
+;;   :type '(repeat symbol))
+
+(defcustom which-key-use-C-h-commands t
+  "Use C-h (or whatever `help-char' is set to) for paging if
+non-nil. Normally C-h after a prefix calls
+`describe-prefix-bindings'. This changes that command to a
+which-key paging command when which-key-mode is active."
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-show-early-on-C-h nil
+  "Show the which-key buffer before if C-h (or whatever
+`help-char' is set to) is pressed in the middle of a prefix
+before the which-key buffer would normally be triggered through
+the idle delay. If combined with the following settings,
+which-key will effectively only show when triggered \"manually\"
+using C-h.
+
+\(setq `which-key-idle-delay' 10000)
+\(setq `which-key-idle-secondary-delay' 0.05)
+
+Note that `which-key-idle-delay' should be set before turning on
+`which-key-mode'. "
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-is-verbose nil
+  "Whether to warn about potential mistakes in configuration."
+  :group 'which-key
+  :type 'boolean)
+
+(defvar which-key-C-h-map
+  (let ((map (make-sparse-keymap)))
+    (dolist (bind `(("\C-a" . which-key-abort)
+                    ("a" . which-key-abort)
+                    ("\C-d" . which-key-toggle-docstrings)
+                    ("d" . which-key-toggle-docstrings)
+                    (,(vector help-char) . which-key-show-standard-help)
+                    ("h" . which-key-show-standard-help)
+                    ("\C-n" . which-key-show-next-page-cycle)
+                    ("n" . which-key-show-next-page-cycle)
+                    ("\C-p" . which-key-show-previous-page-cycle)
+                    ("p" . which-key-show-previous-page-cycle)
+                    ("\C-u" . which-key-undo-key)
+                    ("u" . which-key-undo-key)
+                    ("1" . which-key-digit-argument)
+                    ("2" . which-key-digit-argument)
+                    ("3" . which-key-digit-argument)
+                    ("4" . which-key-digit-argument)
+                    ("5" . which-key-digit-argument)
+                    ("6" . which-key-digit-argument)
+                    ("7" . which-key-digit-argument)
+                    ("8" . which-key-digit-argument)
+                    ("9" . which-key-digit-argument)))
+      (define-key map (car bind) (cdr bind)))
+    map)
+  "Keymap for C-h commands.")
+
+(defvar which-key--paging-functions '(which-key-C-h-dispatch
+                                      which-key-manual-update
+                                      which-key-turn-page
+                                      which-key-show-next-page-cycle
+                                      which-key-show-next-page-no-cycle
+                                      which-key-show-previous-page-cycle
+                                      which-key-show-previous-page-no-cycle
+                                      which-key-undo-key
+                                      which-key-undo))
+
+(defvar which-key-persistent-popup nil
+  "Whether or not to disable `which-key--hide-popup'.")
+
+(defcustom which-key-hide-alt-key-translations t
+  "Hide key translations using Alt key if non nil.
+These translations are not relevant most of the times since a lot
+of terminals issue META modifier for the Alt key.
+
+See http://www.gnu.org/software/emacs/manual/html_node/emacs/Modifier-Keys.html"
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-delay-functions nil
+  "A list of functions that may decide whether to delay the
+which-key popup based on the current incomplete key
+sequence. Each function in the list is run with two arguments,
+the current key sequence as produced by `key-description' and the
+length of the key sequence. If the popup should be delayed based
+on that key sequence, the function should return the delay time
+in seconds. Returning nil means no delay. The first function in
+this list to return a value is the value that is used.
+
+The delay time is effectively added to the normal
+`which-key-idle-delay'."
+  :group 'which-key
+  :type '(repeat function))
+
+(defcustom which-key-allow-regexps nil
+  "A list of regexp strings to use to filter key sequences. When
+non-nil, for a key sequence to trigger the which-key popup it
+must match one of the regexps in this list. The format of the key
+sequences is what is produced by `key-description'."
+  :group 'which-key
+  :type '(repeat regexp))
+
+(defcustom which-key-inhibit-regexps nil
+  "Similar to `which-key-allow-regexps', a list of regexp strings
+to use to filter key sequences. When non-nil, for a key sequence
+to trigger the which-key popup it cannot match one of the regexps
+in this list. The format of the key sequences is what is produced
+by `key-description'."
+  :group 'which-key
+  :type '(repeat regexp))
+
+(defcustom which-key-show-transient-maps nil
+  "Show keymaps created by `set-transient-map' when applicable.
+
+More specifically, detect when `overriding-terminal-local-map' is
+set (this is the keymap used by `set-transient-map') and display
+it."
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-enable-extended-define-key nil
+  "Advise `define-key' to make which-key aware of definitions of the form
+
+  \(define-key KEYMAP KEY '(\"DESCRIPTION\" . DEF))
+
+With the advice, this definition will have the side effect of
+creating a replacement in `which-key-replacement-alist' that
+replaces DEF with DESCRIPTION when the key sequence ends in
+KEY. Using a cons cell like this is a valid definition for
+`define-key'. All this does is to make which-key aware of it.
+
+Since many higher level keybinding functions use `define-key'
+internally, this will affect most if not all of those as well.
+
+This variable must be set before loading which-key."
+  :group 'which-key
+  :type 'boolean)
+
+;; Hooks
+(defcustom which-key-init-buffer-hook '()
+  "Hook run when which-key buffer is initialized."
+  :group 'which-key
+  :type 'hook)
+
+;;;; Faces
+
+(defgroup which-key-faces nil
+  "Faces for which-key-mode"
+  :group 'which-key
+  :prefix "which-key-")
+
+(defface which-key-key-face
+  '((t . (:inherit font-lock-constant-face)))
+  "Face for which-key keys"
+  :group 'which-key-faces)
+
+(defface which-key-separator-face
+  '((t . (:inherit font-lock-comment-face)))
+  "Face for the separator (default separator is an arrow)"
+  :group 'which-key-faces)
+
+(defface which-key-note-face
+  '((t . (:inherit which-key-separator-face)))
+  "Face for notes or hints occasionally provided"
+  :group 'which-key-faces)
+
+(defface which-key-command-description-face
+  '((t . (:inherit font-lock-function-name-face)))
+  "Face for the key description when it is a command"
+  :group 'which-key-faces)
+
+(defface which-key-local-map-description-face
+  '((t . (:inherit which-key-command-description-face)))
+  "Face for the key description when it is found in `current-local-map'"
+  :group 'which-key-faces)
+
+(defface which-key-highlighted-command-face
+  '((t . (:inherit which-key-command-description-face :underline t)))
+  "Default face for the command description when it is a command
+and it matches a string in `which-key-highlighted-command-list'."
+  :group 'which-key-faces)
+
+(defface which-key-group-description-face
+  '((t . (:inherit font-lock-keyword-face)))
+  "Face for the key description when it is a group or prefix"
+  :group 'which-key-faces)
+
+(defface which-key-special-key-face
+  '((t . (:inherit which-key-key-face :inverse-video t :weight bold)))
+  "Face for special keys (SPC, TAB, RET)"
+  :group 'which-key-faces)
+
+(defface which-key-docstring-face
+  '((t . (:inherit which-key-note-face)))
+  "Face for docstrings"
+  :group 'which-key-faces)
+
+;;;; Custom popup
+
+(defcustom which-key-custom-popup-max-dimensions-function nil
+  "Variable to hold a custom max-dimensions function.
+Will be passed the width of the active window and is expected to
+return the maximum height in lines and width in characters of the
+which-key popup in the form a cons cell (height . width)."
+  :group 'which-key
+  :type '(choice function (const nil)))
+
+(defcustom which-key-custom-hide-popup-function nil
+  "Variable to hold a custom hide-popup function.
+It takes no arguments and the return value is ignored."
+  :group 'which-key
+  :type '(choice function (const nil)))
+
+(defcustom which-key-custom-show-popup-function nil
+  "Variable to hold a custom show-popup function.
+Will be passed the required dimensions in the form (height .
+width) in lines and characters respectively.  The return value is
+ignored."
+  :group 'which-key
+  :type '(choice function (const nil)))
+
+(defcustom which-key-lighter " WK"
+  "Minor mode lighter to use in the mode-line."
+  :group 'which-key
+  :type 'string)
+
+(defvar which-key-inhibit nil
+  "Prevent which-key from popping up momentarily by setting this
+to a non-nil value for the execution of a command. Like this
+
+\(let \(\(which-key-inhibit t\)\)
+...\)")
+
+(defvar which-key-keymap-history nil
+  "History of keymap selections in functions like
+`which-key-show-keymap'.")
+
+;;; Internal Vars
+
+(defvar which-key--buffer nil
+  "Internal: Holds reference to which-key buffer.")
+(defvar which-key--timer nil
+  "Internal: Holds reference to open window timer.")
+(defvar which-key--secondary-timer-active nil
+  "Internal: Non-nil if the secondary timer is active.")
+(defvar which-key--paging-timer nil
+  "Internal: Holds reference to timer for paging.")
+(defvar which-key--frame nil
+  "Internal: Holds reference to which-key frame.
+Used when `which-key-popup-type' is frame.")
+(defvar which-key--echo-keystrokes-backup nil
+  "Internal: Backup the initial value of `echo-keystrokes'.")
+(defvar which-key--prefix-help-cmd-backup nil
+  "Internal: Backup the value of `prefix-help-command'.")
+(defvar which-key--last-try-2-loc nil
+  "Internal: Last location of side-window when two locations
+used.")
+(defvar which-key--automatic-display nil
+  "Internal: Non-nil if popup was triggered with automatic
+update.")
+(defvar which-key--debug-buffer-name nil
+  "If non-nil, use this buffer for debug messages.")
+(defvar which-key--multiple-locations nil)
+(defvar which-key--inhibit-next-operator-popup nil)
+(defvar which-key--prior-show-keymap-args nil)
+(defvar which-key--previous-frame-size nil)
+(defvar which-key--prefix-title-alist nil)
+(defvar which-key--evil-keys-regexp (eval-when-compile
+                                      (regexp-opt '("-state"))))
+(defvar which-key--ignore-non-evil-keys-regexp
+  (eval-when-compile
+    (regexp-opt '("mouse-" "wheel-" "remap" "drag-" "scroll-bar"
+                  "select-window" "switch-frame" "which-key-"))))
+(defvar which-key--ignore-keys-regexp
+  (eval-when-compile
+    (regexp-opt '("mouse-" "wheel-" "remap" "drag-" "scroll-bar"
+                  "select-window" "switch-frame" "-state"
+                  "which-key-"))))
+
+(make-obsolete-variable 'which-key-prefix-name-alist nil "2016-10-05")
+(make-obsolete-variable 'which-key-prefix-title-alist nil "2016-10-05")
+
+(defvar which-key--pages-obj nil)
+(cl-defstruct which-key--pages
+  pages
+  height
+  widths
+  keys/page
+  page-nums
+  num-pages
+  total-keys
+  prefix
+  prefix-title)
+
+(defun which-key--rotate (list n)
+  (let* ((len (length list))
+         (n (if (< n 0) (+ len n) n))
+         (n (mod n len)))
+    (append (last list (- len n)) (butlast list (- len n)))))
+
+(defun which-key--pages-set-current-page (pages-obj n)
+  (setf (which-key--pages-pages pages-obj)
+        (which-key--rotate (which-key--pages-pages pages-obj) n))
+  (setf (which-key--pages-widths pages-obj)
+        (which-key--rotate (which-key--pages-widths pages-obj) n))
+  (setf (which-key--pages-keys/page pages-obj)
+        (which-key--rotate (which-key--pages-keys/page pages-obj) n))
+  (setf (which-key--pages-page-nums pages-obj)
+        (which-key--rotate (which-key--pages-page-nums pages-obj) n))
+  pages-obj)
+
+(defsubst which-key--on-first-page ()
+  (= (which-key--pages-page-nums which-key--pages-obj) 1))
+
+(defsubst which-key--on-last-page ()
+  (= (which-key--pages-page-nums which-key--pages-obj)
+     (which-key--pages-num-pages which-key--pages-obj)))
+
+(defsubst which-key--current-prefix ()
+  (when which-key--pages-obj
+    (which-key--pages-prefix which-key--pages-obj)))
+
+(defmacro which-key--debug-message (&rest msg)
+  `(when which-key--debug-buffer-name
+     (let ((buf (get-buffer-create which-key--debug-buffer-name))
+           (fmt-msg (format ,@msg)))
+       (with-current-buffer buf
+         (goto-char (point-max))
+         (insert "\n" fmt-msg "\n")))))
+
+;;; Third-party library support
+;;;; Evil
+
+(defcustom which-key-allow-evil-operators (boundp 'evil-this-operator)
+  "Allow popup to show for evil operators. The popup is normally
+  inhibited in the middle of commands, but setting this to
+  non-nil will override this behavior for evil operators."
+  :group 'which-key
+  :type 'boolean)
+
+(defcustom which-key-show-operator-state-maps nil
+  "Experimental: Try to show the right keys following an evil
+command that reads a motion, such as \"y\", \"d\" and \"c\" from
+normal state. This is experimental, because there might be some
+valid keys missing and it might be showing some invalid keys."
+  :group 'which-key
+  :type 'boolean)
+
+;;;;; God-mode
+
+(defvar which-key--god-mode-support-enabled nil
+  "Support god-mode if non-nil. This is experimental,
+so you need to explicitly opt-in for now. Please report any
+problems at github.")
+
+(defvar which-key--god-mode-key-string nil
+  "Holds key string to use for god-mode support.")
+
+(defadvice god-mode-lookup-command
+    (around which-key--god-mode-lookup-command-advice disable)
+  (setq which-key--god-mode-key-string (ad-get-arg 0))
+  (unwind-protect
+      ad-do-it
+    (when (bound-and-true-p which-key-mode)
+      (which-key--hide-popup))))
+
+(defun which-key-enable-god-mode-support (&optional disable)
+  "Enable support for god-mode if non-nil. This is experimental,
+so you need to explicitly opt-in for now. Please report any
+problems at github. If DISABLE is non-nil disable support."
+  (interactive "P")
+  (setq which-key--god-mode-support-enabled (null disable))
+  (if disable
+      (ad-disable-advice
+       'god-mode-lookup-command
+       'around 'which-key--god-mode-lookup-command-advice)
+    (ad-enable-advice
+     'god-mode-lookup-command
+     'around 'which-key--god-mode-lookup-command-advice))
+  (ad-activate 'god-mode-lookup-command))
+
+;;; Mode
+
+;;;###autoload
+(define-minor-mode which-key-mode
+  "Toggle which-key-mode."
+  :global t
+  :lighter which-key-lighter
+  :keymap (let ((map (make-sparse-keymap)))
+            (mapc
+             (lambda (prefix)
+               (define-key map
+                 (kbd (concat prefix " " which-key-paging-key))
+                 #'which-key-C-h-dispatch))
+             which-key-paging-prefixes)
+            map)
+  (if which-key-mode
+      (progn
+        (setq which-key--echo-keystrokes-backup echo-keystrokes)
+        (when (or (eq which-key-show-prefix 'echo)
+                  (eq which-key-popup-type 'minibuffer))
+          (which-key--setup-echo-keystrokes))
+        (unless (member prefix-help-command which-key--paging-functions)
+          (setq which-key--prefix-help-cmd-backup prefix-help-command))
+        (when (or which-key-use-C-h-commands
+                  which-key-show-early-on-C-h)
+          (setq prefix-help-command #'which-key-C-h-dispatch))
+        (when which-key-show-remaining-keys
+          (add-hook 'pre-command-hook #'which-key--lighter-restore))
+        (add-hook 'pre-command-hook #'which-key--hide-popup)
+        (add-hook 'focus-out-hook #'which-key--stop-timer)
+        (add-hook 'focus-in-hook #'which-key--start-timer)
+        (add-hook 'window-size-change-functions
+                  'which-key--hide-popup-on-frame-size-change)
+        (which-key--start-timer))
+    (setq echo-keystrokes which-key--echo-keystrokes-backup)
+    (when which-key--prefix-help-cmd-backup
+      (setq prefix-help-command which-key--prefix-help-cmd-backup))
+    (when which-key-show-remaining-keys
+      (remove-hook 'pre-command-hook #'which-key--lighter-restore))
+    (remove-hook 'pre-command-hook #'which-key--hide-popup)
+    (remove-hook 'focus-out-hook #'which-key--stop-timer)
+    (remove-hook 'focus-in-hook #'which-key--start-timer)
+    (remove-hook 'window-size-change-functions
+                 'which-key--hide-popup-on-frame-size-change)
+    (which-key--stop-timer)))
+
+(defun which-key--init-buffer ()
+  "Initialize which-key buffer"
+  (unless (buffer-live-p which-key--buffer)
+    (setq which-key--buffer (get-buffer-create which-key-buffer-name))
+    (with-current-buffer which-key--buffer
+      ;; suppress confusing minibuffer message
+      (let (message-log-max)
+        (toggle-truncate-lines 1)
+        (message ""))
+      (setq-local cursor-type nil)
+      (setq-local cursor-in-non-selected-windows nil)
+      (setq-local mode-line-format nil)
+      (setq-local word-wrap nil)
+      (setq-local show-trailing-whitespace nil)
+      (run-hooks 'which-key-init-buffer-hook))))
+
+(defun which-key--setup-echo-keystrokes ()
+  "Reduce `echo-keystrokes' if necessary (it will interfere if
+it's set too high)."
+  (when (and echo-keystrokes
+             (> (abs (- echo-keystrokes which-key-echo-keystrokes)) 0.000001))
+    (if (> which-key-idle-delay which-key-echo-keystrokes)
+        (setq echo-keystrokes which-key-echo-keystrokes)
+      (setq which-key-echo-keystrokes (/ (float which-key-idle-delay) 4)
+            echo-keystrokes which-key-echo-keystrokes))))
+
+(defun which-key-remove-default-unicode-chars ()
+  "Use of `which-key-dont-use-unicode' is preferred to this
+function, but it's included here in case someone cannot set that
+variable early enough in their configuration, if they are using a
+starter kit for example."
+  (when (string-equal which-key-separator " → ")
+    (setq which-key-separator " : "))
+  (setq which-key-key-replacement-alist
+        (delete '("left" . "←") which-key-key-replacement-alist))
+  (setq which-key-key-replacement-alist
+        (delete '("right" . "→") which-key-key-replacement-alist)))
+
+;;; Default configuration functions for use by users.
+
+;;;###autoload
+(defun which-key-setup-side-window-right ()
+  "Apply suggested settings for side-window that opens on right."
+  (interactive)
+  (setq which-key-popup-type 'side-window
+        which-key-side-window-location 'right
+        which-key-show-prefix 'top))
+
+;;;###autoload
+(defun which-key-setup-side-window-right-bottom ()
+  "Apply suggested settings for side-window that opens on right
+if there is space and the bottom otherwise."
+  (interactive)
+  (setq which-key-popup-type 'side-window
+        which-key-side-window-location '(right bottom)
+        which-key-show-prefix 'top))
+
+;;;###autoload
+(defun which-key-setup-side-window-bottom ()
+  "Apply suggested settings for side-window that opens on
+bottom."
+  (interactive)
+  (which-key--setup-echo-keystrokes)
+  (setq which-key-popup-type 'side-window
+        which-key-side-window-location 'bottom
+        which-key-show-prefix 'echo))
+
+;;;###autoload
+(defun which-key-setup-minibuffer ()
+  "Apply suggested settings for minibuffer.
+Do not use this setup if you use the paging commands. Instead use
+`which-key-setup-side-window-bottom', which is nearly identical
+but more functional."
+  (interactive)
+  (which-key--setup-echo-keystrokes)
+  (setq which-key-popup-type 'minibuffer
+        which-key-show-prefix 'left))
+
+;;; Helper functions to modify replacement lists.
+
+;;;###autoload
+(defun which-key-add-key-based-replacements
+    (key-sequence replacement &rest more)
+  "Replace the description of KEY-SEQUENCE with REPLACEMENT.
+KEY-SEQUENCE is a string suitable for use in `kbd'. REPLACEMENT
+may either be a string, as in
+
+\(which-key-add-key-based-replacements \"C-x 1\" \"maximize\"\)
+
+a cons of two strings as in
+
+\(which-key-add-key-based-replacements \"C-x 8\"
+                                        '(\"unicode\" . \"Unicode keys\")\)
+
+or a function that takes a \(KEY . BINDING\) cons and returns a
+replacement.
+
+In the second case, the second string is used to provide a longer
+name for the keys under a prefix.
+
+MORE allows you to specifcy additional KEY REPLACEMENT pairs.  All
+replacements are added to
+`which-key-key-based-description-replacement-alist'."
+  ;; TODO: Make interactive
+  (while key-sequence
+    ;; normalize key sequences before adding
+    (let ((key-seq (key-description (kbd key-sequence)))
+          (replace (or (and (functionp replacement) replacement)
+                       (car-safe replacement)
+                       replacement)))
+      (push (cons (cons (concat "\\`" (regexp-quote key-seq) "\\'") nil)
+                  (if (functionp replace) replace (cons nil replace)))
+            which-key-replacement-alist)
+      (when (and (not (functionp replacement)) (consp replacement))
+        (push (cons key-seq (cdr-safe replacement))
+              which-key--prefix-title-alist)))
+    (setq key-sequence (pop more) replacement (pop more))))
+(put 'which-key-add-key-based-replacements 'lisp-indent-function 'defun)
+
+;;;###autoload
+(defun which-key-add-major-mode-key-based-replacements
+    (mode key-sequence replacement &rest more)
+  "Functions like `which-key-add-key-based-replacements'.
+The difference is that MODE specifies the `major-mode' that must
+be active for KEY-SEQUENCE and REPLACEMENT (MORE contains
+addition KEY-SEQUENCE REPLACEMENT pairs) to apply."
+  ;; TODO: Make interactive
+  (when (not (symbolp mode))
+    (error "MODE should be a symbol corresponding to a value of major-mode"))
+  (let ((mode-alist
+         (or (cdr-safe (assq mode which-key-replacement-alist)) (list)))
+        (title-mode-alist
+         (or (cdr-safe (assq mode which-key--prefix-title-alist)) (list))))
+    (while key-sequence
+    ;; normalize key sequences before adding
+      (let ((key-seq (key-description (kbd key-sequence)))
+            (replace (or (and (functionp replacement) replacement)
+                         (car-safe replacement)
+                         replacement)))
+        (push (cons (cons (concat "\\`" (regexp-quote key-seq) "\\'") nil)
+                    (if (functionp replace) replace (cons nil replace)))
+              mode-alist)
+        (when (and (not (functionp replacement)) (consp replacement))
+          (push (cons key-seq (cdr-safe replacement))
+                title-mode-alist)))
+      (setq key-sequence (pop more) replacement (pop more)))
+    (if (assq mode which-key-replacement-alist)
+        (setcdr (assq mode which-key-replacement-alist) mode-alist)
+      (push (cons mode mode-alist) which-key-replacement-alist))
+    (if (assq mode which-key--prefix-title-alist)
+        (setcdr (assq mode which-key--prefix-title-alist) title-mode-alist)
+      (push (cons mode title-mode-alist) which-key--prefix-title-alist))))
+(put 'which-key-add-major-mode-key-based-replacements
+     'lisp-indent-function 'defun)
+
+(defalias 'which-key-add-prefix-title 'which-key-add-key-based-replacements)
+(make-obsolete 'which-key-add-prefix-title
+               'which-key-add-key-based-replacements
+               "2016-10-05")
+
+(defalias 'which-key-declare-prefixes 'which-key-add-key-based-replacements)
+(make-obsolete 'which-key-declare-prefixes
+               'which-key-add-key-based-replacements
+               "2016-10-05")
+
+(defalias 'which-key-declare-prefixes-for-mode
+  'which-key-add-major-mode-key-based-replacements)
+(make-obsolete 'which-key-declare-prefixes-for-mode
+               'which-key-add-major-mode-key-based-replacements
+               "2016-10-05")
+
+(defun which-key-define-key-recursively (map key def &optional at-root)
+  "Recursively bind KEY in MAP to DEF on every level of MAP except the first.
+If AT-ROOT is non-nil the binding is also placed at the root of MAP."
+  (when at-root (define-key map key def))
+  (map-keymap
+   (lambda (_ev df)
+     (when (keymapp df)
+       (which-key-define-key-recursively df key def t)))
+   map))
+
+(defun which-key--process-define-key-args (keymap key def)
+  "When DEF takes the form (\"DESCRIPTION\". DEF), make sure
+which-key uses \"DESCRIPTION\" for this binding. This function is
+meant to be used as :before advice for `define-key'."
+  (with-demoted-errors "Which-key extended define-key error: %s"
+    (when (and (consp def)
+               (stringp (car def))
+               (symbolp (cdr def)))
+      (define-key keymap (which-key--pseudo-key key) `(which-key ,def)))))
+
+(when which-key-enable-extended-define-key
+  (advice-add #'define-key :before #'which-key--process-define-key-args))
+
+;;; Functions for computing window sizes
+
+(defun which-key--text-width-to-total (text-width)
+  "Convert window text-width to window total-width.
+TEXT-WIDTH is the desired text width of the window.  The function
+calculates what total width is required for a window in the
+selected to have a text-width of TEXT-WIDTH columns.  The
+calculation considers possible fringes and scroll bars.  This
+function assumes that the desired window has the same character
+width as the frame."
+  (let ((char-width (frame-char-width)))
+    (+ text-width
+       (/ (frame-fringe-width) char-width)
+       (/ (frame-scroll-bar-width) char-width)
+       (if (which-key--char-enlarged-p) 1 0)
+       ;; add padding to account for possible wide (unicode) characters
+       3)))
+
+(defun which-key--total-width-to-text (total-width)
+  "Convert window total-width to window text-width.
+TOTAL-WIDTH is the desired total width of the window.  The function calculates
+what text width fits such a window.  The calculation considers possible fringes
+and scroll bars.  This function assumes that the desired window has the same
+character width as the frame."
+  (let ((char-width (frame-char-width)))
+    (- total-width
+       (/ (frame-fringe-width) char-width)
+       (/ (frame-scroll-bar-width) char-width)
+       (if (which-key--char-enlarged-p) 1 0)
+       ;; add padding to account for possible wide (unicode) characters
+       3)))
+
+(defun which-key--char-enlarged-p (&optional _frame)
+  (> (frame-char-width)
+     (/ (float (frame-pixel-width)) (window-total-width (frame-root-window)))))
+
+(defun which-key--char-reduced-p (&optional _frame)
+  (< (frame-char-width)
+     (/ (float (frame-pixel-width)) (window-total-width (frame-root-window)))))
+
+(defun which-key--char-exact-p (&optional _frame)
+  (= (frame-char-width)
+     (/ (float (frame-pixel-width)) (window-total-width (frame-root-window)))))
+
+(defun which-key--width-or-percentage-to-width (width-or-percentage)
+  "Return window total width.
+If WIDTH-OR-PERCENTAGE is a whole number, return it unchanged.  Otherwise, it
+should be a percentage (a number between 0 and 1) out of the frame's width.
+More precisely, it should be a percentage out of the frame's root window's
+total width."
+  (if (wholenump width-or-percentage)
+      width-or-percentage
+    (round (* width-or-percentage (window-total-width (frame-root-window))))))
+
+(defun which-key--height-or-percentage-to-height (height-or-percentage)
+  "Return window total height.
+If HEIGHT-OR-PERCENTAGE is a whole number, return it unchanged.  Otherwise, it
+should be a percentage (a number between 0 and 1) out of the frame's height.
+More precisely, it should be a percentage out of the frame's root window's
+total height."
+  (if (wholenump height-or-percentage)
+      height-or-percentage
+    (round (* height-or-percentage (window-total-height (frame-root-window))))))
+
+(defun which-key--frame-size-changed-p ()
+  "Non-nil if a change in frame size is detected."
+  (let ((new-size (cons (frame-width) (frame-height))))
+    (cond ((null which-key--previous-frame-size)
+           (setq which-key--previous-frame-size new-size)
+           nil)
+          ((not (equal which-key--previous-frame-size new-size))
+           (setq which-key--previous-frame-size new-size)))))
+
+;;; Show/hide which-key buffer
+
+(defun which-key--hide-popup ()
+  "This function is called to hide the which-key buffer."
+  (unless (or which-key-persistent-popup
+              (member real-this-command which-key--paging-functions))
+    (setq which-key--last-try-2-loc nil)
+    (setq which-key--pages-obj nil)
+    (setq which-key--automatic-display nil)
+    (setq which-key--prior-show-keymap-args nil)
+    (when (and which-key-idle-secondary-delay which-key--secondary-timer-active)
+      (which-key--start-timer))
+    (which-key--lighter-restore)
+    (cl-case which-key-popup-type
+      ;; Not necessary to hide minibuffer
+      ;; (minibuffer (which-key--hide-buffer-minibuffer))
+      (side-window (which-key--hide-buffer-side-window))
+      (frame (which-key--hide-buffer-frame))
+      (custom (funcall which-key-custom-hide-popup-function)))))
+
+(defun which-key--hide-popup-ignore-command ()
+  "Version of `which-key--hide-popup' without the check of
+`real-this-command'."
+  (cl-case which-key-popup-type
+    (side-window (which-key--hide-buffer-side-window))
+    (frame (which-key--hide-buffer-frame))
+    (custom (funcall which-key-custom-hide-popup-function))))
+
+(defun which-key--hide-popup-on-frame-size-change (&optional _)
+  "Hide which-key popup if the frame is resized (to trigger a new
+popup)."
+  (when (which-key--frame-size-changed-p)
+    (which-key--hide-popup)))
+
+(defun which-key--hide-buffer-side-window ()
+  "Hide which-key buffer when side-window popup is used."
+  (when (buffer-live-p which-key--buffer)
+    ;; in case which-key buffer was shown in an existing window, `quit-window'
+    ;; will re-show the previous buffer, instead of closing the window
+    (quit-windows-on which-key--buffer)))
+
+(defun which-key--hide-buffer-frame ()
+  "Hide which-key buffer when frame popup is used."
+  (when (frame-live-p which-key--frame)
+    (delete-frame which-key--frame)))
+
+(defun which-key--popup-showing-p ()
+  (and (bufferp which-key--buffer)
+       (window-live-p (get-buffer-window which-key--buffer))))
+
+(defun which-key--show-popup (act-popup-dim)
+  "Show the which-key buffer.
+ACT-POPUP-DIM includes the dimensions, (height . width) of the
+buffer text to be displayed in the popup.  Return nil if no window
+is shown, or if there is no need to start the closing timer."
+  (when (and (> (car act-popup-dim) 0) (> (cdr act-popup-dim) 0))
+    (cl-case which-key-popup-type
+      ;; Not called for minibuffer
+      ;; (minibuffer (which-key--show-buffer-minibuffer act-popup-dim))
+      (side-window (which-key--show-buffer-side-window act-popup-dim))
+      (frame (which-key--show-buffer-frame act-popup-dim))
+      (custom (funcall which-key-custom-show-popup-function act-popup-dim)))))
+
+(defun which-key--fit-buffer-to-window-horizontally
+    (&optional window &rest params)
+  "Slightly modified version of `fit-buffer-to-window'.
+Use &rest params because `fit-buffer-to-window' has a different
+call signature in different emacs versions"
+  (let ((fit-window-to-buffer-horizontally t)
+        (window-min-height 1))
+    (apply #'fit-window-to-buffer window params)))
+
+(defun which-key--show-buffer-side-window (act-popup-dim)
+  "Show which-key buffer when popup type is side-window."
+  (let* ((height (car act-popup-dim))
+         (width (cdr act-popup-dim))
+         (alist
+          (if which-key-allow-imprecise-window-fit
+              `((window-width .  ,(which-key--text-width-to-total width))
+                (window-height . ,height)
+                (side . ,which-key-side-window-location)
+                (slot . ,which-key-side-window-slot))
+            `((window-width . which-key--fit-buffer-to-window-horizontally)
+              (window-height . (lambda (w) (fit-window-to-buffer w nil 1)))
+              (side . ,which-key-side-window-location)
+              (slot . ,which-key-side-window-slot)))))
+    ;; Previously used `display-buffer-in-major-side-window' here, but
+    ;; apparently that is meant to be an internal function. See emacs bug #24828
+    ;; and advice given there.
+    (cond
+     ((eq which-key--multiple-locations t)
+      ;; possibly want to switch sides in this case so we can't reuse the window
+      (delete-windows-on which-key--buffer)
+      (display-buffer-in-side-window which-key--buffer alist))
+     ((get-buffer-window which-key--buffer)
+      (display-buffer-reuse-window which-key--buffer alist))
+     (t
+      (display-buffer-in-side-window which-key--buffer alist)))))
+
+(defun which-key--show-buffer-frame (act-popup-dim)
+  "Show which-key buffer when popup type is frame."
+  (let* (;(orig-window (selected-window))
+         (frame-height (+ (car act-popup-dim)
+                          (if (with-current-buffer which-key--buffer
+                                mode-line-format)
+                              1
+                            0)))
+         ;; without adding 2, frame sometimes isn't wide enough for the buffer.
+         ;; this is probably because of the fringes. however, setting fringes
+         ;; sizes to 0 (instead of adding 2) didn't always make the frame wide
+         ;; enough. don't know why it is so.
+         (frame-width (+ (cdr act-popup-dim) 2))
+         (new-window (if (and (frame-live-p which-key--frame)
+                              (eq which-key--buffer
+                                  (window-buffer
+                                   (frame-root-window which-key--frame))))
+                         (which-key--show-buffer-reuse-frame
+                          frame-height frame-width)
+                       (which-key--show-buffer-new-frame
+                        frame-height frame-width))))
+    (when new-window
+      ;; display successful
+      (setq which-key--frame (window-frame new-window))
+      new-window)))
+
+(defun which-key--show-buffer-new-frame (frame-height frame-width)
+  "Helper for `which-key--show-buffer-frame'."
+  (let* ((frame-params `((height . ,frame-height)
+                         (width . ,frame-width)
+                         ;; tell the window manager to respect the given sizes
+                         (user-size . t)
+                         ;; which-key frame doesn't need a minibuffer
+                         (minibuffer . nil)
+                         (name . "which-key")
+                         ;; no need for scroll bars in which-key frame
+                         (vertical-scroll-bars . nil)
+                         ;; (left-fringe . 0)
+                         ;; (right-fringe . 0)
+                         ;; (right-divider-width . 0)
+                         ;; make sure frame is visible
+                         (visibility . t)))
+         (alist `((pop-up-frame-parameters . ,frame-params)))
+         (orig-frame (selected-frame))
+         (new-window (display-buffer-pop-up-frame which-key--buffer alist)))
+    (when new-window
+      ;; display successful
+      (redirect-frame-focus (window-frame new-window) orig-frame)
+      new-window)))
+
+(defun which-key--show-buffer-reuse-frame (frame-height frame-width)
+  "Helper for `which-key--show-buffer-frame'."
+  (let ((window
+         (display-buffer-reuse-window
+          which-key--buffer `((reusable-frames . ,which-key--frame)))))
+    (when window
+      ;; display successful
+      (set-frame-size (window-frame window) frame-width frame-height)
+      window)))
+
+;;; Max dimension of available window functions
+
+(defun which-key--popup-max-dimensions ()
+  "Dimesion functions should return the maximum possible (height
+. width) of the intended popup. SELECTED-WINDOW-WIDTH is the
+width of currently active window, not the which-key buffer
+window."
+  (cl-case which-key-popup-type
+    (minibuffer (which-key--minibuffer-max-dimensions))
+    (side-window (which-key--side-window-max-dimensions))
+    (frame (which-key--frame-max-dimensions))
+    (custom (funcall which-key-custom-popup-max-dimensions-function
+                     (window-width)))))
+
+(defun which-key--minibuffer-max-dimensions ()
+  "Return max-dimensions of minibuffer (height . width).
+Measured in lines and characters respectively."
+  (cons
+   ;; height
+   (if (floatp max-mini-window-height)
+       (floor (* (frame-text-lines)
+                 max-mini-window-height))
+     max-mini-window-height)
+   ;; width
+   (max 0 (- (frame-text-cols) which-key-unicode-correction))))
+
+(defun which-key--side-window-max-dimensions ()
+  "Return max-dimensions of the side-window popup (height .
+width) in lines and characters respectively."
+  (cons
+   ;; height
+   (if (member which-key-side-window-location '(left right))
+       ;; 1 is a kludge to make sure there is no overlap
+       (- (frame-height) (window-text-height (minibuffer-window)) 1)
+     ;; (window-mode-line-height which-key--window))
+     ;; FIXME: change to something like
+     ;; (min which-*-height (calculate-max-height))
+     (which-key--height-or-percentage-to-height
+      which-key-side-window-max-height))
+   ;; width
+   (max 0
+        (- (if (member which-key-side-window-location '(left right))
+               (which-key--total-width-to-text
+                (which-key--width-or-percentage-to-width
+                 which-key-side-window-max-width))
+             (which-key--total-width-to-text
+              (which-key--width-or-percentage-to-width
+               1.0)))
+           which-key-unicode-correction))))
+
+(defun which-key--frame-max-dimensions ()
+  "Return max-dimensions of the frame popup (height .
+width) in lines and characters respectively."
+  (cons which-key-frame-max-height which-key-frame-max-width))
+
+;;; Sorting functions
+
+(defun which-key--string< (a b &optional alpha)
+  (let ((da (downcase a))
+        (db (downcase b)))
+    (cond
+     ((and alpha (not which-key-sort-uppercase-first))
+      (if (string-equal da db)
+          (not (string-lessp a b))
+        (string-lessp da db)))
+     ((and alpha which-key-sort-uppercase-first)
+      (if (string-equal da db)
+          (string-lessp a b)
+        (string-lessp da db)))
+     ((not which-key-sort-uppercase-first)
+      (let ((aup (not (string-equal da a)))
+            (bup (not (string-equal db b))))
+        (if (eq aup bup)
+            (string-lessp a b)
+          bup)))
+     (t (string-lessp a b)))))
+
+(defun which-key--key-description< (a b &optional alpha)
+  "Sorting function used for `which-key-key-order' and
+`which-key-key-order-alpha'."
+  (save-match-data
+    (let* ((rngrgxp "^\\([^ ]+\\) \\.\\. [^ ]+")
+           (a (if (string-match rngrgxp a) (match-string 1 a) a))
+           (b (if (string-match rngrgxp b) (match-string 1 b) b))
+           (aem? (string-equal a ""))
+           (bem? (string-equal b ""))
+           (a1? (= 1 (length a)))
+           (b1? (= 1 (length b)))
+           (srgxp "^\\(RET\\|SPC\\|TAB\\|DEL\\|LFD\\|ESC\\|NUL\\)")
+           (asp? (string-match-p srgxp a))
+           (bsp? (string-match-p srgxp b))
+           (prrgxp "^\\(M\\|C\\|S\\|A\\|H\\|s\\)-")
+           (apr? (string-match-p prrgxp a))
+           (bpr? (string-match-p prrgxp b))
+           (afn? (string-match-p "" a))
+           (bfn? (string-match-p "" b)))
+      (cond ((or aem? bem?) (and aem? (not bem?)))
+            ((and asp? bsp?)
+             (if (string-equal (substring a 0 3) (substring b 0 3))
+                 (which-key--key-description<
+                  (substring a 3) (substring b 3) alpha)
+               (which-key--string< a b alpha)))
+            ((or asp? bsp?) asp?)
+            ((and a1? b1?) (which-key--string< a b alpha))
+            ((or a1? b1?) a1?)
+            ((and afn? bfn?)
+             (< (string-to-number
+                 (replace-regexp-in-string "" "\\1" a))
+                (string-to-number
+                 (replace-regexp-in-string "" "\\1" b))))
+            ((or afn? bfn?) afn?)
+            ((and apr? bpr?)
+             (if (string-equal (substring a 0 2) (substring b 0 2))
+                 (which-key--key-description<
+                  (substring a 2) (substring b 2) alpha)
+               (which-key--string< a b alpha)))
+            ((or apr? bpr?) apr?)
+            (t (which-key--string< a b alpha))))))
+
+(defsubst which-key-key-order-alpha (acons bcons)
+  "Order key descriptions A and B.
+Order is lexicographic within a \"class\", where the classes and
+the ordering of classes are listed below.
+
+special (SPC,TAB,...) < single char < mod (C-,M-,...) < other.
+Sorts single characters alphabetically with lowercase coming
+before upper."
+  (which-key--key-description< (car acons) (car bcons) t))
+
+(defsubst which-key-key-order (acons bcons)
+  "Order key descriptions A and B.
+Order is lexicographic within a \"class\", where the classes and
+the ordering of classes are listed below.
+
+special (SPC,TAB,...) < single char < mod (C-,M-,...) < other."
+  (which-key--key-description< (car acons) (car bcons)))
+
+(defsubst which-key-description-order (acons bcons)
+  "Order descriptions of A and B.
+Uses `string-lessp' after applying lowercase."
+  (string-lessp (downcase (cdr acons)) (downcase (cdr bcons))))
+
+(defsubst which-key--group-p (description)
+  (or (string-match-p "^\\(group:\\|Prefix\\)" description)
+      (keymapp (intern description))))
+
+(defun which-key-prefix-then-key-order (acons bcons)
+  "Order first by whether A and/or B is a prefix with no prefix
+coming before a prefix. Within these categories order using
+`which-key-key-order'."
+  (let ((apref? (which-key--group-p (cdr acons)))
+        (bpref? (which-key--group-p (cdr bcons))))
+    (if (not (eq apref? bpref?))
+        (and (not apref?) bpref?)
+      (which-key-key-order acons bcons))))
+
+(defun which-key-prefix-then-key-order-reverse (acons bcons)
+  "Order first by whether A and/or B is a prefix with prefix
+coming before a prefix. Within these categories order using
+`which-key-key-order'."
+  (let ((apref? (which-key--group-p (cdr acons)))
+        (bpref? (which-key--group-p (cdr bcons))))
+    (if (not (eq apref? bpref?))
+        (and apref? (not bpref?))
+      (which-key-key-order acons bcons))))
+
+(defun which-key-local-then-key-order (acons bcons)
+  "Order first by whether A and/or B is a local binding with
+local bindings coming first. Within these categories order using
+`which-key-key-order'."
+  (let ((aloc? (which-key--local-binding-p acons))
+        (bloc? (which-key--local-binding-p bcons)))
+    (if (not (eq aloc? bloc?))
+        (and aloc? (not bloc?))
+      (which-key-key-order acons bcons))))
+
+;;; Functions for retrieving and formatting keys
+
+(defsubst which-key--string-width (maybe-string)
+  "If MAYBE-STRING is a string use `which-key--string-width' o/w return 0."
+  (if (stringp maybe-string) (string-width maybe-string) 0))
+
+(defsubst which-key--safe-lookup-key (keymap key)
+  "Version of `lookup-key' that allows KEYMAP to be nil. KEY is not checked."
+  (when (keymapp keymap) (lookup-key keymap key)))
+
+(defsubst which-key--butlast-string (str)
+  (mapconcat #'identity (butlast (split-string str)) " "))
+
+(defun which-key--match-replacement (key-binding replacement)
+  ;; these are mode specific ones to ignore. The mode specific case is
+  ;; handled in the selection of alist
+  (when (and (consp key-binding) (not (symbolp (car replacement))))
+    (let ((key-regexp (caar replacement))
+          (binding-regexp (cdar replacement))
+          case-fold-search)
+      (and (or (null key-regexp)
+               (string-match-p key-regexp
+                               (car key-binding)))
+           (or (null binding-regexp)
+               (string-match-p binding-regexp
+                               (cdr key-binding)))))))
+
+(defun which-key--get-pseudo-binding (key-binding &optional prefix)
+  (let* ((pseudo-binding
+          (key-binding (which-key--pseudo-key (kbd (car key-binding)) prefix)))
+         (pseudo-binding (when pseudo-binding (cadr pseudo-binding)))
+         (pseudo-desc (when pseudo-binding (car pseudo-binding)))
+         (pseudo-def (when pseudo-binding (cdr pseudo-binding)))
+         (real-def (key-binding (kbd (car key-binding))))
+         ;; treat keymaps as if they're nil bindings. This creates the
+         ;; possibility that we rename the wrong binding but this seems
+         ;; unlikely.
+         (real-def (unless (keymapp real-def) real-def)))
+    (when (and pseudo-binding
+               (eq pseudo-def real-def))
+      (cons (car key-binding) pseudo-desc))))
+
+(defun which-key--maybe-replace (key-binding &optional prefix)
+  "Use `which-key--replacement-alist' to maybe replace KEY-BINDING.
+KEY-BINDING is a cons cell of the form \(KEY . BINDING\) each of
+which are strings. KEY is of the form produced by `key-binding'."
+  (let* ((pseudo-binding (which-key--get-pseudo-binding key-binding prefix))
+         one-match)
+    (if pseudo-binding
+        pseudo-binding
+      (let* ((all-repls
+              (append (cdr-safe (assq major-mode which-key-replacement-alist))
+                      which-key-replacement-alist)))
+        (dolist (repl all-repls key-binding)
+          (when (and (or which-key-allow-multiple-replacements
+                         (not one-match))
+                     (which-key--match-replacement key-binding repl))
+            (setq one-match t)
+            (setq key-binding
+                  (cond ((or (not (consp repl)) (null (cdr repl)))
+                         key-binding)
+                        ((functionp (cdr repl))
+                         (funcall (cdr repl) key-binding))
+                        ((consp (cdr repl))
+                         (cons
+                          (cond ((and (caar repl) (cadr repl))
+                                 (replace-regexp-in-string
+                                  (caar repl) (cadr repl) (car key-binding) t))
+                                ((cadr repl) (cadr repl))
+                                (t (car key-binding)))
+                          (cond ((and (cdar repl) (cddr repl))
+                                 (replace-regexp-in-string
+                                  (cdar repl) (cddr repl) (cdr key-binding) t))
+                                ((cddr repl) (cddr repl))
+                                (t (cdr key-binding)))))))))))))
+
+(defsubst which-key--current-key-list (&optional key-str)
+  (append (listify-key-sequence (which-key--current-prefix))
+          (when key-str
+            (listify-key-sequence (kbd key-str)))))
+
+(defsubst which-key--current-key-string (&optional key-str)
+  (key-description (which-key--current-key-list key-str)))
+
+(defun which-key--local-binding-p (keydesc)
+  (eq (which-key--safe-lookup-key
+       (current-local-map) (kbd (which-key--current-key-string (car keydesc))))
+      (intern (cdr keydesc))))
+
+(defun which-key--map-binding-p (map keydesc)
+  "Does MAP contain KEYDESC = (key . binding)?"
+  (or
+   (when (bound-and-true-p evil-state)
+     (let ((lookup
+            (which-key--safe-lookup-key
+             map
+             (kbd (which-key--current-key-string
+                   (format "<%s-state> %s" evil-state (car keydesc)))))))
+       (or (eq lookup (intern (cdr keydesc)))
+           (and (keymapp lookup) (string= (cdr keydesc) "Prefix Command")))))
+   (let ((lookup
+          (which-key--safe-lookup-key
+           map (kbd (which-key--current-key-string (car keydesc))))))
+     (or (eq lookup (intern (cdr keydesc)))
+         (and (keymapp lookup) (string= (cdr keydesc) "Prefix Command"))))))
+
+(defun which-key--pseudo-key (key &optional prefix)
+  "Replace the last key in the sequence KEY by a special symbol
+in order for which-key to allow looking up a description for the key."
+  (let* ((seq (listify-key-sequence key))
+         (final (intern (format "which-key-%s" (key-description (last seq))))))
+    (if prefix
+        (vconcat prefix (list final))
+      (vconcat (butlast seq) (list final)))))
+
+(defun which-key--maybe-get-prefix-title (keys)
+  "KEYS is a string produced by `key-description'.
+A title is possibly returned using
+`which-key--prefix-title-alist'.  An empty string is returned if
+no title exists."
+  (cond
+   ((not (string-equal keys ""))
+    (let* ((title-res
+            (cdr-safe (assoc-string keys which-key--prefix-title-alist)))
+           (repl-res
+            (cdr-safe (which-key--maybe-replace (cons keys ""))))
+           (binding (key-binding (kbd keys)))
+           (alternate (when (and binding (symbolp binding))
+                        (symbol-name binding))))
+      (cond (title-res title-res)
+            ((not (string-equal repl-res "")) repl-res)
+            ((and (eq which-key-show-prefix 'echo) alternate)
+             alternate)
+            ((and (member which-key-show-prefix '(bottom top mode-line))
+                  (eq which-key-side-window-location 'bottom)
+                  echo-keystrokes)
+             (if alternate alternate
+               (concat "Following " keys)))
+            (t ""))))
+   (t "")))
+
+(defun which-key--propertize (string &rest properties)
+  "Version of `propertize' that checks type of STRING."
+  (when (stringp string)
+    (apply #'propertize string properties)))
+
+(defun which-key--propertize-key (key)
+  "Add a face to KEY.
+If KEY contains any \"special keys\" defined in
+`which-key-special-keys' then truncate and add the corresponding
+`which-key-special-key-face'."
+  (let ((key-w-face (which-key--propertize key 'face 'which-key-key-face))
+        (regexp (concat "\\("
+                        (mapconcat 'identity which-key-special-keys
+                                   "\\|") "\\)"))
+        case-fold-search)
+    (save-match-data
+      (if (and which-key-special-keys
+               (string-match regexp key))
+          (let ((beg (match-beginning 0)) (end (match-end 0)))
+            (concat (substring key-w-face 0 beg)
+                    (which-key--propertize (substring key-w-face beg (1+ beg))
+                                'face 'which-key-special-key-face)
+                    (substring key-w-face end
+                               (which-key--string-width key-w-face))))
+        key-w-face))))
+
+(defsubst which-key--truncate-description (desc)
+  "Truncate DESC description to `which-key-max-description-length'."
+  (let* ((last-face (get-text-property (1- (length desc)) 'face desc))
+         (dots (which-key--propertize ".." 'face last-face)))
+    (if (and which-key-max-description-length
+             (> (length desc) which-key-max-description-length))
+        (concat (substring desc 0 which-key-max-description-length) dots)
+      desc)))
+
+(defun which-key--highlight-face (description)
+  "Return the highlight face for DESCRIPTION if it has one."
+  (let (face)
+    (dolist (el which-key-highlighted-command-list)
+      (unless face
+        (cond ((consp el)
+               (when (string-match-p (car el) description)
+                 (setq face (cdr el))))
+              ((stringp el)
+               (when (string-match-p el description)
+                 (setq face 'which-key-highlighted-command-face)))
+              (t
+               (message "which-key: warning: element %s of \
+which-key-highlighted-command-list is not a string or a cons
+cell" el)))))
+    face))
+
+(defun which-key--propertize-description
+    (description group local hl-face &optional original-description)
+  "Add face to DESCRIPTION where the face chosen depends on
+whether the description represents a group or a command. Also
+make some minor adjustments to the description string, like
+removing a \"group:\" prefix.
+
+ORIGINAL-DESCRIPTION is the description given by
+`describe-buffer-bindings'."
+  (when description
+    (let* ((desc description)
+           (desc (if (string-match-p "^group:" desc)
+                     (substring desc 6) desc))
+           (desc (if group (concat which-key-prefix-prefix desc) desc)))
+      (make-text-button
+       desc nil
+       'face (cond (hl-face hl-face)
+                   (group 'which-key-group-description-face)
+                   (local 'which-key-local-map-description-face)
+                   (t 'which-key-command-description-face))
+       'help-echo (cond
+                   ((and original-description
+                         (fboundp (intern original-description))
+                         (documentation (intern original-description))
+                         ;; tooltip-mode doesn't exist in emacs-nox
+                         (boundp 'tooltip-mode) tooltip-mode)
+                    (documentation (intern original-description)))
+                   ((and original-description
+                         (fboundp (intern original-description))
+                         (documentation (intern original-description))
+                         (let* ((doc (documentation
+                                      (intern original-description)))
+                                (str (replace-regexp-in-string "\n" " " doc))
+                                (max (floor (* (frame-width) 0.8))))
+                           (if (> (length str) max)
+                               (concat (substring str 0 max) "...")
+                             str)))))))))
+
+(defun which-key--extract-key (key-str)
+  "Pull the last key (or key range) out of KEY-STR."
+  (save-match-data
+    (let ((key-range-regexp "\\`.*\\([^ \t]+ \\.\\. [^ \t]+\\)\\'"))
+      (if (string-match key-range-regexp key-str)
+          (match-string 1 key-str)
+        (car (last (split-string key-str " ")))))))
+
+(defun which-key--maybe-add-docstring (current original)
+  "Maybe concat a docstring to CURRENT and return result.
+Specifically, do this if ORIGINAL is a command with a docstring
+and `which-key-show-docstrings' is non-nil. If
+`which-key-show-docstrings' is the symbol docstring-only, just
+return the docstring."
+  (let* ((orig-sym (intern original))
+         (doc (when (commandp orig-sym)
+                (documentation orig-sym)))
+         (doc (when doc
+                (replace-regexp-in-string
+                 (concat "^\\(?::"
+                         (regexp-opt '("around" "override"
+                                       "after" "after-until" "after-while"
+                                       "before" "before-until" "before-while"
+                                       "filter-args" "filter-return"))
+                         " advice: [^\n]+\n"
+                         "\\)+\n")
+                 "" doc)))
+         (docstring (when doc
+                      (which-key--propertize (car (split-string doc "\n"))
+                                             'face 'which-key-docstring-face))))
+    (cond ((not (and which-key-show-docstrings docstring))
+           current)
+          ((eq which-key-show-docstrings 'docstring-only)
+           docstring)
+          (t
+           (format "%s %s" current docstring)))))
+
+(defun which-key--format-and-replace (unformatted &optional prefix preserve-full-key)
+  "Take a list of (key . desc) cons cells in UNFORMATTED, add
+faces and perform replacements according to the three replacement
+alists. Returns a list (key separator description)."
+  (let ((sep-w-face
+         (which-key--propertize which-key-separator
+                                'face 'which-key-separator-face))
+        (local-map (current-local-map))
+        new-list)
+    (dolist (key-binding unformatted)
+      (let* ((key (car key-binding))
+             (orig-desc (cdr key-binding))
+             (group (which-key--group-p orig-desc))
+             ;; At top-level prefix is nil
+             (keys (if prefix
+                       (concat (key-description prefix) " " key)
+                     key))
+             (local (eq (which-key--safe-lookup-key local-map (kbd keys))
+                        (intern orig-desc)))
+             (hl-face (which-key--highlight-face orig-desc))
+             (key-binding (which-key--maybe-replace (cons keys orig-desc) prefix))
+             (final-desc (which-key--propertize-description
+                          (cdr key-binding) group local hl-face orig-desc)))
+        (when final-desc
+          (setq final-desc
+                (which-key--truncate-description
+                 (which-key--maybe-add-docstring final-desc orig-desc))))
+        (when (consp key-binding)
+          (push
+           (list (which-key--propertize-key
+                  (if preserve-full-key
+                      (car key-binding)
+                    (which-key--extract-key (car key-binding))))
+                 sep-w-face
+                 final-desc)
+           new-list))))
+    (nreverse new-list)))
+
+(defun which-key--get-keymap-bindings (keymap &optional all prefix)
+  "Retrieve top-level bindings from KEYMAP.
+If ALL is non-nil, get all bindings, not just the top-level
+ones. PREFIX is for internal use and should not be used."
+  (let (bindings)
+    (map-keymap
+     (lambda (ev def)
+       (let* ((key (append prefix (list ev)))
+              (key-desc (key-description key)))
+         (cond ((or (string-match-p
+                     which-key--ignore-non-evil-keys-regexp key-desc)
+                    (eq ev 'menu-bar)))
+               ;; extract evil keys corresponding to current state
+               ((and (keymapp def)
+                     (boundp 'evil-state)
+                     (bound-and-true-p evil-local-mode)
+                     (string-match-p (format "<%s-state>$" evil-state) key-desc))
+                (setq bindings
+                      ;; this function keeps the latter of the two duplicates
+                      ;; which will be the evil binding
+                      (cl-remove-duplicates
+                       (append bindings
+                               (which-key--get-keymap-bindings def all prefix))
+                       :test (lambda (a b) (string= (car a) (car b))))))
+               ((and (keymapp def)
+                     (string-match-p which-key--evil-keys-regexp key-desc)))
+               ((and (keymapp def)
+                     (or all
+                         ;; event 27 is escape, so this will pick up meta
+                         ;; bindings and hopefully not too much more
+                         (and (numberp ev) (= ev 27))))
+                (setq bindings
+                      (append bindings
+                              (which-key--get-keymap-bindings def t key))))
+               (t
+                (when def
+                  (cl-pushnew
+                   (cons key-desc
+                         (cond
+                          ((keymapp def) "Prefix Command")
+                          ((symbolp def) (copy-sequence (symbol-name def)))
+                          ((eq 'lambda (car-safe def)) "lambda")
+                          ((eq 'menu-item (car-safe def)) "menu-item")
+                          ((stringp def) def)
+                          ((vectorp def) (key-description def))
+                          (t "unknown")))
+                   bindings :test (lambda (a b) (string= (car a) (car b)))))))))
+     keymap)
+    bindings))
+
+(defun which-key--compute-binding (binding)
+  "Replace BINDING with remapped binding if it exists.
+
+Requires `which-key-compute-remaps' to be non-nil"
+  (let (remap)
+    (if (and which-key-compute-remaps
+             (setq remap (command-remapping (intern binding))))
+        (copy-sequence (symbol-name remap))
+      binding)))
+
+(defun which-key--get-current-bindings (&optional prefix)
+  "Generate a list of current active bindings."
+  (let ((key-str-qt (regexp-quote (key-description prefix)))
+        (buffer (current-buffer))
+        (ignore-bindings '("self-insert-command" "ignore"
+                           "ignore-event" "company-ignore"))
+        (ignore-sections-regexp
+         (eval-when-compile
+           (regexp-opt '("Key translations" "Function key map translations"
+                         "Input decoding map translations")))))
+    (with-temp-buffer
+      (setq-local indent-tabs-mode t)
+      (setq-local tab-width 8)
+      (describe-buffer-bindings buffer prefix)
+      (goto-char (point-min))
+      (let ((header-p (not (= (char-after) ?\f)))
+            bindings header)
+        (while (not (eobp))
+          (cond
+           (header-p
+            (setq header (buffer-substring-no-properties
+                          (point)
+                          (line-end-position)))
+            (setq header-p nil)
+            (forward-line 3))
+           ((= (char-after) ?\f)
+            (setq header-p t))
+           ((looking-at "^[ \t]*$"))
+           ((or (not (string-match-p ignore-sections-regexp header)) prefix)
+            (let ((binding-start (save-excursion
+                                   (and (re-search-forward "\t+" nil t)
+                                        (match-end 0))))
+                  key binding)
+              (when binding-start
+                (setq key (buffer-substring-no-properties
+                           (point) binding-start))
+                (setq binding (buffer-substring-no-properties
+                               binding-start
+                               (line-end-position)))
+                (save-match-data
+                  (cond
+                   ((member binding ignore-bindings))
+                   ((string-match-p which-key--ignore-keys-regexp key))
+                   ((and prefix
+                         (string-match (format "^%s[ \t]\\([^ \t]+\\)[ \t]+$"
+                                               key-str-qt) key))
+                    (unless (assoc-string (match-string 1 key) bindings)
+                      (push (cons (match-string 1 key)
+                                  (which-key--compute-binding binding))
+                            bindings)))
+                   ((and prefix
+                         (string-match
+                          (format
+                           "^%s[ \t]\\([^ \t]+\\) \\.\\. %s[ \t]\\([^ \t]+\\)[ \t]+$"
+                           key-str-qt key-str-qt) key))
+                    (let ((stripped-key (concat (match-string 1 key)
+                                                " \.\. "
+                                                (match-string 2 key))))
+                      (unless (assoc-string stripped-key bindings)
+                        (push (cons stripped-key
+                                    (which-key--compute-binding binding))
+                              bindings))))
+                   ((string-match
+                     "^\\([^ \t]+\\|[^ \t]+ \\.\\. [^ \t]+\\)[ \t]+$" key)
+                    (unless (assoc-string (match-string 1 key) bindings)
+                      (push (cons (match-string 1 key)
+                                  (which-key--compute-binding binding))
+                            bindings)))))))))
+          (forward-line))
+        (nreverse bindings)))))
+
+(defun which-key--get-bindings (&optional prefix keymap filter recursive)
+  "Collect key bindings.
+If KEYMAP is nil, collect from current buffer using the current
+key sequence as a prefix. Otherwise, collect from KEYMAP. FILTER
+is a function to use to filter the bindings. If RECURSIVE is
+non-nil, then bindings are collected recursively for all prefixes."
+  (let* ((unformatted
+          (cond ((keymapp keymap)
+                 (which-key--get-keymap-bindings keymap recursive))
+                (keymap
+                 (error "%s is not a keymap" keymap))
+                (t
+                 (which-key--get-current-bindings prefix)))))
+    (when filter
+      (setq unformatted (cl-remove-if-not filter unformatted)))
+    (when which-key-sort-order
+      (setq unformatted
+            (sort unformatted which-key-sort-order)))
+    (which-key--format-and-replace unformatted prefix recursive)))
+
+;;; Functions for laying out which-key buffer pages
+
+(defun which-key--normalize-columns (columns)
+  "Pad COLUMNS to the same length using empty strings."
+  (let ((max-len (cl-reduce (lambda (a x) (max a (length x))) columns
+                            :initial-value 0)))
+    (mapcar
+     (lambda (c)
+       (if (< (length c) max-len)
+           (append c (make-list (- max-len (length c)) ""))
+         c))
+     columns)))
+
+(defsubst which-key--join-columns (columns)
+  "Transpose columns into rows, concat rows into lines and rows into page."
+  (let* ((padded (which-key--normalize-columns (nreverse columns)))
+         (rows (apply #'cl-mapcar #'list padded)))
+    (mapconcat (lambda (row) (mapconcat #'identity row " ")) rows "\n")))
+
+(defsubst which-key--max-len (keys index)
+  "Internal function for finding the max length of the INDEX
+element in each list element of KEYS."
+  (cl-reduce
+   (lambda (x y) (max x (which-key--string-width (nth index y))))
+   keys :initial-value 0))
+
+(defun which-key--pad-column (col-keys)
+  "Take a column of (key separator description) COL-KEYS,
+calculate the max width in the column and pad all cells out to
+that width."
+  (let* ((col-key-width  (+ which-key-add-column-padding
+                            (which-key--max-len col-keys 0)))
+         (col-sep-width  (which-key--max-len col-keys 1))
+         (col-desc-width (which-key--max-len col-keys 2))
+         (col-width      (+ 1 col-key-width col-sep-width col-desc-width)))
+    (cons col-width
+          (mapcar (lambda (k)
+                    (format (concat "%" (int-to-string col-key-width)
+                                    "s%s%-" (int-to-string col-desc-width) "s")
+                            (nth 0 k) (nth 1 k) (nth 2 k)))
+                  col-keys))))
+
+(defun which-key--partition-list (n list)
+  "Partition LIST into N-sized sublists."
+  (let (res)
+    (while list
+      (setq res (cons (cl-subseq list 0 (min n (length list))) res)
+            list (nthcdr n list)))
+    (nreverse res)))
+
+(defun which-key--list-to-pages (keys avl-lines avl-width)
+  "Convert list of KEYS to columns based on dimensions AVL-LINES and AVL-WIDTH.
+Returns a `which-key--pages' object that holds the page strings,
+as well as metadata."
+  (let ((cols-w-widths (mapcar #'which-key--pad-column
+                               (which-key--partition-list avl-lines keys)))
+        (page-width 0) (n-pages 0) (n-keys 0) (n-columns 0)
+        page-cols pages page-widths keys/page col)
+    (if (> (apply #'max (mapcar #'car cols-w-widths)) avl-width)
+        ;; give up if no columns fit
+        nil
+      (while cols-w-widths
+        ;; start new page
+        (cl-incf n-pages)
+        (setq col (pop cols-w-widths))
+        (setq page-cols (list (cdr col)))
+        (setq page-width (car col))
+        (setq n-keys (length (cdr col)))
+        (setq n-columns 1)
+        ;; add additional columns as long as they fit
+        (while (and cols-w-widths
+                    (or (null which-key-max-display-columns)
+                        (< n-columns which-key-max-display-columns))
+                    (<= (+ (caar cols-w-widths) page-width) avl-width))
+          (setq col (pop cols-w-widths))
+          (push (cdr col) page-cols)
+          (cl-incf page-width (car col))
+          (cl-incf n-keys (length (cdr col)))
+          (cl-incf n-columns))
+        (push (which-key--join-columns page-cols) pages)
+        (push n-keys keys/page)
+        (push page-width page-widths))
+      (make-which-key--pages
+       :pages (nreverse pages)
+       :height (if (> n-pages 1) avl-lines (min avl-lines n-keys))
+       :widths (nreverse page-widths)
+       :keys/page (reverse keys/page)
+       :page-nums (number-sequence 1 n-pages)
+       :num-pages n-pages
+       :total-keys (apply #'+ keys/page)))))
+
+(defun which-key--create-pages-1
+    (keys available-lines available-width &optional min-lines vertical)
+  "Create page strings using `which-key--list-to-pages'.
+Will try to find the best number of rows and columns using the
+given dimensions and the length and widths of ITEMS. Use VERTICAL
+if the ITEMS are laid out vertically and the number of columns
+should be minimized."
+  (let ((result (which-key--list-to-pages
+                 keys available-lines available-width))
+        (min-lines (or min-lines 0))
+        found prev-result)
+    (if (or (null result)
+            vertical
+            (> (which-key--pages-num-pages result) 1)
+            (= 1 available-lines))
+        result
+      ;; simple search for a fitting page
+      (while (and (> available-lines min-lines)
+                  (not found))
+        (setq available-lines (- available-lines 1)
+              prev-result result
+              result (which-key--list-to-pages
+                      keys available-lines available-width)
+              found (> (which-key--pages-num-pages result) 1)))
+      (if found prev-result result))))
+
+(defun which-key--create-pages (keys &optional prefix-keys prefix-title)
+  "Create page strings using `which-key--list-to-pages'.
+Will try to find the best number of rows and columns using the
+given dimensions and the length and wdiths of KEYS. SEL-WIN-WIDTH
+is the width of the live window."
+  (let* ((max-dims (which-key--popup-max-dimensions))
+         (max-lines (car max-dims))
+         (max-width (cdr max-dims))
+         (prefix-desc (key-description prefix-keys))
+         (full-prefix (which-key--full-prefix prefix-desc))
+         (prefix (when (eq which-key-show-prefix 'left)
+                   (+ 2 (which-key--string-width full-prefix))))
+         (prefix-top-bottom (member which-key-show-prefix '(bottom top)))
+         (avl-lines (if prefix-top-bottom (- max-lines 1) max-lines))
+         (min-lines (min avl-lines which-key-min-display-lines))
+         (avl-width (if prefix (- max-width prefix) max-width))
+         (vertical (and (eq which-key-popup-type 'side-window)
+                        (member which-key-side-window-location '(left right))))
+         result)
+    (setq result
+          (which-key--create-pages-1
+           keys avl-lines avl-width min-lines vertical))
+    (when (and result
+               (> (which-key--pages-num-pages result) 0))
+      (setf (which-key--pages-prefix result) prefix-keys)
+      (setf (which-key--pages-prefix-title result)
+            (or prefix-title
+                (which-key--maybe-get-prefix-title
+                 (key-description prefix-keys))))
+      (which-key--debug-message "Frame height: %s
+Minibuffer height: %s
+Max dimensions: (%s,%s)
+Available for bindings: (%s,%s)
+Actual lines: %s" (frame-height) (window-text-height (minibuffer-window))
+max-lines max-width avl-lines avl-width (which-key--pages-height result))
+      result)))
+
+(defun which-key--lighter-status ()
+  "Possibly show number of keys and total in the mode line."
+  (when which-key-show-remaining-keys
+    (let ((n-shown (car (which-key--pages-keys/page which-key--pages-obj)))
+          (n-tot (which-key--pages-total-keys which-key--pages-obj)))
+      (setcar (cdr (assq 'which-key-mode minor-mode-alist))
+              (format " WK: %s/%s keys" n-shown n-tot)))))
+
+(defun which-key--lighter-restore ()
+  "Restore the lighter for which-key."
+  (when which-key-show-remaining-keys
+    (setcar (cdr (assq 'which-key-mode minor-mode-alist))
+            which-key-lighter)))
+
+(defun which-key--echo (text)
+  "Echo TEXT to minibuffer without logging."
+  (let (message-log-max)
+    (message "%s" text)))
+
+(defun which-key--next-page-hint (prefix-keys)
+  "Return string for next page hint."
+  (let* ((paging-key (concat prefix-keys " " which-key-paging-key))
+         (paging-key-bound (eq 'which-key-C-h-dispatch
+                               (key-binding (kbd paging-key))))
+         (key (key-description (vector help-char)))
+         (key (if paging-key-bound
+                  (concat key " or " which-key-paging-key)
+                key)))
+    (when which-key-use-C-h-commands
+      (which-key--propertize (format "[%s paging/help]" key)
+                             'face 'which-key-note-face))))
+
+(eval-and-compile
+  (if (fboundp 'universal-argument--description)
+      (defalias 'which-key--universal-argument--description
+        'universal-argument--description)
+    (defun which-key--universal-argument--description ()
+      ;; Backport of the definition of universal-argument--description in
+      ;; emacs25 on 2015-12-04
+      (when prefix-arg
+        (concat "C-u"
+                (pcase prefix-arg
+                  (`(-) " -")
+                  (`(,(and (pred integerp) n))
+                   (let ((str ""))
+                     (while (and (> n 4) (= (mod n 4) 0))
+                       (setq str (concat str " C-u"))
+                       (setq n (/ n 4)))
+                     (if (= n 4) str (format " %s" prefix-arg))))
+                  (_ (format " %s" prefix-arg))))))))
+
+(defun which-key--full-prefix (prefix-keys &optional -prefix-arg dont-prop-keys)
+  "Return a description of the full key sequence up to now,
+including prefix arguments."
+  (let* ((left (eq which-key-show-prefix 'left))
+         (prefix-arg (if -prefix-arg -prefix-arg prefix-arg))
+         (str (concat
+               (which-key--universal-argument--description)
+               (when prefix-arg " ")
+               prefix-keys))
+         (dash (if (and (not (string= prefix-keys ""))
+                        (null left)) "-" "")))
+    (if (or (eq which-key-show-prefix 'echo) dont-prop-keys)
+        (concat str dash)
+      (concat (which-key--propertize-key str)
+              (which-key--propertize dash 'face 'which-key-key-face)))))
+
+(defun which-key--get-popup-map ()
+  "Generate transient-map for use in the top level binding display."
+  (unless which-key--automatic-display
+    (let ((map (make-sparse-keymap)))
+      (define-key map (kbd which-key-paging-key) #'which-key-C-h-dispatch)
+      (when which-key-use-C-h-commands
+        ;; Show next page even when C-h is pressed
+        (define-key map (vector help-char) #'which-key-C-h-dispatch))
+      map)))
+
+(defun which-key--process-page (pages-obj)
+  "Add information to the basic list of key bindings, including
+if applicable the current prefix, the name of the current prefix,
+and a page count."
+  (let* ((page (car (which-key--pages-pages pages-obj)))
+         (height (which-key--pages-height pages-obj))
+         (n-pages (which-key--pages-num-pages pages-obj))
+         (page-n (car (which-key--pages-page-nums pages-obj)))
+         (prefix-desc (key-description (which-key--pages-prefix pages-obj)))
+         (prefix-title (which-key--pages-prefix-title pages-obj))
+         (full-prefix (which-key--full-prefix prefix-desc))
+         (nxt-pg-hint (which-key--next-page-hint prefix-desc))
+         ;; not used in left case
+         (status-line
+          (concat (which-key--propertize prefix-title 'face 'which-key-note-face)
+                  (when (< 1 n-pages)
+                    (which-key--propertize (format " (%s of %s)" page-n n-pages)
+                                           'face 'which-key-note-face)))))
+    (pcase which-key-show-prefix
+      (`left
+       (let* ((page-cnt (which-key--propertize (format "%s/%s" page-n n-pages)
+                                               'face 'which-key-separator-face))
+              (first-col-width (+ 2 (max (which-key--string-width full-prefix)
+                                         (which-key--string-width page-cnt))))
+              (prefix (format (concat "%-" (int-to-string first-col-width) "s")
+                              full-prefix))
+              (page-cnt (if (> n-pages 1)
+                            (format
+                             (concat "%-" (int-to-string first-col-width) "s")
+                             page-cnt)
+                          (make-string first-col-width 32)))
+              lines first-line new-end)
+         (if (= 1 height)
+             (cons (concat prefix page) nil)
+           (setq lines (split-string page "\n")
+                 first-line (concat prefix (car lines) "\n" page-cnt)
+                 new-end (concat "\n" (make-string first-col-width 32)))
+           (cons
+            (concat first-line (mapconcat #'identity (cdr lines) new-end))
+            nil))))
+      (`top
+       (cons
+        (concat (when (or (= 0 echo-keystrokes)
+                          (not (eq which-key-side-window-location 'bottom)))
+                  (concat full-prefix " "))
+                status-line " " nxt-pg-hint "\n" page)
+        nil))
+      (`bottom
+       (cons
+        (concat page "\n"
+                (when (or (= 0 echo-keystrokes)
+                          (not (eq which-key-side-window-location 'bottom)))
+                  (concat full-prefix " "))
+                status-line " " nxt-pg-hint)
+        nil))
+      (`echo
+       (cons page
+             (lambda ()
+               (which-key--echo
+                (concat full-prefix (when prefix-desc " ")
+                        status-line (when status-line " ")
+                        nxt-pg-hint)))))
+      (`mode-line
+       (cons page
+             (lambda ()
+               (with-current-buffer which-key--buffer
+                 (setq-local mode-line-format
+                             (concat " " full-prefix
+                                     " " status-line
+                                     " " nxt-pg-hint))))))
+      (_ (cons page nil)))))
+
+(defun which-key--show-page (&optional n)
+  "Show current page. N changes the current page to the Nth page
+relative to the current one."
+  (which-key--init-buffer) ;; in case it was killed
+  (let ((prefix-keys (which-key--current-key-string))
+        golden-ratio-mode)
+    (if (null which-key--pages-obj)
+        (message "%s- which-key can't show keys: There is not \
+enough space based on your settings and frame size." prefix-keys)
+      (when n
+        (setq which-key--pages-obj
+              (which-key--pages-set-current-page which-key--pages-obj n)))
+      (let ((page-echo (which-key--process-page which-key--pages-obj))
+            (height (which-key--pages-height which-key--pages-obj))
+            (width (car (which-key--pages-widths which-key--pages-obj))))
+        (which-key--lighter-status)
+        (if (eq which-key-popup-type 'minibuffer)
+            (which-key--echo (car page-echo))
+          (with-current-buffer which-key--buffer
+            (erase-buffer)
+            (insert (car page-echo))
+            (goto-char (point-min)))
+          (when (cdr page-echo) (funcall (cdr page-echo)))
+          (which-key--show-popup (cons height width)))))
+    ;; used for paging at top-level
+    (if (fboundp 'set-transient-map)
+        (set-transient-map (which-key--get-popup-map))
+      (with-no-warnings
+        (set-temporary-overlay-map (which-key--get-popup-map))))))
+
+;;; Paging functions
+
+;;;###autoload
+(defun which-key-reload-key-sequence (&optional key-seq)
+  "Simulate entering the key sequence KEY-SEQ.
+KEY-SEQ should be a list of events as produced by
+`listify-key-sequence'. If nil, KEY-SEQ defaults to
+`which-key--current-key-list'. Any prefix arguments that were
+used are reapplied to the new key sequence."
+  (let* ((key-seq (or key-seq (which-key--current-key-list)))
+         (next-event (mapcar (lambda (ev) (cons t ev)) key-seq)))
+    (setq prefix-arg current-prefix-arg
+          unread-command-events next-event)))
+
+(defun which-key-turn-page (delta)
+  "Show the next page of keys."
+  (which-key-reload-key-sequence)
+  (if which-key--last-try-2-loc
+      (let ((which-key-side-window-location which-key--last-try-2-loc)
+            (which-key--multiple-locations t))
+        (which-key--show-page delta))
+    (which-key--show-page delta))
+  (which-key--start-paging-timer))
+
+;;;###autoload
+(defun which-key-show-standard-help (&optional _)
+  "Call the command in `which-key--prefix-help-cmd-backup'.
+Usually this is `describe-prefix-bindings'."
+  (interactive)
+  (let ((which-key-inhibit t)
+        (popup-showing (which-key--popup-showing-p)))
+    (which-key--hide-popup-ignore-command)
+    (cond ((and (eq which-key--prefix-help-cmd-backup
+                    'describe-prefix-bindings)
+                ;; If the popup is not showing, we call
+                ;; `describe-prefix-bindings' directly.
+                popup-showing)
+           ;; This is essentially what `describe-prefix-bindings' does. We can't
+           ;; use this function directly, because the prefix will not be correct
+           ;; when we enter using `which-key-C-h-dispatch'.
+           (describe-bindings (kbd (which-key--current-key-string))))
+          ((functionp which-key--prefix-help-cmd-backup)
+           (funcall which-key--prefix-help-cmd-backup)))))
+
+;;;###autoload
+(defun which-key-show-next-page-no-cycle ()
+  "Show next page of keys unless on the last page, in which case
+call `which-key-show-standard-help'."
+  (interactive)
+  (let ((which-key-inhibit t))
+    (if (which-key--on-last-page)
+        (which-key-show-standard-help)
+      (which-key-turn-page 1))))
+
+;;;###autoload
+(defun which-key-show-previous-page-no-cycle ()
+  "Show previous page of keys unless on the first page, in which
+case do nothing."
+  (interactive)
+  (let ((which-key-inhibit t))
+    (unless (which-key--on-first-page)
+      (which-key-turn-page -1))))
+
+;;;###autoload
+(defun which-key-show-next-page-cycle (&optional _)
+  "Show the next page of keys, cycling from end to beginning
+after last page."
+  (interactive)
+  (let ((which-key-inhibit t))
+    (which-key-turn-page 1)))
+
+;;;###autoload
+(defun which-key-show-previous-page-cycle (&optional _)
+  "Show the previous page of keys, cycling from beginning to end
+after first page."
+  (interactive)
+  (let ((which-key-inhibit t))
+    (which-key-turn-page -1)))
+
+;;;###autoload
+(defun which-key-show-top-level (&optional _)
+  "Show top-level bindings."
+  (interactive)
+  (which-key--create-buffer-and-show nil nil nil "Top-level bindings"))
+
+;;;###autoload
+(defun which-key-show-major-mode (&optional all)
+  "Show top-level bindings in the map of the current major mode.
+
+This function will also detect evil bindings made using
+`evil-define-key' in this map. These bindings will depend on the
+current evil state. "
+  (interactive "P")
+  (let ((map-sym (intern (format "%s-map" major-mode))))
+    (if (and (boundp map-sym) (keymapp (symbol-value map-sym)))
+        (which-key--show-keymap
+         "Major-mode bindings"
+         (symbol-value map-sym)
+         (apply-partially #'which-key--map-binding-p (symbol-value map-sym))
+         all)
+      (message "which-key: No map named %s" map-sym))))
+
+;;;###autoload
+(defun which-key-show-full-major-mode ()
+  "Show all bindings in the map of the current major mode.
+
+This function will also detect evil bindings made using
+`evil-define-key' in this map. These bindings will depend on the
+current evil state. "
+  (interactive)
+  (which-key-show-major-mode t))
+
+;;;###autoload
+(defun which-key-dump-bindings (prefix buffer-name)
+  "Dump bindings from PREFIX into buffer named BUFFER-NAME.
+
+PREFIX should be a string suitable for `kbd'."
+  (interactive "sPrefix: \nB")
+  (let* ((buffer (get-buffer-create buffer-name))
+         (keys (which-key--get-bindings (kbd prefix))))
+    (with-current-buffer buffer
+      (point-max)
+      (save-excursion
+        (dolist (key keys)
+          (insert (apply #'format "%s%s%s\n" key)))))
+    (switch-to-buffer-other-window buffer)))
+
+;;;###autoload
+(defun which-key-undo-key (&optional _)
+  "Undo last keypress and force which-key update."
+  (interactive)
+  (let* ((key-lst (butlast (which-key--current-key-list)))
+         (which-key-inhibit t))
+    (cond (which-key--prior-show-keymap-args
+           (if (keymapp (cdr (car-safe which-key--prior-show-keymap-args)))
+               (let ((args (pop which-key--prior-show-keymap-args)))
+                 (which-key--show-keymap (car args) (cdr args)))
+             (which-key--hide-popup)))
+          (key-lst
+           (which-key-reload-key-sequence key-lst)
+           (which-key--create-buffer-and-show (apply #'vector key-lst)))
+          (t (setq which-key--automatic-display nil)
+             (which-key-show-top-level)))))
+(defalias 'which-key-undo 'which-key-undo-key)
+
+(defun which-key-abort (&optional _)
+  "Abort key sequence."
+  (interactive)
+  (let ((which-key-inhibit t))
+    (which-key--hide-popup-ignore-command)
+    (keyboard-quit)))
+
+(defun which-key-digit-argument (key)
+  "Version of `digit-argument' for use in `which-key-C-h-map'."
+  (interactive)
+  (let ((last-command-event (string-to-char key)))
+    (digit-argument key))
+  (let ((current-prefix-arg prefix-arg))
+    (which-key-reload-key-sequence)))
+
+(defun which-key-toggle-docstrings (&optional _)
+  "Toggle the display of docstrings."
+  (interactive)
+  (unless (eq which-key-show-docstrings 'docstring-only)
+    (setq which-key-show-docstrings (null which-key-show-docstrings)))
+  (which-key-reload-key-sequence)
+  (which-key--create-buffer-and-show (which-key--current-prefix)))
+
+;;;###autoload
+(defun which-key-C-h-dispatch ()
+  "Dispatch C-h commands by looking up key in
+`which-key-C-h-map'. This command is always accessible (from any
+prefix) if `which-key-use-C-h-commands' is non nil."
+  (interactive)
+  (cond ((and (not (which-key--popup-showing-p))
+              which-key-show-early-on-C-h)
+         (let* ((current-prefix
+                 (butlast
+                  (listify-key-sequence (which-key--this-command-keys)))))
+           (which-key-reload-key-sequence current-prefix)
+           (if which-key-idle-secondary-delay
+               (which-key--start-timer which-key-idle-secondary-delay t)
+             (which-key--start-timer 0.05 t))))
+        ((not (which-key--popup-showing-p))
+         (which-key-show-standard-help))
+        (t
+         (if (not (which-key--popup-showing-p))
+             (which-key-show-standard-help)
+           (let* ((prefix-keys (which-key--current-key-string))
+                  (full-prefix (which-key--full-prefix prefix-keys current-prefix-arg t))
+                  (prompt (concat (when (string-equal prefix-keys "")
+                                    (which-key--propertize
+                                     (concat " "
+                                             (which-key--pages-prefix-title
+                                              which-key--pages-obj))
+                                     'face 'which-key-note-face))
+                                  full-prefix
+                                  (which-key--propertize
+                                   (substitute-command-keys
+                                    (concat
+                                     " \\"
+                                     " \\[which-key-show-next-page-cycle]"
+                                     which-key-separator "next-page,"
+                                     " \\[which-key-show-previous-page-cycle]"
+                                     which-key-separator "previous-page,"
+                                     " \\[which-key-undo-key]"
+                                     which-key-separator "undo-key,"
+                                     " \\[which-key-toggle-docstrings]"
+                                     which-key-separator "toggle-docstrings,"
+                                     " \\[which-key-show-standard-help]"
+                                     which-key-separator "help,"
+                                     " \\[which-key-abort]"
+                                     which-key-separator "abort"
+                                     " 1..9"
+                                     which-key-separator "digit-arg"))
+                                   'face 'which-key-note-face)))
+                  (key (string (read-key prompt)))
+                  (cmd (lookup-key which-key-C-h-map key))
+                  (which-key-inhibit t))
+             (if cmd (funcall cmd key) (which-key-turn-page 0)))))))
+
+;;; Update
+
+(defun which-key--any-match-p (regexps string)
+  "Non-nil if any of REGEXPS match STRING."
+  (catch 'match
+    (dolist (regexp regexps)
+      (when (string-match-p regexp string)
+        (throw 'match t)))))
+
+(defun which-key--try-2-side-windows
+    (bindings prefix-keys prefix-title loc1 loc2 &rest _ignore)
+  "Try to show BINDINGS (PAGE-N) in LOC1 first.
+
+Only if no bindings fit fallback to LOC2."
+  (let (pages1)
+    (let ((which-key-side-window-location loc1)
+          (which-key--multiple-locations t))
+      (setq pages1 (which-key--create-pages
+                    bindings prefix-keys prefix-title)))
+    (if pages1
+        (progn
+          (setq which-key--pages-obj pages1)
+          (let ((which-key-side-window-location loc1)
+                (which-key--multiple-locations t))
+            (which-key--show-page))
+          loc1)
+      (let ((which-key-side-window-location loc2)
+            (which-key--multiple-locations t))
+        (setq which-key--pages-obj
+              (which-key--create-pages bindings prefix-keys prefix-title))
+        (which-key--show-page)
+        loc2))))
+
+(defun which-key--read-keymap ()
+  "Read keymap symbol from minibuffer."
+  (intern
+   (completing-read "Keymap: " obarray
+                    (lambda (m)
+                      (and (boundp m)
+                           (keymapp (symbol-value m))
+                           (not (equal (symbol-value m)
+                                       (make-sparse-keymap)))))
+                    t
+                    (let ((sym (symbol-at-point)))
+                      (and (boundp sym)
+                           (keymapp (symbol-value sym))
+                           (symbol-name sym)))
+                    'which-key-keymap-history)))
+
+;;;###autoload
+(defun which-key-show-keymap (keymap &optional no-paging)
+  "Show the top-level bindings in KEYMAP using which-key. KEYMAP
+is selected interactively from all available keymaps.
+
+If NO-PAGING is non-nil, which-key will not intercept subsequent
+keypresses for the paging functionality."
+  (interactive (list (which-key--read-keymap)))
+  (which-key--show-keymap (symbol-name keymap)
+                          (symbol-value keymap)
+                          nil nil no-paging))
+
+;;;###autoload
+(defun which-key-show-full-keymap (keymap)
+  "Show all bindings in KEYMAP using which-key. KEYMAP is
+selected interactively from all available keymaps."
+  (interactive (list (which-key--read-keymap)))
+  (which-key--show-keymap (symbol-name keymap)
+                          (symbol-value keymap)
+                          nil t))
+
+;;;###autoload
+(defun which-key-show-minor-mode-keymap (&optional all)
+  "Show the top-level bindings in KEYMAP using which-key. KEYMAP
+is selected interactively by mode in `minor-mode-map-alist'."
+  (interactive)
+  (let ((mode-sym
+         (intern
+          (completing-read
+           "Minor Mode: "
+           (mapcar 'car
+                   (cl-remove-if-not
+                    (lambda (entry)
+                      (and (symbol-value (car entry))
+                           (not (equal (cdr entry) (make-sparse-keymap)))))
+                    minor-mode-map-alist))
+           nil t nil 'which-key-keymap-history))))
+    (which-key--show-keymap (symbol-name mode-sym)
+                            (cdr (assq mode-sym minor-mode-map-alist))
+                            all)))
+;;;###autoload
+(defun which-key-show-full-minor-mode-keymap ()
+  "Show all bindings in KEYMAP using which-key. KEYMAP
+is selected interactively by mode in `minor-mode-map-alist'."
+  (interactive)
+  (which-key-show-minor-mode-keymap t))
+
+(defun which-key--show-keymap
+    (keymap-name keymap &optional prior-args all no-paging filter)
+  (when prior-args (push prior-args which-key--prior-show-keymap-args))
+  (let ((bindings (which-key--get-bindings nil keymap filter all)))
+    (if (= (length bindings) 0)
+        (message "which-key: No bindings found in %s" keymap-name)
+      (cond ((listp which-key-side-window-location)
+             (setq which-key--last-try-2-loc
+                   (apply #'which-key--try-2-side-windows
+                          bindings nil keymap-name
+                          which-key-side-window-location)))
+            (t (setq which-key--pages-obj
+                     (which-key--create-pages bindings nil keymap-name))
+               (which-key--show-page)))
+      (unless no-paging
+        (let* ((key (read-key))
+               (key-desc (key-description (list key)))
+               (next-def (lookup-key keymap (vector key))))
+          (cond ((and which-key-use-C-h-commands
+                      (numberp key) (= key help-char))
+                 (which-key-C-h-dispatch))
+                ((keymapp next-def)
+                 (which-key--hide-popup-ignore-command)
+                 (which-key--show-keymap
+                  (concat keymap-name " " key-desc)
+                  next-def
+                  (cons keymap-name keymap)))
+                (t (which-key--hide-popup))))))))
+
+(defun which-key--evil-operator-filter (binding)
+  (let ((def (intern (cdr binding))))
+    (and (functionp def)
+         (not (evil-get-command-property def :suppress-operator)))))
+
+(defun which-key--show-evil-operator-keymap ()
+  (if which-key--inhibit-next-operator-popup
+      (setq which-key--inhibit-next-operator-popup nil)
+    (let ((keymap
+           (make-composed-keymap (list evil-operator-shortcut-map
+                                       evil-operator-state-map
+                                       evil-motion-state-map))))
+      (when (keymapp keymap)
+        (let ((formatted-keys
+               (which-key--get-bindings
+                nil keymap #'which-key--evil-operator-filter)))
+          (cond ((= (length formatted-keys) 0)
+                 (message "which-key: Keymap empty"))
+                ((listp which-key-side-window-location)
+                 (setq which-key--last-try-2-loc
+                       (apply #'which-key--try-2-side-windows
+                              formatted-keys nil "evil operator/motion keys"
+                              which-key-side-window-location)))
+                (t (setq which-key--pages-obj
+                         (which-key--create-pages
+                          formatted-keys
+                          nil "evil operator/motion keys"))
+                   (which-key--show-page)))))
+      (let* ((key (read-key)))
+        (when (member key '(?f ?F ?t ?T ?`))
+          ;; these keys trigger commands that read the next char manually
+          (setq which-key--inhibit-next-operator-popup t))
+        (cond ((and which-key-use-C-h-commands (numberp key) (= key help-char))
+               (which-key-C-h-dispatch))
+              ((and (numberp key) (= key ?\C-\[))
+               (which-key--hide-popup)
+               (keyboard-quit))
+              (t
+               (which-key--hide-popup)
+               (setq unread-command-events (vector key))))))))
+
+(defun which-key--create-buffer-and-show
+    (&optional prefix-keys from-keymap filter prefix-title)
+  "Fill `which-key--buffer' with key descriptions and reformat.
+Finally, show the buffer."
+  (let ((start-time (current-time))
+        (formatted-keys (which-key--get-bindings
+                         prefix-keys from-keymap filter))
+        (prefix-desc (key-description prefix-keys)))
+    (cond ((= (length formatted-keys) 0)
+           (message "%s-  which-key: There are no keys to show" prefix-desc))
+          ((listp which-key-side-window-location)
+           (setq which-key--last-try-2-loc
+                 (apply #'which-key--try-2-side-windows
+                        formatted-keys prefix-keys prefix-title
+                        which-key-side-window-location)))
+          (t (setq which-key--pages-obj
+                   (which-key--create-pages
+                    formatted-keys prefix-keys prefix-title))
+             (which-key--show-page)))
+    (which-key--debug-message
+     "On prefix \"%s\" which-key took %.0f ms." prefix-desc
+     (* 1000 (float-time (time-since start-time))))))
+
+(defun which-key--this-command-keys ()
+  "Version of `this-single-command-keys' corrected for key-chords and god-mode."
+  (let ((this-command-keys (this-single-command-keys)))
+    (when (and (equal this-command-keys [key-chord])
+               (bound-and-true-p key-chord-mode))
+      (setq this-command-keys
+            (condition-case nil
+                (let ((rkeys (recent-keys)))
+                  (vector 'key-chord
+                          ;; Take the two preceding the last one, because the
+                          ;; read-event call in key-chord seems to add a
+                          ;; spurious key press to this list. Note this is
+                          ;; different from guide-key's method which didn't work
+                          ;; for me.
+                          (aref rkeys (- (length rkeys) 3))
+                          (aref rkeys (- (length rkeys) 2))))
+              (error (progn
+                       (message "which-key error in key-chord handling")
+                       [key-chord])))))
+    (when (and which-key--god-mode-support-enabled
+               (bound-and-true-p god-local-mode)
+               (eq this-command 'god-mode-self-insert))
+      (setq this-command-keys (when which-key--god-mode-key-string
+                          (kbd which-key--god-mode-key-string))))
+    this-command-keys))
+
+(defun which-key--update ()
+  "Function run by timer to possibly trigger
+`which-key--create-buffer-and-show'."
+  (let ((prefix-keys (which-key--this-command-keys))
+        delay-time)
+    (cond ((and (> (length prefix-keys) 0)
+                (or (keymapp (key-binding prefix-keys))
+                    ;; Some keymaps are stored here like iso-transl-ctl-x-8-map
+                    (keymapp (which-key--safe-lookup-key
+                              key-translation-map prefix-keys))
+                    ;; just in case someone uses one of these
+                    (keymapp (which-key--safe-lookup-key
+                              function-key-map prefix-keys)))
+                (not which-key-inhibit)
+                (or (null which-key-allow-regexps)
+                    (which-key--any-match-p
+                     which-key-allow-regexps (key-description prefix-keys)))
+                (or (null which-key-inhibit-regexps)
+                    (not
+                     (which-key--any-match-p
+                      which-key-inhibit-regexps (key-description prefix-keys))))
+                ;; Do not display the popup if a command is currently being
+                ;; executed
+                (or (and which-key-allow-evil-operators
+                         (bound-and-true-p evil-this-operator))
+                    (and which-key--god-mode-support-enabled
+                         (bound-and-true-p god-local-mode)
+                         (eq this-command 'god-mode-self-insert))
+                    (null this-command)))
+           (when (and (not (equal prefix-keys (which-key--current-prefix)))
+                      (or (null which-key-delay-functions)
+                          (null (setq delay-time
+                                      (run-hook-with-args-until-success
+                                       'which-key-delay-functions
+                                       (key-description prefix-keys)
+                                       (length prefix-keys))))
+                          (sit-for delay-time)))
+             (setq which-key--automatic-display t)
+             (which-key--create-buffer-and-show prefix-keys)
+             (when (and which-key-idle-secondary-delay
+                        (not which-key--secondary-timer-active))
+               (which-key--start-timer which-key-idle-secondary-delay t))))
+          ((and which-key-show-transient-maps
+                (keymapp overriding-terminal-local-map)
+                ;; basic test for it being a hydra
+                (not (eq (lookup-key overriding-terminal-local-map "\C-u")
+                         'hydra--universal-argument)))
+           (which-key--create-buffer-and-show
+            nil overriding-terminal-local-map))
+          ((and which-key-show-operator-state-maps
+                (bound-and-true-p evil-state)
+                (eq evil-state 'operator)
+                (not (which-key--popup-showing-p)))
+           (which-key--show-evil-operator-keymap))
+          (which-key--automatic-display
+           (which-key--hide-popup)))))
+
+;;; Timers
+
+(defun which-key--start-timer (&optional delay secondary)
+  "Activate idle timer to trigger `which-key--update'."
+  (which-key--stop-timer)
+  (setq which-key--secondary-timer-active secondary)
+  (setq which-key--timer
+        (run-with-idle-timer
+         (if delay
+             delay
+           which-key-idle-delay) t #'which-key--update)))
+
+(defun which-key--stop-timer ()
+  "Deactivate idle timer for `which-key--update'."
+  (when which-key--timer (cancel-timer which-key--timer)))
+
+(defun which-key--start-paging-timer ()
+  "Activate timer to restart which-key after paging."
+  (when which-key--paging-timer (cancel-timer which-key--paging-timer))
+  (which-key--stop-timer)
+  (setq which-key--paging-timer
+        (run-with-idle-timer
+         0.2 t (lambda ()
+                 (when (or (not (member real-last-command
+                                        which-key--paging-functions))
+                           (and (< 0 (length (this-single-command-keys)))
+                                (not (equal (which-key--current-prefix)
+                                            (which-key--this-command-keys)))))
+                   (cancel-timer which-key--paging-timer)
+                   (if which-key-idle-secondary-delay
+                       ;; we haven't executed a command yet so the secandary
+                       ;; timer is more relevant here
+                       (which-key--start-timer which-key-idle-secondary-delay t)
+                     (which-key--start-timer)))))))
+
+(provide 'which-key)
+;;; which-key.el ends here
diff --git a/lisp/yasnippet.el b/lisp/yasnippet.el
new file mode 100644
index 00000000..d24c7c09
--- /dev/null
+++ b/lisp/yasnippet.el
@@ -0,0 +1,5311 @@
+;;; yasnippet.el --- Yet another snippet extension for Emacs
+
+;; Copyright (C) 2008-2019 Free Software Foundation, Inc.
+;; Authors: pluskid ,
+;;          João Távora ,
+;;          Noam Postavsky 
+;; Maintainer: Noam Postavsky 
+;; Version: 0.14.0
+;; Package-Version: 20200524.2215
+;; Package-Commit: d3d6d70b1cd4818d271752468e0fdb0788db750d
+;; X-URL: http://github.com/joaotavora/yasnippet
+;; Keywords: convenience, emulation
+;; URL: http://github.com/joaotavora/yasnippet
+;; Package-Requires: ((cl-lib "0.5"))
+;; EmacsWiki: YaSnippetMode
+
+;; 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 .
+
+;;; Commentary:
+;;
+;;   Basic steps to setup:
+;;
+;;    (add-to-list 'load-path
+;;                 "~/path-to-yasnippet")
+;;    (require 'yasnippet)
+;;    (yas-global-mode 1)
+;;
+;;
+;;   Interesting variables are:
+;;
+;;       `yas-snippet-dirs'
+;;
+;;           The directory where user-created snippets are to be
+;;           stored.  Can also be a list of directories.  In that case,
+;;           when used for bulk (re)loading of snippets (at startup or
+;;           via `yas-reload-all'), directories appearing earlier in
+;;           the list override other dir's snippets.  Also, the first
+;;           directory is taken as the default for storing the user's
+;;           new snippets.
+;;
+;;           The deprecated `yas/root-directory' aliases this variable
+;;           for backward-compatibility.
+;;
+;;
+;;   Major commands are:
+;;
+;;       M-x yas-expand
+;;
+;;           Try to expand snippets before point.  In `yas-minor-mode',
+;;           this is normally bound to TAB, but you can customize it in
+;;           `yas-minor-mode-map'.
+;;
+;;       M-x yas-load-directory
+;;
+;;           Prompts you for a directory hierarchy of snippets to load.
+;;
+;;       M-x yas-activate-extra-mode
+;;
+;;           Prompts you for an extra mode to add snippets for in the
+;;           current buffer.
+;;
+;;       M-x yas-insert-snippet
+;;
+;;           Prompts you for possible snippet expansion if that is
+;;           possible according to buffer-local and snippet-local
+;;           expansion conditions.  With prefix argument, ignore these
+;;           conditions.
+;;
+;;       M-x yas-visit-snippet-file
+;;
+;;           Prompts you for possible snippet expansions like
+;;           `yas-insert-snippet', but instead of expanding it, takes
+;;           you directly to the snippet definition's file, if it
+;;           exists.
+;;
+;;       M-x yas-new-snippet
+;;
+;;           Lets you create a new snippet file in the correct
+;;           subdirectory of `yas-snippet-dirs', according to the
+;;           active major mode.
+;;
+;;       M-x yas-load-snippet-buffer
+;;
+;;           When editing a snippet, this loads the snippet.  This is
+;;           bound to "C-c C-c" while in the `snippet-mode' editing
+;;           mode.
+;;
+;;       M-x yas-tryout-snippet
+;;
+;;           When editing a snippet, this opens a new empty buffer,
+;;           sets it to the appropriate major mode and inserts the
+;;           snippet there, so you can see what it looks like.  This is
+;;           bound to "C-c C-t" while in `snippet-mode'.
+;;
+;;       M-x yas-describe-tables
+;;
+;;           Lists known snippets in a separate buffer.  User is
+;;           prompted as to whether only the currently active tables
+;;           are to be displayed, or all the tables for all major
+;;           modes.
+;;
+;;   If you have `dropdown-list' installed, you can optionally use it
+;;   as the preferred "prompting method", putting in your .emacs file,
+;;   for example:
+;;
+;;       (require 'dropdown-list)
+;;       (setq yas-prompt-functions '(yas-dropdown-prompt
+;;                                    yas-ido-prompt
+;;                                    yas-completing-prompt))
+;;
+;;   Also check out the customization group
+;;
+;;        M-x customize-group RET yasnippet RET
+;;
+;;   If you use the customization group to set variables
+;;   `yas-snippet-dirs' or `yas-global-mode', make sure the path to
+;;   "yasnippet.el" is present in the `load-path' *before* the
+;;   `custom-set-variables' is executed in your .emacs file.
+;;
+;;   For more information and detailed usage, refer to the project page:
+;;      http://github.com/joaotavora/yasnippet
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'eldoc) ; Needed for 24.
+(declare-function cl-progv-after "cl-extra") ; Needed for 23.4.
+(require 'easymenu)
+(require 'help-mode)
+
+(defvar yas--editing-template)
+(defvar yas--guessed-modes)
+(defvar yas--indent-original-column)
+(defvar yas--scheduled-jit-loads)
+(defvar yas-keymap)
+(defvar yas-selected-text)
+(defvar yas-verbosity)
+(defvar yas--current-template)
+
+
+;;; User customizable variables
+
+(defgroup yasnippet nil
+  "Yet Another Snippet extension"
+  :prefix "yas-"
+  :group 'editing)
+
+(defconst yas--loaddir
+  (file-name-directory (or load-file-name buffer-file-name))
+  "Directory that yasnippet was loaded from.")
+
+(defconst yas-installed-snippets-dir (expand-file-name "snippets" yas--loaddir))
+(make-obsolete-variable 'yas-installed-snippets-dir "\
+Yasnippet no longer comes with installed snippets" "0.14")
+
+(defconst yas--default-user-snippets-dir
+  (expand-file-name "snippets" user-emacs-directory))
+
+(defcustom yas-snippet-dirs (list yas--default-user-snippets-dir)
+  "List of top-level snippet directories.
+
+Each element, a string or a symbol whose value is a string,
+designates a top-level directory where per-mode snippet
+directories can be found.
+
+Elements appearing earlier in the list override later elements'
+snippets.
+
+The first directory is taken as the default for storing snippet's
+created with `yas-new-snippet'. "
+  :type '(choice (directory :tag "Single directory")
+                 (repeat :tag "List of directories"
+                         (choice (directory) (variable))))
+  :set #'(lambda (symbol new)
+           (let ((old (and (boundp symbol)
+                           (symbol-value symbol))))
+             (set-default symbol new)
+             (unless (or (not (fboundp 'yas-reload-all))
+                         (equal old new))
+               (yas-reload-all)))))
+
+(defun yas-snippet-dirs ()
+  "Return variable `yas-snippet-dirs' as list of strings."
+  (cl-loop for e in (if (listp yas-snippet-dirs)
+                        yas-snippet-dirs
+                      (list yas-snippet-dirs))
+           collect
+           (cond ((stringp e) e)
+                 ((and (symbolp e)
+                       (boundp e)
+                       (stringp (symbol-value e)))
+                  (symbol-value e))
+                 (t
+                  (error "[yas] invalid element %s in `yas-snippet-dirs'" e)))))
+
+(defcustom yas-new-snippet-default "\
+# -*- mode: snippet -*-
+# name: $1
+# key: ${2:${1:$(yas--key-from-desc yas-text)}}
+# --
+$0`(yas-escape-text yas-selected-text)`"
+  "Default snippet to use when creating a new snippet.
+If nil, don't use any snippet."
+  :type 'string)
+
+(defcustom yas-prompt-functions '(yas-dropdown-prompt
+                                  yas-completing-prompt
+                                  yas-maybe-ido-prompt
+                                  yas-no-prompt)
+  "Functions to prompt for keys, templates, etc interactively.
+
+These functions are called with the following arguments:
+
+- PROMPT: A string to prompt the user
+
+- CHOICES: a list of strings or objects.
+
+- optional DISPLAY-FN : A function that, when applied to each of
+the objects in CHOICES will return a string.
+
+The return value of any function you put here should be one of
+the objects in CHOICES, properly formatted with DISPLAY-FN (if
+that is passed).
+
+- To signal that your particular style of prompting is
+unavailable at the moment, you can also have the function return
+nil.
+
+- To signal that the user quit the prompting process, you can
+signal `quit' with
+
+    (signal \\='quit \"user quit!\")"
+  :type '(repeat function))
+
+(defcustom yas-indent-line 'auto
+  "Controls indenting applied to a recent snippet expansion.
+
+The following values are possible:
+
+- `fixed' Indent the snippet to the current column;
+
+- `auto' Indent each line of the snippet with `indent-according-to-mode'
+
+Every other value means don't apply any snippet-side indentation
+after expansion (the manual per-line \"$>\" indentation still
+applies)."
+  :type '(choice (const :tag "Nothing"  nothing)
+                 (const :tag "Fixed"    fixed)
+                 (const :tag "Auto"     auto)))
+
+(defcustom yas-also-auto-indent-first-line nil
+  "Non-nil means also auto indent first line according to mode.
+
+Naturally this is only valid when `yas-indent-line' is `auto'."
+  :type 'boolean)
+
+(defcustom yas-also-indent-empty-lines nil
+  "Non-nil means also indent empty lines according to mode."
+  :type 'boolean)
+
+(defcustom yas-snippet-revival t
+  "Non-nil means re-activate snippet fields after undo/redo."
+  :type 'boolean)
+
+(defcustom yas-triggers-in-field nil
+  "If non-nil, allow stacked expansions (snippets inside snippets).
+
+Otherwise `yas-next-field-or-maybe-expand' just moves on to the
+next field"
+  :type 'boolean)
+
+(defcustom yas-fallback-behavior 'return-nil
+  "This option is obsolete.
+Now that the conditional keybinding `yas-maybe-expand' is
+available, there's no more need for it."
+  :type '(choice (const :tag "Call previous command"  call-other-command)
+                 (const :tag "Do nothing"             return-nil)))
+
+(make-obsolete-variable
+ 'yas-fallback-behavior
+ "For `call-other-command' behavior bind to the conditional
+command value `yas-maybe-expand', for `return-nil' behavior bind
+directly to `yas-expand'."
+ "0.12")
+
+(defcustom yas-choose-keys-first nil
+  "If non-nil, prompt for snippet key first, then for template.
+
+Otherwise prompts for all possible snippet names.
+
+This affects `yas-insert-snippet' and `yas-visit-snippet-file'."
+  :type 'boolean)
+
+(defcustom yas-choose-tables-first nil
+  "If non-nil, and multiple eligible snippet tables, prompts user for tables first.
+
+Otherwise, user chooses between the merging together of all
+eligible tables.
+
+This affects `yas-insert-snippet', `yas-visit-snippet-file'"
+  :type 'boolean)
+
+(defcustom yas-use-menu 'abbreviate
+  "Display a YASnippet menu in the menu bar.
+
+When non-nil, submenus for each snippet table will be listed
+under the menu \"Yasnippet\".
+
+- If set to `abbreviate', only the current major-mode
+menu and the modes set in `yas--extra-modes' are listed.
+
+- If set to `full', every submenu is listed
+
+- If set to nil, hide the menu.
+
+Any other non-nil value, every submenu is listed."
+  :type '(choice (const :tag "Full"  full)
+                 (const :tag "Abbreviate" abbreviate)
+                 (const :tag "No menu" nil)))
+
+(defcustom yas-trigger-symbol (or (and (eq window-system 'mac)
+                                       (ignore-errors
+                                         (char-to-string ?\x21E5))) ;; little ->| sign
+                                  " =>")
+  "The text that will be used in menu to represent the trigger."
+  :type 'string)
+
+(defcustom yas-wrap-around-region nil
+  "What to insert for snippet's $0 field.
+
+If set to a character, insert contents of corresponding register.
+If non-nil insert region contents.  This can be overridden on a
+per-snippet basis.  A value of `cua' is considered equivalent to
+`?0' for backwards compatibility."
+  :type '(choice (character :tag "Insert from register")
+                 (const t :tag "Insert region contents")
+                 (const nil :tag "Don't insert anything")
+                 (const cua))) ; backwards compat
+
+(defcustom yas-good-grace t
+  "If non-nil, don't raise errors in elisp evaluation.
+
+This affects both the inline elisp in snippets and the hook
+variables such as `yas-after-exit-snippet-hook'.
+
+If this variable's value is `inline', an error string \"[yas]
+error\" is returned instead of raising the error.  If this
+variable's value is `hooks', a message is output to according to
+`yas-verbosity-level'.  If this variable's value is t, both are
+active."
+  :type 'boolean)
+
+(defcustom yas-visit-from-menu nil
+  "If non-nil visit snippets's files from menu, instead of expanding them.
+
+This can only work when snippets are loaded from files."
+  :type 'boolean)
+
+(defcustom yas-expand-only-for-last-commands nil
+  "List of `last-command' values to restrict tab-triggering to, or nil.
+
+Leave this set at nil (the default) to be able to trigger an
+expansion simply by placing the cursor after a valid tab trigger,
+using whichever commands.
+
+Optionally, set this to something like (self-insert-command) if
+you to wish restrict expansion to only happen when the last
+letter of the snippet tab trigger was typed immediately before
+the trigger key itself."
+  :type '(repeat function))
+
+(defcustom yas-alias-to-yas/prefix-p t
+  "If non-nil make aliases for the old style yas/ prefixed symbols.
+It must be set to nil before loading yasnippet to take effect."
+  :type 'boolean)
+
+;; Only two faces, and one of them shouldn't even be used...
+;;
+(defface yas-field-highlight-face
+  '((t (:inherit region)))
+  "The face used to highlight the currently active field of a snippet")
+
+(defface yas--field-debug-face
+  '()
+  "The face used for debugging some overlays normally hidden")
+
+
+;;; User-visible variables
+
+(defconst yas-maybe-skip-and-clear-field
+  '(menu-item "" yas-skip-and-clear-field
+              :filter yas--maybe-clear-field-filter)
+  "A conditional key definition.
+This can be used as a key definition in keymaps to bind a key to
+`yas-skip-and-clear-field' only when at the beginning of an
+unmodified snippet field.")
+
+(defconst yas-maybe-clear-field
+    '(menu-item "" yas-clear-field
+                :filter yas--maybe-clear-field-filter)
+    "A conditional key definition.
+This can be used as a key definition in keymaps to bind a key to
+`yas-clear-field' only when at the beginning of an
+unmodified snippet field.")
+
+(defun yas-filtered-definition (def)
+  "Return a condition key definition.
+The condition will respect the value of `yas-keymap-disable-hook'."
+  `(menu-item "" ,def
+              :filter ,(lambda (cmd) (unless (run-hook-with-args-until-success
+                                         'yas-keymap-disable-hook)
+                                  cmd))))
+
+(defvar yas-keymap
+  (let ((map (make-sparse-keymap)))
+    (define-key map [(tab)]       (yas-filtered-definition 'yas-next-field-or-maybe-expand))
+    (define-key map (kbd "TAB")   (yas-filtered-definition 'yas-next-field-or-maybe-expand))
+    (define-key map [(shift tab)] (yas-filtered-definition 'yas-prev-field))
+    (define-key map [backtab]     (yas-filtered-definition 'yas-prev-field))
+    (define-key map (kbd "C-g")   (yas-filtered-definition 'yas-abort-snippet))
+    ;; Yes, filters can be chained!
+    (define-key map (kbd "C-d")   (yas-filtered-definition yas-maybe-skip-and-clear-field))
+    (define-key map (kbd "DEL")   (yas-filtered-definition yas-maybe-clear-field))
+    map)
+  "The active keymap while a snippet expansion is in progress.")
+
+(defvar yas-key-syntaxes (list #'yas-try-key-from-whitespace
+                               "w_.()" "w_." "w_" "w")
+  "Syntaxes and functions to help look for trigger keys before point.
+
+Each element in this list specifies how to skip buffer positions
+backwards and look for the start of a trigger key.
+
+Each element can be either a string or a function receiving the
+original point as an argument. A string element is simply passed
+to `skip-syntax-backward' whereas a function element is called
+with no arguments and should also place point before the original
+position.
+
+The string between the resulting buffer position and the original
+point is matched against the trigger keys in the active snippet
+tables.
+
+If no expandable snippets are found, the next element is the list
+is tried, unless a function element returned the symbol `again',
+in which case it is called again from the previous position and
+may once more reposition point.
+
+For example, if `yas-key-syntaxes' has the value (\"w\" \"w_\"),
+trigger keys composed exclusively of \"word\"-syntax characters
+are looked for first. Failing that, longer keys composed of
+\"word\" or \"symbol\" syntax are looked for. Therefore,
+triggering after
+
+foo-barbaz
+
+will, according to the \"w\" element first try \"barbaz\". If
+that isn't a trigger key, \"foo-barbaz\" is tried, respecting the
+second \"w_\" element. Notice that even if \"baz\" is a trigger
+key for an active snippet, it won't be expanded, unless a
+function is added to `yas-key-syntaxes' that eventually places
+point between \"bar\" and \"baz\".
+
+See also Info node `(elisp) Syntax Descriptors'.")
+
+(defvar yas-after-exit-snippet-hook
+  '()
+  "Hooks to run after a snippet exited.
+
+The hooks will be run in an environment where some variables bound to
+proper values:
+
+`yas-snippet-beg' : The beginning of the region of the snippet.
+
+`yas-snippet-end' : Similar to beg.
+
+Attention: These hooks are not run when exiting nested/stacked snippet expansion!")
+
+(defvar yas-before-expand-snippet-hook
+  '()
+  "Hooks to run just before expanding a snippet.")
+
+(defconst yas-not-string-or-comment-condition
+  '(if (let ((ppss (syntax-ppss)))
+         (or (nth 3 ppss) (nth 4 ppss)))
+       '(require-snippet-condition . force-in-comment)
+     t)
+  "Disables snippet expansion in strings and comments.
+To use, set `yas-buffer-local-condition' to this value.")
+
+(defcustom yas-buffer-local-condition t
+  "Snippet expanding condition.
+
+This variable is a Lisp form which is evaluated every time a
+snippet expansion is attempted:
+
+    * If it evaluates to nil, no snippets can be expanded.
+
+    * If it evaluates to the a cons (require-snippet-condition
+      . REQUIREMENT)
+
+       * Snippets bearing no \"# condition:\" directive are not
+         considered
+
+       * Snippets bearing conditions that evaluate to nil (or
+         produce an error) won't be considered.
+
+       * If the snippet has a condition that evaluates to non-nil
+         RESULT:
+
+          * If REQUIREMENT is t, the snippet is considered
+
+          * If REQUIREMENT is `eq' RESULT, the snippet is
+            considered
+
+          * Otherwise, the snippet is not considered.
+
+    * If it evaluates to the symbol `always', all snippets are
+      considered for expansion, regardless of any conditions.
+
+    * If it evaluates to t or some other non-nil value
+
+       * Snippet bearing no conditions, or conditions that
+         evaluate to non-nil, are considered for expansion.
+
+       * Otherwise, the snippet is not considered.
+
+Here's an example preventing snippets from being expanded from
+inside comments, in `python-mode' only, with the exception of
+snippets returning the symbol `force-in-comment' in their
+conditions.
+
+ (add-hook \\='python-mode-hook
+           (lambda ()
+              (setq yas-buffer-local-condition
+                    \\='(if (python-syntax-comment-or-string-p)
+                         \\='(require-snippet-condition . force-in-comment)
+                       t))))"
+  :type
+  `(choice
+    (const :tag "Disable snippet expansion inside strings and comments"
+           ,yas-not-string-or-comment-condition)
+    (const :tag "Expand all snippets regardless of conditions" always)
+    (const :tag "Expand snippets unless their condition is nil" t)
+    (const :tag "Disable all snippet expansion" nil)
+    sexp))
+
+(defcustom yas-keymap-disable-hook nil
+  "The `yas-keymap' bindings are disabled if any function in this list returns non-nil.
+This is useful to control whether snippet navigation bindings
+override bindings from other packages (e.g., `company-mode')."
+  :type 'hook)
+
+(defcustom yas-overlay-priority 100
+  "Priority to use for yasnippets overlays.
+This is useful to control whether snippet navigation bindings
+override `keymap' overlay property bindings from other packages."
+  :type 'integer)
+
+(defcustom yas-inhibit-overlay-modification-protection nil
+  "If nil, changing text outside the active field aborts the snippet.
+This protection is intended to prevent yasnippet from ending up
+in an inconsistent state.  However, some packages (e.g., the
+company completion package) may trigger this protection when it
+is not needed.  In that case, setting this variable to non-nil
+can be useful."
+  ;; See also `yas--on-protection-overlay-modification'.
+  :type 'boolean)
+
+
+;;; Internal variables
+
+(defconst yas--version "0.14.0")
+
+(defvar yas--menu-table (make-hash-table)
+  "A hash table of MAJOR-MODE symbols to menu keymaps.")
+
+(defvar yas--escaped-characters
+  '(?\\ ?` ?\" ?' ?$ ?} ?{ ?\( ?\))
+  "List of characters which *might* need to be escaped.")
+
+(defconst yas--field-regexp
+  "${\\([0-9]+:\\)?\\([^}]*\\)}"
+  "A regexp to *almost* recognize a field.")
+
+(defconst yas--multi-dollar-lisp-expression-regexp
+  "$+[ \t\n]*\\(([^)]*)\\)"
+  "A regexp to *almost* recognize a \"$(...)\" expression.")
+
+(defconst yas--backquote-lisp-expression-regexp
+  "`\\([^`]*\\)`"
+  "A regexp to recognize a \"\\=`lisp-expression\\=`\" expression." )
+
+(defconst yas--transform-mirror-regexp
+  "${\\(?:\\([0-9]+\\):\\)?$\\([ \t\n]*([^}]*\\)"
+  "A regexp to *almost* recognize a mirror with a transform.")
+
+(defconst yas--simple-mirror-regexp
+  "$\\([0-9]+\\)"
+  "A regexp to recognize a simple mirror.")
+
+(defvar yas--snippet-id-seed 0
+  "Contains the next id for a snippet.")
+
+(defvar yas--original-auto-fill-function nil
+  "The original value of `auto-fill-function'.")
+(make-variable-buffer-local 'yas--original-auto-fill-function)
+
+(defvar yas--watch-auto-fill-backtrace nil)
+
+(defun yas--watch-auto-fill (sym newval op _where)
+  (when (and (or (and (eq sym 'yas--original-auto-fill-function)
+                      (null newval)
+                      (eq auto-fill-function 'yas--auto-fill))
+                 (and (eq sym 'auto-fill-function)
+                      (eq newval 'yas--auto-fill)
+                      (null yas--original-auto-fill-function)))
+             (null yas--watch-auto-fill-backtrace)
+             (fboundp 'backtrace-frames) ; Suppress compiler warning.
+             ;; If we're about to change `auto-fill-function' too,
+             ;; it's okay (probably).
+             (not (and (eq op 'makunbound)
+                       (not (eq (default-value 'auto-fill-function) 'yas--auto-fill))
+                       (cl-member 'kill-all-local-variables
+                                  (backtrace-frames 'yas--watch-auto-fill)
+                                  :key (lambda (frame) (nth 1 frame))))))
+    (setq yas--watch-auto-fill-backtrace
+          (backtrace-frames 'yas--watch-auto-fill))))
+
+;; Try to get more info on #873/919 (this only works for Emacs 26+).
+(when (fboundp 'add-variable-watcher)
+  (add-variable-watcher 'yas--original-auto-fill-function
+                        #'yas--watch-auto-fill)
+  (add-variable-watcher 'auto-fill-function
+                        #'yas--watch-auto-fill))
+
+(defun yas--snippet-next-id ()
+  (let ((id yas--snippet-id-seed))
+    (cl-incf yas--snippet-id-seed)
+    id))
+
+
+;;; Minor mode stuff
+
+(defvar yas--minor-mode-menu nil
+  "Holds the YASnippet menu.")
+
+(defvar yas--condition-cache-timestamp nil)
+
+(defun yas-maybe-expand-abbrev-key-filter (cmd)
+  "Return CMD if there is an expandable snippet at point.
+This function is useful as a `:filter' to a conditional key
+definition."
+  (when (let ((yas--condition-cache-timestamp (current-time)))
+          (yas--templates-for-key-at-point))
+    cmd))
+
+(define-obsolete-function-alias 'yas--maybe-expand-key-filter
+  #'yas-maybe-expand-abbrev-key-filter "0.14")
+
+(defconst yas-maybe-expand
+  '(menu-item "" yas-expand :filter yas-maybe-expand-abbrev-key-filter)
+  "A conditional key definition.
+This can be used as a key definition in keymaps to bind a key to
+`yas-expand' only when there is a snippet available to be
+expanded.")
+
+(defvar yas-minor-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [(tab)]     yas-maybe-expand)
+    (define-key map (kbd "TAB") yas-maybe-expand)
+    (define-key map "\C-c&\C-s" 'yas-insert-snippet)
+    (define-key map "\C-c&\C-n" 'yas-new-snippet)
+    (define-key map "\C-c&\C-v" 'yas-visit-snippet-file)
+    map)
+  "The keymap used when `yas-minor-mode' is active.")
+
+(easy-menu-define yas--minor-mode-menu
+      yas-minor-mode-map
+      "Menu used when `yas-minor-mode' is active."
+  '("YASnippet" :visible yas-use-menu
+    "----"
+    ["Expand trigger" yas-expand
+     :help "Possibly expand tab trigger before point"]
+    ["Insert at point..." yas-insert-snippet
+     :help "Prompt for an expandable snippet and expand it at point"]
+    ["New snippet..." yas-new-snippet
+     :help "Create a new snippet in an appropriate directory"]
+    ["Visit snippet file..." yas-visit-snippet-file
+     :help "Prompt for an expandable snippet and find its file"]
+    "----"
+    ("Snippet menu behaviour"
+     ["Visit snippets" (setq yas-visit-from-menu t)
+      :help "Visit snippets from the menu"
+      :active t :style radio   :selected yas-visit-from-menu]
+     ["Expand snippets" (setq yas-visit-from-menu nil)
+      :help "Expand snippets from the menu"
+      :active t :style radio :selected (not yas-visit-from-menu)]
+     "----"
+     ["Show all known modes" (setq yas-use-menu 'full)
+      :help "Show one snippet submenu for each loaded table"
+      :active t :style radio   :selected (eq yas-use-menu 'full)]
+     ["Abbreviate according to current mode" (setq yas-use-menu 'abbreviate)
+      :help "Show only snippet submenus for the current active modes"
+      :active t :style radio   :selected (eq yas-use-menu 'abbreviate)])
+    ("Indenting"
+     ["Auto" (setq yas-indent-line 'auto)
+      :help "Indent each line of the snippet with `indent-according-to-mode'"
+      :active t :style radio   :selected (eq yas-indent-line 'auto)]
+     ["Fixed" (setq yas-indent-line 'fixed)
+      :help "Indent the snippet to the current column"
+      :active t :style radio   :selected (eq yas-indent-line 'fixed)]
+     ["None" (setq yas-indent-line 'none)
+      :help "Don't apply any particular snippet indentation after expansion"
+      :active t :style radio   :selected (not (member yas-indent-line '(fixed auto)))]
+     "----"
+     ["Also auto indent first line" (setq yas-also-auto-indent-first-line
+                                          (not yas-also-auto-indent-first-line))
+      :help "When auto-indenting also, auto indent the first line menu"
+      :active (eq yas-indent-line 'auto)
+      :style toggle :selected yas-also-auto-indent-first-line]
+     )
+    ("Prompting method"
+     ["System X-widget" (setq yas-prompt-functions
+                              (cons #'yas-x-prompt
+                                    (remove #'yas-x-prompt
+                                            yas-prompt-functions)))
+      :help "Use your windowing system's (gtk, mac, windows, etc...) default menu"
+      :active t :style radio   :selected (eq (car yas-prompt-functions)
+                                             #'yas-x-prompt)]
+     ["Dropdown-list" (setq yas-prompt-functions
+                            (cons #'yas-dropdown-prompt
+                                  (remove #'yas-dropdown-prompt
+                                          yas-prompt-functions)))
+      :help "Use a special dropdown list"
+      :active t :style radio   :selected (eq (car yas-prompt-functions)
+                                             #'yas-dropdown-prompt)]
+     ["Ido" (setq yas-prompt-functions
+                  (cons #'yas-ido-prompt
+                        (remove #'yas-ido-prompt
+                                yas-prompt-functions)))
+      :help "Use an ido-style minibuffer prompt"
+      :active t :style radio   :selected (eq (car yas-prompt-functions)
+                                             #'yas-ido-prompt)]
+     ["Completing read" (setq yas-prompt-functions
+                              (cons #'yas-completing-prompt
+                                    (remove #'yas-completing-prompt
+                                            yas-prompt-functions)))
+      :help "Use a normal minibuffer prompt"
+      :active t :style radio   :selected (eq (car yas-prompt-functions)
+                                             #'yas-completing-prompt)]
+     )
+    ("Misc"
+     ["Wrap region in exit marker"
+      (setq yas-wrap-around-region
+            (not yas-wrap-around-region))
+      :help "If non-nil automatically wrap the selected text in the $0 snippet exit"
+      :style toggle :selected yas-wrap-around-region]
+     ["Allow stacked expansions "
+      (setq yas-triggers-in-field
+            (not yas-triggers-in-field))
+      :help "If non-nil allow snippets to be triggered inside other snippet fields"
+      :style toggle :selected yas-triggers-in-field]
+     ["Revive snippets on undo "
+      (setq yas-snippet-revival
+            (not yas-snippet-revival))
+      :help "If non-nil allow snippets to become active again after undo"
+      :style toggle :selected yas-snippet-revival]
+     ["Good grace "
+      (setq yas-good-grace
+            (not yas-good-grace))
+      :help "If non-nil don't raise errors in bad embedded elisp in snippets"
+      :style toggle :selected yas-good-grace]
+     )
+    "----"
+    ["Load snippets..."  yas-load-directory
+     :help "Load snippets from a specific directory"]
+    ["Reload everything" yas-reload-all
+     :help "Cleanup stuff, reload snippets, rebuild menus"]
+    ["About"            yas-about
+     :help "Display some information about YASnippet"]))
+
+(define-obsolete-variable-alias 'yas-extra-modes 'yas--extra-modes "0.9.1")
+(defvar yas--extra-modes nil
+  "An internal list of modes for which to also lookup snippets.
+
+This variable probably makes more sense as buffer-local, so
+ensure your use `make-local-variable' when you set it.")
+
+(defvar yas--tables (make-hash-table)
+  "A hash table of mode symbols to `yas--table' objects.")
+
+(defvar yas--parents (make-hash-table)
+  "A hash table of mode symbols do lists of direct parent mode symbols.
+
+This list is populated when reading the \".yas-parents\" files
+found when traversing snippet directories with
+`yas-load-directory'.
+
+There might be additional parenting information stored in the
+`derived-mode-parent' property of some mode symbols, but that is
+not recorded here.")
+
+(defvar yas--direct-keymaps (list)
+  "Keymap alist supporting direct snippet keybindings.
+
+This variable is placed in `emulation-mode-map-alists'.
+
+Its elements looks like (TABLE-NAME . KEYMAP).  They're
+instantiated on `yas-reload-all' but KEYMAP is added to only when
+loading snippets.  `yas--direct-TABLE-NAME' is then a variable
+set buffer-locally when entering `yas-minor-mode'.  KEYMAP binds
+all defined direct keybindings to `yas-maybe-expand-from-keymap'
+which decides on the snippet to expand.")
+
+(defun yas-direct-keymaps-reload ()
+  "Force reload the direct keybinding for active snippet tables."
+  (interactive)
+  (setq yas--direct-keymaps nil)
+  (maphash #'(lambda (name table)
+               (push (cons (intern (format "yas--direct-%s" name))
+                           (yas--table-direct-keymap table))
+                     yas--direct-keymaps))
+           yas--tables))
+
+(defun yas--modes-to-activate (&optional mode)
+  "Compute list of mode symbols that are active for `yas-expand' and friends."
+  (defvar yas--dfs)        ;We rely on dynbind.  We could use `letrec' instead!
+  (let* ((explored (if mode (list mode) ; Building up list in reverse.
+                     (cons major-mode (reverse yas--extra-modes))))
+         (yas--dfs
+          (lambda (mode)
+            (cl-loop for neighbour
+                     in (cl-list* (or (get mode 'derived-mode-parent)
+                                      ;; Consider `fundamental-mode'
+                                      ;; as ultimate ancestor.
+                                      'fundamental-mode)
+                                  ;; NOTE: `fboundp' check is redundant
+                                  ;; since Emacs 24.4.
+                                  (and (fboundp mode) (symbol-function mode))
+                                  (gethash mode yas--parents))
+                     when (and neighbour
+                               (not (memq neighbour explored))
+                               (symbolp neighbour))
+                     do (push neighbour explored)
+                     (funcall yas--dfs neighbour)))))
+    (mapc yas--dfs explored)
+    (nreverse explored)))
+
+(defvar yas-minor-mode-hook nil
+  "Hook run when `yas-minor-mode' is turned on.")
+
+(defun yas--auto-fill-wrapper ()
+  (when (and auto-fill-function
+             (not (eq auto-fill-function #'yas--auto-fill)))
+    (setq yas--original-auto-fill-function auto-fill-function)
+    (setq auto-fill-function #'yas--auto-fill)))
+
+;;;###autoload
+(define-minor-mode yas-minor-mode
+  "Toggle YASnippet mode.
+
+When YASnippet mode is enabled, `yas-expand', normally bound to
+the TAB key, expands snippets of code depending on the major
+mode.
+
+With no argument, this command toggles the mode.
+positive prefix argument turns on the mode.
+Negative prefix argument turns off the mode.
+
+Key bindings:
+\\{yas-minor-mode-map}"
+  :lighter " yas" ;; The indicator for the mode line.
+  (cond ((and yas-minor-mode (featurep 'yasnippet))
+         ;; Install the direct keymaps in `emulation-mode-map-alists'
+         ;; (we use `add-hook' even though it's not technically a hook,
+         ;; but it works). Then define variables named after modes to
+         ;; index `yas--direct-keymaps'.
+         ;;
+         ;; Also install the post-command-hook.
+         ;;
+         (cl-pushnew 'yas--direct-keymaps emulation-mode-map-alists)
+         (add-hook 'post-command-hook #'yas--post-command-handler nil t)
+         ;; Set the `yas--direct-%s' vars for direct keymap expansion
+         ;;
+         (dolist (mode (yas--modes-to-activate))
+           (let ((name (intern (format "yas--direct-%s" mode))))
+             (set-default name nil)
+             (set (make-local-variable name) t)))
+         ;; Perform JIT loads
+         (yas--load-pending-jits)
+         ;; Install auto-fill handler.
+         (yas--auto-fill-wrapper)       ; Now...
+         (add-hook 'auto-fill-mode-hook #'yas--auto-fill-wrapper)) ; or later.
+        (t
+         ;; Uninstall the direct keymaps, post-command hook, and
+         ;; auto-fill handler.
+         (remove-hook 'post-command-hook #'yas--post-command-handler t)
+         (remove-hook 'auto-fill-mode-hook #'yas--auto-fill-wrapper)
+         (when (local-variable-p 'yas--original-auto-fill-function)
+           (setq auto-fill-function yas--original-auto-fill-function))
+         (setq emulation-mode-map-alists
+               (remove 'yas--direct-keymaps emulation-mode-map-alists)))))
+
+(defun yas-activate-extra-mode (mode)
+  "Activates the snippets for the given `mode' in the buffer.
+
+The function can be called in the hook of a minor mode to
+activate snippets associated with that mode."
+  (interactive
+   (let (modes
+         symbol)
+     (maphash (lambda (k _)
+                (setq modes (cons (list k) modes)))
+              yas--parents)
+     (setq symbol (completing-read
+                   "Activate mode: " modes nil t))
+     (list
+      (when (not (string= "" symbol))
+        (intern symbol)))))
+  (when mode
+    (add-to-list (make-local-variable 'yas--extra-modes) mode)
+    (yas--load-pending-jits)))
+
+(defun yas-deactivate-extra-mode (mode)
+  "Deactivates the snippets for the given `mode' in the buffer."
+  (interactive
+   (list (intern
+          (completing-read
+           "Deactivate mode: " (mapcar #'list yas--extra-modes) nil t))))
+  (set (make-local-variable 'yas--extra-modes)
+       (remove mode
+               yas--extra-modes)))
+
+(defun yas-temp-buffer-p (&optional buffer)
+  (eq (aref (buffer-name buffer) 0) ?\s))
+
+(define-obsolete-variable-alias 'yas-dont-activate
+  'yas-dont-activate-functions "0.9.2")
+(defvar yas-dont-activate-functions (list #'minibufferp #'yas-temp-buffer-p)
+  "Special hook to control which buffers `yas-global-mode' affects.
+Functions are called with no argument, and should return non-nil to prevent
+`yas-global-mode' from enabling yasnippet in this buffer.
+
+In Emacsen < 24, this variable is buffer-local.  Because
+`yas-minor-mode-on' is called by `yas-global-mode' after
+executing the buffer's major mode hook, setting this variable
+there is an effective way to define exceptions to the \"global\"
+activation behaviour.
+
+In Emacsen >= 24, only the global value is used.  To define
+per-mode exceptions to the \"global\" activation behaviour, call
+`yas-minor-mode' with a negative argument directily in the major
+mode's hook.")
+(unless (> emacs-major-version 23)
+  (with-no-warnings
+    (make-variable-buffer-local 'yas-dont-activate)))
+
+
+(defun yas-minor-mode-on ()
+  "Turn on YASnippet minor mode.
+
+Honour `yas-dont-activate-functions', which see."
+  (interactive)
+  (unless (or
+           ;; The old behavior used for Emacs<24 was to set
+           ;; `yas-dont-activate-functions' to t buffer-locally.
+           (not (or (listp yas-dont-activate-functions)
+                    (functionp yas-dont-activate-functions)))
+           (run-hook-with-args-until-success 'yas-dont-activate-functions))
+    (yas-minor-mode 1)))
+
+;;;###autoload
+(define-globalized-minor-mode yas-global-mode yas-minor-mode yas-minor-mode-on)
+
+(defun yas--global-mode-reload-with-jit-maybe ()
+  "Run `yas-reload-all' when `yas-global-mode' is on."
+  (when yas-global-mode (yas-reload-all)))
+
+(add-hook 'yas-global-mode-hook #'yas--global-mode-reload-with-jit-maybe)
+
+
+;;; Major mode stuff
+
+(defvar yas--font-lock-keywords
+  (append '(("^#.*$" . font-lock-comment-face))
+          (with-temp-buffer
+            (let ((prog-mode-hook nil)
+                  (emacs-lisp-mode-hook nil))
+              (ignore-errors (emacs-lisp-mode)))
+            (font-lock-set-defaults)
+            (if (eq t (car-safe font-lock-keywords))
+                ;; They're "compiled", so extract the source.
+                (cadr font-lock-keywords)
+              font-lock-keywords))
+          '(("\\$\\([0-9]+\\)"
+             (0 font-lock-keyword-face)
+             (1 font-lock-string-face t))
+            ("\\${\\([0-9]+\\):?"
+             (0 font-lock-keyword-face)
+             (1 font-lock-warning-face t))
+            ("\\(\\$(\\)" 1 font-lock-preprocessor-face)
+            ("}"
+             (0 font-lock-keyword-face)))))
+
+(defvar snippet-mode-map
+  (let ((map (make-sparse-keymap)))
+    (easy-menu-define nil
+      map
+      "Menu used when snippet-mode is active."
+      (cons "Snippet"
+            (mapcar #'(lambda (ent)
+                        (when (nth 2 ent)
+                          (define-key map (nth 2 ent) (nth 1 ent)))
+                        (vector (nth 0 ent) (nth 1 ent) t))
+                    '(("Load this snippet" yas-load-snippet-buffer "\C-c\C-l")
+                      ("Load and quit window" yas-load-snippet-buffer-and-close "\C-c\C-c")
+                      ("Try out this snippet" yas-tryout-snippet "\C-c\C-t")))))
+    map)
+  "The keymap used when `snippet-mode' is active.")
+
+
+
+;;;###autoload(autoload 'snippet-mode "yasnippet" "A mode for editing yasnippets" t nil)
+(eval-and-compile
+  (if (fboundp 'prog-mode)
+      ;; `prog-mode' is new in 24.1.
+      (define-derived-mode snippet-mode prog-mode "Snippet"
+        "A mode for editing yasnippets"
+        (setq font-lock-defaults '(yas--font-lock-keywords))
+        (set (make-local-variable 'require-final-newline) nil)
+        (set (make-local-variable 'comment-start) "#")
+        (set (make-local-variable 'comment-start-skip) "#+[\t ]*")
+        (add-hook 'after-save-hook #'yas-maybe-load-snippet-buffer nil t))
+    (define-derived-mode snippet-mode fundamental-mode "Snippet"
+      "A mode for editing yasnippets"
+      (setq font-lock-defaults '(yas--font-lock-keywords))
+      (set (make-local-variable 'require-final-newline) nil)
+      (set (make-local-variable 'comment-start) "#")
+      (set (make-local-variable 'comment-start-skip) "#+[\t ]*")
+      (add-hook 'after-save-hook #'yas-maybe-load-snippet-buffer nil t))))
+
+(defun yas-snippet-mode-buffer-p ()
+  "Return non-nil if current buffer should be in `snippet-mode'.
+Meaning it's visiting a file under one of the mode directories in
+`yas-snippet-dirs'."
+  (when buffer-file-name
+    (cl-member buffer-file-name (yas-snippet-dirs)
+               :test #'file-in-directory-p)))
+
+;; We're abusing `magic-fallback-mode-alist' here because
+;; `auto-mode-alist' doesn't support function matchers.
+(add-to-list 'magic-fallback-mode-alist
+             `(yas-snippet-mode-buffer-p . snippet-mode))
+
+
+;;; Internal structs for template management
+
+(cl-defstruct (yas--template
+               (:constructor yas--make-template)
+               ;; Handles `yas-define-snippets' format, plus the
+               ;; initial TABLE argument.
+               (:constructor
+                yas--define-snippets-2
+                (table
+                 key content
+                 &optional xname condition group
+                 expand-env load-file xkeybinding xuuid save-file
+                 &aux
+                 (name (or xname
+                           ;; A little redundant: we always get a name
+                           ;; from `yas--parse-template' except when
+                           ;; there isn't a file.
+                           (and load-file (file-name-nondirectory load-file))
+                           (and save-file (file-name-nondirectory save-file))
+                           key))
+                 (keybinding (yas--read-keybinding xkeybinding))
+                 (uuid (or xuuid name))
+                 (old (gethash uuid (yas--table-uuidhash table)))
+                 (menu-binding-pair
+                  (and old (yas--template-menu-binding-pair old)))
+                 (perm-group
+                  (and old (yas--template-perm-group old))))))
+  "A template for a snippet."
+  key
+  content
+  name
+  condition
+  expand-env
+  load-file
+  save-file
+  keybinding
+  uuid
+  menu-binding-pair
+  group      ;; as dictated by the #group: directive or .yas-make-groups
+  perm-group ;; as dictated by `yas-define-menu'
+  table
+  )
+
+(cl-defstruct (yas--table (:constructor yas--make-snippet-table (name)))
+  "A table to store snippets for a particular mode.
+
+Has the following fields:
+
+`yas--table-name'
+
+  A symbol name normally corresponding to a major mode, but can
+  also be a pseudo major-mode to be used in
+  `yas-activate-extra-mode', for example.
+
+`yas--table-hash'
+
+  A hash table (KEY . NAMEHASH), known as the \"keyhash\". KEY is
+  a string or a vector, where the former is the snippet's trigger
+  and the latter means it's a direct keybinding. NAMEHASH is yet
+  another hash of (NAME . TEMPLATE) where NAME is the snippet's
+  name and TEMPLATE is a `yas--template' object.
+
+`yas--table-direct-keymap'
+
+  A keymap for the snippets in this table that have direct
+  keybindings. This is kept in sync with the keyhash, i.e., all
+  the elements of the keyhash that are vectors appear here as
+  bindings to `yas-maybe-expand-from-keymap'.
+
+`yas--table-uuidhash'
+
+  A hash table mapping snippets uuid's to the same `yas--template'
+  objects. A snippet uuid defaults to the snippet's name."
+  name
+  (hash (make-hash-table :test 'equal))
+  (uuidhash (make-hash-table :test 'equal))
+  (parents nil)
+  (direct-keymap (make-sparse-keymap)))
+
+(defun yas--get-template-by-uuid (mode uuid)
+  "Find the snippet template in MODE by its UUID."
+  (let* ((table (gethash mode yas--tables mode)))
+    (when table
+      (gethash uuid (yas--table-uuidhash table)))))
+
+;; Apropos storing/updating in TABLE, this works in two steps:
+;;
+;; 1. `yas--remove-template-by-uuid' removes any
+;;    keyhash-namehash-template mappings from TABLE, grabbing the
+;;    snippet by its uuid. Also removes mappings from TABLE's
+;;    `yas--table-direct-keymap' (FIXME: and should probably take care
+;;    of potentially stale menu bindings right?.)
+;;
+;; 2. `yas--add-template' adds this all over again.
+;;
+;;    Create a new or add to an existing keyhash-namehash mapping.
+;;
+;;  For reference on understanding this, consider three snippet
+;;  definitions:
+;;
+;;  A:   # name: The Foo
+;;       # key: foo
+;;       # binding: C-c M-l
+;;
+;;  B:   # name: Mrs Foo
+;;       # key: foo
+;;
+;;  C:   # name: The Bar
+;;       # binding: C-c M-l
+;;
+;;  D:   # name: Baz
+;;       # key: baz
+;;
+;;  keyhash       namehashes(3)      yas--template structs(4)
+;;  -----------------------------------------------------
+;;                                            __________
+;;                                           /          \
+;;  "foo"      --->  "The Foo" --->  [yas--template A]   |
+;;                   "Mrs Foo" --->  [yas--template B]   |
+;;                                                      |
+;;  [C-c M-l]  --->  "The Foo" -------------------------/
+;;                   "The Bar" --->  [yas--template C]
+;;
+;;  "baz"      --->  "Baz"     --->  [yas--template D]
+;;
+;; Additionally, since uuid defaults to the name, we have a
+;; `yas--table-uuidhash' for TABLE
+;;
+;; uuidhash       yas--template structs
+;; -------------------------------
+;; "The Foo" ---> [yas--template A]
+;; "Mrs Foo" ---> [yas--template B]
+;; "The Bar" ---> [yas--template C]
+;; "Baz"     ---> [yas--template D]
+;;
+;; FIXME: the more I look at this data-structure the more I think I'm
+;; stupid. There has to be an easier way (but beware lots of code
+;; depends on this).
+;;
+(defun yas--remove-template-by-uuid (table uuid)
+  "Remove from TABLE a template identified by UUID."
+  (let ((template (gethash uuid (yas--table-uuidhash table))))
+    (when template
+      (let* ((name                (yas--template-name template))
+             (empty-keys          nil))
+        ;; Remove the name from each of the targeted namehashes
+        ;;
+        (maphash #'(lambda (k v)
+                     (let ((template (gethash name v)))
+                       (when (and template
+                                  (equal uuid (yas--template-uuid template)))
+                         (remhash name v)
+                         (when (zerop (hash-table-count v))
+                           (push k empty-keys)))))
+                 (yas--table-hash table))
+        ;; Remove the namehash themselves if they've become empty
+        ;;
+        (dolist (key empty-keys)
+          (when (vectorp key)
+            (define-key (yas--table-direct-keymap table) key nil))
+          (remhash key (yas--table-hash table)))
+
+        ;; Finally, remove the uuid from the uuidhash
+        ;;
+        (remhash uuid (yas--table-uuidhash table))))))
+
+(defconst yas-maybe-expand-from-keymap
+  '(menu-item "" yas-expand-from-keymap
+              :filter yas--maybe-expand-from-keymap-filter))
+
+(defun yas--add-template (table template)
+  "Store in TABLE the snippet template TEMPLATE.
+
+KEY can be a string (trigger key) of a vector (direct
+keybinding)."
+  (let ((name (yas--template-name template))
+        (key (yas--template-key template))
+        (keybinding (yas--template-keybinding template))
+        (_menu-binding-pair (yas--template-menu-binding-pair-get-create template)))
+    (dolist (k (remove nil (list key keybinding)))
+      (puthash name
+               template
+               (or (gethash k
+                            (yas--table-hash table))
+                   (puthash k
+                            (make-hash-table :test 'equal)
+                            (yas--table-hash table))))
+      (when (vectorp k)
+        (define-key (yas--table-direct-keymap table) k yas-maybe-expand-from-keymap)))
+
+    ;; Update TABLE's `yas--table-uuidhash'
+    (puthash (yas--template-uuid template)
+             template
+             (yas--table-uuidhash table))))
+
+(defun yas--update-template (table template)
+  "Add or update TEMPLATE in TABLE.
+
+Also takes care of adding and updating to the associated menu.
+Return TEMPLATE."
+  ;; Remove from table by uuid
+  ;;
+  (yas--remove-template-by-uuid table (yas--template-uuid template))
+  ;; Add to table again
+  ;;
+  (yas--add-template table template)
+  ;; Take care of the menu
+  ;;
+  (yas--update-template-menu table template)
+  template)
+
+(defun yas--update-template-menu (table template)
+  "Update every menu-related for TEMPLATE."
+  (let ((menu-binding-pair (yas--template-menu-binding-pair-get-create template))
+        (key (yas--template-key template))
+        (keybinding (yas--template-keybinding template)))
+    ;; The snippet might have changed name or keys, so update
+    ;; user-visible strings
+    ;;
+    (unless (eq (cdr menu-binding-pair) :none)
+      ;; the menu item name
+      ;;
+      (setf (cl-cadar menu-binding-pair) (yas--template-name template))
+      ;; the :keys information (also visible to the user)
+      (setf (cl-getf (cdr (car menu-binding-pair)) :keys)
+            (or (and keybinding (key-description keybinding))
+                (and key (concat key yas-trigger-symbol))))))
+  (unless (yas--template-menu-managed-by-yas-define-menu template)
+    (let ((menu-keymap
+           (yas--menu-keymap-get-create (yas--table-mode table)
+                                        (mapcar #'yas--table-mode
+                                                (yas--table-parents table))))
+          (group (yas--template-group template)))
+      ;; Remove from menu keymap
+      ;;
+      (cl-assert menu-keymap)
+      (yas--delete-from-keymap menu-keymap (yas--template-uuid template))
+
+      ;; Add necessary subgroups as necessary.
+      ;;
+      (dolist (subgroup group)
+        (let ((subgroup-keymap (lookup-key menu-keymap (vector (make-symbol subgroup)))))
+          (unless (and subgroup-keymap
+                       (keymapp subgroup-keymap))
+            (setq subgroup-keymap (make-sparse-keymap))
+            (define-key menu-keymap (vector (make-symbol subgroup))
+              `(menu-item ,subgroup ,subgroup-keymap)))
+          (setq menu-keymap subgroup-keymap)))
+
+      ;; Add this entry to the keymap
+      ;;
+      (define-key menu-keymap
+        (vector (make-symbol (yas--template-uuid template)))
+        (car (yas--template-menu-binding-pair template))))))
+
+(defun yas--namehash-templates-alist (namehash)
+  "Return NAMEHASH as an alist."
+  (let (alist)
+    (maphash #'(lambda (k v)
+                 (push (cons k v) alist))
+             namehash)
+    alist))
+
+(defun yas--fetch (table key)
+  "Fetch templates in TABLE by KEY.
+
+Return a list of cons (NAME . TEMPLATE) where NAME is a
+string and TEMPLATE is a `yas--template' structure."
+  (let* ((keyhash (yas--table-hash table))
+         (namehash (and keyhash (gethash key keyhash))))
+    (when namehash
+      (yas--filter-templates-by-condition (yas--namehash-templates-alist namehash)))))
+
+
+;;; Filtering/condition logic
+
+(defun yas--eval-condition (condition)
+  (condition-case err
+      (save-excursion
+        (save-restriction
+          (save-match-data
+            (eval condition))))
+    (error (progn
+             (yas--message 1 "Error in condition evaluation: %s" (error-message-string err))
+             nil))))
+
+
+(defun yas--filter-templates-by-condition (templates)
+  "Filter the templates using the applicable condition.
+
+TEMPLATES is a list of cons (NAME . TEMPLATE) where NAME is a
+string and TEMPLATE is a `yas--template' structure.
+
+This function implements the rules described in
+`yas-buffer-local-condition'.  See that variables documentation."
+  (let ((requirement (yas--require-template-specific-condition-p)))
+    (if (eq requirement 'always)
+        templates
+      (cl-remove-if-not (lambda (pair)
+                          (yas--template-can-expand-p
+                           (yas--template-condition (cdr pair)) requirement))
+                        templates))))
+
+(defun yas--require-template-specific-condition-p ()
+  "Decide if this buffer requests/requires snippet-specific
+conditions to filter out potential expansions."
+  (if (eq 'always yas-buffer-local-condition)
+      'always
+    (let ((local-condition (or (and (consp yas-buffer-local-condition)
+                                    (yas--eval-condition yas-buffer-local-condition))
+                               yas-buffer-local-condition)))
+      (when local-condition
+        (if (eq local-condition t)
+            t
+          (and (consp local-condition)
+               (eq 'require-snippet-condition (car local-condition))
+               (symbolp (cdr local-condition))
+               (cdr local-condition)))))))
+
+(defun yas--template-can-expand-p (condition requirement)
+  "Evaluate CONDITION and REQUIREMENT and return a boolean."
+  (let* ((result (or (null condition)
+                     (yas--eval-condition condition))))
+    (cond ((eq requirement t)
+           result)
+          (t
+           (eq requirement result)))))
+
+(defun yas--table-templates (table)
+  (when table
+    (let ((acc (list)))
+      (maphash #'(lambda (_key namehash)
+                   (maphash #'(lambda (name template)
+                                (push (cons name template) acc))
+                            namehash))
+               (yas--table-hash table))
+      (maphash #'(lambda (uuid template)
+                   (push (cons uuid template) acc))
+               (yas--table-uuidhash table))
+      (yas--filter-templates-by-condition acc))))
+
+(defun yas--templates-for-key-at-point ()
+  "Find `yas--template' objects for any trigger keys preceding point.
+Returns (TEMPLATES START END). This function respects
+`yas-key-syntaxes', which see."
+  (save-excursion
+    (let ((original (point))
+          (methods yas-key-syntaxes)
+          (templates)
+          (method))
+      (while (and methods
+                  (not templates))
+        (unless (eq method (car methods))
+          ;; TRICKY: `eq'-ness test means we can only be here if
+          ;; `method' is a function that returned `again', and hence
+          ;; don't revert back to original position as per
+          ;; `yas-key-syntaxes'.
+          (goto-char original))
+        (setq method (car methods))
+        (cond ((stringp method)
+               (skip-syntax-backward method)
+               (setq methods (cdr methods)))
+              ((functionp method)
+               (unless (eq (funcall method original)
+                           'again)
+                 (setq methods (cdr methods))))
+              (t
+               (setq methods (cdr methods))
+               (yas--warning "Invalid element `%s' in `yas-key-syntaxes'" method)))
+        (let ((possible-key (buffer-substring-no-properties (point) original)))
+          (save-excursion
+            (goto-char original)
+            (setq templates
+                  (cl-mapcan (lambda (table)
+                               (yas--fetch table possible-key))
+                             (yas--get-snippet-tables))))))
+      (when templates
+        (list templates (point) original)))))
+
+(defun yas--table-all-keys (table)
+  "Get trigger keys of all active snippets in TABLE."
+  (let ((acc))
+    (maphash #'(lambda (key namehash)
+                 (when (yas--filter-templates-by-condition (yas--namehash-templates-alist namehash))
+                   (push key acc)))
+             (yas--table-hash table))
+    acc))
+
+(defun yas--table-mode (table)
+  (intern (yas--table-name table)))
+
+
+;;; Internal functions and macros:
+
+(defun yas--remove-misc-free-from-undo (old-undo-list)
+  "Tries to work around Emacs Bug#30931.
+Helper function for `yas--save-restriction-and-widen'."
+  ;; If Bug#30931 is unfixed, we get (# . INTEGER)
+  ;; entries in the undo list.  If we call `type-of' on the
+  ;; Lisp_Misc_Free object then Emacs aborts, so try to find it by
+  ;; checking that its type is none of the expected ones.
+  (when (consp buffer-undo-list)
+    (let* ((prev buffer-undo-list)
+           (undo-list prev))
+      (while (and (consp undo-list)
+                  ;; Only check new entries.
+                  (not (eq undo-list old-undo-list)))
+        (let ((entry (pop undo-list)))
+          (when (consp entry)
+            (let ((head (car entry)))
+              (unless (or (stringp head)
+                          (markerp head)
+                          (integerp head)
+                          (symbolp head)
+                          (not (integerp (cdr entry))))
+                ;; (message "removing misc free %S" entry)
+                (setcdr prev undo-list)))))
+        (setq prev undo-list)))))
+
+(defmacro yas--save-restriction-and-widen (&rest body)
+  "Equivalent to (save-restriction (widen) BODY).
+Also tries to work around Emacs Bug#30931."
+  (declare (debug (body)) (indent 0))
+  ;; Disable garbage collection, since it could cause an abort.
+  `(let ((gc-cons-threshold most-positive-fixnum)
+         (old-undo-list buffer-undo-list))
+     (prog1 (save-restriction
+              (widen)
+              ,@body)
+       (yas--remove-misc-free-from-undo old-undo-list))))
+
+(defun yas--eval-for-string (form)
+  "Evaluate FORM and convert the result to string."
+  (let ((debug-on-error (and (not (memq yas-good-grace '(t inline)))
+                             debug-on-error)))
+    (condition-case oops
+        (save-excursion
+          (yas--save-restriction-and-widen
+            (save-match-data
+              (let ((result (eval form)))
+                (when result
+                  (format "%s" result))))))
+      ((debug error) (cdr oops)))))
+
+(defun yas--eval-for-effect (form)
+  (yas--safely-call-fun (apply-partially #'eval form)))
+
+(defun yas--read-lisp (string &optional nil-on-error)
+  "Read STRING as a elisp expression and return it.
+
+In case STRING in an invalid expression and NIL-ON-ERROR is nil,
+return an expression that when evaluated will issue an error."
+  (condition-case err
+      (read string)
+    (error (and (not nil-on-error)
+                `(error (error-message-string ,err))))))
+
+(defun yas--read-keybinding (keybinding)
+  "Read KEYBINDING as a snippet keybinding, return a vector."
+  (when (and keybinding
+             (not (string-match "keybinding" keybinding)))
+    (condition-case err
+        (let ((res (or (and (string-match "^\\[.*\\]$" keybinding)
+                            (read keybinding))
+                       (read-kbd-macro keybinding 'need-vector))))
+          res)
+      (error
+       (yas--message 2 "warning: keybinding \"%s\" invalid since %s."
+                keybinding (error-message-string err))
+       nil))))
+
+(defun yas--table-get-create (mode)
+  "Get or create the snippet table corresponding to MODE."
+  (let ((table (gethash mode
+                        yas--tables)))
+    (unless table
+      (setq table (yas--make-snippet-table (symbol-name mode)))
+      (puthash mode table yas--tables)
+      (push (cons (intern (format "yas--direct-%s" mode))
+                  (yas--table-direct-keymap table))
+            yas--direct-keymaps))
+    table))
+
+(defun yas--get-snippet-tables (&optional mode)
+  "Get snippet tables for MODE.
+
+MODE defaults to the current buffer's `major-mode'.
+
+Return a list of `yas--table' objects.  The list of modes to
+consider is returned by `yas--modes-to-activate'"
+  (remove nil
+          (mapcar #'(lambda (name)
+                      (gethash name yas--tables))
+                  (yas--modes-to-activate mode))))
+
+(defun yas--menu-keymap-get-create (mode &optional parents)
+  "Get or create the menu keymap for MODE and its PARENTS.
+
+This may very well create a plethora of menu keymaps and arrange
+them all in `yas--menu-table'"
+  (let* ((menu-keymap (or (gethash mode yas--menu-table)
+                          (puthash mode (make-sparse-keymap) yas--menu-table))))
+    (mapc #'yas--menu-keymap-get-create parents)
+    (define-key yas--minor-mode-menu (vector mode)
+        `(menu-item ,(symbol-name mode) ,menu-keymap
+                    :visible (yas--show-menu-p ',mode)))
+    menu-keymap))
+
+
+;;; Template-related and snippet loading functions
+
+(defun yas--parse-template (&optional file)
+  "Parse the template in the current buffer.
+
+Optional FILE is the absolute file name of the file being
+parsed.
+
+Optional GROUP is the group where the template is to go,
+otherwise we attempt to calculate it from FILE.
+
+Return a snippet-definition, i.e. a list
+
+ (KEY TEMPLATE NAME CONDITION GROUP VARS LOAD-FILE KEYBINDING UUID)
+
+If the buffer contains a line of \"# --\" then the contents above
+this line are ignored. Directives can set most of these with the syntax:
+
+# directive-name : directive-value
+
+Here's a list of currently recognized directives:
+
+ * type
+ * name
+ * contributor
+ * condition
+ * group
+ * key
+ * expand-env
+ * binding
+ * uuid"
+  (goto-char (point-min))
+  (let* ((type 'snippet)
+         (name (and file
+                    (file-name-nondirectory file)))
+         (key nil)
+         template
+         bound
+         condition
+         (group (and file
+                     (yas--calculate-group file)))
+         expand-env
+         binding
+         uuid)
+    (if (re-search-forward "^# --\\s-*\n" nil t)
+        (progn (setq template
+                     (buffer-substring-no-properties (point)
+                                                     (point-max)))
+               (setq bound (point))
+               (goto-char (point-min))
+               (while (re-search-forward "^# *\\([^ ]+?\\) *: *\\(.*?\\)[[:space:]]*$" bound t)
+                 (when (string= "uuid" (match-string-no-properties 1))
+                   (setq uuid (match-string-no-properties 2)))
+                 (when (string= "type" (match-string-no-properties 1))
+                   (setq type (if (string= "command" (match-string-no-properties 2))
+                                  'command
+                                'snippet)))
+                 (when (string= "key" (match-string-no-properties 1))
+                   (setq key (match-string-no-properties 2)))
+                 (when (string= "name" (match-string-no-properties 1))
+                   (setq name (match-string-no-properties 2)))
+                 (when (string= "condition" (match-string-no-properties 1))
+                   (setq condition (yas--read-lisp (match-string-no-properties 2))))
+                 (when (string= "group" (match-string-no-properties 1))
+                   (setq group (match-string-no-properties 2)))
+                 (when (string= "expand-env" (match-string-no-properties 1))
+                   (setq expand-env (yas--read-lisp (match-string-no-properties 2)
+                                                   'nil-on-error)))
+                 (when (string= "binding" (match-string-no-properties 1))
+                   (setq binding (match-string-no-properties 2)))))
+      (setq template
+            (buffer-substring-no-properties (point-min) (point-max))))
+    (unless (or key binding)
+      (setq key (and file (file-name-nondirectory file))))
+    (when (eq type 'command)
+      (setq template (yas--read-lisp (concat "(progn" template ")"))))
+    (when group
+      (setq group (split-string group "\\.")))
+    (list key template name condition group expand-env file binding uuid)))
+
+(defun yas--calculate-group (file)
+  "Calculate the group for snippet file path FILE."
+  (let* ((dominating-dir (locate-dominating-file file
+                                                 ".yas-make-groups"))
+         (extra-path (and dominating-dir
+                          (file-relative-name file dominating-dir)))
+         (extra-dir (and extra-path
+                         (file-name-directory extra-path)))
+         (group (and extra-dir
+                     (replace-regexp-in-string "/"
+                                               "."
+                                               (directory-file-name extra-dir)))))
+    group))
+
+(defun yas--subdirs (directory &optional filep)
+  "Return subdirs or files of DIRECTORY according to FILEP."
+  (cl-remove-if (lambda (file)
+                  (or (string-match "\\`\\."
+                                    (file-name-nondirectory file))
+                      (string-match "\\`#.*#\\'"
+                                    (file-name-nondirectory file))
+                      (string-match "~\\'"
+                                    (file-name-nondirectory file))
+                      (if filep
+                          (file-directory-p file)
+                        (not (file-directory-p file)))))
+                (directory-files directory t)))
+
+(defun yas--make-menu-binding (template)
+  (let ((mode (yas--table-mode (yas--template-table template))))
+    `(lambda () (interactive) (yas--expand-or-visit-from-menu ',mode ,(yas--template-uuid template)))))
+
+(defun yas--expand-or-visit-from-menu (mode uuid)
+  (let* ((table (yas--table-get-create mode))
+         (yas--current-template (and table
+                                    (gethash uuid (yas--table-uuidhash table)))))
+    (when yas--current-template
+      (if yas-visit-from-menu
+          (yas--visit-snippet-file-1 yas--current-template)
+        (let ((where (if (region-active-p)
+                         (cons (region-beginning) (region-end))
+                       (cons (point) (point)))))
+          (yas-expand-snippet yas--current-template
+                              (car where) (cdr where)))))))
+
+(defun yas--key-from-desc (text)
+  "Return a yasnippet key from a description string TEXT."
+  (replace-regexp-in-string "\\(\\w+\\).*" "\\1" text))
+
+
+;;; Popping up for keys and templates
+
+(defun yas--prompt-for-template (templates &optional prompt)
+  "Interactively choose a template from the list TEMPLATES.
+
+TEMPLATES is a list of `yas--template'.
+
+Optional PROMPT sets the prompt to use."
+  (when templates
+    (setq templates
+          (sort templates #'(lambda (t1 t2)
+                              (< (length (yas--template-name t1))
+                                 (length (yas--template-name t2))))))
+    (cl-some (lambda (fn)
+               (funcall fn (or prompt "Choose a snippet: ")
+                        templates
+                        #'yas--template-name))
+             yas-prompt-functions)))
+
+(defun yas--prompt-for-keys (keys &optional prompt)
+  "Interactively choose a template key from the list KEYS.
+
+Optional PROMPT sets the prompt to use."
+  (when keys
+    (cl-some (lambda (fn)
+               (funcall fn (or prompt "Choose a snippet key: ") keys))
+             yas-prompt-functions)))
+
+(defun yas--prompt-for-table (tables &optional prompt)
+  "Interactively choose a table from the list TABLES.
+
+Optional PROMPT sets the prompt to use."
+  (when tables
+    (cl-some (lambda (fn)
+               (funcall fn (or prompt "Choose a snippet table: ")
+                        tables
+                        #'yas--table-name))
+             yas-prompt-functions)))
+
+(defun yas-x-prompt (prompt choices &optional display-fn)
+  "Display choices in a x-window prompt."
+  (when (and window-system choices)
+    ;; Let window position be recalculated to ensure that
+    ;; `posn-at-point' returns non-nil.
+    (redisplay)
+    (or
+     (x-popup-menu
+      (if (fboundp 'posn-at-point)
+          (let ((x-y (posn-x-y (posn-at-point (point)))))
+            (list (list (+ (car x-y) 10)
+                        (+ (cdr x-y) 20))
+                  (selected-window)))
+        t)
+      `(,prompt ("title"
+                 ,@(cl-mapcar (lambda (c d) `(,(concat "   " d) . ,c))
+                              choices
+                              (if display-fn (mapcar display-fn choices)
+                                choices)))))
+     (keyboard-quit))))
+
+(defun yas-maybe-ido-prompt (prompt choices &optional display-fn)
+  (when (bound-and-true-p ido-mode)
+    (yas-ido-prompt prompt choices display-fn)))
+
+(defun yas-ido-prompt (prompt choices &optional display-fn)
+  (require 'ido)
+  (yas-completing-prompt prompt choices display-fn #'ido-completing-read))
+
+(defun yas-dropdown-prompt (_prompt choices &optional display-fn)
+  (when (fboundp 'dropdown-list)
+    (let* ((formatted-choices
+            (if display-fn (mapcar display-fn choices) choices))
+           (n (dropdown-list formatted-choices)))
+      (if n (nth n choices)
+        (keyboard-quit)))))
+
+(defun yas-completing-prompt (prompt choices &optional display-fn completion-fn)
+  (let* ((formatted-choices
+          (if display-fn (mapcar display-fn choices) choices))
+         (chosen (funcall (or completion-fn #'completing-read)
+                          prompt formatted-choices
+                          nil 'require-match nil nil)))
+    (if (eq choices formatted-choices)
+        chosen
+      (nth (or (cl-position chosen formatted-choices :test #'string=) 0)
+           choices))))
+
+(defun yas-no-prompt (_prompt choices &optional _display-fn)
+  (cl-first choices))
+
+
+;;; Defining snippets
+;; This consists of creating and registering `yas--template' objects in the
+;; correct tables.
+;;
+
+(defvar yas--creating-compiled-snippets nil)
+
+(defun yas--define-snippets-1 (snippet snippet-table)
+  "Helper for `yas-define-snippets'."
+  ;; Update the appropriate table.  Also takes care of adding the
+  ;; key indicators in the templates menu entry, if any.
+  (yas--update-template
+   snippet-table (apply #'yas--define-snippets-2 snippet-table snippet)))
+
+(defun yas-define-snippets (mode snippets)
+  "Define SNIPPETS for MODE.
+
+SNIPPETS is a list of snippet definitions, each taking the
+following form
+
+ (KEY TEMPLATE NAME CONDITION GROUP EXPAND-ENV LOAD-FILE KEYBINDING UUID SAVE-FILE)
+
+Within these, only KEY and TEMPLATE are actually mandatory.
+
+TEMPLATE might be a Lisp form or a string, depending on whether
+this is a snippet or a snippet-command.
+
+CONDITION, EXPAND-ENV and KEYBINDING are Lisp forms, they have
+been `yas--read-lisp'-ed and will eventually be
+`yas--eval-for-string'-ed.
+
+The remaining elements are strings.
+
+FILE is probably of very little use if you're programatically
+defining snippets.
+
+UUID is the snippet's \"unique-id\". Loading a second snippet
+file with the same uuid would replace the previous snippet.
+
+You can use `yas--parse-template' to return such lists based on
+the current buffers contents."
+  (if yas--creating-compiled-snippets
+      (let ((print-length nil))
+        (insert ";;; Snippet definitions:\n;;;\n")
+        (dolist (snippet snippets)
+          ;; Fill in missing elements with nil.
+          (setq snippet (append snippet (make-list (- 10 (length snippet)) nil)))
+          ;; Move LOAD-FILE to SAVE-FILE because we will load from the
+          ;; compiled file, not LOAD-FILE.
+          (let ((load-file (nth 6 snippet)))
+            (setcar (nthcdr 6 snippet) nil)
+            (setcar (nthcdr 9 snippet) load-file)))
+        (insert (pp-to-string
+                 `(yas-define-snippets ',mode ',snippets)))
+        (insert "\n\n"))
+    ;; Normal case.
+    (let ((snippet-table (yas--table-get-create mode))
+          (template nil))
+      (dolist (snippet snippets)
+        (setq template (yas--define-snippets-1 snippet
+                                               snippet-table)))
+      template)))
+
+
+;;; Loading snippets from files
+
+(defun yas--template-get-file (template)
+  "Return TEMPLATE's LOAD-FILE or SAVE-FILE."
+  (or (yas--template-load-file template)
+      (let ((file (yas--template-save-file template)))
+        (when file
+          (yas--message 3 "%s has no load file, using save file, %s, instead."
+                        (yas--template-name template) file))
+        file)))
+
+(defun yas--load-yas-setup-file (file)
+  (if (not yas--creating-compiled-snippets)
+      ;; Normal case.
+      (load file 'noerror (<= yas-verbosity 4))
+    (let ((elfile (concat file ".el")))
+      (when (file-exists-p elfile)
+        (insert ";;; contents of the .yas-setup.el support file:\n;;;\n")
+        (insert-file-contents elfile)
+        (goto-char (point-max))))))
+
+(defun yas--define-parents (mode parents)
+  "Add PARENTS to the list of MODE's parents."
+  (puthash mode (cl-remove-duplicates
+                 (append parents
+                         (gethash mode yas--parents)))
+           yas--parents))
+
+(defun yas-load-directory (top-level-dir &optional use-jit interactive)
+  "Load snippets in directory hierarchy TOP-LEVEL-DIR.
+
+Below TOP-LEVEL-DIR each directory should be a mode name.
+
+With prefix argument USE-JIT do jit-loading of snippets."
+  (interactive
+   (list (read-directory-name "Select the root directory: " nil nil t)
+         current-prefix-arg t))
+  (unless yas-snippet-dirs
+    (setq yas-snippet-dirs top-level-dir))
+  (let ((impatient-buffers))
+    (dolist (dir (yas--subdirs top-level-dir))
+      (let* ((major-mode-and-parents (yas--compute-major-mode-and-parents
+                                      (concat dir "/dummy")))
+             (mode-sym (car major-mode-and-parents))
+             (parents (cdr major-mode-and-parents)))
+        ;; Attention: The parents and the menus are already defined
+        ;; here, even if the snippets are later jit-loaded.
+        ;;
+        ;; * We need to know the parents at this point since entering a
+        ;;   given mode should jit load for its parents
+        ;;   immediately. This could be reviewed, the parents could be
+        ;;   discovered just-in-time-as well
+        ;;
+        ;; * We need to create the menus here to support the `full'
+        ;;   option to `yas-use-menu' (all known snippet menus are shown to the user)
+        ;;
+        (yas--define-parents mode-sym parents)
+        (yas--menu-keymap-get-create mode-sym)
+        (let ((fun (apply-partially #'yas--load-directory-1 dir mode-sym)))
+          (if use-jit
+              (yas--schedule-jit mode-sym fun)
+            (funcall fun)))
+        ;; Look for buffers that are already in `mode-sym', and so
+        ;; need the new snippets immediately...
+        ;;
+        (when use-jit
+          (cl-loop for buffer in (buffer-list)
+                   do (with-current-buffer buffer
+                        (when (eq major-mode mode-sym)
+                          (yas--message 4 "Discovered there was already %s in %s" buffer mode-sym)
+                          (push buffer impatient-buffers)))))))
+    ;; ...after TOP-LEVEL-DIR has been completely loaded, call
+    ;; `yas--load-pending-jits' in these impatient buffers.
+    ;;
+    (cl-loop for buffer in impatient-buffers
+             do (with-current-buffer buffer (yas--load-pending-jits))))
+  (when interactive
+    (yas--message 3 "Loaded snippets from %s." top-level-dir)))
+
+(defun yas--load-directory-1 (directory mode-sym)
+  "Recursively load snippet templates from DIRECTORY."
+  (if yas--creating-compiled-snippets
+      (let ((output-file (expand-file-name ".yas-compiled-snippets.el"
+                                           directory)))
+        (with-temp-file output-file
+          (insert (format ";;; Compiled snippets and support files for `%s'\n"
+                          mode-sym))
+          (yas--load-directory-2 directory mode-sym)
+          (insert (format ";;; Do not edit! File generated at %s\n"
+                          (current-time-string)))))
+    ;; Normal case.
+    (unless (file-exists-p (expand-file-name ".yas-skip" directory))
+      (unless (and (load (expand-file-name ".yas-compiled-snippets" directory) 'noerror (<= yas-verbosity 3))
+                   (progn (yas--message 4 "Loaded compiled snippets from %s" directory) t))
+        (yas--message 4 "Loading snippet files from %s" directory)
+        (yas--load-directory-2 directory mode-sym)))))
+
+(defun yas--load-directory-2 (directory mode-sym)
+  ;; Load .yas-setup.el files wherever we find them
+  ;;
+  (yas--load-yas-setup-file (expand-file-name ".yas-setup" directory))
+  (let* ((default-directory directory)
+         (snippet-defs nil))
+    ;; load the snippet files
+    ;;
+    (with-temp-buffer
+      (dolist (file (yas--subdirs directory 'no-subdirs-just-files))
+        (when (file-readable-p file)
+          ;; Erase the buffer instead of passing non-nil REPLACE to
+          ;; `insert-file-contents' (avoids Emacs bug #23659).
+          (erase-buffer)
+          (insert-file-contents file)
+          (push (yas--parse-template file)
+                snippet-defs))))
+    (when snippet-defs
+      (yas-define-snippets mode-sym
+                           snippet-defs))
+    ;; now recurse to a lower level
+    ;;
+    (dolist (subdir (yas--subdirs directory))
+      (yas--load-directory-2 subdir
+                            mode-sym))))
+
+(defun yas--load-snippet-dirs (&optional nojit)
+  "Reload the directories listed in `yas-snippet-dirs' or
+prompt the user to select one."
+  (let (errors)
+    (if (null yas-snippet-dirs)
+        (call-interactively 'yas-load-directory)
+      (when (member yas--default-user-snippets-dir yas-snippet-dirs)
+        (make-directory yas--default-user-snippets-dir t))
+      (dolist (directory (reverse (yas-snippet-dirs)))
+        (cond ((file-directory-p directory)
+               (yas-load-directory directory (not nojit))
+               (if nojit
+                   (yas--message 4 "Loaded %s" directory)
+                 (yas--message 4 "Prepared just-in-time loading for %s" directory)))
+              (t
+               (push (yas--message 1 "Check your `yas-snippet-dirs': %s is not a directory" directory) errors)))))
+    errors))
+
+(defun yas-reload-all (&optional no-jit interactive)
+  "Reload all snippets and rebuild the YASnippet menu.
+
+When NO-JIT is non-nil force immediate reload of all known
+snippets under `yas-snippet-dirs', otherwise use just-in-time
+loading.
+
+When called interactively, use just-in-time loading when given a
+prefix argument."
+  (interactive (list (not current-prefix-arg) t))
+  (catch 'abort
+    (let ((errors)
+          (snippet-editing-buffers
+           (cl-remove-if-not (lambda (buffer)
+                               (with-current-buffer buffer
+                                 yas--editing-template))
+                             (buffer-list))))
+      ;; Warn if there are buffers visiting snippets, since reloading will break
+      ;; any on-line editing of those buffers.
+      ;;
+      (when snippet-editing-buffers
+          (if interactive
+              (if (y-or-n-p "Some buffers editing live snippets, close them and proceed with reload? ")
+                  (mapc #'kill-buffer snippet-editing-buffers)
+                (yas--message 1 "Aborted reload...")
+                (throw 'abort nil))
+            ;; in a non-interactive use, at least set
+            ;; `yas--editing-template' to nil, make it guess it next time around
+            (mapc #'(lambda (buffer)
+                      (with-current-buffer buffer
+                        (kill-local-variable 'yas--editing-template)))
+                  (buffer-list))))
+
+      ;; Empty all snippet tables and parenting info
+      ;;
+      (setq yas--tables (make-hash-table))
+      (setq yas--parents (make-hash-table))
+
+      ;; Before killing `yas--menu-table' use its keys to cleanup the
+      ;; mode menu parts of `yas--minor-mode-menu' (thus also cleaning
+      ;; up `yas-minor-mode-map', which points to it)
+      ;;
+      (maphash #'(lambda (menu-symbol _keymap)
+                   (define-key yas--minor-mode-menu (vector menu-symbol) nil))
+               yas--menu-table)
+      ;; Now empty `yas--menu-table' as well
+      (setq yas--menu-table (make-hash-table))
+
+      ;; Cancel all pending 'yas--scheduled-jit-loads'
+      ;;
+      (setq yas--scheduled-jit-loads (make-hash-table))
+
+      ;; Reload the directories listed in `yas-snippet-dirs' or prompt
+      ;; the user to select one.
+      ;;
+      (setq errors (yas--load-snippet-dirs no-jit))
+      ;; Reload the direct keybindings
+      ;;
+      (yas-direct-keymaps-reload)
+
+      (run-hooks 'yas-after-reload-hook)
+      (let ((no-snippets
+             (cl-every (lambda (table) (= (hash-table-count table) 0))
+                       (list yas--scheduled-jit-loads
+                             yas--parents yas--tables))))
+        (yas--message (if (or no-snippets errors) 2 3)
+                      (if no-jit "Snippets loaded %s."
+                        "Prepared just-in-time loading of snippets %s.")
+                      (cond (errors
+                             "with some errors.  Check *Messages*")
+                            (no-snippets
+                             "(but no snippets found)")
+                            (t
+                             "successfully")))))))
+
+(defvar yas-after-reload-hook nil
+  "Hooks run after `yas-reload-all'.")
+
+(defun yas--load-pending-jits ()
+  (dolist (mode (yas--modes-to-activate))
+    (let ((funs (reverse (gethash mode yas--scheduled-jit-loads))))
+      ;; must reverse to maintain coherence with `yas-snippet-dirs'
+      (dolist (fun funs)
+        (yas--message 4 "Loading for `%s', just-in-time: %s!" mode fun)
+        (funcall fun))
+      (remhash mode yas--scheduled-jit-loads))))
+
+(defun yas-escape-text (text)
+  "Escape TEXT for snippet."
+  (when text
+    (replace-regexp-in-string "[\\$]" "\\\\\\&" text)))
+
+
+;;; Snippet compilation function
+
+(defun yas-compile-directory (top-level-dir)
+  "Create .yas-compiled-snippets.el files under subdirs of TOP-LEVEL-DIR.
+
+This works by stubbing a few functions, then calling
+`yas-load-directory'."
+  (interactive "DTop level snippet directory?")
+  (let ((yas--creating-compiled-snippets t))
+    (yas-load-directory top-level-dir nil)))
+
+(defun yas-recompile-all ()
+  "Compile every dir in `yas-snippet-dirs'."
+  (interactive)
+  (mapc #'yas-compile-directory (yas-snippet-dirs)))
+
+
+;;; JIT loading
+;;;
+
+(defvar yas--scheduled-jit-loads (make-hash-table)
+  "Alist of mode-symbols to forms to be evaled when `yas-minor-mode' kicks in.")
+
+(defun yas--schedule-jit (mode fun)
+  (push fun (gethash mode yas--scheduled-jit-loads)))
+
+
+
+;;; Some user level functions
+
+(defun yas-about ()
+  (interactive)
+  (message "yasnippet (version %s) -- pluskid/joaotavora/npostavs"
+           (or (ignore-errors (car (let ((default-directory yas--loaddir))
+                                     (process-lines "git" "describe"
+                                                    "--tags" "--dirty"))))
+               (when (and (featurep 'package)
+                          (fboundp 'package-desc-version)
+                          (fboundp 'package-version-join))
+                 (defvar package-alist)
+                 (ignore-errors
+                   (let* ((yas-pkg (cdr (assq 'yasnippet package-alist)))
+                          (version (package-version-join
+                                    (package-desc-version (car yas-pkg)))))
+                     ;; Special case for MELPA's bogus version numbers.
+                     (if (string-match "\\`20..[01][0-9][0-3][0-9][.][0-9]\\{3,4\\}\\'"
+                                       version)
+                         (concat yas--version "-snapshot" version)
+                       version))))
+               yas--version)))
+
+
+;;; Apropos snippet menu:
+;;
+;; The snippet menu keymaps are stored by mode in hash table called
+;; `yas--menu-table'. They are linked to the main menu in
+;; `yas--menu-keymap-get-create' and are initially created empty,
+;; reflecting the table hierarchy.
+;;
+;; They can be populated in two mutually exclusive ways: (1) by
+;; reading `yas--template-group', which in turn is populated by the "#
+;; group:" directives of the snippets or the ".yas-make-groups" file
+;; or (2) by using a separate `yas-define-menu' call, which declares a
+;; menu structure based on snippets uuids.
+;;
+;; Both situations are handled in `yas--update-template-menu', which
+;; uses the predicate `yas--template-menu-managed-by-yas-define-menu'
+;; that can tell between the two situations.
+;;
+;; Note:
+;;
+;; * if `yas-define-menu' is used it must run before
+;;   `yas-define-snippets' and the UUIDS must match, otherwise we get
+;;   duplicate entries. The `yas--template' objects are created in
+;;   `yas-define-menu', holding nothing but the menu entry,
+;;   represented by a pair of ((menu-item NAME :keys KEYS) TYPE) and
+;;   stored in `yas--template-menu-binding-pair'.  The (menu-item ...)
+;;   part is then stored in the menu keymap itself which make the item
+;;   appear to the user.  These limitations could probably be revised.
+;;
+;; * The `yas--template-perm-group' slot is only used in
+;;   `yas-describe-tables'.
+;;
+(defun yas--template-menu-binding-pair-get-create (template &optional type)
+  "Get TEMPLATE's menu binding or assign it a new one.
+
+TYPE may be `:stay', signaling this menu binding should be
+static in the menu."
+  (or (yas--template-menu-binding-pair template)
+      (let (;; (key (yas--template-key template))
+            ;; (keybinding (yas--template-keybinding template))
+            )
+        (setf (yas--template-menu-binding-pair template)
+              (cons `(menu-item ,(or (yas--template-name template)
+                                     (yas--template-uuid template))
+                                ,(yas--make-menu-binding template)
+                                :keys ,nil)
+                    type)))))
+(defun yas--template-menu-managed-by-yas-define-menu (template)
+  "Non-nil if TEMPLATE's menu entry was included in a `yas-define-menu' call."
+  (cdr (yas--template-menu-binding-pair template)))
+
+
+(defun yas--show-menu-p (mode)
+  (cond ((eq yas-use-menu 'abbreviate)
+         (cl-find mode
+                  (mapcar #'yas--table-mode
+                          (yas--get-snippet-tables))))
+        (yas-use-menu t)))
+
+(defun yas--delete-from-keymap (keymap uuid)
+  "Recursively delete items with UUID from KEYMAP and its submenus."
+
+  ;; XXX: This used to skip any submenus named \"parent mode\"
+  ;;
+  ;; First of all, recursively enter submenus, i.e. the tree is
+  ;; searched depth first so that stale submenus can be found in the
+  ;; higher passes.
+  ;;
+  (mapc #'(lambda (item)
+            (when (and (consp (cdr-safe item))
+                       (keymapp (nth 2 (cdr item))))
+              (yas--delete-from-keymap (nth 2 (cdr item)) uuid)))
+        (cdr keymap))
+  ;; Set the uuid entry to nil
+  ;;
+  (define-key keymap (vector (make-symbol uuid)) nil)
+  ;; Destructively modify keymap
+  ;;
+  (setcdr keymap (cl-delete-if (lambda (item)
+                                 (cond ((not (listp item)) nil)
+                                       ((null (cdr item)))
+                                       ((and (keymapp (nth 2 (cdr item)))
+                                             (null (cdr (nth 2 (cdr item))))))))
+                               (cdr keymap))))
+
+(defun yas-define-menu (mode menu &optional omit-items)
+  "Define a snippet menu for MODE according to MENU, omitting OMIT-ITEMS.
+
+MENU is a list, its elements can be:
+
+- (yas-item UUID) : Creates an entry the snippet identified with
+  UUID.  The menu entry for a snippet thus identified is
+  permanent, i.e. it will never move (be reordered) in the menu.
+
+- (yas-separator) : Creates a separator
+
+- (yas-submenu NAME SUBMENU) : Creates a submenu with NAME,
+  SUBMENU has the same form as MENU.  NAME is also added to the
+  list of groups of the snippets defined thereafter.
+
+OMIT-ITEMS is a list of snippet uuids that will always be
+omitted from MODE's menu, even if they're manually loaded."
+  (let* ((table (yas--table-get-create mode))
+         (hash (yas--table-uuidhash table)))
+    (yas--define-menu-1 table
+                        (yas--menu-keymap-get-create mode)
+                        menu
+                        hash)
+    (dolist (uuid omit-items)
+      (let ((template (or (gethash uuid hash)
+                          (puthash uuid
+                                   (yas--make-template :table table
+                                                       :uuid uuid)
+                                   hash))))
+        (setf (yas--template-menu-binding-pair template) (cons nil :none))))))
+
+(defun yas--define-menu-1 (table menu-keymap menu uuidhash &optional group-list)
+  "Helper for `yas-define-menu'."
+  (cl-loop
+   for (type name submenu) in (reverse menu)
+   collect (cond
+            ((or (eq type 'yas-item)
+                 (and yas-alias-to-yas/prefix-p
+                      (eq type 'yas/item)))
+             (let ((template (or (gethash name uuidhash)
+                                 (puthash name
+                                          (yas--make-template
+                                           :table table
+                                           :perm-group group-list
+                                           :uuid name)
+                                          uuidhash))))
+               (car (yas--template-menu-binding-pair-get-create
+                     template :stay))))
+            ((or (eq type 'yas-submenu)
+                 (and yas-alias-to-yas/prefix-p
+                      (eq type 'yas/submenu)))
+             (let ((subkeymap (make-sparse-keymap)))
+               (yas--define-menu-1 table subkeymap submenu uuidhash
+                                   (append group-list (list name)))
+               `(menu-item ,name ,subkeymap)))
+            ((or (eq type 'yas-separator)
+                 (and yas-alias-to-yas/prefix-p
+                      (eq type 'yas/separator)))
+             '(menu-item "----"))
+            (t (yas--message 1 "Don't know anything about menu entry %s" type)
+               nil))
+   into menu-entries
+   finally do (push (apply #'vector menu-entries) (cdr menu-keymap))))
+
+(defun yas--define (mode key template &optional name condition group)
+  "Define a snippet.  Expanding KEY into TEMPLATE.
+
+NAME is a description to this template.  Also update the menu if
+`yas-use-menu' is t.  CONDITION is the condition attached to
+this snippet.  If you attach a condition to a snippet, then it
+will only be expanded when the condition evaluated to non-nil."
+  (yas-define-snippets mode
+                       (list (list key template name condition group))))
+
+(defun yas-hippie-try-expand (first-time?)
+  "Integrate with hippie expand.
+
+Just put this function in `hippie-expand-try-functions-list'."
+  (when yas-minor-mode
+    (if (not first-time?)
+        (let ((yas-fallback-behavior 'return-nil))
+          (yas-expand))
+      (undo 1)
+      nil)))
+
+
+;;; Apropos condition-cache:
+;;;
+;;;
+;;;
+;;;
+(defmacro yas-define-condition-cache (func doc &rest body)
+  "Define a function FUNC with doc DOC and body BODY.
+BODY is executed at most once every snippet expansion attempt, to check
+expansion conditions.
+
+It doesn't make any sense to call FUNC programatically."
+  `(defun ,func () ,(if (and doc
+                             (stringp doc))
+                        (concat doc
+"\n\nFor use in snippets' conditions. Within each
+snippet-expansion routine like `yas-expand', computes actual
+value for the first time then always returns a cached value.")
+                      (setq body (cons doc body))
+                      nil)
+     (let ((timestamp-and-value (get ',func 'yas--condition-cache)))
+       (if (equal (car timestamp-and-value) yas--condition-cache-timestamp)
+           (cdr timestamp-and-value)
+         (let ((new-value (progn
+                            ,@body
+                            )))
+           (put ',func 'yas--condition-cache (cons yas--condition-cache-timestamp new-value))
+           new-value)))))
+
+(defalias 'yas-expand 'yas-expand-from-trigger-key)
+(defun yas-expand-from-trigger-key (&optional field)
+  "Expand a snippet before point.
+
+If no snippet expansion is possible, fall back to the behaviour
+defined in `yas-fallback-behavior'.
+
+Optional argument FIELD is for non-interactive use and is an
+object satisfying `yas--field-p' to restrict the expansion to."
+  (interactive)
+  (setq yas--condition-cache-timestamp (current-time))
+  (let (templates-and-pos)
+    (unless (and yas-expand-only-for-last-commands
+                 (not (member last-command yas-expand-only-for-last-commands)))
+      (setq templates-and-pos (if field
+                                  (save-restriction
+                                    (narrow-to-region (yas--field-start field)
+                                                      (yas--field-end field))
+                                    (yas--templates-for-key-at-point))
+                                (yas--templates-for-key-at-point))))
+    (if templates-and-pos
+        (yas--expand-or-prompt-for-template
+         (nth 0 templates-and-pos)
+         ;; Delete snippet key and active region when expanding.
+         (min (if (use-region-p) (region-beginning) most-positive-fixnum)
+              (nth 1 templates-and-pos))
+         (max (if (use-region-p) (region-end) most-negative-fixnum)
+              (nth 2 templates-and-pos)))
+      (yas--fallback))))
+
+(defun yas--maybe-expand-from-keymap-filter (cmd)
+  "Check whether a snippet may be expanded.
+If there are expandable snippets, return CMD (this is useful for
+conditional keybindings) or the list of expandable snippet
+template objects if CMD is nil (this is useful as a more general predicate)."
+  (let* ((yas--condition-cache-timestamp (current-time))
+         (vec (cl-subseq (this-command-keys-vector)
+                         (if current-prefix-arg
+                             (length (this-command-keys))
+                           0)))
+         (templates (cl-mapcan (lambda (table)
+                                 (yas--fetch table vec))
+                               (yas--get-snippet-tables))))
+    (if templates (or cmd templates))))
+
+(defun yas-expand-from-keymap ()
+  "Directly expand some snippets, searching `yas--direct-keymaps'."
+  (interactive)
+  (setq yas--condition-cache-timestamp (current-time))
+  (let* ((templates (yas--maybe-expand-from-keymap-filter nil)))
+    (when templates
+      (yas--expand-or-prompt-for-template templates))))
+
+(defun yas--expand-or-prompt-for-template (templates &optional start end)
+  "Expand one of TEMPLATES from START to END.
+
+Prompt the user if TEMPLATES has more than one element, else
+expand immediately.  Common gateway for
+`yas-expand-from-trigger-key' and `yas-expand-from-keymap'."
+  (let ((yas--current-template
+         (or (and (cl-rest templates) ;; more than one
+                  (yas--prompt-for-template (mapcar #'cdr templates)))
+             (cdar templates))))
+    (when yas--current-template
+      (yas-expand-snippet yas--current-template start end))))
+
+;; Apropos the trigger key and the fallback binding:
+;;
+;; When `yas-minor-mode-map' binds , that correctly overrides
+;; org-mode's , for example and searching for fallbacks correctly
+;; returns `org-cycle'. However, most other modes bind "TAB". TODO,
+;; improve this explanation.
+;;
+(defun yas--fallback ()
+  "Fallback after expansion has failed.
+
+Common gateway for `yas-expand-from-trigger-key' and
+`yas-expand-from-keymap'."
+  (cond ((eq yas-fallback-behavior 'return-nil)
+         ;; return nil
+         nil)
+        ((eq yas-fallback-behavior 'yas--fallback)
+         (error (concat "yasnippet fallback loop!\n"
+                        "This can happen when you bind `yas-expand' "
+                        "outside of the `yas-minor-mode-map'.")))
+        ((eq yas-fallback-behavior 'call-other-command)
+         (let* ((yas-fallback-behavior 'yas--fallback)
+                ;; Also bind `yas-minor-mode' to prevent fallback
+                ;; loops when other extensions use mechanisms similar
+                ;; to `yas--keybinding-beyond-yasnippet'. (github #525
+                ;; and #526)
+                ;;
+                (yas-minor-mode nil)
+                (beyond-yasnippet (yas--keybinding-beyond-yasnippet)))
+           (yas--message 4 "Falling back to %s"  beyond-yasnippet)
+           (cl-assert (or (null beyond-yasnippet) (commandp beyond-yasnippet)))
+           (setq this-command beyond-yasnippet)
+           (when beyond-yasnippet
+             (call-interactively beyond-yasnippet))))
+        ((and (listp yas-fallback-behavior)
+              (cdr yas-fallback-behavior)
+              (eq 'apply (car yas-fallback-behavior)))
+         (let ((command-or-fn (cadr yas-fallback-behavior))
+               (args (cddr yas-fallback-behavior))
+               (yas-fallback-behavior 'yas--fallback)
+               (yas-minor-mode nil))
+           (if args
+               (apply command-or-fn args)
+             (when (commandp command-or-fn)
+               (setq this-command command-or-fn)
+               (call-interactively command-or-fn)))))
+        (t
+         ;; also return nil if all the other fallbacks have failed
+         nil)))
+
+(defun yas--keybinding-beyond-yasnippet ()
+  "Get current keys's binding as if YASsnippet didn't exist."
+  (let* ((yas-minor-mode nil)
+         (yas--direct-keymaps nil)
+         (keys (this-single-command-keys)))
+    (or (key-binding keys t)
+        (key-binding (yas--fallback-translate-input keys) t))))
+
+(defun yas--fallback-translate-input (keys)
+  "Emulate `read-key-sequence', at least what I think it does.
+
+Keys should be an untranslated key vector.  Returns a translated
+vector of keys.  FIXME not thoroughly tested."
+  (let ((retval [])
+        (i 0))
+    (while (< i (length keys))
+      (let ((j i)
+            (translated local-function-key-map))
+        (while (and (< j (length keys))
+                    translated
+                    (keymapp translated))
+          (setq translated (cdr (assoc (aref keys j) (remove 'keymap translated)))
+                j (1+ j)))
+        (setq retval (vconcat retval (cond ((symbolp translated)
+                                            `[,translated])
+                                           ((vectorp translated)
+                                            translated)
+                                           (t
+                                            (substring keys i j)))))
+        (setq i j)))
+    retval))
+
+
+;;; Utils for snippet development:
+
+(defun yas--all-templates (tables)
+  "Get `yas--template' objects in TABLES, applicable for buffer and point.
+
+Honours `yas-choose-tables-first', `yas-choose-keys-first' and
+`yas-buffer-local-condition'"
+  (when yas-choose-tables-first
+    (setq tables (list (yas--prompt-for-table tables))))
+  (mapcar #'cdr
+          (if yas-choose-keys-first
+              (let ((key (yas--prompt-for-keys
+                          (cl-mapcan #'yas--table-all-keys tables))))
+                (when key
+                  (cl-mapcan (lambda (table)
+                               (yas--fetch table key))
+                             tables)))
+            (cl-remove-duplicates (cl-mapcan #'yas--table-templates tables)
+                                  :test #'equal))))
+
+(defun yas--lookup-snippet-1 (name mode)
+  "Get the snippet called NAME in MODE's tables."
+  (let ((yas-choose-tables-first nil)   ; avoid prompts
+        (yas-choose-keys-first nil))
+    (cl-find name (yas--all-templates
+                   (yas--get-snippet-tables mode))
+             :key #'yas--template-name :test #'string=)))
+
+(defun yas-lookup-snippet (name &optional mode noerror)
+  "Get the snippet named NAME in MODE's tables.
+
+MODE defaults to the current buffer's `major-mode'.  If NOERROR
+is non-nil, then don't signal an error if there isn't any snippet
+called NAME.
+
+Honours `yas-buffer-local-condition'."
+  (cond
+   ((yas--lookup-snippet-1 name mode))
+   (noerror nil)
+   (t (error "No snippet named: %s" name))))
+
+(defun yas-insert-snippet (&optional no-condition)
+  "Choose a snippet to expand, pop-up a list of choices according
+to `yas-prompt-functions'.
+
+With prefix argument NO-CONDITION, bypass filtering of snippets
+by condition."
+  (interactive "P")
+  (setq yas--condition-cache-timestamp (current-time))
+  (let* ((yas-buffer-local-condition (or (and no-condition
+                                              'always)
+                                         yas-buffer-local-condition))
+         (templates (yas--all-templates (yas--get-snippet-tables)))
+         (yas--current-template (and templates
+                                    (or (and (cl-rest templates) ;; more than one template for same key
+                                             (yas--prompt-for-template templates))
+                                        (car templates))))
+         (where (if (region-active-p)
+                    (cons (region-beginning) (region-end))
+                  (cons (point) (point)))))
+    (if yas--current-template
+        (yas-expand-snippet yas--current-template (car where) (cdr where))
+      (yas--message 1 "No snippets can be inserted here!"))))
+
+(defun yas-visit-snippet-file ()
+  "Choose a snippet to edit, selection like `yas-insert-snippet'.
+
+Only success if selected snippet was loaded from a file.  Put the
+visited file in `snippet-mode'."
+  (interactive)
+  (let* ((yas-buffer-local-condition 'always)
+         (templates (yas--all-templates (yas--get-snippet-tables)))
+         (template (and templates
+                        (or (yas--prompt-for-template templates
+                                                     "Choose a snippet template to edit: ")
+                            (car templates)))))
+
+    (if template
+        (yas--visit-snippet-file-1 template)
+      (message "No snippets tables active!"))))
+
+(defun yas--visit-snippet-file-1 (template)
+  "Helper for `yas-visit-snippet-file'."
+  (let ((file (yas--template-get-file template)))
+    (cond ((and file (file-readable-p file))
+           (find-file-other-window file)
+           (snippet-mode)
+           (set (make-local-variable 'yas--editing-template) template))
+          (file
+           (message "Original file %s no longer exists!" file))
+          (t
+           (switch-to-buffer (format "*%s*"(yas--template-name template)))
+           (let ((type 'snippet))
+             (when (listp (yas--template-content template))
+               (insert (format "# type: command\n"))
+               (setq type 'command))
+             (insert (format "# key: %s\n" (yas--template-key template)))
+             (insert (format "# name: %s\n" (yas--template-name template)))
+             (when (yas--template-keybinding template)
+               (insert (format "# binding: %s\n" (yas--template-keybinding template))))
+             (when (yas--template-expand-env template)
+               (insert (format "# expand-env: %s\n" (yas--template-expand-env template))))
+             (when (yas--template-condition template)
+               (insert (format "# condition: %s\n" (yas--template-condition template))))
+             (insert "# --\n")
+             (insert (if (eq type 'command)
+                         (pp-to-string (yas--template-content template))
+                       (yas--template-content template))))
+           (snippet-mode)
+           (set (make-local-variable 'yas--editing-template) template)
+           (set (make-local-variable 'default-directory)
+                (car (cdr (car (yas--guess-snippet-directories (yas--template-table template))))))))))
+
+(defun yas--guess-snippet-directories-1 (table)
+  "Guess possible snippet subdirectories for TABLE."
+  (cons (file-name-as-directory (yas--table-name table))
+        (cl-mapcan #'yas--guess-snippet-directories-1
+                   (yas--table-parents table))))
+
+(defun yas--guess-snippet-directories (&optional table)
+  "Try to guess suitable directories based on the current active
+tables (or optional TABLE).
+
+Returns a list of elements (TABLE . DIRS) where TABLE is a
+`yas--table' object and DIRS is a list of all possible directories
+where snippets of table might exist."
+  (let ((main-dir (car (or (yas-snippet-dirs)
+                           (setq yas-snippet-dirs
+                                 (list yas--default-user-snippets-dir)))))
+        (tables (if table (list table)
+                  (yas--get-snippet-tables))))
+    ;; HACK! the snippet table created here is actually registered!
+    (unless table
+      ;; The major mode is probably the best guess, put it first.
+      (let ((major-mode-table (yas--table-get-create major-mode)))
+        (cl-callf2 delq major-mode-table tables)
+        (push major-mode-table tables)))
+
+    (mapcar #'(lambda (table)
+                (cons table
+                      (mapcar #'(lambda (subdir)
+                                  (expand-file-name subdir main-dir))
+                              (yas--guess-snippet-directories-1 table))))
+            tables)))
+
+(defun yas--make-directory-maybe (table-and-dirs &optional main-table-string)
+  "Return a dir inside TABLE-AND-DIRS, prompts for creation if none exists."
+  (or (cl-some (lambda (dir) (when (file-directory-p dir) dir))
+               (cdr table-and-dirs))
+      (let ((candidate (cl-first (cdr table-and-dirs))))
+        (unless (file-writable-p (file-name-directory candidate))
+          (error (yas--format "%s is not writable." candidate)))
+        (if (y-or-n-p (format "Guessed directory (%s) for%s%s table \"%s\" does not exist! Create? "
+                              candidate
+                              (if (gethash (yas--table-mode (car table-and-dirs))
+                                           yas--tables)
+                                  ""
+                                " brand new")
+                              (or main-table-string
+                                  "")
+                              (yas--table-name (car table-and-dirs))))
+            (progn
+              (make-directory candidate 'also-make-parents)
+              ;; create the .yas-parents file here...
+              candidate)))))
+
+;; NOTE: Using the traditional "*new snippet*" stops whitespace mode
+;; from activating (it doesn't like the leading "*").
+(defconst yas-new-snippet-buffer-name "+new-snippet+")
+
+(defun yas-new-snippet (&optional no-template)
+  "Pops a new buffer for writing a snippet.
+
+Expands a snippet-writing snippet, unless the optional prefix arg
+NO-TEMPLATE is non-nil."
+  (interactive "P")
+  (let ((guessed-directories (yas--guess-snippet-directories))
+        (yas-selected-text (or yas-selected-text
+                               (and (region-active-p)
+                                    (buffer-substring-no-properties
+                                     (region-beginning) (region-end))))))
+
+    (switch-to-buffer yas-new-snippet-buffer-name)
+    (erase-buffer)
+    (kill-all-local-variables)
+    (snippet-mode)
+    (yas-minor-mode 1)
+    (set (make-local-variable 'yas--guessed-modes)
+         (mapcar (lambda (d) (yas--table-mode (car d)))
+                 guessed-directories))
+    (set (make-local-variable 'default-directory)
+         (car (cdr (car guessed-directories))))
+    (if (and (not no-template) yas-new-snippet-default)
+        (yas-expand-snippet yas-new-snippet-default))))
+
+(defun yas--compute-major-mode-and-parents (file)
+  "Given FILE, find the nearest snippet directory for a given mode.
+
+Returns a list (MODE-SYM PARENTS), the mode's symbol and a list
+representing one or more of the mode's parents.
+
+Note that MODE-SYM need not be the symbol of a real major mode,
+neither do the elements of PARENTS."
+  (let* ((file-dir (and file
+                        (directory-file-name
+                         (or (cl-some (lambda (special)
+                                        (locate-dominating-file file special))
+                                      '(".yas-setup.el"
+                                        ".yas-make-groups"
+                                        ".yas-parents"))
+                             (directory-file-name (file-name-directory file))))))
+         (parents-file-name (concat file-dir "/.yas-parents"))
+         (major-mode-name (and file-dir
+                               (file-name-nondirectory file-dir)))
+         (major-mode-sym (or (and major-mode-name
+                                  (intern major-mode-name))))
+         (parents (when (file-readable-p parents-file-name)
+                         (mapcar #'intern
+                                 (split-string
+                                  (with-temp-buffer
+                                    (insert-file-contents parents-file-name)
+                                    (buffer-substring-no-properties (point-min)
+                                                                    (point-max))))))))
+    (when major-mode-sym
+      (cons major-mode-sym (remove major-mode-sym parents)))))
+
+(defvar yas--editing-template nil
+  "Supporting variable for `yas-load-snippet-buffer' and `yas--visit-snippet'.")
+
+(defvar yas--current-template nil
+  "Holds the current template being expanded into a snippet.")
+
+(defvar yas--guessed-modes nil
+  "List of guessed modes supporting `yas-load-snippet-buffer'.")
+
+(defun yas--read-table ()
+  "Ask user for a snippet table, help with some guessing."
+  (let ((prompt (if (and (featurep 'ido)
+                         ido-mode)
+                    'ido-completing-read 'completing-read)))
+    (unless yas--guessed-modes
+      (set (make-local-variable 'yas--guessed-modes)
+           (or (yas--compute-major-mode-and-parents buffer-file-name))))
+    (intern
+     (funcall prompt (format "Choose or enter a table (yas guesses %s): "
+                             (if yas--guessed-modes
+                                 (cl-first yas--guessed-modes)
+                               "nothing"))
+              (mapcar #'symbol-name yas--guessed-modes)
+              nil
+              nil
+              nil
+              nil
+              (if (cl-first yas--guessed-modes)
+                  (symbol-name (cl-first yas--guessed-modes)))))))
+
+(defun yas-load-snippet-buffer (table &optional interactive)
+  "Parse and load current buffer's snippet definition into TABLE.
+TABLE is a symbol name passed to `yas--table-get-create'.  When
+called interactively, prompt for the table name.
+Return the `yas--template' object created"
+  (interactive (list (yas--read-table) t))
+  (cond
+   ;;  We have `yas--editing-template', this buffer's content comes from a
+   ;;  template which is already loaded and neatly positioned,...
+   ;;
+   (yas--editing-template
+    (yas--define-snippets-1 (yas--parse-template (yas--template-load-file yas--editing-template))
+                           (yas--template-table yas--editing-template)))
+   ;; Try to use `yas--guessed-modes'. If we don't have that use the
+   ;; value from `yas--compute-major-mode-and-parents'
+   ;;
+   (t
+    (unless yas--guessed-modes
+      (set (make-local-variable 'yas--guessed-modes) (or (yas--compute-major-mode-and-parents buffer-file-name))))
+    (let* ((table (yas--table-get-create table)))
+      (set (make-local-variable 'yas--editing-template)
+           (yas--define-snippets-1 (yas--parse-template buffer-file-name)
+                                  table)))))
+  (when interactive
+    (yas--message 3 "Snippet \"%s\" loaded for %s."
+                  (yas--template-name yas--editing-template)
+                  (yas--table-name (yas--template-table yas--editing-template))))
+  yas--editing-template)
+
+(defun yas-maybe-load-snippet-buffer ()
+  "Added to `after-save-hook' in `snippet-mode'."
+  (let* ((mode (intern (file-name-sans-extension
+                        (file-name-nondirectory
+                         (directory-file-name default-directory)))))
+         (current-snippet
+          (apply #'yas--define-snippets-2 (yas--table-get-create mode)
+                 (yas--parse-template buffer-file-name)))
+         (uuid (yas--template-uuid current-snippet)))
+    (unless (equal current-snippet
+                   (if uuid (yas--get-template-by-uuid mode uuid)
+                     (yas--lookup-snippet-1
+                      (yas--template-name current-snippet) mode)))
+      (yas-load-snippet-buffer mode t))))
+
+(defun yas-load-snippet-buffer-and-close (table &optional kill)
+  "Load and save the snippet, then `quit-window' if saved.
+Loading is performed by `yas-load-snippet-buffer'.  If the
+snippet is new, ask the user whether (and where) to save it.  If
+the snippet already has a file, just save it.
+
+The prefix argument KILL is passed to `quit-window'.
+
+Don't use this from a Lisp program, call `yas-load-snippet-buffer'
+and `kill-buffer' instead."
+  (interactive (list (yas--read-table) current-prefix-arg))
+  (let ((template (yas-load-snippet-buffer table t)))
+    (when (and (buffer-modified-p)
+               (y-or-n-p
+                (format "[yas] Loaded for %s. Also save snippet buffer?"
+                        (yas--table-name (yas--template-table template)))))
+      (let ((default-directory (car (cdr (car (yas--guess-snippet-directories
+                                               (yas--template-table template))))))
+            (default-file-name (yas--template-name template)))
+        (unless (or buffer-file-name (not default-file-name))
+          (setq buffer-file-name
+                (read-file-name "File to save snippet in: "
+                                nil nil nil default-file-name))
+          (rename-buffer (file-name-nondirectory buffer-file-name) t))
+        (save-buffer)))
+    (quit-window kill)))
+
+(declare-function yas-debug-snippets "yasnippet-debug")
+
+(defun yas-tryout-snippet (&optional debug)
+  "Test current buffer's snippet template in other buffer.
+DEBUG is for debugging the YASnippet engine itself."
+  (interactive "P")
+  (let* ((major-mode-and-parent (yas--compute-major-mode-and-parents buffer-file-name))
+         (parsed (yas--parse-template))
+         (test-mode (or (and (car major-mode-and-parent)
+                             (fboundp (car major-mode-and-parent))
+                             (car major-mode-and-parent))
+                        (cl-first yas--guessed-modes)
+                        (intern (read-from-minibuffer (yas--format "Please input a mode: ")))))
+         (yas--current-template
+          (and parsed
+               (fboundp test-mode)
+               (yas--make-template :table       nil ;; no tables for ephemeral snippets
+                                   :key         (nth 0 parsed)
+                                   :content     (nth 1 parsed)
+                                   :name        (nth 2 parsed)
+                                   :expand-env  (nth 5 parsed)))))
+    (cond (yas--current-template
+           (let ((buffer-name
+                  (format "*testing snippet: %s*"
+                          (yas--template-name yas--current-template))))
+             (kill-buffer (get-buffer-create buffer-name))
+             (switch-to-buffer (get-buffer-create buffer-name))
+             (setq buffer-undo-list nil)
+             (condition-case nil (funcall test-mode) (error nil))
+	     (yas-minor-mode 1)
+             (setq buffer-read-only nil)
+             (yas-expand-snippet yas--current-template
+                                 (point-min) (point-max))
+             (when (and debug
+                        (require 'yasnippet-debug nil t))
+               (yas-debug-snippets "*YASnippet trace*" 'snippet-navigation)
+               (display-buffer "*YASnippet trace*"))))
+          (t
+           (yas--message 1 "Cannot test snippet for unknown major mode")))))
+
+(defun yas-active-keys ()
+  "Return all active trigger keys for current buffer and point."
+  (cl-remove-duplicates
+   (cl-remove-if-not #'stringp (cl-mapcan #'yas--table-all-keys
+                                          (yas--get-snippet-tables)))
+   :test #'string=))
+
+(defun yas--template-fine-group (template)
+  (car (last (or (yas--template-group template)
+                 (yas--template-perm-group template)))))
+
+(defun yas-describe-table-by-namehash ()
+  "Display snippet tables by NAMEHASH."
+  (interactive)
+  (with-current-buffer (get-buffer-create "*YASnippet Tables by NAMEHASH*")
+    (let ((inhibit-read-only t))
+      (erase-buffer)
+      (insert "YASnippet tables by NAMEHASH: \n")
+      (maphash
+       (lambda (_mode table)
+         (insert (format "\nSnippet table `%s':\n\n" (yas--table-name table)))
+         (maphash
+          (lambda (key _v)
+            (insert (format "   key %s maps snippets: %s\n" key
+                            (let ((names))
+                              (maphash #'(lambda (k _v)
+                                           (push k names))
+                                       (gethash key (yas--table-hash table)))
+                              names))))
+          (yas--table-hash table)))
+       yas--tables))
+    (view-mode +1)
+    (goto-char 1)
+    (display-buffer (current-buffer))))
+
+(defun yas-describe-tables (&optional with-nonactive)
+  "Display snippets for each table."
+  (interactive "P")
+  (let ((original-buffer (current-buffer))
+        (tables (yas--get-snippet-tables)))
+   (with-current-buffer (get-buffer-create "*YASnippet Tables*")
+     (let ((inhibit-read-only t))
+       (when with-nonactive
+         (maphash #'(lambda (_k v)
+                      (cl-pushnew v tables))
+                  yas--tables))
+       (erase-buffer)
+       (insert "YASnippet tables:\n")
+       (dolist (table tables)
+         (yas--describe-pretty-table table original-buffer))
+       (yas--create-snippet-xrefs))
+     (help-mode)
+     (goto-char 1)
+     (display-buffer (current-buffer)))))
+
+(defun yas--describe-pretty-table (table &optional original-buffer)
+  (insert (format "\nSnippet table `%s'"
+                  (yas--table-name table)))
+  (if (yas--table-parents table)
+      (insert (format " parents: %s\n"
+                      (mapcar #'yas--table-name
+                              (yas--table-parents table))))
+    (insert "\n"))
+  (insert (make-string 100 ?-) "\n")
+  (insert "group                   state name                                    key             binding\n")
+  (let ((groups-hash (make-hash-table :test #'equal)))
+    (maphash #'(lambda (_k v)
+                 (let ((group (or (yas--template-fine-group v)
+                                  "(top level)")))
+                   (when (yas--template-name v)
+                     (puthash group
+                              (cons v (gethash group groups-hash))
+                              groups-hash))))
+             (yas--table-uuidhash table))
+    (maphash
+     #'(lambda (group templates)
+         (setq group (truncate-string-to-width group 25 0 ?  "..."))
+         (insert (make-string 100 ?-) "\n")
+         (dolist (p templates)
+           (let* ((name (truncate-string-to-width (propertize (format "\\\\snippet `%s'" (yas--template-name p))
+                                                              'yasnippet p)
+                                                  50 0 ? "..."))
+                  (group (prog1 group
+                           (setq group (make-string (length group) ? ))))
+                  (condition-string (let ((condition (yas--template-condition p)))
+                                      (if (and condition
+                                               original-buffer)
+                                          (with-current-buffer original-buffer
+                                            (if (yas--eval-condition condition)
+                                                "(y)"
+                                              "(s)"))
+                                        "(a)")))
+                  (key-description-string (key-description (yas--template-keybinding p)))
+                  (template-key-padding (if (string= key-description-string "") nil ? )))
+             (insert group " "
+                     condition-string " "
+                     name (if (string-match "\\.\\.\\.$" name)
+                              "'" " ")
+                     " "
+                     (truncate-string-to-width (or (yas--template-key p) "")
+                                               15 0 template-key-padding "...")
+                     (or template-key-padding "")
+                     (truncate-string-to-width key-description-string
+                                               15 0 nil "...")
+                     "\n"))))
+     groups-hash)))
+
+
+
+;;; User convenience functions, for using in `yas-key-syntaxes'
+
+(defun yas-try-key-from-whitespace (_start-point)
+  "As `yas-key-syntaxes' element, look for whitespace delimited key.
+
+A newline will be considered whitespace even if the mode syntax
+marks it as something else (typically comment ender)."
+  (skip-chars-backward "^[:space:]\n"))
+
+(defun yas-shortest-key-until-whitespace (_start-point)
+  "Like `yas-longest-key-from-whitespace' but take the shortest key."
+  (when (/= (skip-chars-backward "^[:space:]\n" (1- (point))) 0)
+    'again))
+
+(defun yas-longest-key-from-whitespace (start-point)
+  "As `yas-key-syntaxes' element, look for longest key between point and whitespace.
+
+A newline will be considered whitespace even if the mode syntax
+marks it as something else (typically comment ender)."
+  (if (= (point) start-point)
+      (yas-try-key-from-whitespace start-point)
+    (forward-char))
+  (unless (<= start-point (1+ (point)))
+    'again))
+
+
+
+;;; User convenience functions, for using in snippet definitions
+
+(defvar yas-modified-p nil
+  "Non-nil if field has been modified by user or transformation.")
+
+(defvar yas-moving-away-p nil
+  "Non-nil if user is about to exit field.")
+
+(defvar yas-text nil
+  "Contains current field text.")
+
+(defun yas-substr (str pattern &optional subexp)
+  "Search PATTERN in STR and return SUBEXPth match.
+
+If found, the content of subexp group SUBEXP (default 0) is
+  returned, or else the original STR will be returned."
+  (let ((grp (or subexp 0)))
+    (save-match-data
+      (if (string-match pattern str)
+          (match-string-no-properties grp str)
+        str))))
+
+(defun yas-choose-value (&rest possibilities)
+  "Prompt for a string in POSSIBILITIES and return it.
+
+The last element of POSSIBILITIES may be a list of strings."
+  (unless (or yas-moving-away-p
+              yas-modified-p)
+    (let* ((last-link (last possibilities))
+           (last-elem (car last-link)))
+      (when (listp last-elem)
+        (setcar last-link (car last-elem))
+        (setcdr last-link (cdr last-elem))))
+    (cl-some (lambda (fn)
+               (funcall fn "Choose: " possibilities))
+             yas-prompt-functions)))
+
+(defun yas-completing-read (&rest args)
+  "A snippet-aware version of `completing-read'.
+This can be used to query the user for the initial value of a
+snippet field.  The arguments are the same as `completing-read'.
+
+\(fn PROMPT COLLECTION &optional PREDICATE REQUIRE-MATCH INITIAL-INPUT HIST DEF INHERIT-INPUT-METHOD)"
+  (unless (or yas-moving-away-p
+              yas-modified-p)
+    (apply #'completing-read args)))
+
+(defun yas--auto-next ()
+  "Helper for `yas-auto-next'."
+  (cl-loop
+   do (progn (remove-hook 'post-command-hook #'yas--auto-next t)
+             (yas-next-field))
+   ;; The transform in the next field may have requested auto-next as
+   ;; well.  Call it ourselves, since the command loop itself won't
+   ;; recheck the value of post-command-hook while running it.
+   while (memq #'yas--auto-next post-command-hook)))
+
+(defmacro yas-auto-next (&rest body)
+  "Automatically advance to next field after eval'ing BODY."
+  (declare (indent 0) (debug t))
+  `(unless yas-moving-away-p
+     (prog1 ,@body
+       (add-hook 'post-command-hook #'yas--auto-next nil t))))
+
+(defun yas-key-to-value (alist)
+  (unless (or yas-moving-away-p
+              yas-modified-p)
+    (let ((key (read-key-sequence "")))
+      (when (stringp key)
+        (or (cdr (cl-find key alist :key #'car :test #'string=))
+            key)))))
+
+(defun yas-throw (text)
+  "Signal `yas-exception' with TEXT as the reason."
+  (signal 'yas-exception (list text)))
+(put 'yas-exception 'error-conditions '(error yas-exception))
+(put 'yas-exception 'error-message "[yas] Exception")
+
+(defun yas-verify-value (possibilities)
+  "Verify that the current field value is in POSSIBILITIES.
+Otherwise signal `yas-exception'."
+  (when (and yas-moving-away-p (not (member yas-text possibilities)))
+    (yas-throw (format "Field only allows %s" possibilities))))
+
+(defun yas-field-value (number)
+  "Get the string for field with NUMBER.
+
+Use this in primary and mirror transformations to get the text of
+other fields."
+  (let* ((snippet (car (yas-active-snippets)))
+         (field (and snippet
+                     (yas--snippet-find-field snippet number))))
+    (when field
+      (yas--field-text-for-display field))))
+
+(defun yas-text ()
+  "Return `yas-text' if that exists and is non-empty, else nil."
+  (if (and yas-text
+           (not (string= "" yas-text)))
+      yas-text))
+
+(defun yas-selected-text ()
+  "Return `yas-selected-text' if that exists and is non-empty, else nil."
+  (if (and yas-selected-text
+           (not (string= "" yas-selected-text)))
+      yas-selected-text))
+
+(defun yas--get-field-once (number &optional transform-fn)
+  (unless yas-modified-p
+    (if transform-fn
+        (funcall transform-fn (yas-field-value number))
+      (yas-field-value number))))
+
+(defun yas-default-from-field (number)
+  (unless yas-modified-p
+    (yas-field-value number)))
+
+(defun yas-inside-string ()
+  "Return non-nil if the point is inside a string according to font-lock."
+  (equal 'font-lock-string-face (get-char-property (1- (point)) 'face)))
+
+(defun yas-unimplemented (&optional missing-feature)
+  (if yas--current-template
+      (if (y-or-n-p (format "This snippet is unimplemented (missing %s) Visit the snippet definition? "
+                            (or missing-feature
+                                "something")))
+          (yas--visit-snippet-file-1 yas--current-template))
+    (message "No implementation. Missing %s" (or missing-feature "something"))))
+
+
+;;; Snippet expansion and field management
+
+(defvar yas--active-field-overlay nil
+  "Overlays the currently active field.")
+
+(defvar yas--active-snippets nil
+  "List of currently active snippets")
+(make-variable-buffer-local 'yas--active-snippets)
+
+(defvar yas--field-protection-overlays nil
+  "Two overlays protect the current active field.")
+
+(defvar yas-selected-text nil
+  "The selected region deleted on the last snippet expansion.")
+
+(defvar yas--start-column nil
+  "The column where the snippet expansion started.")
+
+(make-variable-buffer-local 'yas--active-field-overlay)
+(make-variable-buffer-local 'yas--field-protection-overlays)
+(put 'yas--active-field-overlay 'permanent-local t)
+(put 'yas--field-protection-overlays 'permanent-local t)
+
+(cl-defstruct (yas--snippet (:constructor yas--make-snippet (expand-env)))
+  "A snippet.
+
+..."
+  expand-env
+  (fields '())
+  (exit nil)
+  (id (yas--snippet-next-id) :read-only t)
+  (control-overlay nil)
+  active-field
+  ;; stacked expansion: the `previous-active-field' slot saves the
+  ;; active field where the child expansion took place
+  previous-active-field
+  force-exit)
+
+(cl-defstruct (yas--field (:constructor yas--make-field (number start end parent-field)))
+  "A field.
+
+NUMBER is the field number.
+START and END are mostly buffer markers, but see \"apropos markers-to-points\".
+PARENT-FIELD is a `yas--field' this field is nested under, or nil.
+MIRRORS is a list of `yas--mirror's
+TRANSFORM is a lisp form.
+MODIFIED-P is a boolean set to true once user inputs text.
+NEXT is another `yas--field' or `yas--mirror' or `yas--exit'.
+"
+  number
+  start end
+  parent-field
+  (mirrors '())
+  (transform nil)
+  (modified-p nil)
+  next)
+
+
+(cl-defstruct (yas--mirror (:constructor yas--make-mirror (start end transform)))
+  "A mirror.
+
+START and END are mostly buffer markers, but see \"apropos markers-to-points\".
+TRANSFORM is a lisp form.
+PARENT-FIELD is a `yas--field' this mirror is nested under, or nil.
+NEXT is another `yas--field' or `yas--mirror' or `yas--exit'
+DEPTH is a count of how many nested mirrors can affect this mirror"
+  start end
+  (transform nil)
+  parent-field
+  next
+  depth)
+
+(cl-defstruct (yas--exit (:constructor yas--make-exit (marker)))
+  marker
+  next)
+
+(defmacro yas--letenv (env &rest body)
+  "Evaluate BODY with bindings from ENV.
+ENV is a lisp expression that evaluates to list of elements with
+the form (VAR FORM), where VAR is a symbol and FORM is a lisp
+expression that evaluates to its value."
+  (declare (debug (form body)) (indent 1))
+  (let ((envvar (make-symbol "envvar")))
+    `(let ((,envvar ,env))
+       (cl-progv
+           (mapcar #'car ,envvar)
+           (mapcar (lambda (v-f) (eval (cadr v-f))) ,envvar)
+         ,@body))))
+
+(defun yas--snippet-map-markers (fun snippet)
+  "Apply FUN to all marker (sub)fields in SNIPPET.
+Update each field with the result of calling FUN."
+  (dolist (field (yas--snippet-fields snippet))
+    (setf (yas--field-start field) (funcall fun (yas--field-start field)))
+    (setf (yas--field-end field)   (funcall fun (yas--field-end field)))
+    (dolist (mirror (yas--field-mirrors field))
+      (setf (yas--mirror-start mirror) (funcall fun (yas--mirror-start mirror)))
+      (setf (yas--mirror-end mirror)   (funcall fun (yas--mirror-end mirror)))))
+  (let ((snippet-exit (yas--snippet-exit snippet)))
+    (when snippet-exit
+      (setf (yas--exit-marker snippet-exit)
+            (funcall fun (yas--exit-marker snippet-exit))))))
+
+(defun yas--snippet-live-p (snippet)
+  "Return non-nil if SNIPPET hasn't been committed."
+  (catch 'live
+    (yas--snippet-map-markers (lambda (m)
+                                (if (markerp m) m
+                                  (throw 'live nil)))
+                              snippet)
+    t))
+
+(defun yas--apply-transform (field-or-mirror field &optional empty-on-nil-p)
+  "Calculate transformed string for FIELD-OR-MIRROR from FIELD.
+
+If there is no transform for ht field, return nil.
+
+If there is a transform but it returns nil, return the empty
+string iff EMPTY-ON-NIL-P is true."
+  (let* ((yas-text (yas--field-text-for-display field))
+         (yas-modified-p (yas--field-modified-p field))
+         (transform (if (yas--mirror-p field-or-mirror)
+                        (yas--mirror-transform field-or-mirror)
+                      (yas--field-transform field-or-mirror)))
+         (start-point (if (yas--mirror-p field-or-mirror)
+                          (yas--mirror-start field-or-mirror)
+                        (yas--field-start field-or-mirror)))
+         (transformed (and transform
+                           (save-excursion
+                             (goto-char start-point)
+                             (let ((ret (yas--eval-for-string transform)))
+                               (or ret (and empty-on-nil-p "")))))))
+    transformed))
+
+(defsubst yas--replace-all (from to &optional text)
+  "Replace all occurrences from FROM to TO.
+
+With optional string TEXT do it in that string."
+  (if text
+      (replace-regexp-in-string (regexp-quote from) to text t t)
+    (goto-char (point-min))
+    (while (search-forward from nil t)
+      (replace-match to t t text))))
+
+(defun yas--snippet-find-field (snippet number)
+  (cl-find-if (lambda (field)
+                (eq number (yas--field-number field)))
+              (yas--snippet-fields snippet)))
+
+(defun yas--snippet-sort-fields (snippet)
+  "Sort the fields of SNIPPET in navigation order."
+  (setf (yas--snippet-fields snippet)
+        (sort (yas--snippet-fields snippet)
+              #'yas--snippet-field-compare)))
+
+(defun yas--snippet-field-compare (field1 field2)
+  "Compare FIELD1 and FIELD2.
+
+The field with a number is sorted first.  If they both have a
+number, compare through the number.  If neither have, compare
+through the field's start point"
+  (let ((n1 (yas--field-number field1))
+        (n2 (yas--field-number field2)))
+    (if n1
+        (if n2
+            (or (zerop n2) (and (not (zerop n1))
+                                (< n1 n2)))
+          (not (zerop n1)))
+      (if n2
+          (zerop n2)
+        (< (yas--field-start field1)
+           (yas--field-start field2))))))
+
+(defun yas--field-probably-deleted-p (snippet field)
+  "Guess if SNIPPET's FIELD should be skipped."
+  (and
+   ;; field must be zero length
+   ;;
+   (zerop (- (yas--field-start field) (yas--field-end field)))
+   ;; field must have been modified
+   ;;
+   (yas--field-modified-p field)
+   ;; either:
+   (or
+    ;;  1) it's a nested field
+    ;;
+    (yas--field-parent-field field)
+    ;;  2) ends just before the snippet end
+    ;;
+    (and (eq field (car (last (yas--snippet-fields snippet))))
+         (= (yas--field-start field) (overlay-end (yas--snippet-control-overlay snippet)))))
+   ;; the field numbered 0, just before the exit marker, should
+   ;; never be skipped
+   ;;
+   (not (and (yas--field-number field)
+             (zerop (yas--field-number field))))))
+
+(defun yas-active-snippets (&optional beg end)
+  "Return a sorted list of active snippets.
+The most recently-inserted snippets are returned first.
+
+Only snippets overlapping the region BEG ... END are returned.
+Overlapping has the same meaning as described in `overlays-in'.
+If END is omitted, it defaults to (1+ BEG).  If BEG is omitted,
+it defaults to point.  A non-nil, non-buffer position BEG is
+equivalent to a range covering the whole buffer."
+  (unless beg
+    (setq beg (point)))
+  (cond ((not (or (integerp beg) (markerp beg)))
+         (setq beg (point-min) end (point-max)))
+        ((not end)
+         (setq end (1+ beg))))
+  (if (and (eq beg (point-min))
+           (eq end (point-max)))
+      yas--active-snippets
+    ;; Note: don't use `mapcar' here, since it would allocate in
+    ;; proportion to the amount of overlays, even though the list of
+    ;; active snippets should be very small.
+    (let ((snippets nil))
+      (dolist (ov (overlays-in beg end))
+        (let ((snippet (overlay-get ov 'yas--snippet)))
+          ;; Snippets have multiple overlays, so check for dups.
+          (when (and snippet (not (memq snippet snippets)))
+            (push snippet snippets))))
+      (cl-sort snippets #'>= :key #'yas--snippet-id))))
+
+(define-obsolete-function-alias 'yas--snippets-at-point
+  'yas-active-snippets "0.12")
+
+(defun yas-next-field-or-maybe-expand ()
+  "Try to expand a snippet at a key before point.
+
+Otherwise delegate to `yas-next-field'."
+  (interactive)
+  (if yas-triggers-in-field
+      (let ((yas-fallback-behavior 'return-nil)
+            (active-field (overlay-get yas--active-field-overlay 'yas--field)))
+        (when active-field
+          (unless (yas-expand-from-trigger-key active-field)
+            (yas-next-field))))
+    (yas-next-field)))
+
+(defun yas-next-field-will-exit-p (&optional arg)
+  "Return non-nil if (yas-next-field ARG) would exit the current snippet."
+  (let ((snippet (car (yas-active-snippets)))
+        (active (overlay-get yas--active-field-overlay 'yas--field)))
+    (when snippet
+      (not (yas--find-next-field arg snippet active)))))
+
+(defun yas--find-next-field (n snippet active)
+  "Return the Nth field after the ACTIVE one in SNIPPET."
+  (let ((live-fields (cl-remove-if
+                      (lambda (field)
+                        (and (not (eq field active))
+                             (yas--field-probably-deleted-p snippet field)))
+                      (yas--snippet-fields snippet))))
+    (nth (abs n) (memq active (if (>= n 0) live-fields (reverse live-fields))))))
+
+(defun yas-next-field (&optional arg)
+  "Navigate to the ARGth next field.
+
+If there's none, exit the snippet."
+  (interactive)
+  (unless arg (setq arg 1))
+  (let* ((active-field (overlay-get yas--active-field-overlay 'yas--field))
+         (snippet (car (yas-active-snippets (yas--field-start active-field)
+                                            (yas--field-end active-field))))
+         (target-field (yas--find-next-field arg snippet active-field)))
+    (yas--letenv (yas--snippet-expand-env snippet)
+      ;; Apply transform to active field.
+      (when active-field
+        (let ((yas-moving-away-p t))
+          (when (yas--field-update-display active-field)
+            (yas--update-mirrors snippet))))
+      ;; Now actually move...
+      (if target-field
+          (yas--move-to-field snippet target-field)
+        (yas-exit-snippet snippet)))))
+
+(defun yas--place-overlays (snippet field)
+  "Correctly place overlays for SNIPPET's FIELD."
+  (yas--make-move-field-protection-overlays snippet field)
+  ;; Only move active field overlays if this is field is from the
+  ;; innermost snippet.
+  (when (eq snippet (car (yas-active-snippets (1- (yas--field-start field))
+                                              (1+ (yas--field-end field)))))
+    (yas--make-move-active-field-overlay snippet field)))
+
+(defun yas--move-to-field (snippet field)
+  "Update SNIPPET to move to field FIELD.
+
+Also create some protection overlays"
+  (goto-char (yas--field-start field))
+  (yas--place-overlays snippet field)
+  (overlay-put yas--active-field-overlay 'yas--snippet snippet)
+  (overlay-put yas--active-field-overlay 'yas--field field)
+  (let ((number (yas--field-number field)))
+    ;; check for the special ${0: ...} field
+    (if (and number (zerop number))
+        (progn
+          (set-mark (yas--field-end field))
+          (setf (yas--snippet-force-exit snippet)
+                (or (yas--field-transform field)
+                    t)))
+      ;; make this field active
+      (setf (yas--snippet-active-field snippet) field)
+      ;; primary field transform: first call to snippet transform
+      (unless (yas--field-modified-p field)
+        (if (yas--field-update-display field)
+            (yas--update-mirrors snippet)
+          (setf (yas--field-modified-p field) nil))))))
+
+(defun yas-prev-field ()
+  "Navigate to prev field.  If there's none, exit the snippet."
+  (interactive)
+  (yas-next-field -1))
+
+(defun yas-abort-snippet (&optional snippet)
+  (interactive)
+  (let ((snippet (or snippet
+                     (car (yas-active-snippets)))))
+    (when snippet
+      (setf (yas--snippet-force-exit snippet) t))))
+
+(defun yas-exit-snippet (snippet)
+  "Goto exit-marker of SNIPPET."
+  (interactive (list (cl-first (yas-active-snippets))))
+  (when snippet
+    (setf (yas--snippet-force-exit snippet) t)
+    (goto-char (if (yas--snippet-exit snippet)
+                   (yas--exit-marker (yas--snippet-exit snippet))
+                 (overlay-end (yas--snippet-control-overlay snippet))))))
+
+(defun yas-exit-all-snippets ()
+  "Exit all snippets."
+  (interactive)
+  (mapc #'(lambda (snippet)
+            (yas-exit-snippet snippet)
+            (yas--check-commit-snippet))
+        (yas-active-snippets 'all)))
+
+
+;;; Some low level snippet-routines:
+
+(defvar yas--inhibit-overlay-hooks nil
+  "Bind this temporarily to non-nil to prevent running `yas--on-*-modification'.")
+
+(defvar yas-snippet-beg nil "Beginning position of the last snippet committed.")
+(defvar yas-snippet-end nil "End position of the last snippet committed.")
+
+(defun yas--commit-snippet (snippet)
+  "Commit SNIPPET, but leave point as it is.
+
+This renders the snippet as ordinary text."
+
+  (let ((control-overlay (yas--snippet-control-overlay snippet)))
+    ;;
+    ;; Save the end of the moribund snippet in case we need to revive it
+    ;; its original expansion.
+    ;;
+    (when (and control-overlay
+               (overlay-buffer control-overlay))
+      (setq yas-snippet-beg (overlay-start control-overlay))
+      (setq yas-snippet-end (overlay-end control-overlay))
+      (delete-overlay control-overlay)
+      (setf (yas--snippet-control-overlay snippet) nil))
+
+    (let ((yas--inhibit-overlay-hooks t))
+      (when yas--active-field-overlay
+        (delete-overlay yas--active-field-overlay))
+      (when yas--field-protection-overlays
+        (mapc #'delete-overlay yas--field-protection-overlays)))
+
+    ;; stacked expansion: if the original expansion took place from a
+    ;; field, make sure we advance it here at least to
+    ;; `yas-snippet-end'...
+    ;;
+    (let ((previous-field (yas--snippet-previous-active-field snippet)))
+      (when (and yas-snippet-end previous-field)
+        (yas--advance-end-maybe-previous-fields
+         previous-field yas-snippet-end (cdr yas--active-snippets))))
+
+    ;; Convert all markers to points,
+    ;;
+    (yas--markers-to-points snippet)
+
+    ;; It's no longer an active snippet.
+    (cl-callf2 delq snippet yas--active-snippets)
+
+    ;; Take care of snippet revival on undo.
+    (if (and yas-snippet-revival (listp buffer-undo-list))
+        (push `(apply yas--snippet-revive ,yas-snippet-beg ,yas-snippet-end ,snippet)
+              buffer-undo-list)
+      ;; Dismember the snippet... this is useful if we get called
+      ;; again from `yas--take-care-of-redo'....
+      (setf (yas--snippet-fields snippet) nil)))
+
+  (yas--message 4 "Snippet %s exited." (yas--snippet-id snippet)))
+
+(defvar yas--snippets-to-move nil)
+(make-variable-buffer-local 'yas--snippets-to-move)
+
+(defun yas--prepare-snippets-for-move (beg end buf pos)
+  "Gather snippets in BEG..END for moving to POS in BUF."
+  (let ((to-move nil)
+        (snippets (yas-active-snippets beg end))
+        (dst-base-line (with-current-buffer buf
+                         (count-lines (point-min) pos))))
+    (when snippets
+      (dolist (snippet snippets)
+        (yas--snippet-map-markers
+         (lambda (m)
+           (prog1 (cons m (yas--snapshot-line-location m))
+             (set-marker m nil)))
+         snippet)
+        (let ((ctrl-ov (yas--snapshot-overlay-line-location
+                        (yas--snippet-control-overlay snippet))))
+          (push (list ctrl-ov dst-base-line snippet) to-move)
+          (delete-overlay (car ctrl-ov))))
+      (with-current-buffer buf
+        (cl-callf2 nconc to-move yas--snippets-to-move)))))
+
+(defun yas--on-buffer-kill ()
+  ;; Org mode uses temp buffers for fontification and "native tab",
+  ;; move all the snippets to the original org-mode buffer when it's
+  ;; killed.
+  (let ((org-marker nil)
+        (org-buffer nil))
+    (when (and yas-minor-mode
+               (or (bound-and-true-p org-edit-src-from-org-mode)
+                   (bound-and-true-p org-src--from-org-mode))
+               (markerp
+                (setq org-marker
+                      (or (bound-and-true-p org-edit-src-beg-marker)
+                          (bound-and-true-p org-src--beg-marker))))
+               ;; If the org source buffer is killed before the temp
+               ;; fontification one, org-marker might point nowhere.
+               (setq org-buffer (marker-buffer org-marker)))
+      (yas--prepare-snippets-for-move
+       (point-min) (point-max)
+       org-buffer org-marker))))
+
+(add-hook 'kill-buffer-hook #'yas--on-buffer-kill)
+
+(defun yas--finish-moving-snippets ()
+  "Finish job started in `yas--prepare-snippets-for-move'."
+  (cl-loop for (ctrl-ov base-line snippet) in yas--snippets-to-move
+           for base-pos = (progn (goto-char (point-min))
+                                 (forward-line base-line) (point))
+           do (yas--snippet-map-markers
+               (lambda (saved-location)
+                 (let ((m (pop saved-location)))
+                   (set-marker m (yas--goto-saved-line-location
+                                  base-pos saved-location))
+                   m))
+               snippet)
+           (goto-char base-pos)
+           (yas--restore-overlay-line-location base-pos ctrl-ov)
+           (yas--maybe-move-to-active-field snippet)
+           (push snippet yas--active-snippets))
+  (setq yas--snippets-to-move nil))
+
+(defun yas--safely-call-fun (fun)
+  "Call FUN and catch any errors."
+  (condition-case error
+      (funcall fun)
+    ((debug error)
+     (yas--message 2 "Error running %s: %s" fun
+                   (error-message-string error)))))
+
+(defun yas--safely-run-hook (hook)
+  "Call HOOK's functions.
+HOOK should be a symbol, a hook variable, as in `run-hooks'."
+  (let ((debug-on-error (and (not (memq yas-good-grace '(t hooks)))
+                             debug-on-error)))
+    (yas--safely-call-fun (apply-partially #'run-hooks hook))))
+
+(defun yas--check-commit-snippet ()
+  "Check if point exited the currently active field of the snippet.
+
+If so cleans up the whole snippet up."
+  (let* ((snippet-exit-transform nil)
+         (exited-snippets-p nil)
+         ;; Record the custom snippet `yas-after-exit-snippet-hook'
+         ;; set in the expand-env field.
+         (snippet-exit-hook yas-after-exit-snippet-hook))
+    (dolist (snippet yas--active-snippets)
+      (let ((active-field (yas--snippet-active-field snippet)))
+        (yas--letenv (yas--snippet-expand-env snippet)
+          ;; Note: the `force-exit' field could be a transform in case of
+          ;; ${0: ...}, see `yas--move-to-field'.
+          (setq snippet-exit-transform (yas--snippet-force-exit snippet))
+          (cond ((or snippet-exit-transform
+                     (not (and active-field (yas--field-contains-point-p active-field))))
+                 (setf (yas--snippet-force-exit snippet) nil)
+                 (setq snippet-exit-hook yas-after-exit-snippet-hook)
+                 (yas--commit-snippet snippet)
+                 (setq exited-snippets-p t))
+                ((and active-field
+                      (or (not yas--active-field-overlay)
+                          (not (overlay-buffer yas--active-field-overlay))))
+                 ;;
+                 ;; stacked expansion: this case is mainly for recent
+                 ;; snippet exits that place us back int the field of
+                 ;; another snippet
+                 ;;
+                 (save-excursion
+                   (yas--move-to-field snippet active-field)
+                   (yas--update-mirrors snippet)))
+                (t
+                 nil)))))
+    (unless (or yas--active-snippets (not exited-snippets-p))
+      (when snippet-exit-transform
+        (yas--eval-for-effect snippet-exit-transform))
+      (let ((yas-after-exit-snippet-hook snippet-exit-hook))
+        (yas--safely-run-hook 'yas-after-exit-snippet-hook)))))
+
+;; Apropos markers-to-points:
+;;
+;; This was found useful for performance reasons, so that an excessive
+;; number of live markers aren't kept around in the
+;; `buffer-undo-list'.  We don't reuse the original marker object
+;; because that leaves an unreadable object in the history list and
+;; undo-tree persistence has trouble with that.
+;;
+;; This shouldn't bring horrible problems with undo/redo, but you
+;; never know.
+;;
+(defun yas--markers-to-points (snippet)
+  "Save all markers of SNIPPET as positions."
+  (yas--snippet-map-markers (lambda (m)
+                              (prog1 (marker-position m)
+                                (set-marker m nil)))
+                            snippet))
+
+(defun yas--points-to-markers (snippet)
+  "Restore SNIPPET's marker positions, saved by `yas--markers-to-points'."
+  (yas--snippet-map-markers #'copy-marker snippet))
+
+(defun yas--maybe-move-to-active-field (snippet)
+  "Try to move to SNIPPET's active (or first) field and return it if found."
+  (let ((target-field (or (yas--snippet-active-field snippet)
+                          (car (yas--snippet-fields snippet)))))
+    (when target-field
+      (yas--move-to-field snippet target-field)
+      target-field)))
+
+(defun yas--field-contains-point-p (field &optional point)
+  (let ((point (or point
+                   (point))))
+    (and (>= point (yas--field-start field))
+         (<= point (yas--field-end field)))))
+
+(defun yas--field-text-for-display (field)
+  "Return the propertized display text for field FIELD."
+  (buffer-substring (yas--field-start field) (yas--field-end field)))
+
+(defun yas--undo-in-progress ()
+  "True if some kind of undo is in progress."
+  (or undo-in-progress
+      (eq this-command 'undo)
+      (eq this-command 'redo)))
+
+(defun yas--make-control-overlay (snippet start end)
+  "Create the control overlay that surrounds the snippet and
+holds the keymap."
+  (let ((overlay (make-overlay start
+                               end
+                               nil
+                               nil
+                               t)))
+    (overlay-put overlay 'keymap yas-keymap)
+    (overlay-put overlay 'priority yas-overlay-priority)
+    (overlay-put overlay 'yas--snippet snippet)
+    overlay))
+
+(defun yas-current-field ()
+  "Return the currently active field."
+  (and yas--active-field-overlay
+       (overlay-buffer yas--active-field-overlay)
+       (overlay-get yas--active-field-overlay 'yas--field)))
+
+(defun yas--maybe-clear-field-filter (cmd)
+  "Return CMD if at start of unmodified snippet field.
+Use as a `:filter' argument for a conditional keybinding."
+  (let ((field (yas-current-field)))
+    (when (and field
+               (not (yas--field-modified-p field))
+               (eq (point) (marker-position (yas--field-start field))))
+      cmd)))
+
+(defun yas-skip-and-clear-field (&optional field)
+  "Clears unmodified FIELD if at field start, skips to next tab."
+  (interactive)
+  (yas--skip-and-clear (or field (yas-current-field)))
+  (yas-next-field 1))
+
+(defun yas-clear-field (&optional field)
+  "Clears unmodified FIELD if at field start."
+  (interactive)
+  (yas--skip-and-clear (or field (yas-current-field))))
+
+(defun yas-skip-and-clear-or-delete-char (&optional field)
+  "Clears unmodified field if at field start, skips to next tab.
+
+Otherwise deletes a character normally by calling `delete-char'."
+  (interactive)
+  (declare (obsolete "Bind to `yas-maybe-skip-and-clear-field' instead." "0.13"))
+  (cond ((yas--maybe-clear-field-filter t)
+         (yas--skip-and-clear (or field (yas-current-field)))
+         (yas-next-field 1))
+        (t (call-interactively 'delete-char))))
+
+(defun yas--skip-and-clear (field &optional from)
+  "Deletes the region of FIELD and sets it's modified state to t.
+If given, FROM indicates position to start at instead of FIELD's beginning."
+  ;; Just before skipping-and-clearing the field, mark its children
+  ;; fields as modified, too. If the children have mirrors-in-fields
+  ;; this prevents them from updating erroneously (we're skipping and
+  ;; deleting!).
+  ;;
+  (yas--mark-this-and-children-modified field)
+  (unless (= (yas--field-start field) (yas--field-end field))
+    (delete-region (or from (yas--field-start field)) (yas--field-end field))))
+
+(defun yas--mark-this-and-children-modified (field)
+  (setf (yas--field-modified-p field) t)
+  (let ((fom (yas--field-next field)))
+    (while (and fom
+                (yas--fom-parent-field fom))
+      (when (and (eq (yas--fom-parent-field fom) field)
+                 (yas--field-p fom))
+        (yas--mark-this-and-children-modified fom))
+      (setq fom (yas--fom-next fom)))))
+
+(defun yas--make-move-active-field-overlay (snippet field)
+  "Place the active field overlay in SNIPPET's FIELD.
+
+Move the overlay, or create it if it does not exit."
+  (if (and yas--active-field-overlay
+           (overlay-buffer yas--active-field-overlay))
+      (move-overlay yas--active-field-overlay
+                    (yas--field-start field)
+                    (yas--field-end field))
+    (setq yas--active-field-overlay
+          (make-overlay (yas--field-start field)
+                        (yas--field-end field)
+                        nil nil t))
+    (overlay-put yas--active-field-overlay 'priority yas-overlay-priority)
+    (overlay-put yas--active-field-overlay 'face 'yas-field-highlight-face)
+    (overlay-put yas--active-field-overlay 'yas--snippet snippet)
+    (overlay-put yas--active-field-overlay 'modification-hooks '(yas--on-field-overlay-modification))
+    (overlay-put yas--active-field-overlay 'insert-in-front-hooks
+                 '(yas--on-field-overlay-modification))
+    (overlay-put yas--active-field-overlay 'insert-behind-hooks
+                 '(yas--on-field-overlay-modification))))
+
+(defun yas--skip-and-clear-field-p (field beg _end length)
+  "Tell if newly modified FIELD should be cleared and skipped.
+BEG, END and LENGTH like overlay modification hooks."
+  (and (= length 0) ; A 0 pre-change length indicates insertion.
+       (= beg (yas--field-start field)) ; Insertion at field start?
+       (not (yas--field-modified-p field))))
+
+
+(defun yas--merge-and-drop-dups (list1 list2 cmp key)
+  ;; `delete-consecutive-dups' + `cl-merge'.
+  (funcall (if (fboundp 'delete-consecutive-dups)
+               #'delete-consecutive-dups ; 24.4
+             #'delete-dups)
+           (cl-merge 'list list1 list2 cmp :key key)))
+
+(defvar yas--before-change-modified-snippets nil)
+(make-variable-buffer-local 'yas--before-change-modified-snippets)
+
+(defun yas--gather-active-snippets (overlay beg end then-delete)
+  ;; Add active snippets in BEG..END into an OVERLAY keyed entry of
+  ;; `yas--before-change-modified-snippets'.  Return accumulated list.
+  ;; If THEN-DELETE is non-nil, delete the entry.
+  (let ((new (yas-active-snippets beg end))
+        (old (assq overlay yas--before-change-modified-snippets)))
+    (prog1 (cond ((and new old)
+                  (setf (cdr old)
+                        (yas--merge-and-drop-dups
+                         (cdr old) new
+                         ;; Sort like `yas-active-snippets'.
+                         #'>= #'yas--snippet-id)))
+                 (new (unless then-delete
+                        ;; Don't add new entry if we're about to
+                        ;; remove it anyway.
+                        (push (cons overlay new)
+                              yas--before-change-modified-snippets))
+                      new)
+                 (old (cdr old))
+                 (t nil))
+      (when then-delete
+        (cl-callf2 delq old yas--before-change-modified-snippets)))))
+
+(defvar yas--todo-snippet-indent nil nil)
+(make-variable-buffer-local 'yas--todo-snippet-indent)
+
+(defun yas--on-field-overlay-modification (overlay after? beg end &optional length)
+  "Clears the field and updates mirrors, conditionally.
+
+Only clears the field if it hasn't been modified and point is at
+field start.  This hook does nothing if an undo is in progress."
+  (unless (or yas--inhibit-overlay-hooks
+              (not (overlayp yas--active-field-overlay)) ; Avoid Emacs bug #21824.
+              ;; If a single change hits multiple overlays of the same
+              ;; snippet, then we delete the snippet the first time,
+              ;; and then subsequent calls get a deleted overlay.
+              ;; Don't delete the snippet again!
+              (not (overlay-buffer overlay))
+              (yas--undo-in-progress))
+    (let* ((inhibit-modification-hooks nil)
+           (yas--inhibit-overlay-hooks t)
+           (field (overlay-get overlay 'yas--field))
+           (snippet (overlay-get yas--active-field-overlay 'yas--snippet)))
+      (if (yas--snippet-live-p snippet)
+          (if after?
+              (save-match-data
+                (yas--letenv (yas--snippet-expand-env snippet)
+                  (when (yas--skip-and-clear-field-p field beg end length)
+                    ;; We delete text starting from the END of insertion.
+                    (yas--skip-and-clear field end))
+                  (setf (yas--field-modified-p field) t)
+                  ;; Adjust any pending active fields in case of stacked
+                  ;; expansion.
+                  (yas--advance-end-maybe-previous-fields
+                   field (overlay-end overlay)
+                   (yas--gather-active-snippets overlay beg end t))
+                  ;; Update fields now, but delay auto indentation until
+                  ;; post-command.  We don't want to run indentation on
+                  ;; the intermediate state where field text might be
+                  ;; removed (and hence the field could be deleted along
+                  ;; with leading indentation).
+                  (let ((yas-indent-line nil))
+                    (save-excursion
+                      (yas--field-update-display field))
+                    (yas--update-mirrors snippet))
+                  (unless (or (not (eq yas-indent-line 'auto))
+                              (memq snippet yas--todo-snippet-indent))
+                    (push snippet yas--todo-snippet-indent))))
+            ;; Remember active snippets to use for after the change.
+            (yas--gather-active-snippets overlay beg end nil))
+        (lwarn '(yasnippet zombie) :warning "Killing zombie snippet!")
+        (delete-overlay overlay)))))
+
+(defun yas--do-todo-snippet-indent ()
+  ;; Do pending indentation of snippet fields, called from
+  ;; `yas--post-command-handler'.
+  (when yas--todo-snippet-indent
+    (save-excursion
+      (cl-loop for snippet in yas--todo-snippet-indent
+               do (yas--indent-mirrors-of-snippet
+                   snippet (yas--snippet-field-mirrors snippet)))
+      (setq yas--todo-snippet-indent nil))))
+
+(defun yas--auto-fill ()
+  ;; Preserve snippet markers during auto-fill.
+  (let* ((orig-point (point))
+         (end (progn (forward-paragraph) (point)))
+         (beg (progn (backward-paragraph) (point)))
+         (snippets (yas-active-snippets beg end))
+         (remarkers nil)
+         (reoverlays nil))
+    (dolist (snippet snippets)
+      (dolist (m (yas--collect-snippet-markers snippet))
+        (when (and (<= beg m) (<= m end))
+          (push (cons m (yas--snapshot-location m beg end)) remarkers)))
+      (push (yas--snapshot-overlay-location
+             (yas--snippet-control-overlay snippet) beg end)
+            reoverlays))
+    (goto-char orig-point)
+    (let ((yas--inhibit-overlay-hooks t))
+      (if yas--original-auto-fill-function
+          (funcall yas--original-auto-fill-function)
+        ;; Shouldn't happen, gather more info about it (see #873/919).
+        (let ((yas--fill-fun-values `((t ,(default-value 'yas--original-auto-fill-function))))
+              (fill-fun-values `((t ,(default-value 'auto-fill-function))))
+              ;; Listing 2 buffers with the same value is enough
+              (print-length 3))
+          (save-current-buffer
+            (dolist (buf (let ((bufs (buffer-list)))
+                           ;; List the current buffer first.
+                           (setq bufs (cons (current-buffer)
+                                            (remq (current-buffer) bufs)))))
+              (set-buffer buf)
+              (let* ((yf-cell (assq yas--original-auto-fill-function
+                                    yas--fill-fun-values))
+                     (af-cell (assq auto-fill-function fill-fun-values)))
+                (when (local-variable-p 'yas--original-auto-fill-function)
+                  (if yf-cell (setcdr yf-cell (cons buf (cdr yf-cell)))
+                    (push (list yas--original-auto-fill-function buf) yas--fill-fun-values)))
+                (when (local-variable-p 'auto-fill-function)
+                  (if af-cell (setcdr af-cell (cons buf (cdr af-cell)))
+                    (push (list auto-fill-function buf) fill-fun-values))))))
+          (lwarn '(yasnippet auto-fill bug) :error
+                 "`yas--original-auto-fill-function' unexpectedly nil in %S!  Disabling auto-fill.
+  %S
+  `auto-fill-function': %S\n%s"
+                 (current-buffer) yas--fill-fun-values fill-fun-values
+                 (if (fboundp 'backtrace--print-frame)
+                     (with-output-to-string
+                       (mapc (lambda (frame)
+                               (apply #'backtrace--print-frame frame))
+                             yas--watch-auto-fill-backtrace))
+                   ""))
+          ;; Try to avoid repeated triggering of this bug.
+          (auto-fill-mode -1)
+          ;; Don't pop up more than once in a session (still log though).
+          (defvar warning-suppress-types) ; `warnings' is autoloaded by `lwarn'.
+          (add-to-list 'warning-suppress-types '(yasnippet auto-fill bug)))))
+    (save-excursion
+      (setq end (progn (forward-paragraph) (point)))
+      (setq beg (progn (backward-paragraph) (point))))
+    (save-excursion
+      (save-restriction
+        (narrow-to-region beg end)
+        (dolist (remarker remarkers)
+          (set-marker (car remarker)
+                      (yas--goto-saved-location (cdr remarker))))
+        (mapc #'yas--restore-overlay-location reoverlays))
+      (mapc (lambda (snippet)
+              (yas--letenv (yas--snippet-expand-env snippet)
+                (yas--update-mirrors snippet)))
+            snippets))))
+
+
+;;; Apropos protection overlays:
+;;
+;; These exist for nasty users who will try to delete parts of the
+;; snippet outside the active field. Actual protection happens in
+;; `yas--on-protection-overlay-modification'.
+;;
+;; As of github #537 this no longer inhibits the command by issuing an
+;; error: all the snippets at point, including nested snippets, are
+;; automatically commited and the current command can proceed.
+;;
+(defun yas--make-move-field-protection-overlays (snippet field)
+  "Place protection overlays surrounding SNIPPET's FIELD.
+
+Move the overlays, or create them if they do not exit."
+  (let ((start (yas--field-start field))
+        (end (yas--field-end field)))
+    ;; First check if the (1+ end) is contained in the buffer,
+    ;; otherwise we'll have to do a bit of cheating and silently
+    ;; insert a newline. the `(1+ (buffer-size))' should prevent this
+    ;; when using stacked expansion
+    ;;
+    (when (< (buffer-size) end)
+      (save-excursion
+        (let ((yas--inhibit-overlay-hooks t))
+          (goto-char (point-max))
+          (newline))))
+    ;; go on to normal overlay creation/moving
+    ;;
+    (cond ((and yas--field-protection-overlays
+                (cl-every #'overlay-buffer yas--field-protection-overlays))
+           (move-overlay (nth 0 yas--field-protection-overlays)
+                         (1- start) start)
+           (move-overlay (nth 1 yas--field-protection-overlays) end (1+ end)))
+          (t
+           (setq yas--field-protection-overlays
+                 (list (make-overlay (1- start) start nil t nil)
+                       (make-overlay end (1+ end) nil t nil)))
+           (dolist (ov yas--field-protection-overlays)
+             (overlay-put ov 'face 'yas--field-debug-face)
+             (overlay-put ov 'yas--snippet snippet)
+             ;; (overlay-put ov 'evaporate t)
+             (overlay-put ov 'modification-hooks '(yas--on-protection-overlay-modification)))))))
+
+(defun yas--on-protection-overlay-modification (_overlay after? beg end &optional length)
+  "Commit the snippet if the protection overlay is being killed."
+  (unless (or yas--inhibit-overlay-hooks
+              yas-inhibit-overlay-modification-protection
+              (not after?)
+              (= length (- end beg)) ; deletion or insertion
+              (yas--undo-in-progress))
+    (let ((snippets (yas-active-snippets)))
+      (yas--message 2 "Committing snippets. Action would destroy a protection overlay.")
+      (cl-loop for snippet in snippets
+               do (yas--commit-snippet snippet)))))
+
+(add-to-list 'debug-ignored-errors "^Exit the snippet first!$")
+
+
+;;; Snippet expansion and "stacked" expansion:
+;;
+;; Stacked expansion is when you try to expand a snippet when already
+;; inside a snippet expansion.
+;;
+;; The parent snippet does not run its fields modification hooks
+;; (`yas--on-field-overlay-modification' and
+;; `yas--on-protection-overlay-modification') while the child snippet
+;; is active. This means, among other things, that the mirrors of the
+;; parent snippet are not updated, this only happening when one exits
+;; the child snippet.
+;;
+;; Unfortunately, this also puts some ugly (and not fully-tested)
+;; bits of code in `yas-expand-snippet' and
+;; `yas--commit-snippet'. I've tried to mark them with "stacked
+;; expansion:".
+;;
+;; This was thought to be safer in an undo/redo perspective, but
+;; maybe the correct implementation is to make the globals
+;; `yas--active-field-overlay' and `yas--field-protection-overlays' be
+;; snippet-local and be active even while the child snippet is
+;; running. This would mean a lot of overlay modification hooks
+;; running, but if managed correctly (including overlay priorities)
+;; they should account for all situations...
+
+(defun yas-expand-snippet (snippet &optional start end expand-env)
+  "Expand SNIPPET at current point.
+
+Text between START and END will be deleted before inserting
+template.  EXPAND-ENV is a list of (SYM VALUE) let-style dynamic
+bindings considered when expanding the snippet.  If omitted, use
+SNIPPET's expand-env field.
+
+SNIPPET may be a snippet structure (e.g., as returned by
+`yas-lookup-snippet'), or just a snippet body (which is a string
+for normal snippets, and a list for command snippets)."
+  (cl-assert (and yas-minor-mode
+                  (memq 'yas--post-command-handler post-command-hook))
+             nil
+             "[yas] `yas-expand-snippet' needs properly setup `yas-minor-mode'")
+  (run-hooks 'yas-before-expand-snippet-hook)
+
+  (let* ((clear-field
+          (let ((field (and yas--active-field-overlay
+                            (overlay-buffer yas--active-field-overlay)
+                            (overlay-get yas--active-field-overlay 'yas--field))))
+            (and field (yas--skip-and-clear-field-p
+                        field (point) (point) 0)
+                 field)))
+         (start (cond (start)
+                      ((region-active-p)
+                       (region-beginning))
+                      (clear-field
+                       (yas--field-start clear-field))
+                      (t (point))))
+         (end (cond (end)
+                    ((region-active-p)
+                     (region-end))
+                    (clear-field
+                     (yas--field-end clear-field))
+                    (t (point))))
+         (to-delete (and (> end start)
+                         (buffer-substring-no-properties start end)))
+         (yas-selected-text
+          (cond (yas-selected-text)
+                ((and (region-active-p)
+                      (not clear-field))
+                 to-delete))))
+    (goto-char start)
+    (setq yas--indent-original-column (current-column))
+    ;; Delete the region to delete, this *does* get undo-recorded.
+    (when to-delete
+      (delete-region start end))
+
+    (let ((content (if (yas--template-p snippet)
+                       (yas--template-content snippet)
+                     snippet)))
+      (when (and (not expand-env) (yas--template-p snippet))
+        (setq expand-env (yas--template-expand-env snippet)))
+      (cond ((listp content)
+             ;; x) This is a snippet-command.
+             (yas--eval-for-effect content))
+            (t
+             ;; x) This is a snippet-snippet :-)
+             (setq yas--start-column (current-column))
+             ;; Stacked expansion: also shoosh the overlay modification hooks.
+             (let ((yas--inhibit-overlay-hooks t))
+               (setq snippet
+                     (yas--snippet-create content expand-env start (point))))
+
+             ;; Stacked-expansion: This checks for stacked expansion, save the
+             ;; `yas--previous-active-field' and advance its boundary.
+             (let ((existing-field (and yas--active-field-overlay
+                                        (overlay-buffer yas--active-field-overlay)
+                                        (overlay-get yas--active-field-overlay 'yas--field))))
+               (when existing-field
+                 (setf (yas--snippet-previous-active-field snippet) existing-field)
+                 (yas--advance-end-maybe-previous-fields
+                  existing-field (overlay-end yas--active-field-overlay)
+                  (cdr yas--active-snippets))))
+
+             ;; Exit the snippet immediately if no fields.
+             (unless (yas--snippet-fields snippet)
+               (yas-exit-snippet snippet))
+
+             ;; Now, schedule a move to the first field.
+             (let ((first-field (car (yas--snippet-fields snippet))))
+               (when first-field
+                 (sit-for 0) ;; fix issue 125
+                 (yas--letenv (yas--snippet-expand-env snippet)
+                   (yas--move-to-field snippet first-field))
+                 (when (and (eq (yas--field-number first-field) 0)
+                            (> (length (yas--field-text-for-display
+                                        first-field))
+                               0))
+                   ;; Keep region for ${0:exit text}.
+                   (setq deactivate-mark nil))))
+             (yas--message 4 "snippet %d expanded." (yas--snippet-id snippet))
+             t)))))
+
+(defun yas--take-care-of-redo (snippet)
+  "Commits SNIPPET, which in turn pushes an undo action for reviving it.
+
+Meant to exit in the `buffer-undo-list'."
+  ;; slightly optimize: this action is only needed for snippets with
+  ;; at least one field
+  (when (yas--snippet-fields snippet)
+    (yas--commit-snippet snippet)))
+
+(defun yas--snippet-revive (beg end snippet)
+  "Revives SNIPPET and creates a control overlay from BEG to END.
+
+BEG and END are, we hope, the original snippets boundaries.
+All the markers/points exiting existing inside SNIPPET should point
+to their correct locations *at the time the snippet is revived*.
+
+After revival, push the `yas--take-care-of-redo' in the
+`buffer-undo-list'"
+  ;; Reconvert all the points to markers
+  (yas--points-to-markers snippet)
+  ;; When at least one editable field existed in the zombie snippet,
+  ;; try to revive the whole thing...
+  (when (yas--maybe-move-to-active-field snippet)
+    (setf (yas--snippet-control-overlay snippet) (yas--make-control-overlay snippet beg end))
+    (overlay-put (yas--snippet-control-overlay snippet) 'yas--snippet snippet)
+    (push snippet yas--active-snippets)
+    (when (listp buffer-undo-list)
+      (push `(apply yas--take-care-of-redo ,snippet)
+            buffer-undo-list))))
+
+(defun yas--snippet-create (content expand-env begin end)
+  "Create a snippet from a template inserted at BEGIN to END.
+
+Returns the newly created snippet."
+  (save-restriction
+    (let ((snippet (yas--make-snippet expand-env)))
+      (yas--letenv expand-env
+        ;; Put a single undo action for the expanded snippet's
+        ;; content.
+        (let ((buffer-undo-list t))
+          (goto-char begin)
+          ;; Call before and after change functions manually,
+          ;; otherwise cc-mode's cache can get messed up.  Don't use
+          ;; `inhibit-modification-hooks' for that, that blocks
+          ;; overlay and text property hooks as well!  FIXME: Maybe
+          ;; use `combine-change-calls'?  (Requires Emacs 27+ though.)
+          (run-hook-with-args 'before-change-functions begin end)
+          (let ((before-change-functions nil)
+                (after-change-functions nil))
+            ;; Some versions of cc-mode (might be the one with Emacs
+            ;; 24.3 only) fail when inserting snippet content in a
+            ;; narrowed buffer, so make sure to insert before
+            ;; narrowing.
+            (insert content)
+            (narrow-to-region begin (point))
+            (goto-char (point-min))
+            (yas--snippet-parse-create snippet))
+          (run-hook-with-args 'after-change-functions
+                              (point-min) (point-max)
+                              (- end begin)))
+        (when (listp buffer-undo-list)
+          (push (cons (point-min) (point-max))
+                buffer-undo-list))
+
+        ;; Indent, collecting undo information normally.
+        (yas--indent snippet)
+
+        ;; Follow up with `yas--take-care-of-redo' on the newly
+        ;; inserted snippet boundaries.
+        (when (listp buffer-undo-list)
+          (push `(apply yas--take-care-of-redo ,snippet)
+                buffer-undo-list))
+
+        ;; Sort and link each field
+        (yas--snippet-sort-fields snippet)
+
+        ;; Create keymap overlay for snippet
+        (setf (yas--snippet-control-overlay snippet)
+              (yas--make-control-overlay snippet (point-min) (point-max)))
+
+        ;; Move to end
+        (goto-char (point-max))
+
+        (push snippet yas--active-snippets)
+        snippet))))
+
+
+;;; Apropos adjacencies and "fom's":
+;;
+;; Once the $-constructs bits like "$n" and "${:n" are deleted in the
+;; recently expanded snippet, we might actually have many fields,
+;; mirrors (and the snippet exit) in the very same position in the
+;; buffer. Therefore we need to single-link the
+;; fields-or-mirrors-or-exit (which I have abbreviated to "fom")
+;; according to their original positions in the buffer.
+;;
+;; Then we have operation `yas--advance-end-maybe' and
+;; `yas--advance-start-maybe', which conditionally push the starts and
+;; ends of these foms down the chain.
+;;
+;; This allows for like the printf with the magic ",":
+;;
+;;   printf ("${1:%s}\\n"${1:$(if (string-match "%" text) "," "\);")}  \
+;;   $2${1:$(if (string-match "%" text) "\);" "")}$0
+;;
+(defun yas--fom-start (fom)
+  (cond ((yas--field-p fom)
+         (yas--field-start fom))
+        ((yas--mirror-p fom)
+         (yas--mirror-start fom))
+        (t
+         (yas--exit-marker fom))))
+
+(defun yas--fom-end (fom)
+  (cond ((yas--field-p fom)
+         (yas--field-end fom))
+        ((yas--mirror-p fom)
+         (yas--mirror-end fom))
+        (t
+         (yas--exit-marker fom))))
+
+(defun yas--fom-next (fom)
+  (cond ((yas--field-p fom)
+         (yas--field-next fom))
+        ((yas--mirror-p fom)
+         (yas--mirror-next fom))
+        (t
+         (yas--exit-next fom))))
+
+(defun yas--fom-parent-field (fom)
+  (cond ((yas--field-p fom)
+         (yas--field-parent-field fom))
+        ((yas--mirror-p fom)
+         (yas--mirror-parent-field fom))
+        (t
+         nil)))
+
+(defun yas--calculate-adjacencies (snippet)
+  "Calculate adjacencies for fields or mirrors of SNIPPET.
+
+This is according to their relative positions in the buffer, and
+has to be called before the $-constructs are deleted."
+  (let* ((fom-set-next-fom
+         (lambda (fom nextfom)
+           (cond ((yas--field-p fom)
+                  (setf (yas--field-next fom) nextfom))
+                 ((yas--mirror-p fom)
+                  (setf (yas--mirror-next fom) nextfom))
+                 (t
+                  (setf (yas--exit-next fom) nextfom)))))
+        (compare-fom-begs
+         (lambda (fom1 fom2)
+           (if (= (yas--fom-start fom2) (yas--fom-start fom1))
+               (yas--mirror-p fom2)
+             (>= (yas--fom-start fom2) (yas--fom-start fom1)))))
+        (link-foms fom-set-next-fom))
+    ;; make some yas--field, yas--mirror and yas--exit soup
+    (let ((soup))
+      (when (yas--snippet-exit snippet)
+        (push (yas--snippet-exit snippet) soup))
+      (dolist (field (yas--snippet-fields snippet))
+        (push field soup)
+        (dolist (mirror (yas--field-mirrors field))
+          (push mirror soup)))
+      (setq soup
+            (sort soup compare-fom-begs))
+      (when soup
+        (cl-reduce link-foms soup)))))
+
+(defun yas--calculate-simple-fom-parentage (snippet fom)
+  "Discover if FOM is parented by some field in SNIPPET.
+
+Use the tightest containing field if more than one field contains
+the mirror.  Intended to be called *before* the dollar-regions are
+deleted."
+  (let ((min (point-min))
+        (max (point-max)))
+    (dolist (field (remq fom (yas--snippet-fields snippet)))
+      (when (and (<= (yas--field-start field) (yas--fom-start fom))
+                 (<= (yas--fom-end fom) (yas--field-end field))
+               (< min (yas--field-start field))
+               (< (yas--field-end field) max))
+          (setq min (yas--field-start field)
+                max (yas--field-end field))
+          (cond ((yas--field-p fom)
+                 (setf (yas--field-parent-field fom) field))
+                ((yas--mirror-p fom)
+                 (setf (yas--mirror-parent-field fom) field))
+                (t ; it's an exit, so noop
+                 nil ))))))
+
+(defun yas--advance-end-maybe (fom newend)
+  "Maybe advance FOM's end to NEWEND if it needs it.
+
+If it does, also:
+
+* call `yas--advance-start-maybe' on FOM's next fom.
+
+* in case FOM is field call `yas--advance-end-maybe' on its parent
+  field
+
+Also, if FOM is an exit-marker, always call
+`yas--advance-start-maybe' on its next fom.  This is because
+exit-marker have identical start and end markers."
+  (cond ((and fom (< (yas--fom-end fom) newend))
+         (set-marker (yas--fom-end fom) newend)
+         (yas--advance-start-maybe (yas--fom-next fom) newend)
+         (yas--advance-end-of-parents-maybe (yas--fom-parent-field fom) newend))
+        ((yas--exit-p fom)
+         (yas--advance-start-maybe (yas--fom-next fom) newend))))
+
+(defun yas--advance-end-maybe-previous-fields (field end snippets)
+  "Call `yas--advance-end-maybe' on FIELD, and previous fields on SNIPPETS."
+  (dolist (snippet snippets)
+    (cl-assert (memq field (yas--snippet-fields snippet)))
+    (yas--advance-end-maybe field end)
+    (setq field (yas--snippet-previous-active-field snippet))))
+
+(defun yas--advance-start-maybe (fom newstart)
+  "Maybe advance FOM's start to NEWSTART if it needs it.
+
+If it does, also call `yas--advance-end-maybe' on FOM."
+  (when (and fom (< (yas--fom-start fom) newstart))
+    (set-marker (yas--fom-start fom) newstart)
+    (yas--advance-end-maybe fom newstart)))
+
+(defun yas--advance-end-of-parents-maybe (field newend)
+  "Like `yas--advance-end-maybe' but for parent fields.
+
+Only works for fields and doesn't care about the start of the
+next FOM.  Works its way up recursively for parents of parents."
+  (when (and field
+             (< (yas--field-end field) newend))
+    (set-marker (yas--field-end field) newend)
+    (yas--advance-end-of-parents-maybe (yas--field-parent-field field) newend)))
+
+(defvar yas--dollar-regions nil
+  "When expanding the snippet the \"parse-create\" functions add
+cons cells to this var.")
+
+(defvar yas--indent-markers nil
+  "List of markers for manual indentation.")
+
+(defun yas--snippet-parse-create (snippet)
+  "Parse a recently inserted snippet template, creating all
+necessary fields, mirrors and exit points.
+
+Meant to be called in a narrowed buffer, does various passes"
+  (let ((saved-quotes nil)
+        (parse-start (point)))
+    ;; Avoid major-mode's syntax propertizing function, since we
+    ;; change the syntax-table while calling `scan-sexps'.
+    (let ((syntax-propertize-function nil))
+      (setq yas--dollar-regions nil)  ; Reset the yas--dollar-regions.
+      (yas--protect-escapes nil '(?`))  ; Protect just the backquotes.
+      (goto-char parse-start)
+      (setq saved-quotes (yas--save-backquotes)) ; `expressions`.
+      (yas--protect-escapes)            ; Protect escaped characters.
+      (goto-char parse-start)
+      (yas--indent-parse-create)        ; Parse indent markers: `$>'.
+      (goto-char parse-start)
+      (yas--field-parse-create snippet) ; Parse fields with {}.
+      (goto-char parse-start)
+      (yas--simple-fom-create snippet) ; Parse simple mirrors & fields.
+      (goto-char parse-start)
+      (yas--transform-mirror-parse-create snippet) ; Parse mirror transforms.
+      ;; Invalidate any syntax-propertizing done while
+      ;; `syntax-propertize-function' was nil.
+      (syntax-ppss-flush-cache parse-start))
+    ;; Set "next" links of fields & mirrors.
+    (yas--calculate-adjacencies snippet)
+    (yas--save-restriction-and-widen    ; Delete $-constructs.
+      (yas--delete-regions yas--dollar-regions))
+    ;; Make sure to do this insertion *after* deleting the dollar
+    ;; regions, otherwise we invalidate the calculated positions of
+    ;; all the fields following $0.
+    (let ((exit (yas--snippet-exit snippet)))
+      (goto-char (if exit (yas--exit-marker exit) (point-max))))
+    (when (eq yas-wrap-around-region 'cua)
+      (setq yas-wrap-around-region ?0))
+    (cond ((and yas-wrap-around-region yas-selected-text)
+           (insert yas-selected-text))
+          ((and (characterp yas-wrap-around-region)
+                (get-register yas-wrap-around-region))
+           (insert (prog1 (get-register yas-wrap-around-region)
+                     (set-register yas-wrap-around-region nil)))))
+    (yas--restore-backquotes saved-quotes)  ; Restore `expression` values.
+    (goto-char parse-start)
+    (yas--restore-escapes)        ; Restore escapes.
+    (yas--update-mirrors snippet) ; Update mirrors for the first time.
+    (goto-char parse-start)))
+
+;; HACK: Some implementations of `indent-line-function' (called via
+;; `indent-according-to-mode') delete text before they insert (like
+;; cc-mode), some make complicated regexp replacements (looking at
+;; you, org-mode).  To find place where the marker "should" go after
+;; indentation, we create a regexp based on what the line looks like
+;; before, putting a capture group where the marker is.  The regexp
+;; matches any whitespace with [[:space:]]* to allow for the
+;; indentation changing whitespace.  Additionally, we try to preserve
+;; the amount of whitespace *following* the marker, because
+;; indentation generally affects whitespace at the beginning, not the
+;; end.
+;;
+;; Two other cases where we apply a similar strategy:
+;;
+;; 1. Handling `auto-fill-mode', in this case we need to use the
+;; current paragraph instead of line.
+;;
+;; 2. Moving snippets from an `org-src' temp buffer into the main org
+;; buffer, in this case we need to count the relative line number
+;; (because org may add indentation on each line making character
+;; positions unreliable).
+;;
+;; Data formats:
+;; (LOCATION) = (REGEXP WS-COUNT)
+;; MARKER -> (MARKER . (LOCATION))
+;; OVERLAY -> (OVERLAY LOCATION-BEG LOCATION-END)
+;;
+;; For `org-src' temp buffer, add a line number to format:
+;; (LINE-LOCATION) = (LINE . (LOCATION))
+;; MARKER@LINE -> (MARKER . (LINE-LOCATION))
+;; OVERLAY@LINE -> (OVERLAY LINE-LOCATION-BEG LINE-LOCATION-END)
+;;
+;; This is all best-effort heuristic stuff, but it should cover 99% of
+;; use-cases.
+
+(defun yas--snapshot-location (position &optional beg end)
+  "Returns info for restoring POSITIONS's location after indent.
+The returned value is a list of the form (REGEXP WS-COUNT).
+POSITION may be either a marker or just a buffer position.  The
+REGEXP matches text between BEG..END which default to the current
+line if omitted."
+  (goto-char position)
+  (unless beg (setq beg (line-beginning-position)))
+  (unless end (setq end (line-end-position)))
+  (let ((before (split-string (buffer-substring-no-properties beg position)
+                              "[[:space:]\n]+" t))
+        (after (split-string (buffer-substring-no-properties position end)
+                             "[[:space:]\n]+" t)))
+    (list (concat "[[:space:]\n]*"
+                  (mapconcat (lambda (s)
+                               (if (eq s position) "\\(\\)"
+                                 (regexp-quote s)))
+                             (nconc before (list position) after)
+                             "[[:space:]\n]*"))
+          (progn (skip-chars-forward "[:space:]\n" end)
+                 (- (point) position)))))
+
+(defun yas--snapshot-line-location (position &optional beg end)
+  "Like `yas--snapshot-location', but return also line number.
+Returned format is (LINE REGEXP WS-COUNT)."
+  (goto-char position)
+  (cons (count-lines (point-min) (line-beginning-position))
+        (yas--snapshot-location position beg end)))
+
+(defun yas--snapshot-overlay-location (overlay beg end)
+  "Like `yas--snapshot-location' for overlays.
+The returned format is (OVERLAY (RE WS) (RE WS)).  Either of
+the (RE WS) lists may be nil if the start or end, respectively,
+of the overlay is outside the range BEG .. END."
+  (let ((obeg (overlay-start overlay))
+        (oend (overlay-end overlay)))
+    (list overlay
+          (when (and (<= beg obeg) (< obeg end))
+            (yas--snapshot-location obeg beg end))
+          (when (and (<= beg oend) (< oend end))
+            (yas--snapshot-location oend beg end)))))
+
+(defun yas--snapshot-overlay-line-location (overlay)
+  "Return info for restoring OVERLAY's line based location.
+The returned format is (OVERLAY (LINE RE WS) (LINE RE WS))."
+  (list overlay
+        (yas--snapshot-line-location (overlay-start overlay))
+        (yas--snapshot-line-location (overlay-end overlay))))
+
+(defun yas--goto-saved-location (re-count)
+  "Move to and return point saved by `yas--snapshot-location'.
+Buffer must be narrowed to BEG..END used to create the snapshot info."
+  (let ((regexp (pop re-count))
+        (ws-count (pop re-count)))
+    (goto-char (point-min))
+    (if (not (looking-at regexp))
+        (lwarn '(yasnippet re-marker) :warning
+               "Couldn't find: %S" regexp)
+      (goto-char (match-beginning 1))
+      (skip-chars-forward "[:space:]\n")
+      (skip-chars-backward "[:space:]\n" (- (point) ws-count)))
+    (point)))
+
+(defun yas--restore-overlay-location (ov-locations)
+  "Restores marker based on info from `yas--snapshot-overlay-location'.
+Buffer must be narrowed to BEG..END used to create the snapshot info."
+  (cl-destructuring-bind (overlay loc-beg loc-end) ov-locations
+    (move-overlay overlay
+                  (if (not loc-beg) (overlay-start overlay)
+                    (yas--goto-saved-location loc-beg))
+                  (if (not loc-end) (overlay-end overlay)
+                    (yas--goto-saved-location loc-end)))))
+
+(defun yas--goto-saved-line-location (base-pos l-re-count)
+  "Move to and return point saved by `yas--snapshot-line-location'.
+Additionally requires BASE-POS to tell where the line numbers are
+relative to."
+  (goto-char base-pos)
+  (forward-line (pop l-re-count))
+  (save-restriction
+    (narrow-to-region (line-beginning-position)
+                      (line-end-position))
+    (yas--goto-saved-location l-re-count)))
+
+(defun yas--restore-overlay-line-location (base-pos ov-locations)
+  "Restores marker based on info from `yas--snapshot-overlay-line-location'."
+  (cl-destructuring-bind (overlay beg-l-r-w end-l-r-w)
+      ov-locations
+    (move-overlay overlay
+                  (yas--goto-saved-line-location base-pos beg-l-r-w)
+                  (yas--goto-saved-line-location base-pos end-l-r-w))))
+
+(defun yas--indent-region (from to snippet)
+  "Indent the lines between FROM and TO with `indent-according-to-mode'.
+The SNIPPET's markers are preserved."
+  (save-excursion
+    (yas--save-restriction-and-widen
+      (let* ((snippet-markers (yas--collect-snippet-markers snippet))
+             (to (set-marker (make-marker) to)))
+        (goto-char from)
+        (cl-loop for bol = (line-beginning-position)
+                 for eol = (line-end-position)
+                 if (or yas-also-indent-empty-lines
+                        (/= bol eol))
+                 do
+                 ;; Indent each non-empty line.
+                 (let ((remarkers nil))
+                   (dolist (m snippet-markers)
+                     (when (and (<= bol m) (<= m eol))
+                       (push (cons m (yas--snapshot-location m bol eol))
+                             remarkers)))
+                   (unwind-protect
+                       (progn (back-to-indentation)
+                              (indent-according-to-mode))
+                     (save-restriction
+                       (narrow-to-region bol (line-end-position))
+                       (dolist (remarker remarkers)
+                         (set-marker (car remarker)
+                                     (yas--goto-saved-location (cdr remarker)))))))
+                 while (and (zerop (forward-line 1))
+                            (< (point) to)))))))
+
+(defvar yas--indent-original-column nil)
+(defun yas--indent (snippet)
+  ;; Indent lines that had indent markers (`$>') on them.
+  (save-excursion
+    (dolist (marker yas--indent-markers)
+      (unless (eq yas-indent-line 'auto)
+        (goto-char marker)
+        (yas--indent-region (line-beginning-position)
+                            (line-end-position)
+                            snippet))
+      ;; Finished with this marker.
+      (set-marker marker nil))
+    (setq yas--indent-markers nil))
+  ;; Now do stuff for `fixed' and `auto'.
+  (save-excursion
+    ;; We need to be at end of line, so that `forward-line' will only
+    ;; report 0 if it actually moves over a newline.
+    (end-of-line)
+    (cond ((eq yas-indent-line 'fixed)
+           (when (= (forward-line 1) 0)
+             (let ((indent-line-function
+                    (lambda ()
+                      ;; We need to be at beginning of line in order to
+                      ;; indent existing whitespace correctly.
+                      (beginning-of-line)
+                      (indent-to-column yas--indent-original-column))))
+               (yas--indent-region (line-beginning-position)
+                                   (point-max)
+                                   snippet))))
+          ((eq yas-indent-line 'auto)
+           (when (or yas-also-auto-indent-first-line
+                     (= (forward-line 1) 0))
+             (yas--indent-region (line-beginning-position)
+                                 (point-max)
+                                 snippet))))))
+
+(defun yas--collect-snippet-markers (snippet)
+  "Make a list of all the markers used by SNIPPET."
+  (let (markers)
+    (yas--snippet-map-markers (lambda (m) (push m markers) m) snippet)
+    markers))
+
+(defun yas--escape-string (escaped)
+  (concat "YASESCAPE" (format "%d" escaped) "PROTECTGUARD"))
+
+(defun yas--protect-escapes (&optional text escaped)
+  "Protect all escaped characters with their numeric ASCII value.
+
+With optional string TEXT do it in string instead of buffer."
+  (let ((changed-text text)
+        (text-provided-p text))
+    (mapc #'(lambda (escaped)
+              (setq changed-text
+                    (yas--replace-all (concat "\\" (char-to-string escaped))
+                                     (yas--escape-string escaped)
+                                     (when text-provided-p changed-text))))
+          (or escaped yas--escaped-characters))
+    changed-text))
+
+(defun yas--restore-escapes (&optional text escaped)
+  "Restore all escaped characters from their numeric ASCII value.
+
+With optional string TEXT do it in string instead of the buffer."
+  (let ((changed-text text)
+        (text-provided-p text))
+    (mapc #'(lambda (escaped)
+              (setq changed-text
+                    (yas--replace-all (yas--escape-string escaped)
+                                     (char-to-string escaped)
+                                     (when text-provided-p changed-text))))
+          (or escaped yas--escaped-characters))
+    changed-text))
+
+(defun yas--save-backquotes ()
+  "Save all \"\\=`(lisp-expression)\\=`\"-style expressions.
+Return a list of (MARKER . STRING) entires for each backquoted
+Lisp expression."
+  (let* ((saved-quotes nil)
+         (yas--snippet-buffer (current-buffer))
+         (yas--change-detected nil)
+         (detect-change (lambda (_beg _end)
+                          (when (eq (current-buffer) yas--snippet-buffer)
+                            (setq yas--change-detected t)))))
+    (while (re-search-forward yas--backquote-lisp-expression-regexp nil t)
+      (let ((current-string (match-string-no-properties 1)) transformed)
+        (yas--save-restriction-and-widen
+          (delete-region (match-beginning 0) (match-end 0)))
+        (let ((before-change-functions
+               (cons detect-change before-change-functions)))
+          (setq transformed (yas--eval-for-string (yas--read-lisp
+                                                   (yas--restore-escapes
+                                                    current-string '(?`))))))
+        (goto-char (match-beginning 0))
+        (when transformed
+          (let ((marker (make-marker)))
+            (yas--save-restriction-and-widen
+              (insert "Y") ;; quite horrendous, I love it :)
+              (set-marker marker (point))
+              (insert "Y"))
+            (push (cons marker transformed) saved-quotes)))))
+    (when yas--change-detected
+      (lwarn '(yasnippet backquote-change) :warning
+             "`%s' modified buffer in a backquote expression.
+  To hide this warning, add (yasnippet backquote-change) to `warning-suppress-types'."
+             (if yas--current-template
+                 (yas--template-name yas--current-template)
+               "Snippet")))
+    saved-quotes))
+
+(defun yas--restore-backquotes (saved-quotes)
+  "Replace markers in SAVED-QUOTES with their values.
+SAVED-QUOTES is the in format returned by `yas--save-backquotes'."
+  (cl-loop for (marker . string) in saved-quotes do
+           (save-excursion
+             (goto-char marker)
+             (yas--save-restriction-and-widen
+               (delete-char -1)
+               (insert string)
+               (delete-char 1))
+             (set-marker marker nil))))
+
+(defun yas--scan-sexps (from count)
+  (ignore-errors
+    (save-match-data ; `scan-sexps' may modify match data.
+      ;; Parse using the syntax table corresponding to the yasnippet syntax.
+      (with-syntax-table (standard-syntax-table)
+        ;; And ignore syntax-table properties that may have been placed by the
+        ;; major mode since these aren't related to the yasnippet syntax.
+        (let ((parse-sexp-lookup-properties nil))
+          (scan-sexps from count))))))
+
+(defun yas--make-marker (pos)
+  "Create a marker at POS with nil `marker-insertion-type'."
+  (let ((marker (set-marker (make-marker) pos)))
+    (set-marker-insertion-type marker nil)
+    marker))
+
+(defun yas--indent-parse-create ()
+  "Parse the \"$>\" indentation markers just inserted."
+  (setq yas--indent-markers ())
+  (while (search-forward "$>" nil t)
+    (delete-region (match-beginning 0) (match-end 0))
+    ;; Mark the beginning of the line.
+    (push (yas--make-marker (line-beginning-position))
+          yas--indent-markers))
+  (setq yas--indent-markers (nreverse yas--indent-markers)))
+
+(defun yas--scan-for-field-end ()
+  (while (progn (re-search-forward "\\${\\|}")
+                (when (eq (char-before) ?\{)
+                  ;; Nested field.
+                  (yas--scan-for-field-end))))
+  (point))
+
+(defun yas--field-parse-create (snippet &optional parent-field)
+  "Parse most field expressions in SNIPPET, except for the simple one \"$n\".
+
+The following count as a field:
+
+* \"${n: text}\", for a numbered field with default text, as long as N is not 0;
+
+* \"${n: text$(expression)}, the same with a Lisp expression;
+  this is caught with the curiously named `yas--multi-dollar-lisp-expression-regexp'
+
+* the same as above but unnumbered, (no N:) and number is calculated automatically.
+
+When multiple expressions are found, only the last one counts."
+  ;;
+  (save-excursion
+    (while (re-search-forward yas--field-regexp nil t)
+      (let* ((brace-scan (save-match-data
+                           (goto-char (match-beginning 2))
+                           (yas--scan-for-field-end)))
+             ;; if the `brace-scan' didn't reach a brace, we have a
+             ;; snippet with invalid escaping, probably a closing
+             ;; brace escaped with two backslashes (github#979). But
+             ;; be lenient, because we can.
+             (real-match-end-0 (if (eq ?} (char-before brace-scan))
+                                   brace-scan
+                                 (point)))
+             (number (and (match-string-no-properties 1)
+                          (string-to-number (match-string-no-properties 1))))
+             (brand-new-field (and real-match-end-0
+                                   ;; break if on "$(" immediately
+                                   ;; after the ":", this will be
+                                   ;; caught as a mirror with
+                                   ;; transform later.
+                                   (not (string-match-p "\\`\\$[ \t\n]*("
+                                                        (match-string-no-properties 2)))
+                                   ;; allow ${0: some exit text}
+                                   ;; (not (and number (zerop number)))
+                                   (yas--make-field number
+                                                   (yas--make-marker (match-beginning 2))
+                                                   (yas--make-marker (1- real-match-end-0))
+                                                   parent-field))))
+        (when brand-new-field
+          (goto-char real-match-end-0)
+          (push (cons (1- real-match-end-0) real-match-end-0)
+                yas--dollar-regions)
+          (push (cons (match-beginning 0) (match-beginning 2))
+                yas--dollar-regions)
+          (push brand-new-field (yas--snippet-fields snippet))
+          (save-excursion
+            (save-restriction
+              (narrow-to-region (yas--field-start brand-new-field) (yas--field-end brand-new-field))
+              (goto-char (point-min))
+              (yas--field-parse-create snippet brand-new-field)))))))
+  ;; if we entered from a parent field, now search for the
+  ;; `yas--multi-dollar-lisp-expression-regexp'. This is used for
+  ;; primary field transformations
+  ;;
+  (when parent-field
+    (save-excursion
+      (while (re-search-forward yas--multi-dollar-lisp-expression-regexp nil t)
+        (let* ((real-match-end-1 (yas--scan-sexps (match-beginning 1) 1)))
+          ;; commit the primary field transformation if:
+          ;;
+          ;; 1. we don't find it in yas--dollar-regions (a subnested
+          ;; field) might have already caught it.
+          ;;
+          ;; 2. we really make sure we have either two '$' or some
+          ;; text and a '$' after the colon ':'. This is a FIXME: work
+          ;; my regular expressions and end these ugly hacks.
+          ;;
+          (when (and real-match-end-1
+                     (not (member (cons (match-beginning 0)
+                                        real-match-end-1)
+                                  yas--dollar-regions))
+                     (not (eq ?:
+                              (char-before (1- (match-beginning 1))))))
+            (let ((lisp-expression-string (buffer-substring-no-properties (match-beginning 1)
+                                                                          real-match-end-1)))
+              (setf (yas--field-transform parent-field)
+                    (yas--read-lisp (yas--restore-escapes lisp-expression-string))))
+            (push (cons (match-beginning 0) real-match-end-1)
+                  yas--dollar-regions)))))))
+
+(defun yas--transform-mirror-parse-create (snippet)
+  "Parse the \"${n:$(lisp-expression)}\" mirror transformations in SNIPPET."
+  (while (re-search-forward yas--transform-mirror-regexp nil t)
+    (let* ((real-match-end-0 (yas--scan-sexps (1+ (match-beginning 0)) 1))
+           (number (string-to-number (match-string-no-properties 1)))
+           (field (and number
+                       (not (zerop number))
+                       (yas--snippet-find-field snippet number)))
+           (brand-new-mirror
+            (and real-match-end-0
+                 field
+                 (yas--make-mirror (yas--make-marker (match-beginning 0))
+                                  (yas--make-marker (match-beginning 0))
+                                  (yas--read-lisp
+                                   (yas--restore-escapes
+                                    (buffer-substring-no-properties (match-beginning 2)
+                                                                    (1- real-match-end-0))))))))
+      (when brand-new-mirror
+        (push brand-new-mirror
+              (yas--field-mirrors field))
+        (yas--calculate-simple-fom-parentage snippet brand-new-mirror)
+        (push (cons (match-beginning 0) real-match-end-0) yas--dollar-regions)))))
+
+(defun yas--simple-fom-create (snippet)
+  "Parse the simple \"$n\" fields/mirrors/exitmarkers in SNIPPET."
+  (while (re-search-forward yas--simple-mirror-regexp nil t)
+    (let ((number (string-to-number (match-string-no-properties 1))))
+      (cond ((zerop number)
+             (setf (yas--snippet-exit snippet)
+                   (yas--make-exit (yas--make-marker (match-end 0))))
+             (push (cons (match-beginning 0) (yas--exit-marker (yas--snippet-exit snippet)))
+                   yas--dollar-regions))
+            (t
+             (let ((field (yas--snippet-find-field snippet number))
+                   (fom))
+               (if field
+                   (push
+                    (setq fom (yas--make-mirror
+                               (yas--make-marker (match-beginning 0))
+                               (yas--make-marker (match-beginning 0))
+                               nil))
+                    (yas--field-mirrors field))
+                 (push
+                  (setq fom (yas--make-field number
+                                             (yas--make-marker (match-beginning 0))
+                                             (yas--make-marker (match-beginning 0))
+                                             nil))
+                  (yas--snippet-fields snippet)))
+               (yas--calculate-simple-fom-parentage snippet fom))
+             (push (cons (match-beginning 0) (match-end 0))
+                   yas--dollar-regions))))))
+
+(defun yas--delete-regions (regions)
+  "Sort disjuct REGIONS by start point, then delete from the back."
+  (mapc #'(lambda (reg)
+            (delete-region (car reg) (cdr reg)))
+        (sort regions
+              #'(lambda (r1 r2)
+                  (>= (car r1) (car r2))))))
+
+(defun yas--calculate-mirror-depth (mirror &optional traversed)
+  (let* ((parent (yas--mirror-parent-field mirror))
+         (parents-mirrors (and parent
+                               (yas--field-mirrors parent))))
+    (or (yas--mirror-depth mirror)
+        (setf (yas--mirror-depth mirror)
+              (cond ((memq mirror traversed) 0)
+                    ((and parent parents-mirrors)
+                     (1+ (cl-reduce
+                          #'max parents-mirrors
+                          :key (lambda (m)
+                                 (yas--calculate-mirror-depth
+                                  m (cons mirror traversed))))))
+                    (parent 1)
+                    (t 0))))))
+
+(defun yas--snippet-field-mirrors (snippet)
+  ;; Make a list of (FIELD . MIRROR).
+  (cl-sort
+   (cl-mapcan (lambda (field)
+                (mapcar (lambda (mirror)
+                          (cons field mirror))
+                        (yas--field-mirrors field)))
+              (yas--snippet-fields snippet))
+   ;; Then sort this list so that entries with mirrors with
+   ;; parent fields appear before.  This was important for
+   ;; fixing #290, and also handles the case where a mirror in
+   ;; a field causes another mirror to need reupdating.
+   #'> :key (lambda (fm) (yas--calculate-mirror-depth (cdr fm)))))
+
+(defun yas--indent-mirrors-of-snippet (snippet &optional f-ms)
+  ;; Indent mirrors of SNIPPET.  F-MS is the return value of
+  ;; (yas--snippet-field-mirrors SNIPPET).
+  (when (eq yas-indent-line 'auto)
+    (let ((yas--inhibit-overlay-hooks t))
+      (cl-loop for (beg . end) in
+               (cl-sort (mapcar (lambda (f-m)
+                                  (let ((mirror (cdr f-m)))
+                                    (cons (yas--mirror-start mirror)
+                                          (yas--mirror-end mirror))))
+                                (or f-ms
+                                    (yas--snippet-field-mirrors snippet)))
+                        #'< :key #'car)
+               do (yas--indent-region beg end snippet)))))
+
+(defun yas--update-mirrors (snippet)
+  "Update all the mirrors of SNIPPET."
+  (yas--save-restriction-and-widen
+    (save-excursion
+      (let ((f-ms (yas--snippet-field-mirrors snippet)))
+        (cl-loop
+         for (field . mirror) in f-ms
+         ;; Before updating a mirror with a parent-field, maybe advance
+         ;; its start (#290).
+         do (let ((parent-field (yas--mirror-parent-field mirror)))
+              (when parent-field
+                (yas--advance-start-maybe mirror (yas--fom-start parent-field))))
+         ;; Update this mirror.
+         do (yas--mirror-update-display mirror field)
+         ;; `yas--place-overlays' is needed since the active field and
+         ;; protected overlays might have been changed because of insertions
+         ;; in `yas--mirror-update-display'.
+         do (let ((active-field (yas--snippet-active-field snippet)))
+              (when active-field (yas--place-overlays snippet active-field))))
+        ;; Delay indenting until we're done all mirrors.  We must do
+        ;; this to avoid losing whitespace between fields that are
+        ;; still empty (i.e., they will be non-empty after updating).
+        (yas--indent-mirrors-of-snippet snippet f-ms)))))
+
+(defun yas--mirror-update-display (mirror field)
+  "Update MIRROR according to FIELD (and mirror transform)."
+
+  (let* ((mirror-parent-field (yas--mirror-parent-field mirror))
+         (reflection (and (not (and mirror-parent-field
+                                    (yas--field-modified-p mirror-parent-field)))
+                          (or (yas--apply-transform mirror field 'empty-on-nil)
+                              (yas--field-text-for-display field)))))
+    (when (and reflection
+               (not (string= reflection (buffer-substring-no-properties (yas--mirror-start mirror)
+                                                                        (yas--mirror-end mirror)))))
+      (goto-char (yas--mirror-start mirror))
+      (let ((yas--inhibit-overlay-hooks t))
+        (insert reflection))
+      (if (> (yas--mirror-end mirror) (point))
+          (delete-region (point) (yas--mirror-end mirror))
+        (set-marker (yas--mirror-end mirror) (point))
+        (yas--advance-start-maybe (yas--mirror-next mirror) (point))
+        ;; super-special advance
+        (yas--advance-end-of-parents-maybe mirror-parent-field (point))))))
+
+(defun yas--field-update-display (field)
+  "Much like `yas--mirror-update-display', but for fields."
+  (when (yas--field-transform field)
+    (let ((transformed (and (not (eq (yas--field-number field) 0))
+                            (yas--apply-transform field field))))
+      (when (and transformed
+                 (not (string= transformed (buffer-substring-no-properties (yas--field-start field)
+                                                                           (yas--field-end field)))))
+        (setf (yas--field-modified-p field) t)
+        (goto-char (yas--field-start field))
+        (let ((yas--inhibit-overlay-hooks t))
+          (insert transformed)
+          (if (> (yas--field-end field) (point))
+              (delete-region (point) (yas--field-end field))
+            (set-marker (yas--field-end field) (point))
+            (yas--advance-start-maybe (yas--field-next field) (point)))
+          t)))))
+
+
+;;; Post-command hook:
+;;
+(defun yas--post-command-handler ()
+  "Handles various yasnippet conditions after each command."
+  (when (and yas--watch-auto-fill-backtrace
+             (fboundp 'backtrace--print-frame)
+             (null yas--original-auto-fill-function)
+             (eq auto-fill-function 'yas--auto-fill))
+    (lwarn '(yasnippet auto-fill bug) :error
+           "`yas--original-auto-fill-function' unexpectedly nil! Please report this backtrace\n%S"
+           (with-output-to-string
+             (mapc #'backtrace--print-frame
+                     yas--watch-auto-fill-backtrace)))
+    ;; Don't pop up more than once in a session (still log though).
+    (defvar warning-suppress-types) ; `warnings' is autoloaded by `lwarn'.
+    (add-to-list 'warning-suppress-types '(yasnippet auto-fill bug)))
+  (yas--do-todo-snippet-indent)
+  (condition-case err
+      (progn (yas--finish-moving-snippets)
+             (cond ((eq 'undo this-command)
+                    ;;
+                    ;; After undo revival the correct field is sometimes not
+                    ;; restored correctly, this condition handles that
+                    ;;
+                    (let* ((snippet (car (yas-active-snippets)))
+                           (target-field
+                            (and snippet
+                                 (cl-find-if-not
+                                  (lambda (field)
+                                    (yas--field-probably-deleted-p snippet field))
+                                  (remq nil
+                                        (cons (yas--snippet-active-field snippet)
+                                              (yas--snippet-fields snippet)))))))
+                      (when target-field
+                        (yas--move-to-field snippet target-field))))
+                   ((not (yas--undo-in-progress))
+                    ;; When not in an undo, check if we must commit the snippet
+                    ;; (user exited it).
+                    (yas--check-commit-snippet))))
+    ((debug error) (signal (car err) (cdr err)))))
+
+;;; Fancy docs:
+;;
+;; The docstrings for some functions are generated dynamically
+;; depending on the context.
+;;
+(put 'yas-expand  'function-documentation
+     '(yas--expand-from-trigger-key-doc t))
+(defun yas--expand-from-trigger-key-doc (context)
+  "A doc synthesizer for `yas--expand-from-trigger-key-doc'."
+  (let* ((yas-fallback-behavior (and context yas-fallback-behavior))
+         (fallback-description
+          (cond ((eq yas-fallback-behavior 'call-other-command)
+                 (let* ((fallback (yas--keybinding-beyond-yasnippet)))
+                   (or (and fallback
+                            (format "call command `%s'."
+                                    (pp-to-string fallback)))
+                       "do nothing (`yas-expand' doesn't override\nanything).")))
+                ((eq yas-fallback-behavior 'return-nil)
+                 "do nothing.")
+                (t "defer to `yas-fallback-behavior' (which see)."))))
+    (concat "Expand a snippet before point. If no snippet
+expansion is possible, "
+            fallback-description
+            "\n\nOptional argument FIELD is for non-interactive use and is an
+object satisfying `yas--field-p' to restrict the expansion to.")))
+
+(put 'yas-expand-from-keymap 'function-documentation
+     '(yas--expand-from-keymap-doc t))
+(defun yas--expand-from-keymap-doc (context)
+  "A doc synthesizer for `yas--expand-from-keymap-doc'."
+  (add-hook 'temp-buffer-show-hook #'yas--snippet-description-finish-runonce)
+  (concat "Expand/run snippets from keymaps, possibly falling back to original binding.\n"
+          (when (and context (eq this-command 'describe-key))
+            (let* ((vec (this-single-command-keys))
+                   (templates (cl-mapcan (lambda (table)
+                                           (yas--fetch table vec))
+                                         (yas--get-snippet-tables)))
+                   (yas--direct-keymaps nil)
+                   (fallback (key-binding vec)))
+              (concat "In this case, "
+                      (when templates
+                        (concat "these snippets are bound to this key:\n"
+                                (yas--template-pretty-list templates)
+                                "\n\nIf none of these expands, "))
+                      (or (and fallback
+                               (format "fallback `%s' will be called." (pp-to-string fallback)))
+                          "no fallback keybinding is called."))))))
+
+(defun yas--template-pretty-list (templates)
+  (let ((acc)
+        (yas-buffer-local-condition 'always))
+    (dolist (plate templates)
+      (setq acc (concat acc "\n*) "
+                        (propertize (concat "\\\\snippet `" (car plate) "'")
+                                    'yasnippet (cdr plate)))))
+    acc))
+
+(define-button-type 'help-snippet-def
+  :supertype 'help-xref
+  'help-function (lambda (template) (yas--visit-snippet-file-1 template))
+  'help-echo (purecopy "mouse-2, RET: find snippets's definition"))
+
+(defun yas--snippet-description-finish-runonce ()
+  "Final adjustments for the help buffer when snippets are concerned."
+  (yas--create-snippet-xrefs)
+  (remove-hook 'temp-buffer-show-hook
+               #'yas--snippet-description-finish-runonce))
+
+(defun yas--create-snippet-xrefs ()
+  (save-excursion
+    (goto-char (point-min))
+    (while (search-forward-regexp "\\\\\\\\snippet[ \s\t]+`\\([^']+\\)'" nil t)
+      (let ((template (get-text-property (match-beginning 1)
+                                         'yasnippet)))
+        (when template
+          (help-xref-button 1 'help-snippet-def template)
+          (delete-region (match-end 1) (match-end 0))
+          (delete-region (match-beginning 0) (match-beginning 1)))))))
+
+;;; Eldoc configuration.
+(eldoc-add-command 'yas-next-field-or-maybe-expand
+                   'yas-next-field 'yas-prev-field
+                   'yas-expand 'yas-expand-from-keymap
+                   'yas-expand-from-trigger-key)
+
+;;; Utils
+
+(defvar yas-verbosity 3
+  "Log level for `yas--message' 4 means trace most anything, 0 means nothing.")
+
+(defun yas--message (level message &rest args)
+  "When LEVEL is at or below `yas-verbosity', log MESSAGE and ARGS."
+  (when (>= yas-verbosity level)
+    (message "%s" (apply #'yas--format message args))))
+
+(defun yas--warning (format-control &rest format-args)
+  (let ((msg (apply #'format format-control format-args)))
+    (display-warning 'yasnippet msg :warning)
+    (yas--message 1 msg)))
+
+(defun yas--format (format-control &rest format-args)
+  (apply #'format (concat "[yas] " format-control) format-args))
+
+
+;;; Unloading
+
+(defvar unload-function-defs-list) ; loadhist.el
+
+(defun yasnippet-unload-function ()
+  "Disable minor modes when calling `unload-feature'."
+  ;; Disable `yas-minor-mode' everywhere it's enabled.
+  (yas-global-mode -1)
+  (save-current-buffer
+    (dolist (buffer (buffer-list))
+      (set-buffer buffer)
+      (when yas-minor-mode
+        (yas-minor-mode -1))))
+  ;; Remove symbol properties of all our functions, this avoids
+  ;; Bug#25088 in Emacs 25.1, where the compiler macro on
+  ;; `cl-defstruct' created functions hang around in the symbol plist
+  ;; and cause errors when loading again (we don't *need* to clean
+  ;; *all* symbol plists, but it's easier than being precise).
+  (dolist (def unload-function-defs-list)
+    (when (eq (car-safe def) 'defun)
+      (setplist (cdr def) nil)))
+  ;; Return nil so that `unload-feature' will take of undefining
+  ;; functions, and changing any buffers using `snippet-mode'.
+  nil)
+
+
+;;; Backward compatibility to yasnippet <= 0.7
+
+(defun yas-initialize ()
+  "For backward compatibility, enable `yas-minor-mode' globally."
+  (declare (obsolete "Use (yas-global-mode 1) instead." "0.8"))
+  (yas-global-mode 1))
+
+(defvar yas--backported-syms '(;; `defcustom's
+                             ;;
+                             yas-snippet-dirs
+                             yas-prompt-functions
+                             yas-indent-line
+                             yas-also-auto-indent-first-line
+                             yas-snippet-revival
+                             yas-triggers-in-field
+                             yas-fallback-behavior
+                             yas-choose-keys-first
+                             yas-choose-tables-first
+                             yas-use-menu
+                             yas-trigger-symbol
+                             yas-wrap-around-region
+                             yas-good-grace
+                             yas-visit-from-menu
+                             yas-expand-only-for-last-commands
+                             yas-field-highlight-face
+
+                             ;; these vars can be customized as well
+                             ;;
+                             yas-keymap
+                             yas-verbosity
+                             yas-extra-modes
+                             yas-key-syntaxes
+                             yas-after-exit-snippet-hook
+                             yas-before-expand-snippet-hook
+                             yas-buffer-local-condition
+                             yas-dont-activate
+
+                             ;; prompting functions
+                             ;;
+                             yas-x-prompt
+                             yas-ido-prompt
+                             yas-no-prompt
+                             yas-completing-prompt
+                             yas-dropdown-prompt
+
+                             ;; interactive functions
+                             ;;
+                             yas-expand
+                             yas-minor-mode
+                             yas-global-mode
+                             yas-direct-keymaps-reload
+                             yas-minor-mode-on
+                             yas-load-directory
+                             yas-reload-all
+                             yas-compile-directory
+                             yas-recompile-all
+                             yas-about
+                             yas-expand-from-trigger-key
+                             yas-expand-from-keymap
+                             yas-insert-snippet
+                             yas-visit-snippet-file
+                             yas-new-snippet
+                             yas-load-snippet-buffer
+                             yas-tryout-snippet
+                             yas-describe-tables
+                             yas-next-field-or-maybe-expand
+                             yas-next-field
+                             yas-prev-field
+                             yas-abort-snippet
+                             yas-exit-snippet
+                             yas-exit-all-snippets
+                             yas-skip-and-clear-or-delete-char
+                             yas-initialize
+
+                             ;; symbols that I "exported" for use
+                             ;; in snippets and hookage
+                             ;;
+                             yas-expand-snippet
+                             yas-define-snippets
+                             yas-define-menu
+                             yas-snippet-beg
+                             yas-snippet-end
+                             yas-modified-p
+                             yas-moving-away-p
+                             yas-substr
+                             yas-choose-value
+                             yas-key-to-value
+                             yas-throw
+                             yas-verify-value
+                             yas-field-value
+                             yas-text
+                             yas-selected-text
+                             yas-default-from-field
+                             yas-inside-string
+                             yas-unimplemented
+                             yas-define-condition-cache
+                             yas-hippie-try-expand
+
+                             ;; debug definitions
+                             ;; yas-debug-snippet-vars
+                             ;; yas-exterminate-package
+                             ;; yas-debug-test
+
+                             ;; testing definitions
+                             ;; yas-should-expand
+                             ;; yas-should-not-expand
+                             ;; yas-mock-insert
+                             ;; yas-make-file-or-dirs
+                             ;; yas-variables
+                             ;; yas-saving-variables
+                             ;; yas-call-with-snippet-dirs
+                             ;; yas-with-snippet-dirs
+)
+  "Backported yasnippet symbols.
+
+They are mapped to \"yas/*\" variants.")
+
+(when yas-alias-to-yas/prefix-p
+  (dolist (sym yas--backported-syms)
+    (let ((backported (intern (replace-regexp-in-string "\\`yas-" "yas/" (symbol-name sym)))))
+      (when (boundp sym)
+        (make-obsolete-variable backported sym "yasnippet 0.8")
+        (defvaralias backported sym))
+      (when (fboundp sym)
+        (make-obsolete backported sym "yasnippet 0.8")
+        (defalias backported sym))))
+  (make-obsolete 'yas/root-directory 'yas-snippet-dirs "yasnippet 0.8")
+  (defvaralias 'yas/root-directory 'yas-snippet-dirs))
+
+(defvar yas--exported-syms
+  (let (exported)
+    (mapatoms (lambda (atom)
+                (if (and (or (and (boundp atom)
+                                  (not (get atom 'byte-obsolete-variable)))
+                             (and (fboundp atom)
+                                  (not (get atom 'byte-obsolete-info))))
+                         (string-match-p "\\`yas-[^-]" (symbol-name atom)))
+                    (push atom exported))))
+    exported)
+  "Exported yasnippet symbols.
+
+i.e. the ones with \"yas-\" single dash prefix. I will try to
+keep them in future yasnippet versions and other elisp libraries
+can more or less safely rely upon them.")
+
+
+(provide 'yasnippet)
+;; Local Variables:
+;; coding: utf-8
+;; indent-tabs-mode: nil
+;; End:
+;;; yasnippet.el ends here